wip make http request
[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                                    ]
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)