use Network.HTTP.Client w/o Conduit
[pdns-pipe-nmc.git] / pdns-pipe-nmc.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Main where
4
5 import Prelude hiding (lookup, readFile)
6 import System.Environment
7 import System.IO hiding (readFile)
8 import System.IO.Error
9 import Control.Exception
10 import Text.Show.Pretty hiding (String)
11 import Control.Monad
12 import Control.Monad.State
13 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head, empty)
14 import qualified Data.ByteString.Char8 as C (pack)
15 import qualified Data.ByteString.Lazy.Char8 as L (pack)
16 import qualified Data.Text as T (pack)
17 import Data.List.Split
18 import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
19 import Data.Aeson (encode, decode, Value(..))
20 import Network.HTTP.Types
21 import Network.HTTP.Client
22 import Data.Default (def)
23
24 import JsonRpcClient
25 import Config
26 import PowerDns
27 import NmcRpc
28 import NmcDom
29 import NmcTransform
30
31 confFile = "/etc/namecoin.conf"
32
33 -- HTTP/JsonRpc interface
34
35 qReq :: Config -> String -> Int -> Request
36 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
37              $ def { host           = (C.pack (rpchost cf))
38                    , port           = (rpcport cf)
39                    , method         = "PUT"
40                    , requestHeaders = [ (hAccept,      "application/json")
41                                       , (hContentType, "application/json")
42                                       , (hConnection,  "Keep-Alive")
43                                       ]
44                    , requestBody    = RequestBodyLBS $ encode $
45                                       JsonRpcRequest JsonRpcV1
46                                                      "name_show"
47                                                      [L.pack q]
48                                                      (String (T.pack (show id)))
49                    , checkStatus    = \_ _ _ -> Nothing
50                    }
51
52 qRsp :: Response ByteString -> Either String ByteString
53 qRsp rsp =
54     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
55       Left  jerr -> 
56         case (jrpcErrCode jerr) of
57           (-4) -> Right "{}"    -- this is how non-existent entry is returned
58           _    -> Left $ "JsonRpc error response: " ++ (show jerr)
59       Right jrsp -> Right $ resValue jrsp
60
61 -- NMC interface
62
63 queryOpNmc cfg mgr qid key =
64   httpLbs (qReq cfg key qid) mgr >>= return . qRsp
65
66 queryOpFile key = catch (readFile key >>= return . Right)
67                         (\e -> return (Left (show (e :: IOException))))
68
69 queryDom queryOp fqdn =
70   case reverse (splitOn "." fqdn) of
71     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
72     _           -> return $ Left "Only \".bit\" domain is supported"
73
74 -- Main entries
75
76 mainPdnsNmc = do
77
78   cfg <- readConfig confFile
79
80   hSetBuffering stdin  LineBuffering
81   hSetBuffering stdout LineBuffering
82
83   ver <- do
84     let
85       loopErr e = forever $ do
86         putStrLn $ "FAIL\t" ++ e
87         _ <- getLine
88         return ()
89     s <- getLine
90     case words s of
91       ["HELO", "1"] -> return 1
92       ["HELO", "2"] -> return 2
93       ["HELO", "3"] -> return 3
94       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
95       _             -> loopErr $ "bad HELO " ++ (show s)
96
97   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
98
99   mgr <- newManager defaultManagerSettings
100
101   let
102     fetch = lookup
103     -- Save the name under current count, increment count for the next run
104     -- so the name is saved under the count that was put into the response.
105     stow name (count, cache) =
106       (if count >= 99 then 0 else count + 1
107       , insert count name
108           $ delete (if count >= 10 then count - 10 else count + 90) cache
109       )
110     io = liftIO
111
112     mainloop = forever $ do
113       l <- io getLine
114       (count, cache) <- get
115       case pdnsParse ver l of
116         Left e -> io $ putStr $ pdnsReport e
117         Right preq -> do
118           case preq of
119             PdnsRequestQ qname qtype id _ _ _ -> do
120               io $ queryDom (queryOpNmc cfg mgr id) qname
121                      >>= putStr . (pdnsOutQ ver count qname qtype)
122   -- debug
123               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
124                            ++ " id: " ++ (show id)
125                            ++ " qname: " ++ qname
126                            ++ " qtype: " ++ (show qtype)
127                            ++ " cache size: " ++ (show (size cache))
128   -- end debug
129               put $ stow qname (count, cache)
130             PdnsRequestAXFR xrq ->
131               case fetch xrq cache of
132                 Nothing ->
133                   io $ putStr $
134                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))
135                 Just qname ->
136                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
137                     >>= putStr . (pdnsOutXfr ver count qname)
138             PdnsRequestPing -> io $ putStrLn "END"
139
140   runStateT mainloop (0, empty) >> return ()
141
142 -- helper for command-line tools
143
144 pdnsOut key qt dom =
145   case qt of
146     "AXFR" -> pdnsOutXfr 1 (-1) key dom
147     _      -> pdnsOutQ 1 (-1) key (rrType qt) dom
148
149 -- query by key from Namecoin
150
151 mainOne key qt = do
152   cfg <- readConfig confFile
153   mgr <- newManager defaultManagerSettings
154   dom <- queryDom (queryOpNmc cfg mgr (-1)) key
155   putStrLn $ ppShow dom
156   putStr $ pdnsOut key qt dom
157
158 -- using file backend for testing json domain data
159
160 mainFile key qt = do
161   dom <- queryDom queryOpFile key
162   putStrLn $ ppShow dom
163   putStr $ pdnsOut key qt dom
164
165 -- Entry point
166
167 main = do
168   args <- getArgs
169   case args of
170     []                 -> mainPdnsNmc
171     [key, qtype]       -> mainOne key qtype
172     ["-f" ,key, qtype] -> mainFile key qtype
173     _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\" (type in caps)"