support some more RRs
[pdns-pipe-nmc.git] / pdns-pipe-nmc.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Main where
4
5 import Prelude hiding (readFile)
6 import System.Environment
7 import System.IO hiding (readFile)
8 import System.IO.Error
9 import Control.Exception
10 import Text.Show.Pretty hiding (String)
11 import Control.Monad
12 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head)
13 import qualified Data.ByteString.Char8 as C (pack)
14 import qualified Data.ByteString.Lazy.Char8 as L (pack)
15 import qualified Data.Text as T (pack)
16 import Data.List.Split
17 import Data.Aeson (encode, decode, Value(..))
18 import Network.HTTP.Types
19 import Data.Conduit
20 import Network.HTTP.Conduit
21
22 import JsonRpcClient
23 import Config
24 import PowerDns
25 import NmcRpc
26 import NmcDom
27 import NmcTransform
28
29 confFile = "/etc/namecoin.conf"
30
31 -- HTTP/JsonRpc interface
32
33 qReq :: Config -> String -> String -> Request m
34 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
35              $ def { host           = (C.pack (rpchost cf))
36                    , port           = (rpcport cf)
37                    , method         = "PUT"
38                    , requestHeaders = [ (hAccept,      "application/json")
39                                       , (hContentType, "application/json")
40                                       , (hConnection,  "Keep-Alive")
41                                       ]
42                    , requestBody    = RequestBodyLBS $ encode $
43                                       JsonRpcRequest JsonRpcV1
44                                                      "name_show"
45                                                      [L.pack q]
46                                                      (String (T.pack id))
47                    , checkStatus    = \_ _ _ -> Nothing
48                    }
49
50 qRsp :: Response ByteString -> Either String ByteString
51 qRsp rsp =
52     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
53       Left  jerr -> 
54         case (jrpcErrCode jerr) of
55           -4 -> Right "{}"      -- this is how non-existent entry is returned
56           _  -> Left $ "JsonRpc error response: " ++ (show jerr)
57       Right jrsp -> Right $ resValue jrsp
58
59 -- NMC interface
60
61 queryOpNmc cfg mgr qid key =
62   runResourceT (httpLbs (qReq cfg key qid) mgr) >>= return . qRsp
63
64 queryOpFile key = catch (readFile key >>= return . Right)
65                         (\e -> return (Left (show (e :: IOException))))
66
67 queryDom queryOp fqdn =
68   case reverse (splitOn "." fqdn) of
69     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
70     _           -> return $ Left "Only \".bit\" domain is supported"
71
72 -- Main entries
73
74 mainPdnsNmc = do
75
76   cfg <- readConfig confFile
77
78   hSetBuffering stdin  LineBuffering
79   hSetBuffering stdout LineBuffering
80   ver <- do
81     let
82       loopErr e = forever $ do
83         putStrLn $ "FAIL\t" ++ e
84         _ <- getLine
85         return ()
86     s <- getLine
87     case words s of
88       ["HELO", "1"] -> return 1
89       ["HELO", "2"] -> return 2
90       ["HELO", "3"] -> return 3
91       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
92       _             -> loopErr $ "bad HELO " ++ (show s)
93
94   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
95
96   mgr <- newManager def
97   forever $ do
98     l <- getLine
99     case pdnsParse ver l of
100       Left e -> putStr $ pdnsReport e
101       Right preq -> do
102         case preq of
103           PdnsRequestQ qname qtype id _ _ _ ->
104             queryDom (queryOpNmc cfg mgr id) qname
105               >>= putStr . (pdnsOut ver id qname qtype)
106           PdnsRequestAXFR xfrreq ->
107             putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
108           PdnsRequestPing -> putStrLn "END"
109
110 -- query by key from Namecoin
111
112 mainOne key = do
113   cfg <- readConfig confFile
114   mgr <- newManager def
115   dom <- queryDom (queryOpNmc cfg mgr "_") key
116   putStrLn $ ppShow dom
117   putStr $ pdnsOut 1 "_" key RRTypeANY dom
118
119 -- using file backend for testing json domain data
120
121 mainFile key = do
122   dom <- queryDom queryOpFile key
123   putStrLn $ ppShow dom
124   putStr $ pdnsOut 1 "+" key RRTypeANY dom
125
126 -- Entry point
127
128 main = do
129   args <- getArgs
130   case args of
131     []         -> mainPdnsNmc
132     [key]      -> mainOne key
133     ["-f",key] -> mainFile key
134     _ -> error $ "usage: empty args, or \"[-f] <fqdn>\""