next take on version-dependent build
[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",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
108       _             -> loopErr $ "bad HELO " ++ (show s)
109
110   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
111
112   mgr <- newManager defaultManagerSettings
113
114   let
115     fetch = lookup
116     -- Save the name under current count, increment count for the next run
117     -- so the name is saved under the count that was put into the response.
118     stow name (count, cache) =
119       (if count >= 99 then 0 else count + 1
120       , insert count name
121           $ delete (if count >= 10 then count - 10 else count + 90) cache
122       )
123     io = liftIO
124
125     mainloop = forever $ do
126       l <- io getLine
127       gen <- io $ nmcAge
128       (count, cache) <- get
129       case pdnsParse ver l of
130         Left e -> io $ putStr $ pdnsReport e
131         Right preq -> do
132           case preq of
133             PdnsRequestQ qname qtype id _ _ _ -> do
134               io $ queryDom (queryOpNmc cfg mgr id) qname
135                      >>= putStr . (pdnsOutQ ver count gen qname qtype)
136   {-
137   -- debug
138               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
139                            ++ " id: " ++ (show id)
140                            ++ " qname: " ++ qname
141                            ++ " qtype: " ++ (show qtype)
142                            ++ " cache size: " ++ (show (size cache))
143   -- end debug
144   -}
145               put $ stow qname (count, cache)
146             PdnsRequestAXFR xrq ->
147               case fetch xrq cache of
148                 Nothing ->
149                   io $ putStr $
150                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))
151                 Just qname ->
152                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
153                     >>= putStr . (pdnsOutXfr ver count gen qname)
154             PdnsRequestPing -> io $ putStrLn "END"
155
156   runStateT mainloop (0, empty) >> return ()
157
158 -- helper for command-line tools
159
160 pdnsOut gen key qt dom =
161   case qt of
162     "AXFR" -> pdnsOutXfr 1 (-1) gen key dom
163     _      -> pdnsOutQ 1 (-1) gen key (rrType qt) dom
164
165 -- run one query by key from Namecoin, print domain object and answer
166
167 mainOne gen key qt = do
168   cfg <- readConfig confFile
169   mgr <- newManager defaultManagerSettings
170   dom <- queryDom (queryOpNmc cfg mgr (-1)) key
171   putStrLn $ ppShow dom
172   putStr $ pdnsOut gen key qt dom
173
174 -- get data from the file, print domain object and answer
175
176 mainFile gen key qt = do
177   dom <- queryDom queryOpFile key
178   putStrLn $ ppShow dom
179   putStr $ pdnsOut gen key qt dom
180
181 -- Entry point
182
183 main = do
184   args <- getArgs
185   gen <- nmcAge
186   let
187     with f xs = case xs of
188       [qfqdn, qtype]       -> f gen qfqdn qtype
189       _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\""
190                 ++ " (type in caps)"
191   case args of
192     []      -> mainPdnsNmc
193     "-f":xs -> with mainFile xs
194     _       -> with mainOne args