]> gitweb @ CieloNegro.org - haskell-dns.git/blob - Network/DNS/Named/Zone.hs
Code clean up
[haskell-dns.git] / Network / DNS / Named / Zone.hs
1 module Network.DNS.Named.Zone
2     ( ZoneFinder(..)
3     , fromZones
4
5     , Zone(zoneName)
6     , SomeZone(..)
7     , ExternalZone(..)
8     , FunctionalZone(..)
9     , StaticZone(..)
10     , fromRecords
11     , isInZone
12     , wrapZone
13
14     , isAuthoritativeZone
15     , getRecords
16     )
17     where
18
19 import           Control.Monad
20 import           Data.List
21 import qualified Data.Map as M
22 import           Data.Map (Map)
23 import           Data.Maybe
24 import           Data.Typeable
25 import           Network.DNS.Message
26 import           Network.DNS.DomainMap
27
28
29 class ZoneFinder a where
30     findZone :: a -> DomainName -> IO (Maybe SomeZone)
31
32 instance ZoneFinder (DomainMap SomeZone) where
33     findZone = (return .) . flip nearest
34
35 instance ZoneFinder (IO (DomainMap SomeZone)) where
36     findZone = flip (fmap . nearest)
37
38 instance ZoneFinder (DomainMap (IO SomeZone)) where
39     findZone m n
40         = do let getZoneM = nearest n m
41              case getZoneM of
42                Just getZone -> liftM Just getZone
43                Nothing      -> return Nothing
44
45 instance ZoneFinder (DomainName -> Maybe SomeZone) where
46     findZone = (return .)
47
48 instance ZoneFinder (DomainName -> IO (Maybe SomeZone)) where
49     findZone = id
50
51
52 fromZones :: [SomeZone] -> DomainMap SomeZone
53 fromZones = fromList . map toPair
54     where
55       toPair z = (zoneName z, z)
56
57
58 class Zone a where
59     zoneName          :: a -> DomainName
60     getRecordNames    :: a -> IO [DomainName]
61     getRecordsForName :: a -> DomainName -> IO [SomeRR]
62
63
64 data SomeZone = forall a. Zone a => SomeZone a
65
66 instance Zone SomeZone where
67     zoneName          (SomeZone a) = zoneName a
68     getRecordNames    (SomeZone a) = getRecordNames a
69     getRecordsForName (SomeZone a) = getRecordsForName a
70
71
72 data ExternalZone
73     = ExternalZone {
74         ezName           :: !DomainName
75       , ezRecordNames    :: !(IO [DomainName])
76       , ezRecordsForName :: !(DomainName -> IO [SomeRR])
77       }
78 instance Zone ExternalZone where
79     zoneName          = ezName
80     getRecordNames    = ezRecordNames
81     getRecordsForName = ezRecordsForName
82
83
84 data FunctionalZone
85     = FunctionalZone {
86         fzName           :: !DomainName
87       , fzRecordNames    :: ![DomainName]
88       , fzRecordsForName :: !(DomainName -> [SomeRR])
89       }
90 instance Zone FunctionalZone where
91     zoneName          = fzName
92     getRecordNames    = return . fzRecordNames
93     getRecordsForName = (return .) . fzRecordsForName
94
95
96 data StaticZone
97     = StaticZone {
98         szName    :: !DomainName
99       , szRecords :: !(Map DomainName [SomeRR])
100       }
101     deriving (Show, Eq)
102
103 instance Zone StaticZone where
104     zoneName          = szName
105     getRecordNames    = return . M.keys . szRecords
106     getRecordsForName = ((return . fromMaybe []) .) . flip M.lookup . szRecords
107
108
109 fromRecords :: [SomeRR] -> Map DomainName [SomeRR]
110 fromRecords = foldl ins M.empty
111     where
112       ins m (SomeRR rr)
113           = case M.lookup (rrName rr) m of
114               Just l
115                   -> M.insert (rrName rr) (l ++ [SomeRR rr]) m
116               Nothing
117                   -> M.insert (rrName rr) [SomeRR rr] m
118
119
120 isInZone :: Zone z => DomainName -> z -> Bool
121 isInZone name zone = zoneName zone `isZoneOf` name
122
123
124 wrapZone :: Zone z => z -> SomeZone
125 wrapZone = SomeZone
126
127
128 isAuthoritativeZone :: Zone z => z -> IO Bool
129 isAuthoritativeZone z
130     = do let q = Question {
131                    qName  = zoneName z
132                  , qType  = SOA
133                  , qClass = IN -- Should we consider any classes other than the Internet?
134                  }
135          rs <- getRecords z q
136          case rs of
137            [] -> return False
138            _  -> return True
139
140
141 getRecords :: (QueryType qt, QueryClass qc, Zone z) =>
142               z
143            -> Question qt qc
144            -> IO [SomeRR]
145 getRecords z q
146     | cast (qType q) == Just AXFR
147         = getRecordsForAXFR
148
149     | otherwise
150         = do rs <- getRecordsForName z (qName q)
151              return $ filterRecords q rs
152
153     where
154       getRecordsForAXFR
155           | qName q == zoneName z
156               = do names      <- getRecordNames z
157                    (soaM, rs) <- liftM (spitSOA . concat) $ mapM (getRecordsForName z) names
158                    case soaM of
159                      Just soa -> return ([soa] ++ rs ++ [soa])
160                      Nothing  -> return []
161           | otherwise
162               = return []
163
164       spitSOA :: [SomeRR] -> (Maybe SomeRR, [SomeRR])
165       spitSOA xs = (findSOA xs, collectNonSOA xs)
166
167       findSOA :: [SomeRR] -> Maybe SomeRR
168       findSOA []     = Nothing
169       findSOA (SomeRR x : xs)
170           | typeOf (rrType x) == typeOf SOA = Just (SomeRR x)
171           | otherwise                       = findSOA xs
172
173       collectNonSOA :: [SomeRR] -> [SomeRR]
174       collectNonSOA []     = []
175       collectNonSOA (SomeRR x : xs)
176           | typeOf (rrType x) == typeOf SOA = collectNonSOA xs
177           | otherwise                       = SomeRR x : collectNonSOA xs
178
179
180 filterRecords :: (QueryType qt, QueryClass qc) =>
181                  Question qt qc
182               -> [SomeRR]
183               -> [SomeRR]
184 filterRecords q = filter predicate
185     where
186       predicate rr
187           = predForType rr && predForClass rr
188
189       predForType (SomeRR rr)
190           | typeOf (qType q) == typeOf ANY
191               = True
192
193           | typeOf (qType q) == typeOf MAILB
194               = typeOf (rrType rr) == typeOf MR ||
195                 typeOf (rrType rr) == typeOf MB ||
196                 typeOf (rrType rr) == typeOf MG ||
197                 typeOf (rrType rr) == typeOf MINFO
198
199           | otherwise
200               = typeOf (rrType rr) == typeOf (qType q) ||
201                 typeOf (rrType rr) == typeOf CNAME
202
203       predForClass (SomeRR rr)
204           | typeOf (qClass q) == typeOf ANY
205               = True
206
207           | otherwise
208               = typeOf (rrClass rr) == typeOf (qClass q)