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