Network/DNS/Named/Zone.hs

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