PowerDns.hs

   1 module PowerDns ( RRType(..)
   2                 , PdnsRequest(..)
   3                 , pdnsParse
   4                 , pdnsReport
   5                 , pdnsOut
   6                 , pdnsOutXfr
   7                 ) where
   8
   9 import Data.Text.Lazy (splitOn, pack)
  10
  11 import NmcDom
  12
  13 data RRType = RRTypeSRV   | RRTypeA   | RRTypeAAAA | RRTypeCNAME
  14             | RRTypeDNAME | RRTypeSOA | RRTypeRP   | RRTypeLOC
  15             | RRTypeNS    | RRTypeDS  | RRTypeMX
  16             | RRTypeANY   | RRTypeError String
  17
  18 instance Show RRType where
  19   show RRTypeSRV       = "SRV"
  20   show RRTypeA         = "A"
  21   show RRTypeAAAA      = "AAAA"
  22   show RRTypeCNAME     = "CNAME"
  23   show RRTypeDNAME     = "DNAME"
  24   show RRTypeSOA       = "SOA"
  25   show RRTypeRP        = "RP"
  26   show RRTypeLOC       = "LOC"
  27   show RRTypeNS        = "NS"
  28   show RRTypeDS        = "DS"
  29   show RRTypeMX        = "MX"
  30   show RRTypeANY       = "ANY"
  31   show (RRTypeError s) = "RR type error: " ++ (show s)
  32
  33 data PdnsRequest = PdnsRequestQ
  34                    { qName              :: String
  35                    , qType              :: RRType
  36                    , iD                 :: Int
  37                    , remoteIpAddress    :: String
  38                    , localIpAddress     :: Maybe String
  39                    , ednsSubnetAddress  :: Maybe String
  40                    }
  41                  | PdnsRequestAXFR Int
  42                  | PdnsRequestPing
  43         deriving (Show)
  44
  45 -- | Parse request string read from the core PowerDNS process
  46 pdnsParse :: Int -> String -> Either String PdnsRequest
  47 pdnsParse ver s =
  48   let
  49     getInt s = case reads s :: [(Int, String)] of
  50       [(x, _)] -> x
  51       _        -> -1
  52     getQt qt = case qt of
  53       "SRV"     -> RRTypeSRV
  54       "A"       -> RRTypeA
  55       "AAAA"    -> RRTypeAAAA
  56       "CNAME"   -> RRTypeCNAME
  57       "DNAME"   -> RRTypeDNAME
  58       "SOA"     -> RRTypeSOA
  59       "RP"      -> RRTypeRP
  60       "LOC"     -> RRTypeLOC
  61       "NS"      -> RRTypeNS
  62       "DS"      -> RRTypeDS
  63       "MX"      -> RRTypeMX
  64       "ANY"     -> RRTypeANY
  65       _         -> RRTypeError qt
  66     getLIp ver xs
  67       | ver >= 2  = case xs of
  68                       x:_       -> Just x
  69                       _         -> Nothing
  70       | otherwise = Nothing
  71     getRIp ver xs
  72       | ver >= 3  = case xs of
  73                       _:x:_     -> Just x
  74                       _         -> Nothing
  75       | otherwise = Nothing
  76   in
  77     case words s of
  78       "PING":[]                 -> Right PdnsRequestPing
  79       "AXFR":x:[]               -> Right (PdnsRequestAXFR (getInt x))
  80       "Q":qn:"IN":qt:id:rip:xs  -> Right (PdnsRequestQ
  81                                             { qName = qn
  82                                             , qType = getQt qt
  83                                             , iD = getInt id
  84                                             , remoteIpAddress = rip
  85                                             , localIpAddress = getLIp ver xs
  86                                             , ednsSubnetAddress = getRIp ver xs
  87                                             })
  88       _                         -> Left $ "Unparseable PDNS Request: " ++ s
  89
  90 -- | Produce LOG entry followed by FAIL
  91 pdnsReport :: String -> String
  92 pdnsReport err = "LOG\tError: " ++ err ++ "\nFAIL\n"
  93
  94 -- | Produce answer to the Q request
  95 pdnsOut :: Int -> Int -> String -> RRType -> Either String NmcDom -> String
  96 pdnsOut ver id name rrtype edom = case edom of
  97   Left  err ->
  98     pdnsReport $ err ++ " in a " ++ (show rrtype) ++ "query for " ++ name
  99   Right dom ->
 100     case rrtype of
 101       RRTypeANY -> foldr (\x a -> (formatRR ver id name dom x) ++ a) "END\n"
 102           [RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME, RRTypeDNAME,
 103            RRTypeRP, RRTypeLOC, RRTypeNS, RRTypeDS, RRTypeMX]
 104       _         -> (formatRR ver id name dom rrtype) ++ "END\n"
 105
 106 -- | Produce answer to the AXFR request
 107 pdnsOutXfr :: Int -> Int -> String -> Either String NmcDom -> String
 108 pdnsOutXfr ver id name edom = "" -- FIXME
 109
 110 justl accessor _ dom = case accessor dom of
 111   Nothing -> []
 112   Just xs -> xs
 113
 114 justv accessor _ dom = case accessor dom of
 115   Nothing -> []
 116   Just x  -> [x]
 117
 118 dotmail addr =
 119   let (aname, adom) = break (== '@') addr
 120   in case adom of
 121     "" -> aname
 122     _  -> aname ++ "." ++ (tail adom)
 123
 124 dataRR RRTypeSRV   = justl domSrv
 125 dataRR RRTypeMX    = justl domMx
 126 dataRR RRTypeA     = justl domIp
 127 dataRR RRTypeAAAA  = justl domIp6
 128 dataRR RRTypeCNAME = justv domAlias
 129 dataRR RRTypeDNAME = justv domTranslate
 130 dataRR RRTypeSOA   = soa
 131   where
 132     soa name dom  =     -- FIXME generate only for top domain
 133                         -- FIXME make realistic version field
 134                         -- FIXME make realistic nameserver field
 135   -- Follows a relatively ugly hack to figure if we are at the top
 136   -- level domain ("something.bit"). Only in such case we provide
 137   -- the synthetic SOA RR. Otherwise yield empty.
 138       case splitOn (pack ".") (pack name) of
 139         [_,_] ->
 140           if dom == emptyNmcDom then []
 141           else ["ns " ++ email ++ " 99999 10800 3600 604800 86400"]
 142             where
 143               email = case domEmail dom of
 144                 Nothing   -> "hostmaster." ++ name
 145                 Just addr -> dotmail addr
 146         _ -> []
 147 dataRR RRTypeRP    = rp
 148   where
 149     rp _ dom = case domEmail dom of
 150       Nothing   -> []
 151       Just addr -> [(dotmail addr) ++ " ."]
 152 dataRR RRTypeLOC   = justv domLoc
 153 dataRR RRTypeNS    = justl domNs
 154 dataRR RRTypeDS    = ds
 155   where
 156     ds _ dom = case domDs dom of
 157       Nothing  -> []
 158       Just dss -> map dsStr dss
 159         where
 160           dsStr x = (show (dsKeyTag x)) ++ " "
 161                  ++ (show (dsAlgo x)) ++ " "
 162                  ++ (show (dsHashType x)) ++ " "
 163                  ++ (dsHashValue x)
 164
 165 formatRR ver id name dom rrtype =
 166   foldr (\x a -> "DATA\t" ++ v3ext ++ name ++ "\tIN\t" ++ (show rrtype)
 167             ++ "\t" ++ ttl ++ "\t" ++ (show id) ++ "\t" ++ x ++ "\n" ++ a)
 168         "" $ dataRR rrtype name dom
 169     where
 170       v3ext = case ver of
 171         3 -> "0\t1\t"
 172         _ -> ""
 173       ttl = show 3600