+ when (qName q == zoneName zone) $
+ do when (Just (qType q) == cast SOA ||
+ Just (qType q) == cast ANY )
+ $ case zoneSOARecord zone of
+ Just rr -> addAnswer rr
+ Nothing -> return ()
+
+ when (Just (qType q) == cast NS ||
+ Just (qType q) == cast ANY )
+ $ case zoneNSRecord zone of
+ Just rr -> addAnswer rr
+ Nothing -> return ()
+
+ mapM_ addAdditional additionals
+
+ case zoneNSRecord zone of
+ Just rr -> addAuthority rr
+ Nothing -> unauthorise
+
+ getAdditionals :: Zone -> SomeRR -> IO [SomeRR]
+ getAdditionals zone (SomeRR rr)
+ = case cast (rrData rr) :: Maybe DomainName of
+ Nothing
+ -> return []
+ Just name
+ -> do allRecords <- zoneResponder zone name
+
+ let filtered = filterRecords (SomeQ q') allRecords
+ q' = Question {
+ qName = name
+ , qType = A
+ , qClass = IN
+ }
+ return filtered
+
+ filterRecords :: SomeQ -> [SomeRR] -> [SomeRR]
+ filterRecords (SomeQ q)
+ | Just (qType q) == cast ANY &&
+ Just (qClass q) == cast ANY = id
+ | Just (qType q) == cast ANY = filter matchClass
+ | Just (qClass q) == cast ANY = filter matchType
+ | otherwise = filter matchBoth
+ where
+ matchClass (SomeRR rr)
+ = Just (qClass q) == cast (rrClass rr)
+
+ matchType (SomeRR rr)
+ = Just (qType q) == cast (rrType rr) ||
+ Just CNAME == cast (rrType rr)
+
+ matchBoth rr
+ = matchType rr && matchClass rr
+
+ handleAXFR :: SomeQ -> Zone -> IO (Builder ())
+ handleAXFR (SomeQ q) zone
+ | qName q == zoneName zone &&
+ isJust (zoneSOA zone) &&
+ cnfAllowTransfer cnf
+ = do names <- zoneRecordNames zone
+ allRecords <- liftM concat $ mapM (zoneResponder zone) names
+ return $ do addAnswer $ fromJust $ zoneSOARecord zone
+ addAnswer $ fromJust $ zoneNSRecord zone
+ mapM_ addAnswer allRecords
+ addAnswerNonuniquely $ fromJust $ zoneSOARecord zone
+ | otherwise
+ = return $ return ()
+
+
+validateQuery :: Message -> ResponseCode
+validateQuery = validateHeader . msgHeader
+ where
+ validateHeader :: Header -> ResponseCode
+ validateHeader hdr
+ | hdMessageType hdr /= Query = NotImplemented
+ | hdOpcode hdr /= StandardQuery = NotImplemented
+ | otherwise = NoError
+
+
+packMessage :: Maybe Int -> Message -> BS.ByteString
+packMessage limM = BS.concat . LBS.toChunks . truncateMsg
+ where
+ truncateMsg :: Message -> LBS.ByteString
+ truncateMsg msg
+ = let packet = encode msg
+ needTrunc = fromMaybe False $
+ do lim <- limM
+ return $ fromIntegral (LBS.length packet) > lim
+ in
+ if needTrunc then
+ truncateMsg $ trunc' msg
+ else
+ packet
+
+ trunc' :: Message -> Message
+ trunc' msg
+ | notNull $ msgAdditionals msg
+ = msg {
+ msgAdditionals = truncList $ msgAdditionals msg
+ }
+ | notNull $ msgAuthorities msg
+ = msg {
+ msgHeader = setTruncFlag $ msgHeader msg
+ , msgAuthorities = truncList $ msgAuthorities msg
+ }
+ | notNull $ msgAnswers msg
+ = msg {
+ msgHeader = setTruncFlag $ msgHeader msg
+ , msgAnswers = truncList $ msgAnswers msg
+ }
+ | notNull $ msgQuestions msg
+ = msg {
+ msgHeader = setTruncFlag $ msgHeader msg
+ , msgQuestions = truncList $ msgQuestions msg
+ }
+ | otherwise
+ = error ("packMessage: You are already skinny and need no diet: " ++ show msg)
+
+ setTruncFlag :: Header -> Header
+ setTruncFlag hdr = hdr { hdIsTruncated = True }
+
+ notNull :: [a] -> Bool
+ notNull = not . null
+
+ truncList :: [a] -> [a]
+ truncList xs = take (length xs - 1) xs