pdns-pipe-nmc.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Main where
   4
   5 import Control.Applicative
   6 import Control.Monad
   7 import Data.ConfigFile
   8 import Data.Either.Utils
   9 import Data.List.Split
  10 import Data.Aeson (decode)
  11 import Network.JsonRpc.Client
  12 import NmcJson
  13
  14 confFile = "/etc/namecoin.conf"
  15
  16 -- Config file handling
  17
  18 data Config = Config { rpcuser       :: String
  19                      , rpcpassword   :: String
  20                      , rpchost       :: String
  21                      , rpcport       :: String
  22                      } deriving (Show)
  23
  24 readConfig :: String -> IO Config
  25 readConfig f = do
  26   cp <- return . forceEither =<< readfile emptyCP f
  27   return (Config     { rpcuser       = getSetting cp "rpcuser"     ""
  28                      , rpcpassword   = getSetting cp "rpcpassword" ""
  29                      , rpchost       = getSetting cp "rpchost"     "localhost"
  30                      , rpcport       = getSetting cp "rpcport"     "8336"
  31                      })
  32     where
  33       getSetting cp x dfl = case get cp "DEFAULT" x of
  34                               Left _  -> dfl
  35                               Right x -> x
  36
  37 -- NMC interface
  38
  39 queryNmc :: String -> String -> RRType -> String -> IO (Either String NmcDom)
  40 queryNmc uri fqdn qtype qid = do
  41   case reverse  (splitOn "." fqdn) of
  42     "bit":dn:xs -> do
  43       ans <- detailledRemote Version1 [] uri "name_show" $ "d/" ++ dn
  44       let mdom = decode (resValue ans) :: Maybe NmcDom
  45       case mdom of
  46         Nothing  -> return $ Left ("Unparseable: " ++ (show (resValue ans)))
  47         Just dom -> return $ Right dom
  48     _           ->
  49       return $ Left "Only \".bit\" domain is supported"
  50
  51 -- PowerDNS ABI
  52
  53 data RRType = RRTypeSRV   | RRTypeA   | RRTypeAAAA | RRTypeCNAME
  54             | RRTypeDNAME | RRTypeSOA | RRTypeRP   | RRTypeLOC
  55             | RRTypeNS    | RRTypeDS
  56             | RRTypeANY   | RRTypeError String
  57         deriving (Show)
  58
  59 data PdnsRequest = PdnsRequestQ
  60                    { qName              :: String
  61                    , qType              :: RRType
  62                    , iD                 :: String
  63                    , remoteIpAddress    :: String
  64                    , localIpAddress     :: Maybe String
  65                    , ednsSubnetAddress  :: Maybe String
  66                    }
  67                  | PdnsRequestAXFR String
  68                  | PdnsRequestPing
  69         deriving (Show)
  70
  71 pdnsParse ver s =
  72   let
  73     getQt qt = case qt of
  74       "SRV"     -> RRTypeSRV
  75       "A"       -> RRTypeA
  76       "AAAA"    -> RRTypeAAAA
  77       "CNAME"   -> RRTypeCNAME
  78       "DNAME"   -> RRTypeDNAME
  79       "SOA"     -> RRTypeSOA
  80       "RP"      -> RRTypeRP
  81       "LOC"     -> RRTypeLOC
  82       "NS"      -> RRTypeNS
  83       "DS"      -> RRTypeDS
  84       "ANY"     -> RRTypeANY
  85       _         -> RRTypeError qt
  86     getLIp ver xs
  87       | ver >= 2  = case xs of
  88                       x:_       -> Just x
  89                       _         -> Nothing
  90       | otherwise = Nothing
  91     getRIp ver xs
  92       | ver >= 3  = case xs of
  93                       _:x:_     -> Just x
  94                       _         -> Nothing
  95       | otherwise = Nothing
  96   in
  97     case words s of
  98       "PING":[]                 -> Right PdnsRequestPing
  99       "AXFR":x:[]               -> Right (PdnsRequestAXFR x)
 100       "Q":qn:"IN":qt:id:rip:xs  -> Right (PdnsRequestQ
 101                                         { qName = qn
 102                                         , qType = getQt qt
 103                                         , iD = id
 104                                         , remoteIpAddress = rip
 105                                         , localIpAddress = getLIp ver xs
 106                                         , ednsSubnetAddress = getRIp ver xs
 107                                         })
 108       _                         -> Left s
 109
 110 pdnsOut :: String -> Either String PdnsRequest -> IO ()
 111 pdnsOut _   (Left e)   = putStrLn ("ERROR\tUnparseable request: " ++ e)
 112 pdnsOut uri (Right rq) = case rq of
 113     PdnsRequestQ qn qt id lip rip eip -> do
 114       dom <- queryNmc uri qn qt id
 115       case dom of
 116         Left  e      -> putStrLn ("ERROR\tNmc query error: " ++ e)
 117         Right result -> print result
 118     PdnsRequestAXFR xfrreq ->
 119       putStrLn ("ERROR\t No support for AXFR " ++ xfrreq)
 120     PdnsRequestPing -> putStrLn "OK"
 121
 122 -- Main entry
 123
 124 main = do
 125   cfg <- readConfig confFile
 126   let uri = "http://" ++ rpcuser cfg ++ ":" ++ rpcpassword cfg ++
 127             "@" ++ rpchost cfg ++ ":" ++ rpcport cfg ++ "/"
 128   ver <- do
 129     let
 130       loopErr e = forever $ do
 131         putStrLn $ "FAIL\t" ++ e
 132         _ <- getLine
 133         return ()
 134     s <- getLine
 135     case words s of
 136       ["HELO", "1"] -> return 1
 137       ["HELO", "2"] -> return 2
 138       ["HELO", "3"] -> return 3
 139       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
 140       _             -> loopErr $ "bad HELO " ++ (show s)
 141
 142   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 143   forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)