pdns-pipe-nmc.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Main where
   4
   5 import Prelude hiding (readFile)
   6 import System.Environment
   7 import System.IO hiding (readFile)
   8 import System.IO.Error
   9 import Control.Exception
  10 import Text.Show.Pretty hiding (String)
  11 import Control.Monad
  12 import Control.Monad.State
  13 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head, empty)
  14 import qualified Data.ByteString.Char8 as C (pack)
  15 import qualified Data.ByteString.Lazy.Char8 as L (pack)
  16 import qualified Data.Text as T (pack)
  17 import Data.List.Split
  18 import Data.Map.Lazy (Map, empty, insert, delete, size)
  19 import Data.Aeson (encode, decode, Value(..))
  20 import Network.HTTP.Types
  21 import Data.Conduit
  22 import Network.HTTP.Conduit
  23
  24 import JsonRpcClient
  25 import Config
  26 import PowerDns
  27 import NmcRpc
  28 import NmcDom
  29 import NmcTransform
  30
  31 confFile = "/etc/namecoin.conf"
  32
  33 -- HTTP/JsonRpc interface
  34
  35 qReq :: Config -> String -> String -> Request m
  36 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
  37              $ def { host           = (C.pack (rpchost cf))
  38                    , port           = (rpcport cf)
  39                    , method         = "PUT"
  40                    , requestHeaders = [ (hAccept,      "application/json")
  41                                       , (hContentType, "application/json")
  42                                       , (hConnection,  "Keep-Alive")
  43                                       ]
  44                    , requestBody    = RequestBodyLBS $ encode $
  45                                       JsonRpcRequest JsonRpcV1
  46                                                      "name_show"
  47                                                      [L.pack q]
  48                                                      (String (T.pack id))
  49                    , checkStatus    = \_ _ _ -> Nothing
  50                    }
  51
  52 qRsp :: Response ByteString -> Either String ByteString
  53 qRsp rsp =
  54     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
  55       Left  jerr ->
  56         case (jrpcErrCode jerr) of
  57           -4 -> Right "{}"      -- this is how non-existent entry is returned
  58           _  -> Left $ "JsonRpc error response: " ++ (show jerr)
  59       Right jrsp -> Right $ resValue jrsp
  60
  61 -- NMC interface
  62
  63 queryOpNmc cfg mgr qid key =
  64   runResourceT (httpLbs (qReq cfg key qid) mgr) >>= return . qRsp
  65
  66 queryOpFile key = catch (readFile key >>= return . Right)
  67                         (\e -> return (Left (show (e :: IOException))))
  68
  69 queryDom queryOp fqdn =
  70   case reverse (splitOn "." fqdn) of
  71     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
  72     _           -> return $ Left "Only \".bit\" domain is supported"
  73
  74 -- Main entries
  75
  76 mainPdnsNmc = do
  77
  78   cfg <- readConfig confFile
  79
  80   hSetBuffering stdin  LineBuffering
  81   hSetBuffering stdout LineBuffering
  82   ver <- do
  83     let
  84       loopErr e = forever $ do
  85         putStrLn $ "FAIL\t" ++ e
  86         _ <- getLine
  87         return ()
  88     s <- getLine
  89     case words s of
  90       ["HELO", "1"] -> return 1
  91       ["HELO", "2"] -> return 2
  92       ["HELO", "3"] -> return 3
  93       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
  94       _             -> loopErr $ "bad HELO " ++ (show s)
  95
  96   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
  97
  98   mgr <- newManager def
  99   let
 100     newcache count name = (insert count name) . (delete (count - 10))
 101     io = liftIO
 102     mainloop = forever $ do
 103       l <- io getLine
 104       (count, cache) <- get
 105       case pdnsParse ver l of
 106         Left e -> io $ putStr $ pdnsReport e
 107         Right preq -> do
 108           case preq of
 109             PdnsRequestQ qname qtype id _ _ _ -> do
 110               io $ queryDom (queryOpNmc cfg mgr id) qname
 111                      >>= putStr . (pdnsOut ver (show count) qname qtype)
 112               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
 113                            ++ " id: " ++ id
 114                            ++ " qname: " ++ qname
 115                            ++ " qtype: " ++ (show qtype)
 116                            ++ " cache size: " ++ (show (size cache))
 117               put (count + 1, newcache count qname cache)
 118             PdnsRequestAXFR xfrreq ->
 119               io $ putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
 120             PdnsRequestPing -> io $ putStrLn "END"
 121   runStateT mainloop (0, empty) >> return ()
 122
 123 -- query by key from Namecoin
 124
 125 mainOne key = do
 126   cfg <- readConfig confFile
 127   mgr <- newManager def
 128   dom <- queryDom (queryOpNmc cfg mgr "_") key
 129   putStrLn $ ppShow dom
 130   putStr $ pdnsOut 1 "_" key RRTypeANY dom
 131
 132 -- using file backend for testing json domain data
 133
 134 mainFile key = do
 135   dom <- queryDom queryOpFile key
 136   putStrLn $ ppShow dom
 137   putStr $ pdnsOut 1 "+" key RRTypeANY dom
 138
 139 -- Entry point
 140
 141 main = do
 142   args <- getArgs
 143   case args of
 144     []         -> mainPdnsNmc
 145     [key]      -> mainOne key
 146     ["-f",key] -> mainFile key
 147     _ -> error $ "usage: empty args, or \"[-f] <fqdn>\""