X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=pdns-pipe-nmc.hs;h=737c9e771f4d0c81c32518eae45e97961a332231;hp=3d1e46d112705132f8d4ed2934ef20aa6ea69c4e;hb=a94698b56a0faf340c007fe11b6ac7bcb2c566e2;hpb=e76cfb2c55808966d70deb1d6fe73a5102590c68 diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs index 3d1e46d..737c9e7 100644 --- a/pdns-pipe-nmc.hs +++ b/pdns-pipe-nmc.hs @@ -2,153 +2,81 @@ module Main where ---import Control.Applicative +import Prelude hiding (readFile) +import System.Environment +import System.IO hiding (readFile) +import System.IO.Error +import Control.Exception +import Text.Show.Pretty hiding (String) import Control.Monad -import Data.ByteString.Char8 (pack, unpack) -import Data.ByteString.Lazy hiding (pack, unpack, putStrLn) -import Data.ConfigFile -import Data.Either.Utils +import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head) +import qualified Data.ByteString.Char8 as C (pack) +import qualified Data.ByteString.Lazy.Char8 as L (pack) +import qualified Data.Text as T (pack) import Data.List.Split import Data.Aeson (encode, decode, Value(..)) import Network.HTTP.Types import Data.Conduit import Network.HTTP.Conduit -import Data.JsonRpcClient -import NmcJson -confFile = "/etc/namecoin.conf" +import JsonRpcClient +import Config +import PowerDns +import NmcRpc +import NmcDom +import NmcTransform --- Config file handling - -data Config = Config { rpcuser :: String - , rpcpassword :: String - , rpchost :: String - , rpcport :: Int - } 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 +confFile = "/etc/namecoin.conf" -- HTTP/JsonRpc interface -qReq cf q = applyBasicAuth (pack (rpcuser cf)) (pack (rpcpassword cf)) - $ def { host = (pack (rpchost cf)) - , port = (rpcport cf) - , method = "PUT" - , requestHeaders = [ (hAccept, "application/json") - , (hContentType, "application/json") - ] - , requestBody = RequestBodyLBS $ encode $ - JsonRpcRequest JsonRpcV1 - "name_show" - [q] - (String "pdns-nmc") - } +qReq :: Config -> String -> String -> Request m +qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf)) + $ def { host = (C.pack (rpchost cf)) + , port = (rpcport cf) + , method = "PUT" + , requestHeaders = [ (hAccept, "application/json") + , (hContentType, "application/json") + , (hConnection, "Keep-Alive") + ] + , requestBody = RequestBodyLBS $ encode $ + JsonRpcRequest JsonRpcV1 + "name_show" + [L.pack q] + (String (T.pack id)) + , checkStatus = \_ _ _ -> Nothing + } + +qRsp :: Response ByteString -> Either String ByteString +qRsp rsp = + case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of + Left jerr -> + case (jrpcErrCode jerr) of + -4 -> Right "{}" -- this is how non-existent entry is returned + _ -> Left $ "JsonRpc error response: " ++ (show jerr) + Right jrsp -> Right $ resValue jrsp -- 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 +queryOpNmc cfg mgr qid key = + runResourceT (httpLbs (qReq cfg key qid) mgr) >>= return . qRsp -main = do +queryOpFile key = catch (readFile key >>= return . Right) + (\e -> return (Left (show (e :: IOException)))) + +queryDom queryOp fqdn = + case reverse (splitOn "." fqdn) of + "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn + _ -> return $ Left "Only \".bit\" domain is supported" + +-- Main entries + +mainPdnsNmc = do cfg <- readConfig confFile + hSetBuffering stdin LineBuffering + hSetBuffering stdout LineBuffering ver <- do let loopErr e = forever $ do @@ -166,9 +94,40 @@ main = do putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver) mgr <- newManager def + forever $ do + l <- getLine + case pdnsParse ver l of + Left e -> putStr $ pdnsReport e + Right preq -> do + case preq of + PdnsRequestQ qname qtype id _ _ _ -> + queryDom (queryOpNmc cfg mgr id) qname >>= putStr . (pdnsOut ver id qname qtype) + PdnsRequestAXFR xfrreq -> + putStr $ pdnsReport ("No support for AXFR " ++ xfrreq) + PdnsRequestPing -> putStrLn "END" + +-- query by key from Namecoin + +mainOne key = do + cfg <- readConfig confFile + mgr <- newManager def + dom <- queryDom (queryOpNmc cfg mgr "_") key + putStrLn $ ppShow dom + putStr $ pdnsOut 1 "_" key RRTypeANY dom - print $ qReq cfg "d/dot-bit" - rsp <- runResourceT $ httpLbs (qReq cfg "d/dot-bit") mgr - print rsp +-- using file backend for testing json domain data - --forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver) +mainFile key = do + dom <- queryDom queryOpFile key + putStrLn $ ppShow dom + putStr $ pdnsOut 1 "+" key RRTypeANY dom + +-- Entry point + +main = do + args <- getArgs + case args of + [] -> mainPdnsNmc + [key] -> mainOne key + ["-f",key] -> mainFile key + _ -> error $ "usage: empty args, or \"[-f] \""