Initial import

diff --git a/NmcJson.hs b/NmcJson.hs
new file mode 100644 (file)
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 (file)
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)