pdns-pipe-nmc.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Main where
   4
   5 --import Control.Applicative
   6 import Control.Monad
   7 import Data.ByteString.Char8 (pack, unpack)
   8 import Data.ByteString.Lazy hiding (pack, unpack, putStrLn)
   9 import Data.ConfigFile
  10 import Data.Either.Utils
  11 import Data.List.Split
  12 import Data.Aeson (encode, decode, Value(..))
  13 import Network.HTTP.Types
  14 import Data.Conduit
  15 import Network.HTTP.Conduit
  16 import Data.JsonRpcClient
  17 import NmcJson
  18
  19 confFile = "/etc/namecoin.conf"
  20
  21 -- Config file handling
  22
  23 data Config = Config { rpcuser       :: String
  24                      , rpcpassword   :: String
  25                      , rpchost       :: String
  26                      , rpcport       :: Int
  27                      } deriving (Show)
  28
  29 readConfig :: String -> IO Config
  30 readConfig f = do
  31   cp <- return . forceEither =<< readfile emptyCP f
  32   return (Config { rpcuser       = getSetting cp "rpcuser"     ""
  33                  , rpcpassword   = getSetting cp "rpcpassword" ""
  34                  , rpchost       = getSetting cp "rpchost"     "localhost"
  35                  , rpcport       = getSetting cp "rpcport"     8336
  36                  })
  37     where
  38       getSetting cp x dfl = case get cp "DEFAULT" x of
  39                               Left  _ -> dfl
  40                               Right x -> x
  41
  42 -- HTTP/JsonRpc interface
  43
  44 qReq cf q = applyBasicAuth (pack (rpcuser cf)) (pack (rpcpassword cf))
  45           $ def { host           = (pack (rpchost cf))
  46                 , port           = (rpcport cf)
  47                 , method         = "PUT"
  48                 , requestHeaders = [ (hAccept,      "application/json")
  49                                    , (hContentType, "application/json")
  50                                    , (hConnection,  "Keep-Alive")
  51                                    ]
  52                 , requestBody    = RequestBodyLBS $ encode $
  53                                    JsonRpcRequest JsonRpcV1
  54                                                   "name_show"
  55                                                   [q]
  56                                                   (String "pdns-nmc")
  57                 , checkStatus    = \_ _ _ -> Nothing
  58                 }
  59
  60 -- NMC interface
  61
  62 {-
  63 queryNmc :: String -> String -> RRType -> String -> IO (Either String NmcDom)
  64 queryNmc uri fqdn qtype qid = do
  65   case reverse  (splitOn "." fqdn) of
  66     "bit":dn:xs -> do
  67       ans <- detailledRemote Version1 [] uri "name_show" $ "d/" ++ dn
  68       let mdom = decode (resValue ans) :: Maybe NmcDom
  69       case mdom of
  70         Nothing  -> return $ Left ("Unparseable: " ++ (show (resValue ans)))
  71         Just dom -> return $ Right dom
  72     _           ->
  73       return $ Left "Only \".bit\" domain is supported"
  74 -}
  75 -- PowerDNS ABI
  76
  77 data RRType = RRTypeSRV   | RRTypeA   | RRTypeAAAA | RRTypeCNAME
  78             | RRTypeDNAME | RRTypeSOA | RRTypeRP   | RRTypeLOC
  79             | RRTypeNS    | RRTypeDS
  80             | RRTypeANY   | RRTypeError String
  81         deriving (Show)
  82
  83 data PdnsRequest = PdnsRequestQ
  84                    { qName              :: String
  85                    , qType              :: RRType
  86                    , iD                 :: String
  87                    , remoteIpAddress    :: String
  88                    , localIpAddress     :: Maybe String
  89                    , ednsSubnetAddress  :: Maybe String
  90                    }
  91                  | PdnsRequestAXFR String
  92                  | PdnsRequestPing
  93         deriving (Show)
  94
  95 pdnsParse ver s =
  96   let
  97     getQt qt = case qt of
  98       "SRV"     -> RRTypeSRV
  99       "A"       -> RRTypeA
 100       "AAAA"    -> RRTypeAAAA
 101       "CNAME"   -> RRTypeCNAME
 102       "DNAME"   -> RRTypeDNAME
 103       "SOA"     -> RRTypeSOA
 104       "RP"      -> RRTypeRP
 105       "LOC"     -> RRTypeLOC
 106       "NS"      -> RRTypeNS
 107       "DS"      -> RRTypeDS
 108       "ANY"     -> RRTypeANY
 109       _         -> RRTypeError qt
 110     getLIp ver xs
 111       | ver >= 2  = case xs of
 112                       x:_       -> Just x
 113                       _         -> Nothing
 114       | otherwise = Nothing
 115     getRIp ver xs
 116       | ver >= 3  = case xs of
 117                       _:x:_     -> Just x
 118                       _         -> Nothing
 119       | otherwise = Nothing
 120   in
 121     case words s of
 122       "PING":[]                 -> Right PdnsRequestPing
 123       "AXFR":x:[]               -> Right (PdnsRequestAXFR x)
 124       "Q":qn:"IN":qt:id:rip:xs  -> Right (PdnsRequestQ
 125                                             { qName = qn
 126                                             , qType = getQt qt
 127                                             , iD = id
 128                                             , remoteIpAddress = rip
 129                                             , localIpAddress = getLIp ver xs
 130                                             , ednsSubnetAddress = getRIp ver xs
 131                                             })
 132       _                         -> Left s
 133
 134 {-
 135 pdnsOut :: String -> Either String PdnsRequest -> IO ()
 136 pdnsOut _   (Left e)   = putStrLn ("ERROR\tUnparseable request: " ++ e)
 137 pdnsOut uri (Right rq) = case rq of
 138     PdnsRequestQ qn qt id lip rip eip -> do
 139       dom <- queryNmc uri qn qt id
 140       case dom of
 141         Left  e      -> putStrLn ("ERROR\tNmc query error: " ++ e)
 142         Right result -> print result
 143     PdnsRequestAXFR xfrreq ->
 144       putStrLn ("ERROR\t No support for AXFR " ++ xfrreq)
 145     PdnsRequestPing -> putStrLn "OK"
 146 -}
 147
 148 -- Main entry
 149
 150 main = do
 151
 152   cfg <- readConfig confFile
 153
 154   ver <- do
 155     let
 156       loopErr e = forever $ do
 157         putStrLn $ "FAIL\t" ++ e
 158         _ <- getLine
 159         return ()
 160     s <- getLine
 161     case words s of
 162       ["HELO", "1"] -> return 1
 163       ["HELO", "2"] -> return 2
 164       ["HELO", "3"] -> return 3
 165       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
 166       _             -> loopErr $ "bad HELO " ++ (show s)
 167
 168   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 169
 170   mgr <- newManager def
 171
 172   print $ qReq cfg "d/nosuchdomain"
 173   rsp <- runResourceT $ httpLbs (qReq cfg "d/nosuchdomain") mgr
 174   print $ (statusCode . responseStatus) rsp
 175   putStrLn "===== complete response is:"
 176   print rsp
 177   let rbody = responseBody rsp
 178   putStrLn "===== response body is:"
 179   print rbody
 180   let result = parseJsonRpc rbody :: Either JsonRpcError NmcRes
 181   putStrLn "===== parsed response is:"
 182   print result
 183 --  print $ parseJsonRpc (responseBody rsp)
 184
 185   --forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)