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