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