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