update spec doc, notably FQDN requirement
[pdns-pipe-nmc.git] / PowerDns.hs
1 module PowerDns ( RRType(..)
2                 , rrType
3                 , PdnsRequest(..)
4                 , pdnsParse
5                 , pdnsReport
6                 , pdnsOutQ
7                 , pdnsOutXfr
8                 ) where
9
10 import Data.Text.Lazy (splitOn, pack)
11 import Data.Map.Lazy (foldrWithKey)
12
13 import NmcDom
14
15 data RRType = RRTypeSRV   | RRTypeA   | RRTypeAAAA | RRTypeCNAME
16             | RRTypeDNAME | RRTypeSOA | RRTypeRP   | RRTypeLOC
17             | RRTypeNS    | RRTypeDS  | RRTypeMX
18             | RRTypeANY   | RRTypeError String
19
20 instance Show RRType where
21   show RRTypeSRV       = "SRV"
22   show RRTypeA         = "A"
23   show RRTypeAAAA      = "AAAA"
24   show RRTypeCNAME     = "CNAME"
25   show RRTypeDNAME     = "DNAME"
26   show RRTypeSOA       = "SOA"
27   show RRTypeRP        = "RP"
28   show RRTypeLOC       = "LOC"
29   show RRTypeNS        = "NS"
30   show RRTypeDS        = "DS"
31   show RRTypeMX        = "MX"
32   show RRTypeANY       = "ANY"
33   show (RRTypeError s) = "Unknown RR type: " ++ (show s)
34
35 rrType qt = case qt of
36   "SRV"     -> RRTypeSRV
37   "A"       -> RRTypeA
38   "AAAA"    -> RRTypeAAAA
39   "CNAME"   -> RRTypeCNAME
40   "DNAME"   -> RRTypeDNAME
41   "SOA"     -> RRTypeSOA
42   "RP"      -> RRTypeRP
43   "LOC"     -> RRTypeLOC
44   "NS"      -> RRTypeNS
45   "DS"      -> RRTypeDS
46   "MX"      -> RRTypeMX
47   "ANY"     -> RRTypeANY
48   _         -> RRTypeError qt
49
50 data PdnsRequest = PdnsRequestQ
51                    { qName              :: String
52                    , qType              :: RRType
53                    , iD                 :: Int
54                    , remoteIpAddress    :: String
55                    , localIpAddress     :: Maybe String
56                    , ednsSubnetAddress  :: Maybe String
57                    }
58                  | PdnsRequestAXFR Int
59                  | PdnsRequestPing
60         deriving (Show)
61
62 -- | Parse request string read from the core PowerDNS process
63 pdnsParse :: Int -> String -> Either String PdnsRequest
64 pdnsParse ver s =
65   let
66     getInt s = case reads s :: [(Int, String)] of
67       [(x, _)] -> x
68       _        -> (-1)
69     getLIp ver xs
70       | ver >= 2  = case xs of
71                       x:_       -> Just x
72                       _         -> Nothing
73       | otherwise = Nothing
74     getRIp ver xs
75       | ver >= 3  = case xs of
76                       _:x:_     -> Just x
77                       _         -> Nothing
78       | otherwise = Nothing
79   in
80     case words s of
81       "PING":[]                 -> Right PdnsRequestPing
82       "AXFR":x:[]               -> Right (PdnsRequestAXFR (getInt x))
83       "Q":qn:"IN":qt:id:rip:xs  -> case rrType qt of
84                                      RRTypeError e ->
85                                        Left $ "Unrecognized RR type: " ++ e
86                                      rt ->
87                                        Right (PdnsRequestQ
88                                             { qName = qn
89                                             , qType = rrType qt
90                                             , iD = getInt id
91                                             , remoteIpAddress = rip
92                                             , localIpAddress = getLIp ver xs
93                                             , ednsSubnetAddress = getRIp ver xs
94                                             })
95       _                         -> Left $ "Unparseable PDNS Request: " ++ s
96
97 -- | Produce LOG entry followed by FAIL
98 pdnsReport :: String -> String
99 pdnsReport err = "LOG\tError: " ++ err ++ "\nFAIL\n"
100
101 -- | Produce answer to the Q request
102 pdnsOutQ :: Int -> Int -> String -> RRType -> Either String NmcDom -> String
103 pdnsOutQ ver id name rrt edom =
104   let
105     rrl = case rrt of
106       RRTypeANY -> [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME
107                    , RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS
108                    , RRTypeDS, RRTypeMX -- SOA not included
109                    ]
110       x         -> [x]
111   in
112     case edom of
113       Left  err ->
114         pdnsReport $ err ++ " in the " ++ (show rrt) ++ " query for " ++ name
115       Right dom ->
116         formatDom ver id rrl name dom "END\n"
117
118 -- | Produce answer to the AXFR request
119 pdnsOutXfr :: Int -> Int -> String -> Either String NmcDom -> String
120 pdnsOutXfr ver id name edom =
121   let
122     allrrs = [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME
123              , RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS
124              , RRTypeDS, RRTypeMX, RRTypeSOA
125              ]
126     walkDom f acc name dom =
127       f name dom $ case domMap dom of
128         Nothing -> acc
129         Just dm ->
130           foldrWithKey (\n d a -> walkDom f a (n ++ "." ++ name) d) acc dm
131   in
132     case edom of
133       Left  err ->
134         pdnsReport $ err ++ " in the AXFR request for " ++ name
135       Right dom ->
136         walkDom (formatDom ver id allrrs) "END\n" name dom
137
138 formatDom ver id rrl name dom acc =
139   foldr (\x a -> (formatRR ver id name dom x) ++ a) acc rrl
140
141 formatRR ver id name dom rrtype =
142   foldr (\x a -> "DATA\t" ++ v3ext ++ name ++ "\tIN\t" ++ (show rrtype)
143               ++ "\t" ++ ttl ++ "\t" ++ (show id) ++ "\t" ++ x ++ "\n" ++ a)
144         "" $ dataRR rrtype name dom
145     where
146       v3ext = case ver of
147         3 -> "0\t1\t"
148         _ -> ""
149       ttl = show 3600
150
151 justl accessor _ dom = case accessor dom of
152   Nothing -> []
153   Just xs -> xs
154
155 justv accessor _ dom = case accessor dom of
156   Nothing -> []
157   Just x  -> [x]
158
159 dotmail addr =
160   let (aname, adom) = break (== '@') addr
161   in case adom of
162     "" -> aname ++ "."
163     _  -> aname ++ "." ++ (tail adom) ++ "."
164
165 dataRR RRTypeSRV   = justl domSrv
166 dataRR RRTypeMX    = justl domMx
167 dataRR RRTypeA     = justl domIp
168 dataRR RRTypeAAAA  = justl domIp6
169 dataRR RRTypeCNAME = justv domAlias
170 dataRR RRTypeDNAME = justv domTranslate
171 dataRR RRTypeSOA   = \ name dom -> -- FIXME make realistic version field
172   let
173     ns = case domNs dom of
174       Just (x:_) -> x           -- FIXME Terminate with a dot?
175       _          -> "."
176     email = case domEmail dom of
177       Nothing   -> "hostmaster." ++ name ++ "."
178       Just addr -> dotmail addr
179   in
180     if dom == emptyNmcDom then []
181     else
182     -- Follows a relatively ugly hack to figure if we are at the top
183     -- level domain ("something.bit"). Only in such case we provide
184     -- the synthetic SOA RR. Otherwise yield empty.
185     -- Alternative would be to carry "top-ness" as a parameter through
186     -- all the calls from the very top where we split the fqdn.
187       case splitOn (pack ".") (pack name) of
188         [_,_] -> [ns ++ " " ++ email ++ " 0 10800 3600 604800 86400"]
189         _     -> []
190 dataRR RRTypeRP    = \ _ dom ->
191   case domEmail dom of
192     Nothing   -> []
193     Just addr -> [(dotmail addr) ++ " ."]
194 dataRR RRTypeLOC   = justv domLoc
195 dataRR RRTypeNS    = justl domNs -- FIXME Terminate with a dot?
196 dataRR RRTypeDS    = \ _ dom ->
197   case domDs dom of
198     Nothing  -> []
199     Just dss -> map dsStr dss
200       where
201         dsStr x = (show (dsKeyTag x)) ++ " "
202                ++ (show (dsAlgo x)) ++ " "
203                ++ (show (dsHashType x)) ++ " "
204                ++ (dsHashValue x)
205 -- This only comes into play when data arrived _not_ from a PDNS request:
206 dataRR (RRTypeError e) = \ _ _ ->
207   ["; No data for bad request type " ++ e]