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 -- does not exist -- import Network.HTTP.Client
  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                                    ]
  51                 , requestBody    = RequestBodyLBS $ encode $
  52                                    JsonRpcRequest JsonRpcV1
  53                                                   "name_show"
  54                                                   [q]
  55                                                   (String "pdns-nmc")
  56                 }
  57
  58 -- NMC interface
  59
  60 {-
  61 queryNmc :: String -> String -> RRType -> String -> IO (Either String NmcDom)
  62 queryNmc uri fqdn qtype qid = do
  63   case reverse  (splitOn "." fqdn) of
  64     "bit":dn:xs -> do
  65       ans <- detailledRemote Version1 [] uri "name_show" $ "d/" ++ dn
  66       let mdom = decode (resValue ans) :: Maybe NmcDom
  67       case mdom of
  68         Nothing  -> return $ Left ("Unparseable: " ++ (show (resValue ans)))
  69         Just dom -> return $ Right dom
  70     _           ->
  71       return $ Left "Only \".bit\" domain is supported"
  72 -}
  73 -- PowerDNS ABI
  74
  75 data RRType = RRTypeSRV   | RRTypeA   | RRTypeAAAA | RRTypeCNAME
  76             | RRTypeDNAME | RRTypeSOA | RRTypeRP   | RRTypeLOC
  77             | RRTypeNS    | RRTypeDS
  78             | RRTypeANY   | RRTypeError String
  79         deriving (Show)
  80
  81 data PdnsRequest = PdnsRequestQ
  82                    { qName              :: String
  83                    , qType              :: RRType
  84                    , iD                 :: String
  85                    , remoteIpAddress    :: String
  86                    , localIpAddress     :: Maybe String
  87                    , ednsSubnetAddress  :: Maybe String
  88                    }
  89                  | PdnsRequestAXFR String
  90                  | PdnsRequestPing
  91         deriving (Show)
  92
  93 pdnsParse ver s =
  94   let
  95     getQt qt = case qt of
  96       "SRV"     -> RRTypeSRV
  97       "A"       -> RRTypeA
  98       "AAAA"    -> RRTypeAAAA
  99       "CNAME"   -> RRTypeCNAME
 100       "DNAME"   -> RRTypeDNAME
 101       "SOA"     -> RRTypeSOA
 102       "RP"      -> RRTypeRP
 103       "LOC"     -> RRTypeLOC
 104       "NS"      -> RRTypeNS
 105       "DS"      -> RRTypeDS
 106       "ANY"     -> RRTypeANY
 107       _         -> RRTypeError qt
 108     getLIp ver xs
 109       | ver >= 2  = case xs of
 110                       x:_       -> Just x
 111                       _         -> Nothing
 112       | otherwise = Nothing
 113     getRIp ver xs
 114       | ver >= 3  = case xs of
 115                       _:x:_     -> Just x
 116                       _         -> Nothing
 117       | otherwise = Nothing
 118   in
 119     case words s of
 120       "PING":[]                 -> Right PdnsRequestPing
 121       "AXFR":x:[]               -> Right (PdnsRequestAXFR x)
 122       "Q":qn:"IN":qt:id:rip:xs  -> Right (PdnsRequestQ
 123                                             { qName = qn
 124                                             , qType = getQt qt
 125                                             , iD = id
 126                                             , remoteIpAddress = rip
 127                                             , localIpAddress = getLIp ver xs
 128                                             , ednsSubnetAddress = getRIp ver xs
 129                                             })
 130       _                         -> Left s
 131
 132 {-
 133 pdnsOut :: String -> Either String PdnsRequest -> IO ()
 134 pdnsOut _   (Left e)   = putStrLn ("ERROR\tUnparseable request: " ++ e)
 135 pdnsOut uri (Right rq) = case rq of
 136     PdnsRequestQ qn qt id lip rip eip -> do
 137       dom <- queryNmc uri qn qt id
 138       case dom of
 139         Left  e      -> putStrLn ("ERROR\tNmc query error: " ++ e)
 140         Right result -> print result
 141     PdnsRequestAXFR xfrreq ->
 142       putStrLn ("ERROR\t No support for AXFR " ++ xfrreq)
 143     PdnsRequestPing -> putStrLn "OK"
 144 -}
 145
 146 -- Main entry
 147
 148 main = do
 149   cfg <- readConfig confFile
 150   ver <- do
 151     let
 152       loopErr e = forever $ do
 153         putStrLn $ "FAIL\t" ++ e
 154         _ <- getLine
 155         return ()
 156     s <- getLine
 157     case words s of
 158       ["HELO", "1"] -> return 1
 159       ["HELO", "2"] -> return 2
 160       ["HELO", "3"] -> return 3
 161       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
 162       _             -> loopErr $ "bad HELO " ++ (show s)
 163
 164 --  mgr <- newManager conduitManagerSettings
 165
 166   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 167
 168   print $ qReq cfg "samplequery"
 169
 170   --forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)