X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=pdns-pipe-nmc.hs;h=d9ced8f3318629029611f1f5aff08e998dfebb73;hp=4d47e5045bcc10c70b5d8c3bfcd56d99f432a669;hb=f0b5926d1268770bbcbcb8af7036238ae066d400;hpb=35cea210f8d3a22afd24848441b5d34702d83239 diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs index 4d47e50..d9ced8f 100644 --- a/pdns-pipe-nmc.hs +++ b/pdns-pipe-nmc.hs @@ -40,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"