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