wip handling response
[pdns-pipe-nmc.git] / 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)