X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=pdns-pipe-nmc.hs;h=d9ced8f3318629029611f1f5aff08e998dfebb73;hp=304e049a9280467234768e5a21b742c63b148a0a;hb=f0b5926d1268770bbcbcb8af7036238ae066d400;hpb=85a22c59d0638770076d5450555cab524e2e504d diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs index 304e049..d9ced8f 100644 --- a/pdns-pipe-nmc.hs +++ b/pdns-pipe-nmc.hs @@ -16,7 +16,8 @@ import Network.HTTP.Conduit import JsonRpcClient import Config import PowerDns -import NmcJson +import NmcRpc +import NmcDom confFile = "/etc/namecoin.conf" @@ -39,33 +40,32 @@ qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf)) , checkStatus = \_ _ _ -> Nothing } -qRsp :: Response ByteString -> Either String NmcDom +qRsp :: Response ByteString -> Either String ByteString qRsp rsp = case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of Left jerr -> case (jrpcErrCode jerr) of - -4 -> Right emptyNmcDom + -4 -> Right "{}" -- this is how non-existent entry is returned _ -> Left $ "JsonRpc error response: " ++ (show jerr) - Right jrsp -> - case resValue jrsp of - "" -> Right emptyNmcDom - vstr -> - case decode vstr :: Maybe NmcDom of - Nothing -> Left $ "Unparseable value: " ++ (show vstr) - Just dom -> Right dom + Right jrsp -> Right $ resValue jrsp -- NMC interface +queryOp :: Manager -> Config -> String -> String + -> IO (Either String ByteString) +queryOp mgr cfg qid key = do + rsp <- runResourceT $ + httpLbs (qReq cfg (L.pack key) (L.pack qid)) mgr + return $ qRsp rsp + queryNmc :: Manager -> Config -> String -> String -> IO (Either String NmcDom) queryNmc mgr cfg fqdn qid = do case reverse (splitOn "." fqdn) of "bit":dn:xs -> do - rsp <- runResourceT $ - httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr - return $ case qRsp rsp of - Left err -> Left err - Right dom -> Right $ descendNmc xs dom + dom <- mergeImport (queryOp mgr cfg qid) $ + emptyNmcDom { domImport = Just ("d/" ++ dn)} + return $ Right $ descendNmcDom xs dom _ -> return $ Left "Only \".bit\" domain is supported"