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 Data.Time.Clock.POSIX
  10 import Control.Exception
  11 import Text.Show.Pretty hiding (String)
  12 import Control.Monad
  13 import Control.Monad.State
  14 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head, empty)
  15 import qualified Data.ByteString.Char8 as C (pack)
  16 import qualified Data.ByteString.Lazy.Char8 as L (pack)
  17 import qualified Data.Text as T (pack)
  18 import Data.List.Split
  19 import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
  20 import Data.Aeson (encode, decode, Value(..))
  21 import Network.HTTP.Types
  22 import Network.HTTP.Client
  23 import Data.Default (def)
  24
  25 import JsonRpcClient
  26 import Config
  27 import PowerDns
  28 import NmcRpc
  29 import NmcDom
  30 import NmcTransform
  31
  32 confFile = "/etc/namecoin.conf"
  33
  34 -- HTTP/JsonRpc interface
  35
  36 qReq :: Config -> String -> Int -> Request
  37 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
  38              $ def { host           = (C.pack (rpchost cf))
  39                    , port           = (rpcport cf)
  40                    , method         = "PUT"
  41                    , requestHeaders = [ (hAccept,      "application/json")
  42                                       , (hContentType, "application/json")
  43                                       , (hConnection,  "Keep-Alive")
  44                                       ]
  45                    , requestBody    = RequestBodyLBS $ encode $
  46                                       JsonRpcRequest JsonRpcV1
  47                                                      "name_show"
  48                                                      [L.pack q]
  49                                                      (String (T.pack (show id)))
  50                    , checkStatus    = \_ _ _ -> Nothing
  51                    }
  52
  53 qRsp :: Response ByteString -> Either String ByteString
  54 qRsp rsp =
  55     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
  56       Left  jerr ->
  57         case (jrpcErrCode jerr) of
  58           (-4) -> Right "{}"    -- this is how non-existent entry is returned
  59           _    -> Left $ "JsonRpc error response: " ++ (show jerr)
  60       Right jrsp -> Right $ resValue jrsp
  61
  62 -- NMC interface
  63
  64 queryOpNmc cfg mgr qid key =
  65   httpLbs (qReq cfg key qid) mgr >>= return . qRsp
  66
  67 queryOpFile key = catch (readFile key >>= return . Right)
  68                         (\e -> return (Left (show (e :: IOException))))
  69
  70 queryDom queryOp fqdn =
  71   case reverse (splitOn "." fqdn) of
  72     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
  73     _           -> return $ Left "Only \".bit\" domain is supported"
  74
  75 -- Number of ten minute intervals elapsed since creation of Namecoin
  76 -- on April 18, 2011. Another option would be to use blockcount
  77 -- but that would require another lookup, and we are cheap.
  78 -- Yet another - to use (const - expires_in) from the lookup.
  79 nmcAge = fmap (\x -> floor ((x - 1303070400) / 600)) getPOSIXTime
  80
  81 -- Main entries
  82
  83 mainPdnsNmc = do
  84
  85   cfg <- readConfig confFile
  86
  87   hSetBuffering stdin  LineBuffering
  88   hSetBuffering stdout LineBuffering
  89
  90   ver <- do
  91     let
  92       loopErr e = forever $ do
  93         putStrLn $ "FAIL\t" ++ e
  94         _ <- getLine
  95         return ()
  96     s <- getLine
  97     case words s of
  98       ["HELO", "1"] -> return 1
  99       ["HELO", "2"] -> return 2
 100       ["HELO", "3"] -> return 3
 101       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
 102       _             -> loopErr $ "bad HELO " ++ (show s)
 103
 104   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 105
 106   mgr <- newManager defaultManagerSettings
 107
 108   let
 109     fetch = lookup
 110     -- Save the name under current count, increment count for the next run
 111     -- so the name is saved under the count that was put into the response.
 112     stow name (count, cache) =
 113       (if count >= 99 then 0 else count + 1
 114       , insert count name
 115           $ delete (if count >= 10 then count - 10 else count + 90) cache
 116       )
 117     io = liftIO
 118
 119     mainloop = forever $ do
 120       l <- io getLine
 121       gen <- io $ nmcAge
 122       (count, cache) <- get
 123       case pdnsParse ver l of
 124         Left e -> io $ putStr $ pdnsReport e
 125         Right preq -> do
 126           case preq of
 127             PdnsRequestQ qname qtype id _ _ _ -> do
 128               io $ queryDom (queryOpNmc cfg mgr id) qname
 129                      >>= putStr . (pdnsOutQ ver count gen qname qtype)
 130   {-
 131   -- debug
 132               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
 133                            ++ " id: " ++ (show id)
 134                            ++ " qname: " ++ qname
 135                            ++ " qtype: " ++ (show qtype)
 136                            ++ " cache size: " ++ (show (size cache))
 137   -- end debug
 138   -}
 139               put $ stow qname (count, cache)
 140             PdnsRequestAXFR xrq ->
 141               case fetch xrq cache of
 142                 Nothing ->
 143                   io $ putStr $
 144                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))
 145                 Just qname ->
 146                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
 147                     >>= putStr . (pdnsOutXfr ver count gen qname)
 148             PdnsRequestPing -> io $ putStrLn "END"
 149
 150   runStateT mainloop (0, empty) >> return ()
 151
 152 -- helper for command-line tools
 153
 154 pdnsOut gen key qt dom =
 155   case qt of
 156     "AXFR" -> pdnsOutXfr 1 (-1) gen key dom
 157     _      -> pdnsOutQ 1 (-1) gen key (rrType qt) dom
 158
 159 -- query by key from Namecoin
 160
 161 mainOne gen key qt = do
 162   cfg <- readConfig confFile
 163   mgr <- newManager defaultManagerSettings
 164   dom <- queryDom (queryOpNmc cfg mgr (-1)) key
 165   putStrLn $ ppShow dom
 166   putStr $ pdnsOut gen key qt dom
 167
 168 -- using file backend for testing json domain data
 169
 170 mainFile gen key qt = do
 171   dom <- queryDom queryOpFile key
 172   putStrLn $ ppShow dom
 173   putStr $ pdnsOut gen key qt dom
 174
 175 -- Entry point
 176
 177 main = do
 178   args <- getArgs
 179   gen <- nmcAge
 180   case args of
 181     []                 -> mainPdnsNmc
 182     [key, qtype]       -> mainOne gen key qtype
 183     ["-f" ,key, qtype] -> mainFile gen key qtype
 184     _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\" (type in caps)"