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