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 Network.HTTP.Client
  22 import Data.Default (def)
  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
  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   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
  83   ver <- do
  84     let
  85       loopErr e = forever $ do
  86         putStrLn $ "FAIL\t" ++ e
  87         _ <- getLine
  88         return ()
  89     s <- getLine
  90     case words s of
  91       ["HELO", "1"] -> return 1
  92       ["HELO", "2"] -> return 2
  93       ["HELO", "3"] -> return 3
  94       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
  95       _             -> loopErr $ "bad HELO " ++ (show s)
  96
  97   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
  98
  99   mgr <- newManager defaultManagerSettings
 100
 101   let
 102     fetch = lookup
 103     -- Save the name under current count, increment count for the next run
 104     -- so the name is saved under the count that was put into the response.
 105     stow name (count, cache) =
 106       (if count >= 99 then 0 else count + 1
 107       , insert count name
 108           $ delete (if count >= 10 then count - 10 else count + 90) cache
 109       )
 110     io = liftIO
 111
 112     mainloop = forever $ do
 113       l <- io getLine
 114       (count, cache) <- get
 115       case pdnsParse ver l of
 116         Left e -> io $ putStr $ pdnsReport e
 117         Right preq -> do
 118           case preq of
 119             PdnsRequestQ qname qtype id _ _ _ -> do
 120               io $ queryDom (queryOpNmc cfg mgr id) qname
 121                      >>= putStr . (pdnsOutQ ver count qname qtype)
 122   -- debug
 123               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
 124                            ++ " id: " ++ (show id)
 125                            ++ " qname: " ++ qname
 126                            ++ " qtype: " ++ (show qtype)
 127                            ++ " cache size: " ++ (show (size cache))
 128   -- end debug
 129               put $ stow qname (count, cache)
 130             PdnsRequestAXFR xrq ->
 131               case fetch xrq cache of
 132                 Nothing ->
 133                   io $ putStr $
 134                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))
 135                 Just qname ->
 136                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
 137                     >>= putStr . (pdnsOutXfr ver count qname)
 138             PdnsRequestPing -> io $ putStrLn "END"
 139
 140   runStateT mainloop (0, empty) >> return ()
 141
 142 -- helper for command-line tools
 143
 144 pdnsOut key qt dom =
 145   case qt of
 146     "AXFR" -> pdnsOutXfr 1 (-1) key dom
 147     _      -> pdnsOutQ 1 (-1) key (rrType qt) dom
 148
 149 -- query by key from Namecoin
 150
 151 mainOne key qt = do
 152   cfg <- readConfig confFile
 153   mgr <- newManager defaultManagerSettings
 154   dom <- queryDom (queryOpNmc cfg mgr (-1)) key
 155   putStrLn $ ppShow dom
 156   putStr $ pdnsOut key qt dom
 157
 158 -- using file backend for testing json domain data
 159
 160 mainFile key qt = do
 161   dom <- queryDom queryOpFile key
 162   putStrLn $ ppShow dom
 163   putStr $ pdnsOut key qt dom
 164
 165 -- Entry point
 166
 167 main = do
 168   args <- getArgs
 169   case args of
 170     []                 -> mainPdnsNmc
 171     [key, qtype]       -> mainOne key qtype
 172     ["-f" ,key, qtype] -> mainFile key qtype
 173     _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\" (type in caps)"