From 6e3dba2c2adb717490fb05b29e2bd50e2e9369a0 Mon Sep 17 00:00:00 2001 From: Eugene Crosser Date: Sun, 23 Mar 2014 01:58:15 +0400 Subject: [PATCH 1/1] Initial import --- NmcJson.hs | 111 ++++++++++++++++++++++++++++++++++++ pdns-pipe-nmc.hs | 143 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 254 insertions(+) create mode 100644 NmcJson.hs create mode 100644 pdns-pipe-nmc.hs diff --git a/NmcJson.hs b/NmcJson.hs new file mode 100644 index 0000000..b744929 --- /dev/null +++ b/NmcJson.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} + +module NmcJson ( NmcRes(..) + , NmcDom + ) where + +import Data.ByteString.Lazy (ByteString) +import Data.Map (Map) +import Control.Applicative ((<$>), (<*>), empty) +import Data.Aeson + +data NmcRRService = NmcRRService -- unused + { srvName :: String + , srvProto :: String + , srvW1 :: Int + , srvW2 :: Int + , srvPort :: Int + , srvHost :: [String] + } deriving (Show) + +instance FromJSON NmcRRService where + parseJSON (Object o) = NmcRRService + <$> o .: "name" + <*> o .: "proto" + <*> o .: "w1" + <*> o .: "w2" + <*> o .: "port" + <*> o .: "host" + parseJSON _ = empty + +data NmcRRI2p = NmcRRI2p -- unused + { i2pDestination :: String + , i2pName :: String + , i2pB32 :: String + } deriving (Show) + +instance FromJSON NmcRRI2p where + parseJSON (Object o) = NmcRRI2p + <$> o .: "destination" + <*> o .: "name" + <*> o .: "b32" + parseJSON _ = empty + +data NmcDom = NmcDom { domService :: Maybe [[String]] -- [NmcRRService] + , domIp :: Maybe [String] + , domIp6 :: Maybe [String] + , domTor :: Maybe String + , domI2p :: Maybe NmcRRI2p + , domFreenet :: Maybe String + , domAlias :: Maybe String + , domTranslate :: Maybe String + , domEmail :: Maybe String + , domLoc :: Maybe String + , domInfo :: Maybe Value + , domNs :: Maybe [String] + , domDelegate :: Maybe [String] + , domImport :: Maybe [[String]] + , domMap :: Maybe (Map String NmcDom) + , domFingerprint :: Maybe [String] + , domTls :: Maybe (Map String + (Map String [[String]])) + , domDs :: Maybe [[String]] + } deriving (Show) + +instance FromJSON NmcDom where + parseJSON (Object o) = NmcDom + <$> o .:? "service" + <*> o .:? "ip" + <*> o .:? "ip6" + <*> o .:? "tor" + <*> o .:? "i2p" + <*> o .:? "freenet" + <*> o .:? "alias" + <*> o .:? "translate" + <*> o .:? "email" + <*> o .:? "loc" + <*> o .:? "info" + <*> o .:? "ns" + <*> o .:? "delegate" + <*> o .:? "import" + <*> o .:? "map" + <*> o .:? "fingerprint" + <*> o .:? "tls" + <*> o .:? "ds" + parseJSON _ = empty + +data NmcRes = NmcRes { resName :: String + , resValue :: ByteString -- NmcDom + , resTxid :: String + , resAddress :: String + , resExpires_in :: Int + } deriving (Show) +instance FromJSON NmcRes where + parseJSON (Object o) = NmcRes + <$> o .: "name" + <*> o .: "value" + <*> o .: "txid" + <*> o .: "address" + <*> o .: "expires_in" + parseJSON _ = empty + +main = do + let l = "{\"name\":\"d/dot-bit\",\"value\":\"{\\\"info\\\":{\\\"description\\\":\\\"Dot-BIT Project - Official Website\\\",\\\"registrar\\\":\\\"http://register.dot-bit.org\\\"},\\\"fingerprint\\\":[\\\"30:B0:60:94:32:08:EC:F5:BE:DF:F4:BB:EE:52:90:2C:5D:47:62:46\\\"],\\\"ns\\\":[\\\"ns0.web-sweet-web.net\\\",\\\"ns1.web-sweet-web.net\\\"],\\\"map\\\":{\\\"\\\":{\\\"ns\\\":[\\\"ns0.web-sweet-web.net\\\",\\\"ns1.web-sweet-web.net\\\"]}},\\\"email\\\":\\\"register@dot-bit.org\\\"}\",\"txid\":\"7412603f2e6c3459be56accc6e1f3646b603f3d4a4188119a4072f125c1340d5\",\"address\":\"Mw3KCQcqC44nm75w7r79ZifZbEqT8RetWn\",\"expires_in\":18915}" + let r = decode l :: Maybe NmcRes + case r of + Just resp -> do + let value = (resValue resp) + let dom = decode value :: Maybe NmcDom + print dom + Nothing -> + print "Unparseable NMC response" diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs new file mode 100644 index 0000000..6874bb0 --- /dev/null +++ b/pdns-pipe-nmc.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Applicative +import Control.Monad +import Data.ConfigFile +import Data.Either.Utils +import Data.List.Split +import Data.Aeson (decode) +import Network.JsonRpc.Client +import NmcJson + +confFile = "/etc/namecoin.conf" + +-- Config file handling + +data Config = Config { rpcuser :: String + , rpcpassword :: String + , rpchost :: String + , rpcport :: String + } deriving (Show) + +readConfig :: String -> IO Config +readConfig f = do + cp <- return . forceEither =<< readfile emptyCP f + return (Config { rpcuser = getSetting cp "rpcuser" "" + , rpcpassword = getSetting cp "rpcpassword" "" + , rpchost = getSetting cp "rpchost" "localhost" + , rpcport = getSetting cp "rpcport" "8336" + }) + where + getSetting cp x dfl = case get cp "DEFAULT" x of + Left _ -> dfl + Right x -> x + +-- NMC interface + +queryNmc :: String -> String -> RRType -> String -> IO (Either String NmcDom) +queryNmc uri fqdn qtype qid = do + case reverse (splitOn "." fqdn) of + "bit":dn:xs -> do + ans <- detailledRemote Version1 [] uri "name_show" $ "d/" ++ dn + let mdom = decode (resValue ans) :: Maybe NmcDom + case mdom of + Nothing -> return $ Left ("Unparseable: " ++ (show (resValue ans))) + Just dom -> return $ Right dom + _ -> + return $ Left "Only \".bit\" domain is supported" + +-- PowerDNS ABI + +data RRType = RRTypeSRV | RRTypeA | RRTypeAAAA | RRTypeCNAME + | RRTypeDNAME | RRTypeSOA | RRTypeRP | RRTypeLOC + | RRTypeNS | RRTypeDS + | RRTypeANY | RRTypeError String + deriving (Show) + +data PdnsRequest = PdnsRequestQ + { qName :: String + , qType :: RRType + , iD :: String + , remoteIpAddress :: String + , localIpAddress :: Maybe String + , ednsSubnetAddress :: Maybe String + } + | PdnsRequestAXFR String + | PdnsRequestPing + deriving (Show) + +pdnsParse ver s = + let + getQt qt = case qt of + "SRV" -> RRTypeSRV + "A" -> RRTypeA + "AAAA" -> RRTypeAAAA + "CNAME" -> RRTypeCNAME + "DNAME" -> RRTypeDNAME + "SOA" -> RRTypeSOA + "RP" -> RRTypeRP + "LOC" -> RRTypeLOC + "NS" -> RRTypeNS + "DS" -> RRTypeDS + "ANY" -> RRTypeANY + _ -> RRTypeError qt + getLIp ver xs + | ver >= 2 = case xs of + x:_ -> Just x + _ -> Nothing + | otherwise = Nothing + getRIp ver xs + | ver >= 3 = case xs of + _:x:_ -> Just x + _ -> Nothing + | otherwise = Nothing + in + case words s of + "PING":[] -> Right PdnsRequestPing + "AXFR":x:[] -> Right (PdnsRequestAXFR x) + "Q":qn:"IN":qt:id:rip:xs -> Right (PdnsRequestQ + { qName = qn + , qType = getQt qt + , iD = id + , remoteIpAddress = rip + , localIpAddress = getLIp ver xs + , ednsSubnetAddress = getRIp ver xs + }) + _ -> Left s + +pdnsOut :: String -> Either String PdnsRequest -> IO () +pdnsOut _ (Left e) = putStrLn ("ERROR\tUnparseable request: " ++ e) +pdnsOut uri (Right rq) = case rq of + PdnsRequestQ qn qt id lip rip eip -> do + dom <- queryNmc uri qn qt id + case dom of + Left e -> putStrLn ("ERROR\tNmc query error: " ++ e) + Right result -> print result + PdnsRequestAXFR xfrreq -> + putStrLn ("ERROR\t No support for AXFR " ++ xfrreq) + PdnsRequestPing -> putStrLn "OK" + +-- Main entry + +main = do + cfg <- readConfig confFile + let uri = "http://" ++ rpcuser cfg ++ ":" ++ rpcpassword cfg ++ + "@" ++ rpchost cfg ++ ":" ++ rpcport cfg ++ "/" + ver <- do + let + loopErr e = forever $ do + putStrLn $ "FAIL\t" ++ e + _ <- getLine + return () + s <- getLine + case words s of + ["HELO", "1"] -> return 1 + ["HELO", "2"] -> return 2 + ["HELO", "3"] -> return 3 + ["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x) + _ -> loopErr $ "bad HELO " ++ (show s) + + putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver) + forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver) -- 2.43.0