wip convert to other http client
[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 -- 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)