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)