pdns-pipe-nmc.hs

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