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