1 {-# LANGUAGE OverloadedStrings #-}
5 --import Control.Applicative
7 import Data.ByteString.Char8 (pack, unpack)
8 import Data.ByteString.Lazy hiding (pack, unpack, putStrLn)
10 import Data.Either.Utils
11 import Data.List.Split
12 import Data.Aeson (encode, decode, Value(..))
13 import Network.HTTP.Types
15 import Network.HTTP.Conduit
16 import Data.JsonRpcClient
19 confFile = "/etc/namecoin.conf"
21 -- Config file handling
23 data Config = Config { rpcuser :: String
24 , rpcpassword :: String
29 readConfig :: String -> IO Config
31 cp <- return . forceEither =<< readfile emptyCP f
32 return (Config { rpcuser = getSetting cp "rpcuser" ""
33 , rpcpassword = getSetting cp "rpcpassword" ""
34 , rpchost = getSetting cp "rpchost" "localhost"
35 , rpcport = getSetting cp "rpcport" 8336
38 getSetting cp x dfl = case get cp "DEFAULT" x of
42 -- HTTP/JsonRpc interface
44 qReq cf q = applyBasicAuth (pack (rpcuser cf)) (pack (rpcpassword cf))
45 $ def { host = (pack (rpchost cf))
48 , requestHeaders = [ (hAccept, "application/json")
49 , (hContentType, "application/json")
51 , requestBody = RequestBodyLBS $ encode $
52 JsonRpcRequest JsonRpcV1
61 queryNmc :: String -> String -> RRType -> String -> IO (Either String NmcDom)
62 queryNmc uri fqdn qtype qid = do
63 case reverse (splitOn "." fqdn) of
65 ans <- detailledRemote Version1 [] uri "name_show" $ "d/" ++ dn
66 let mdom = decode (resValue ans) :: Maybe NmcDom
68 Nothing -> return $ Left ("Unparseable: " ++ (show (resValue ans)))
69 Just dom -> return $ Right dom
71 return $ Left "Only \".bit\" domain is supported"
75 data RRType = RRTypeSRV | RRTypeA | RRTypeAAAA | RRTypeCNAME
76 | RRTypeDNAME | RRTypeSOA | RRTypeRP | RRTypeLOC
78 | RRTypeANY | RRTypeError String
81 data PdnsRequest = PdnsRequestQ
85 , remoteIpAddress :: String
86 , localIpAddress :: Maybe String
87 , ednsSubnetAddress :: Maybe String
89 | PdnsRequestAXFR String
99 "CNAME" -> RRTypeCNAME
100 "DNAME" -> RRTypeDNAME
109 | ver >= 2 = case xs of
112 | otherwise = Nothing
114 | ver >= 3 = case xs of
117 | otherwise = Nothing
120 "PING":[] -> Right PdnsRequestPing
121 "AXFR":x:[] -> Right (PdnsRequestAXFR x)
122 "Q":qn:"IN":qt:id:rip:xs -> Right (PdnsRequestQ
126 , remoteIpAddress = rip
127 , localIpAddress = getLIp ver xs
128 , ednsSubnetAddress = getRIp ver xs
133 pdnsOut :: String -> Either String PdnsRequest -> IO ()
134 pdnsOut _ (Left e) = putStrLn ("ERROR\tUnparseable request: " ++ e)
135 pdnsOut uri (Right rq) = case rq of
136 PdnsRequestQ qn qt id lip rip eip -> do
137 dom <- queryNmc uri qn qt id
139 Left e -> putStrLn ("ERROR\tNmc query error: " ++ e)
140 Right result -> print result
141 PdnsRequestAXFR xfrreq ->
142 putStrLn ("ERROR\t No support for AXFR " ++ xfrreq)
143 PdnsRequestPing -> putStrLn "OK"
150 cfg <- readConfig confFile
154 loopErr e = forever $ do
155 putStrLn $ "FAIL\t" ++ e
160 ["HELO", "1"] -> return 1
161 ["HELO", "2"] -> return 2
162 ["HELO", "3"] -> return 3
163 ["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x)
164 _ -> loopErr $ "bad HELO " ++ (show s)
166 putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
168 mgr <- newManager def
170 print $ qReq cfg "d/dot-bit"
171 rsp <- runResourceT $ httpLbs (qReq cfg "d/dot-bit") mgr
174 --forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)