wip AXFR support
[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 Data.Conduit
22 import Network.HTTP.Conduit
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 m
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   runResourceT (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   ver <- do
83     let
84       loopErr e = forever $ do
85         putStrLn $ "FAIL\t" ++ e
86         _ <- getLine
87         return ()
88     s <- getLine
89     case words s of
90       ["HELO", "1"] -> return 1
91       ["HELO", "2"] -> return 2
92       ["HELO", "3"] -> return 3
93       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
94       _             -> loopErr $ "bad HELO " ++ (show s)
95
96   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
97
98   mgr <- newManager def
99   let
100     newcache count name = (insert count name)
101       . (delete (if count >= 10 then count - 10 else count + 90))
102     io = liftIO
103     mainloop = forever $ do
104       l <- io getLine
105       (count, cache) <- get
106       case pdnsParse ver l of
107         Left e -> io $ putStr $ pdnsReport e
108         Right preq -> do
109           case preq of
110             PdnsRequestQ qname qtype id _ _ _ -> do
111               io $ queryDom (queryOpNmc cfg mgr id) qname
112                      >>= putStr . (pdnsOut ver count qname qtype)
113               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
114                            ++ " id: " ++ (show id)
115                            ++ " qname: " ++ qname
116                            ++ " qtype: " ++ (show qtype)
117                            ++ " cache size: " ++ (show (size cache))
118               put (if count >= 99 then 0 else count + 1,
119                    newcache count qname cache)
120             PdnsRequestAXFR xrq ->
121               case lookup xrq cache of
122                 Nothing ->
123                   io $ putStr $
124                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))
125                 Just qname ->
126                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
127                     >>= putStr . (pdnsOutXfr ver count qname)
128             PdnsRequestPing -> io $ putStrLn "END"
129   runStateT mainloop (0, empty) >> return ()
130
131 -- query by key from Namecoin
132
133 mainOne key = do
134   cfg <- readConfig confFile
135   mgr <- newManager def
136   dom <- queryDom (queryOpNmc cfg mgr (-1)) key
137   putStrLn $ ppShow dom
138   putStr $ pdnsOut 1 (-1) key RRTypeANY dom
139
140 -- using file backend for testing json domain data
141
142 mainFile key = do
143   dom <- queryDom queryOpFile key
144   putStrLn $ ppShow dom
145   putStr $ pdnsOut 1 (-1) key RRTypeANY dom
146
147 -- Entry point
148
149 main = do
150   args <- getArgs
151   case args of
152     []         -> mainPdnsNmc
153     [key]      -> mainOne key
154     ["-f",key] -> mainFile key
155     _ -> error $ "usage: empty args, or \"[-f] <fqdn>\""