pdns-pipe-nmc.hs

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