f2669a23489ef7eae103838bf29ed2dd45c8ce80
[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 queryNmc :: Manager -> Config -> String -> String
62          -> IO (Either String NmcDom)
63 queryNmc mgr cfg qid fqdn =
64   case reverse (splitOn "." fqdn) of
65     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
66     _           -> return $ Left "Only \".bit\" domain is supported"
67   where
68     queryOp key = do
69       rsp <- runResourceT $ httpLbs (qReq cfg key qid) mgr
70       -- print $ qRsp rsp
71       return $ qRsp rsp
72
73 -- Main entry
74
75 mainNmc = do
76
77   cfg <- readConfig confFile
78
79   hSetBuffering stdin  LineBuffering
80   hSetBuffering stdout LineBuffering
81   ver <- do
82     let
83       loopErr e = forever $ do
84         putStrLn $ "FAIL\t" ++ e
85         _ <- getLine
86         return ()
87     s <- getLine
88     case words s of
89       ["HELO", "1"] -> return 1
90       ["HELO", "2"] -> return 2
91       ["HELO", "3"] -> return 3
92       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
93       _             -> loopErr $ "bad HELO " ++ (show s)
94
95   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
96
97   mgr <- newManager def
98   forever $ do
99     l <- getLine
100     case pdnsParse ver l of
101       Left e -> putStr $ pdnsReport e
102       Right preq -> do
103         case preq of
104           PdnsRequestQ qname qtype id _ _ _ ->
105             queryNmc mgr cfg id qname >>= 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 <- queryNmc mgr cfg "+" key
116   putStrLn $ ppShow dom
117   putStr $ pdnsOut 1 "+" key RRTypeANY dom
118
119 -- using file backend for testing json domain data
120
121 queryFile :: String -> IO (Either String ByteString)
122 queryFile key = catch (readFile key >>= return . Right)
123                       (\e -> return (Left (show (e :: IOException))))
124
125 mainFile key = do
126   dom <- descendNmcDom queryFile [] (seedNmcDom key)
127   putStrLn $ ppShow dom
128   putStr $ pdnsOut 1 "+" key RRTypeANY dom
129
130 -- Entry point
131
132 main = do
133   args <- getArgs
134   case args of
135     []         -> mainNmc
136     [key]      -> mainOne key
137     ["-f",key] -> mainFile key
138     _ -> error $ "usage: empty args, or \"<key>\", or \"-f <key>\""