fix SOA and style cleanup
[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   -- debug
114               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
115                            ++ " id: " ++ (show id)
116                            ++ " qname: " ++ qname
117                            ++ " qtype: " ++ (show qtype)
118                            ++ " cache size: " ++ (show (size cache))
119   -- end debug
120               put (if count >= 99 then 0 else count + 1,
121                    newcache count qname cache)
122             PdnsRequestAXFR xrq ->
123               case lookup xrq cache of
124                 Nothing ->
125                   io $ putStr $
126                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))
127                 Just qname ->
128                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
129                     >>= putStr . (pdnsOutXfr ver count qname)
130             PdnsRequestPing -> io $ putStrLn "END"
131   runStateT mainloop (0, empty) >> return ()
132
133 -- query by key from Namecoin
134
135 mainOne key = do
136   cfg <- readConfig confFile
137   mgr <- newManager def
138   dom <- queryDom (queryOpNmc cfg mgr (-1)) key
139   putStrLn $ ppShow dom
140   putStr $ pdnsOut 1 (-1) key RRTypeANY dom
141
142 -- using file backend for testing json domain data
143
144 mainFile key = do
145   dom <- queryDom queryOpFile key
146   putStrLn $ ppShow dom
147   putStr $ pdnsOut 1 (-1) key RRTypeANY dom
148
149 -- Entry point
150
151 main = do
152   args <- getArgs
153   case args of
154     []         -> mainPdnsNmc
155     [key]      -> mainOne key
156     ["-f",key] -> mainFile key
157     _ -> error $ "usage: empty args, or \"[-f] <fqdn>\""