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                                    ]
  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
 150   cfg <- readConfig confFile
 151
 152   ver <- do
 153     let
 154       loopErr e = forever $ do
 155         putStrLn $ "FAIL\t" ++ e
 156         _ <- getLine
 157         return ()
 158     s <- getLine
 159     case words s of
 160       ["HELO", "1"] -> return 1
 161       ["HELO", "2"] -> return 2
 162       ["HELO", "3"] -> return 3
 163       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
 164       _             -> loopErr $ "bad HELO " ++ (show s)
 165
 166   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 167
 168   mgr <- newManager def
 169
 170   print $ qReq cfg "d/dot-bit"
 171   rsp <- runResourceT $ httpLbs (qReq cfg "d/dot-bit") mgr
 172   print rsp
 173
 174   --forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)