pdns-pipe-nmc.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Main where
   4
   5 import Prelude hiding (lookup, 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, lookup, 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 -> Int -> 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 (show 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)
 101       . (delete (if count >= 10 then count - 10 else count + 90))
 102     io = liftIO
 103     mainloop = forever $ do
 104       l <- io getLine
 105       (count, cache) <- get
 106       case pdnsParse ver l of
 107         Left e -> io $ putStr $ pdnsReport e
 108         Right preq -> do
 109           case preq of
 110             PdnsRequestQ qname qtype id _ _ _ -> do
 111               io $ queryDom (queryOpNmc cfg mgr id) qname
 112                      >>= putStr . (pdnsOut ver count qname qtype)
 113   -- debug
 114               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
 115                            ++ " id: " ++ (show id)
 116                            ++ " qname: " ++ qname
 117                            ++ " qtype: " ++ (show qtype)
 118                            ++ " cache size: " ++ (show (size cache))
 119   -- end debug
 120               put (if count >= 99 then 0 else count + 1,
 121                    newcache count qname cache)
 122             PdnsRequestAXFR xrq ->
 123               case lookup xrq cache of
 124                 Nothing ->
 125                   io $ putStr $
 126                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))
 127                 Just qname ->
 128                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
 129                     >>= putStr . (pdnsOutXfr ver count qname)
 130             PdnsRequestPing -> io $ putStrLn "END"
 131   runStateT mainloop (0, empty) >> return ()
 132
 133 -- query by key from Namecoin
 134
 135 mainOne key = do
 136   cfg <- readConfig confFile
 137   mgr <- newManager def
 138   dom <- queryDom (queryOpNmc cfg mgr (-1)) key
 139   putStrLn $ ppShow dom
 140   putStr $ pdnsOut 1 (-1) key RRTypeANY dom
 141
 142 -- using file backend for testing json domain data
 143
 144 mainFile key = do
 145   dom <- queryDom queryOpFile key
 146   putStrLn $ ppShow dom
 147   putStr $ pdnsOut 1 (-1) key RRTypeANY dom
 148
 149 -- Entry point
 150
 151 main = do
 152   args <- getArgs
 153   case args of
 154     []         -> mainPdnsNmc
 155     [key]      -> mainOne key
 156     ["-f",key] -> mainFile key
 157     _ -> error $ "usage: empty args, or \"[-f] <fqdn>\""