diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,26 @@ +# 4.0.1 + +- Bugfix: Retry without EDNS on empty FormatErr responses. Non-EDNS resolvers + may return a FormErr response with an empty question section. Such a response + must be accepted as a valid signal to switch to non-EDNS queries, even though + the response does not contain a matching question. +- Feature: New RData constructors RD_CDS and RD_CDNSKEY +- Usability: More friendly network errors, instead of reporting the error + location as an overly verbose "addrinfo" it is now just the essential + "tcp@address" or "udp@address". +- BCP: The EDNS UDP buffer size has been changed to the RIPE recommended + default of 1232 bytes. Note that this recomendation is for a default value, + to be used when better information is not available. Users can still + configure larger values if their networks support larger data frames and they + are certain there is no risk of IP fragmentation. +- CI: Linux tests now pass with GHC 8.0.2, 8.2.2, 8.4.4, 8.6.5 and 8.8.1. + Windows tests now build and run, but pass only intermittently. The Windows + doctests hang most of the time, perhaps a bug or portability issue in the + doctest code, rather than the DNS library? +- Build: Internal modules are no longer exposed outside the build, this uses + Cabal 2.0 or later features to expose internal modules only to the test + executables. + # 4.0.0 - Breaking change: when `Domain` name ByteStrings are diff --git a/Network/DNS.hs b/Network/DNS.hs --- a/Network/DNS.hs +++ b/Network/DNS.hs @@ -9,8 +9,8 @@ -- Examples: -- -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupA resolver "www.mew.org" --- Right [210.130.207.72] +-- >>> withResolver rs $ \resolver -> lookupA resolver "192.0.2.1.nip.io" +-- Right [192.0.2.1] module Network.DNS ( -- * High level module Network.DNS.Lookup @@ -53,6 +53,3 @@ import Network.DNS.Resolver import Network.DNS.Types import Network.DNS.Utils - --- $setup --- >>> :set -XOverloadedStrings diff --git a/Network/DNS/Base32Hex.hs b/Network/DNS/Base32Hex.hs deleted file mode 100644 --- a/Network/DNS/Base32Hex.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Network.DNS.Base32Hex (encode) where - -import Control.Monad (when) -import qualified Data.Array.MArray as A -import qualified Data.Array.IArray as A -import qualified Data.Array.ST as A -import qualified Data.ByteString as B -import Data.Bits - --- | Encode ByteString using the --- --- encoding with no padding as specified for the --- --- field. --- -encode :: B.ByteString -- ^ input buffer - -> B.ByteString -- ^ base32hex output -encode bs = - let len = (8 * B.length bs + 4) `div` 5 - ws = B.unpack bs - in B.pack $ A.elems $ A.runSTUArray $ do - a <- A.newArray (0 :: Int, len-1) 0 - go ws a 0 - where - toHex32 w | w < 10 = 48 + w - | otherwise = 55 + w - - load8 a i = A.readArray a i - store8 a i v = A.writeArray a i v - - -- Encode a list of 8-bit words at bit offset @n@ - -- into an array 'a' of 5-bit words. - go [] a _ = A.mapArray toHex32 a - go (w:ws) a n = do - -- Split 8 bits into left, middle and right parts. The - -- right part only gets written when the 8-bit input word - -- splits across three different 5-bit words. - -- - let (q, r) = n `divMod` 5 - wl = w `shiftR` ( 3 + r) - wm = (w `shiftL` ( 5 - r)) `shiftR` 3 - wr = (w `shiftL` (10 - r)) `shiftR` 3 - al <- case r of - 0 -> pure wl - _ -> (wl .|.) <$> load8 a q - store8 a q al - store8 a (q + 1) wm - when (r > 2) $ store8 a (q+2) wr - go ws a $ n + 8 -{-# INLINE encode #-} diff --git a/Network/DNS/Decode.hs b/Network/DNS/Decode.hs --- a/Network/DNS/Decode.hs +++ b/Network/DNS/Decode.hs @@ -28,7 +28,7 @@ import Network.DNS.Decode.Parsers import Network.DNS.Imports import Network.DNS.StateBinary -import Network.DNS.Types +import Network.DNS.Types.Internal ---------------------------------------------------------------- diff --git a/Network/DNS/Decode/Internal.hs b/Network/DNS/Decode/Internal.hs deleted file mode 100644 --- a/Network/DNS/Decode/Internal.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - -module Network.DNS.Decode.Internal ( - -- ** Internal message component decoders for tests - decodeDNSHeader - , decodeDNSFlags - , decodeDomain - , decodeMailbox - , decodeResourceRecordAt - , decodeResourceRecord - ) where - -import Network.DNS.Imports -import Network.DNS.StateBinary -import Network.DNS.Types -import Network.DNS.Decode.Parsers - ----------------------------------------------------------------- - --- | Decode the 'DNSFlags' field of 'DNSHeader'. This is an internal function --- exposed only for testing. --- -decodeDNSFlags :: ByteString -> Either DNSError DNSFlags -decodeDNSFlags bs = fst <$> runSGet getDNSFlags bs - --- | Decode the 'DNSHeader' of a message. This is an internal function. --- exposed only for testing. --- -decodeDNSHeader :: ByteString -> Either DNSError DNSHeader -decodeDNSHeader bs = fst <$> runSGet getHeader bs - --- | Decode a domain name. Since DNS names may use name compression, it is not --- generally possible to decode the names separately from the enclosing DNS --- message. This is an internal function exposed only for testing. --- -decodeDomain :: ByteString -> Either DNSError Domain -decodeDomain bs = fst <$> runSGet getDomain bs - --- | Decode a mailbox name (the SOA record /mrname/ field). Since DNS names --- may use name compression, it is not generally possible to decode the names --- separately from the enclosing DNS message. This is an internal function. --- -decodeMailbox :: ByteString -> Either DNSError Mailbox -decodeMailbox bs = fst <$> runSGet getMailbox bs - --- | Decoding resource records. - --- | Decode a resource record (RR) with any DNS timestamps interpreted at the --- nominal epoch time (see 'decodeAt'). Since RRs may use name compression, --- it is not generally possible to decode resource record separately from the --- enclosing DNS message. This is an internal function. --- -decodeResourceRecord :: ByteString -> Either DNSError ResourceRecord -decodeResourceRecord bs = fst <$> runSGet getResourceRecord bs - --- | Decode a resource record (RR) with DNS timestamps interpreted at the --- supplied epoch time. Since RRs may use DNS name compression, it is not --- generally possible to decode resource record separately from the enclosing --- DNS message. This is an internal function. --- -decodeResourceRecordAt :: Int64 -- ^ current epoch time - -> ByteString -- ^ encoded resource record - -> Either DNSError ResourceRecord -decodeResourceRecordAt t bs = fst <$> runSGetAt t getResourceRecord bs diff --git a/Network/DNS/Decode/Parsers.hs b/Network/DNS/Decode/Parsers.hs deleted file mode 100644 --- a/Network/DNS/Decode/Parsers.hs +++ /dev/null @@ -1,470 +0,0 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings #-} - -module Network.DNS.Decode.Parsers ( - getResponse - , getDNSFlags - , getHeader - , getResourceRecord - , getResourceRecords - , getDomain - , getMailbox - ) where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BS -import qualified Data.IP -import Data.IP (IP(..), toIPv4, toIPv6b, makeAddrRange) -import Data.List (partition) - -import Network.DNS.Imports -import Network.DNS.StateBinary -import Network.DNS.Types - --- $setup --- >>> :set -XOverloadedStrings - ----------------------------------------------------------------- - -getResponse :: SGet DNSMessage -getResponse = do - hm <- getHeader - qdCount <- getInt16 - anCount <- getInt16 - nsCount <- getInt16 - arCount <- getInt16 - queries <- getQueries qdCount - answers <- getResourceRecords anCount - authrrs <- getResourceRecords nsCount - addnrrs <- getResourceRecords arCount - let (opts, rest) = partition ((==) OPT. rrtype) addnrrs - flgs = flags hm - rc = fromRCODE $ rcode flgs - (eh, erc) = getEDNS rc opts - hd = hm { flags = flgs { rcode = erc } } - pure $ DNSMessage hd eh queries answers authrrs $ ifEDNS eh rest addnrrs - - where - - -- | Get EDNS pseudo-header and the high eight bits of the extended RCODE. - -- - getEDNS :: Word16 -> AdditionalRecords -> (EDNSheader, RCODE) - getEDNS rc rrs = case rrs of - [rr] | Just (edns, erc) <- optEDNS rr - -> (EDNSheader edns, toRCODE erc) - [] -> (NoEDNS, toRCODE rc) - _ -> (InvalidEDNS, BadRCODE) - - where - - -- | Extract EDNS information from an OPT RR. - -- - optEDNS :: ResourceRecord -> Maybe (EDNS, Word16) - optEDNS (ResourceRecord "." OPT udpsiz ttl' (RD_OPT opts)) = - let hrc = fromIntegral rc .&. 0x0f - erc = shiftR (ttl' .&. 0xff000000) 20 .|. hrc - secok = ttl' `testBit` 15 - vers = fromIntegral $ shiftR (ttl' .&. 0x00ff0000) 16 - in Just (EDNS vers udpsiz secok opts, fromIntegral erc) - optEDNS _ = Nothing - ----------------------------------------------------------------- - -getDNSFlags :: SGet DNSFlags -getDNSFlags = do - flgs <- get16 - oc <- getOpcode flgs - return $ DNSFlags (getQorR flgs) - oc - (getAuthAnswer flgs) - (getTrunCation flgs) - (getRecDesired flgs) - (getRecAvailable flgs) - (getRcode flgs) - (getAuthenData flgs) - (getChkDisable flgs) - where - getQorR w = if testBit w 15 then QR_Response else QR_Query - getOpcode w = - case shiftR w 11 .&. 0x0f of - n | Just opc <- toOPCODE n - -> pure opc - | otherwise - -> failSGet $ "Unsupported header opcode: " ++ show n - getAuthAnswer w = testBit w 10 - getTrunCation w = testBit w 9 - getRecDesired w = testBit w 8 - getRecAvailable w = testBit w 7 - getRcode w = toRCODE $ w .&. 0x0f - getAuthenData w = testBit w 5 - getChkDisable w = testBit w 4 - ----------------------------------------------------------------- - -getHeader :: SGet DNSHeader -getHeader = - DNSHeader <$> decodeIdentifier <*> getDNSFlags - where - decodeIdentifier = get16 - ----------------------------------------------------------------- - -getQueries :: Int -> SGet [Question] -getQueries n = replicateM n getQuery - -getTYPE :: SGet TYPE -getTYPE = toTYPE <$> get16 - --- XXX: Include the class when implemented, or otherwise perhaps check the --- implicit assumption that the class is classIN. --- -getQuery :: SGet Question -getQuery = Question <$> getDomain - <*> getTYPE - <* ignoreClass - where - ignoreClass = get16 - -getResourceRecords :: Int -> SGet [ResourceRecord] -getResourceRecords n = replicateM n getResourceRecord - -getResourceRecord :: SGet ResourceRecord -getResourceRecord = do - dom <- getDomain - typ <- getTYPE - cls <- get16 - ttl <- get32 - len <- getInt16 - dat <- fitSGet len $ getRData typ len - return $ ResourceRecord dom typ cls ttl dat - ----------------------------------------------------------------- - --- | Helper to find position of RData end, that is, the offset of the first --- byte /after/ the current RData. --- -rdataEnd :: Int -- ^ number of bytes left from current position - -> SGet Int -- ^ end position -rdataEnd !len = (+) len <$> getPosition - -getRData :: TYPE -> Int -> SGet RData -getRData NS _ = RD_NS <$> getDomain -getRData MX _ = RD_MX <$> get16 <*> getDomain -getRData CNAME _ = RD_CNAME <$> getDomain -getRData DNAME _ = RD_DNAME <$> getDomain -getRData TXT len = RD_TXT <$> getTXT len -getRData A _ = RD_A . toIPv4 <$> getNBytes 4 -getRData AAAA _ = RD_AAAA . toIPv6b <$> getNBytes 16 -getRData SOA _ = RD_SOA <$> getDomain - <*> getMailbox - <*> decodeSerial - <*> decodeRefesh - <*> decodeRetry - <*> decodeExpire - <*> decodeMinimum - where - decodeSerial = get32 - decodeRefesh = get32 - decodeRetry = get32 - decodeExpire = get32 - decodeMinimum = get32 -getRData PTR _ = RD_PTR <$> getDomain -getRData SRV _ = RD_SRV <$> decodePriority - <*> decodeWeight - <*> decodePort - <*> getDomain - where - decodePriority = get16 - decodeWeight = get16 - decodePort = get16 -getRData OPT len = RD_OPT <$> getOpts len --- -getRData TLSA len = RD_TLSA <$> decodeUsage - <*> decodeSelector - <*> decodeMType - <*> decodeADF - where - decodeUsage = get8 - decodeSelector = get8 - decodeMType = get8 - decodeADF = getNByteString (len - 3) --- -getRData DS len = RD_DS <$> decodeTag - <*> decodeAlg - <*> decodeDtyp - <*> decodeDval - where - decodeTag = get16 - decodeAlg = get8 - decodeDtyp = get8 - decodeDval = getNByteString (len - 4) --- -getRData RRSIG len = RD_RRSIG <$> decodeRRSIG - where - decodeRRSIG = do - -- The signature follows a variable length zone name - -- and occupies the rest of the RData. Simplest to - -- checkpoint the position at the start of the RData, - -- and after reading the zone name, and subtract that - -- from the RData length. - -- - end <- rdataEnd len - typ <- getTYPE - alg <- get8 - cnt <- get8 - ttl <- get32 - tex <- getDnsTime - tin <- getDnsTime - tag <- get16 - dom <- getDomain -- XXX: Enforce no compression? - pos <- getPosition - val <- getNByteString $ end - pos - return $ RDREP_RRSIG typ alg cnt ttl tex tin tag dom val - getDnsTime = do - tnow <- getAtTime - tdns <- get32 - return $! dnsTime tdns tnow --- -getRData NULL len = RD_NULL <$> getNByteString len -getRData NSEC len = do - end <- rdataEnd len - dom <- getDomain - pos <- getPosition - RD_NSEC dom <$> getNsecTypes (end - pos) --- -getRData DNSKEY len = RD_DNSKEY <$> decodeKeyFlags - <*> decodeKeyProto - <*> decodeKeyAlg - <*> decodeKeyBytes - where - decodeKeyFlags = get16 - decodeKeyProto = get8 - decodeKeyAlg = get8 - decodeKeyBytes = getNByteString (len - 4) --- -getRData NSEC3 len = do - dend <- rdataEnd len - halg <- get8 - flgs <- get8 - iter <- get16 - salt <- getInt8 >>= getNByteString - hash <- getInt8 >>= getNByteString - tpos <- getPosition - RD_NSEC3 halg flgs iter salt hash <$> getNsecTypes (dend - tpos) --- -getRData NSEC3PARAM _ = RD_NSEC3PARAM <$> decodeHashAlg - <*> decodeFlags - <*> decodeIterations - <*> decodeSalt - where - decodeHashAlg = get8 - decodeFlags = get8 - decodeIterations = get16 - decodeSalt = getInt8 >>= getNByteString --- -getRData _ len = UnknownRData <$> getNByteString len - ----------------------------------------------------------------- - --- $ --- --- >>> import Network.DNS.StateBinary --- >>> let Right ((t,_),l) = runSGetWithLeftovers (getTXT 8) "\3foo\3barbaz" --- >>> (t, l) == ("foobar", "baz") --- True - --- | Concatenate a sequence of length-prefixed strings of text --- https://tools.ietf.org/html/rfc1035#section-3.3 --- -getTXT :: Int -> SGet ByteString -getTXT !len = B.concat <$> sGetMany "TXT RR string" len getstring - where - getstring = getInt8 >>= getNByteString - --- --- Parse a list of EDNS options --- -getOpts :: Int -> SGet [OData] -getOpts !len = sGetMany "EDNS option" len getoption - where - getoption = do - code <- toOptCode <$> get16 - olen <- getInt16 - getOData code olen - --- --- Parse a list of NSEC type bitmaps --- -getNsecTypes :: Int -> SGet [TYPE] -getNsecTypes !len = concat <$> sGetMany "NSEC type bitmap" len getbits - where - getbits = do - window <- flip shiftL 8 <$> getInt8 - blocks <- getInt8 - when (blocks > 32) $ - failSGet $ "NSEC bitmap block too long: " ++ show blocks - concatMap blkTypes. zip [window, window + 8..] <$> getNBytes blocks - where - blkTypes (bitOffset, byte) = - [ toTYPE $ fromIntegral $ bitOffset + i | - i <- [0..7], byte .&. bit (7-i) /= 0 ] - ----------------------------------------------------------------- - -getOData :: OptCode -> Int -> SGet OData -getOData NSID len = OD_NSID <$> getNByteString len -getOData DAU len = OD_DAU <$> getNoctets len -getOData DHU len = OD_DHU <$> getNoctets len -getOData N3U len = OD_N3U <$> getNoctets len -getOData ClientSubnet len = do - family <- get16 - srcBits <- get8 - scpBits <- get8 - addrbs <- getNByteString (len - 4) -- 4 = 2 + 1 + 1 - -- - -- https://tools.ietf.org/html/rfc7871#section-6 - -- - -- o ADDRESS, variable number of octets, contains either an IPv4 or - -- IPv6 address, depending on FAMILY, which MUST be truncated to the - -- number of bits indicated by the SOURCE PREFIX-LENGTH field, - -- padding with 0 bits to pad to the end of the last octet needed. - -- - -- o A server receiving an ECS option that uses either too few or too - -- many ADDRESS octets, or that has non-zero ADDRESS bits set beyond - -- SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet, - -- as a signal to the software developer making the request to fix - -- their implementation. - -- - -- In order to avoid needless decoding errors, when the ECS encoding - -- requirements are violated, we construct an OD_ECSgeneric OData, - -- instread of an IP-specific OD_ClientSubnet OData, which will only - -- be used for valid inputs. When the family is neither IPv4(1) nor - -- IPv6(2), or the address prefix is not correctly encoded (too long - -- or too short), the OD_ECSgeneric data contains the verbatim input - -- from the peer. - -- - case BS.length addrbs == (fromIntegral srcBits + 7) `div` 8 of - True | Just ip <- bstoip family addrbs srcBits scpBits - -> pure $ OD_ClientSubnet srcBits scpBits ip - _ -> pure $ OD_ECSgeneric family srcBits scpBits addrbs - where - prefix addr bits = Data.IP.addr $ makeAddrRange addr $ fromIntegral bits - zeropad = (++ repeat 0). map fromIntegral. B.unpack - checkBits fromBytes toIP srcBits scpBits bytes = - let addr = fromBytes bytes - maskedAddr = prefix addr srcBits - maxBits = fromIntegral $ 8 * length bytes - in if addr == maskedAddr && scpBits <= maxBits - then Just $ toIP addr - else Nothing - bstoip :: Word16 -> B.ByteString -> Word8 -> Word8 -> Maybe IP - bstoip family bs srcBits scpBits = case family of - 1 -> checkBits toIPv4 IPv4 srcBits scpBits $ take 4 $ zeropad bs - 2 -> checkBits toIPv6b IPv6 srcBits scpBits $ take 16 $ zeropad bs - _ -> Nothing -getOData opc len = UnknownOData (fromOptCode opc) <$> getNByteString len - ----------------------------------------------------------------- - --- | Pointers MUST point back into the packet per RFC1035 Section 4.1.4. This --- is further interpreted by the DNS community (from a discussion on the IETF --- DNSOP mailing list) to mean that they don't point back into the same domain. --- Therefore, when starting to parse a domain, the current offset is also a --- strict upper bound on the targets of any pointers that arise while processing --- the domain. When following a pointer, the target again becomes a stict upper --- bound for any subsequent pointers. This results in a simple loop-prevention --- algorithm, each sequence of valid pointer values is necessarily strictly --- decreasing! The third argument to 'getDomain'' is a strict pointer upper --- bound, and is set here to the position at the start of parsing the domain --- or mailbox. --- --- Note: the separator passed to 'getDomain'' is required to be either \'.\' or --- \'\@\', or else 'unparseLabel' needs to be modified to handle the new value. --- - -getDomain :: SGet Domain -getDomain = getPosition >>= getDomain' dot - -getMailbox :: SGet Mailbox -getMailbox = getPosition >>= getDomain' atsign - -dot, atsign :: Word8 -dot = fromIntegral $ fromEnum '.' -- 46 -atsign = fromIntegral $ fromEnum '@' -- 64 - --- $ --- Pathological case: pointer embedded inside a label! The pointer points --- behind the start of the domain and is then absorbed into the initial label! --- Though we don't IMHO have to support this, it is not manifestly illegal, and --- does exercise the code in an interesting way. Ugly as this is, it also --- "works" the same in Perl's Net::DNS and reportedly in ISC's BIND. --- --- >>> :{ --- let input = "\6\3foo\192\0\3bar\0" --- parser = skipNBytes 1 >> getDomain' dot 1 --- Right (output, _) = runSGet parser input --- in output == "foo.\\003foo\\192\\000.bar." --- :} --- True --- --- The case below fails to point far enough back, and triggers the loop --- prevention code-path. --- --- >>> :{ --- let input = "\6\3foo\192\1\3bar\0" --- parser = skipNBytes 1 >> getDomain' dot 1 --- Left (DecodeError err) = runSGet parser input --- in err --- :} --- "invalid name compression pointer" - --- | Get a domain name, using sep1 as the separator between the 1st and 2nd --- label. Subsequent labels (and always the trailing label) are terminated --- with a ".". --- --- Note: the separator is required to be either \'.\' or \'\@\', or else --- 'unparseLabel' needs to be modified to handle the new value. --- --- Domain name compression pointers must always refer to a position that --- precedes the start of the current domain name. The starting offsets form a --- strictly decreasing sequence, which prevents pointer loops. --- -getDomain' :: Word8 -> Int -> SGet ByteString -getDomain' sep1 ptrLimit = do - pos <- getPosition - c <- getInt8 - let n = getValue c - getdomain pos c n - where - getdomain pos c n - | c == 0 = return "." -- Perhaps the root domain? - | isPointer c = do - d <- getInt8 - let offset = n * 256 + d - when (offset >= ptrLimit) $ - failSGet "invalid name compression pointer" - mo <- pop offset - case mo of - Nothing -> do - msg <- getInput - -- Reprocess the same ByteString starting at the pointer - -- target (offset). - let parser = skipNBytes offset >> getDomain' sep1 offset - case runSGet parser msg of - Left (DecodeError err) -> failSGet err - Left err -> fail $ show err - Right o -> push pos (fst o) >> return (fst o) - Just o -> push pos o >> return o - -- As for now, extended labels have no use. - -- This may change some time in the future. - | isExtLabel c = return "" - | otherwise = do - hs <- unparseLabel sep1 <$> getNByteString n - ds <- getDomain' dot ptrLimit - let dom = case ds of -- avoid trailing ".." - "." -> hs <> "." - _ -> hs <> B.singleton sep1 <> ds - push pos dom - return dom - getValue c = c .&. 0x3f - isPointer c = testBit c 7 && testBit c 6 - isExtLabel c = not (testBit c 7) && testBit c 6 diff --git a/Network/DNS/Encode.hs b/Network/DNS/Encode.hs --- a/Network/DNS/Encode.hs +++ b/Network/DNS/Encode.hs @@ -21,7 +21,7 @@ import Network.DNS.Imports import Network.DNS.StateBinary -import Network.DNS.Types +import Network.DNS.Types.Internal import Network.DNS.Encode.Builders -- | Encode a 'DNSMessage' for transmission over UDP. For transmission over diff --git a/Network/DNS/Encode/Builders.hs b/Network/DNS/Encode/Builders.hs deleted file mode 100644 --- a/Network/DNS/Encode/Builders.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# LANGUAGE - BangPatterns - , RecordWildCards - , TransformListComp - #-} - --- | DNS Message builder. -module Network.DNS.Encode.Builders ( - putDNSMessage - , putDNSFlags - , putHeader - , putDomain - , putMailbox - , putResourceRecord - ) where - -import Control.Monad.State (State, modify, execState, gets) -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.IP -import Data.List (foldl') -import Data.IP (IP(..), fromIPv4, fromIPv6b, makeAddrRange) -import GHC.Exts (the, groupWith) - -import Network.DNS.Imports -import Network.DNS.StateBinary -import Network.DNS.Types - ----------------------------------------------------------------- - -putDNSMessage :: DNSMessage -> SPut -putDNSMessage msg = putHeader hd - <> putNums - <> mconcat (map putQuestion qs) - <> mconcat (map putResourceRecord an) - <> mconcat (map putResourceRecord au) - <> mconcat (map putResourceRecord ad) - where - putNums = mconcat $ fmap putInt16 [ length qs - , length an - , length au - , length ad - ] - hm = header msg - fl = flags hm - eh = ednsHeader msg - qs = question msg - an = answer msg - au = authority msg - hd = ifEDNS eh hm $ hm { flags = fl { rcode = rc } } - rc = ifEDNS eh <$> id <*> nonEDNSrcode $ rcode fl - where - nonEDNSrcode code | fromRCODE code < 16 = code - | otherwise = FormatErr - ad = prependOpt $ additional msg - where - prependOpt ads = mapEDNS eh (fromEDNS ads $ fromRCODE rc) ads - where - fromEDNS :: AdditionalRecords -> Word16 -> EDNS -> AdditionalRecords - fromEDNS rrs rc' edns = ResourceRecord name' type' class' ttl' rdata' : rrs - where - name' = BS.singleton '.' - type' = OPT - class' = maxUdpSize `min` (minUdpSize `max` ednsUdpSize edns) - ttl0' = fromIntegral (rc' .&. 0xff0) `shiftL` 20 - vers' = fromIntegral (ednsVersion edns) `shiftL` 16 - ttl' - | ednsDnssecOk edns = ttl0' `setBit` 15 .|. vers' - | otherwise = ttl0' .|. vers' - rdata' = RD_OPT $ ednsOptions edns - -putHeader :: DNSHeader -> SPut -putHeader hdr = putIdentifier (identifier hdr) - <> putDNSFlags (flags hdr) - where - putIdentifier = put16 - -putDNSFlags :: DNSFlags -> SPut -putDNSFlags DNSFlags{..} = put16 word - where - set :: Word16 -> State Word16 () - set byte = modify (.|. byte) - - st :: State Word16 () - st = sequence_ - [ set (fromRCODE rcode .&. 0x0f) - , when chkDisable $ set (bit 4) - , when authenData $ set (bit 5) - , when recAvailable $ set (bit 7) - , when recDesired $ set (bit 8) - , when trunCation $ set (bit 9) - , when authAnswer $ set (bit 10) - , set (fromOPCODE opcode `shiftL` 11) - , when (qOrR==QR_Response) $ set (bit 15) - ] - - word = execState st 0 - --- XXX: Use question class when implemented --- -putQuestion :: Question -> SPut -putQuestion Question{..} = putDomain qname - <> put16 (fromTYPE qtype) - <> put16 classIN - -putResourceRecord :: ResourceRecord -> SPut -putResourceRecord ResourceRecord{..} = mconcat [ - putDomain rrname - , put16 (fromTYPE rrtype) - , put16 rrclass - , put32 rrttl - , putResourceRData rdata - ] - where - putResourceRData :: RData -> SPut - putResourceRData rd = do - addPositionW 2 -- "simulate" putInt16 - rDataBuilder <- putRData rd - let rdataLength = fromIntegral . LBS.length . BB.toLazyByteString $ rDataBuilder - let rlenBuilder = BB.int16BE rdataLength - return $ rlenBuilder <> rDataBuilder - - -putRData :: RData -> SPut -putRData rd = case rd of - RD_A address -> mconcat $ map putInt8 (fromIPv4 address) - RD_NS nsdname -> putDomain nsdname - RD_CNAME cname -> putDomain cname - RD_SOA a b c d e f g -> putSOA a b c d e f g - RD_NULL bytes -> putByteString bytes - RD_PTR ptrdname -> putDomain ptrdname - RD_MX pref exch -> mconcat [put16 pref, putDomain exch] - RD_TXT textstring -> putTXT textstring - RD_AAAA address -> mconcat $ map putInt8 (fromIPv6b address) - RD_SRV pri wei prt tgt -> putSRV pri wei prt tgt - RD_DNAME dname -> putDomain dname - RD_OPT options -> mconcat $ fmap putOData options - RD_DS kt ka dt d -> putDS kt ka dt d - RD_RRSIG rrsig -> putRRSIG rrsig - RD_NSEC next types -> putDomain next <> putNsecTypes types - RD_DNSKEY f p alg key -> putDNSKEY f p alg key - RD_NSEC3 a f i s h types -> putNSEC3 a f i s h types - RD_NSEC3PARAM a f iter salt -> putNSEC3PARAM a f iter salt - RD_TLSA u s m dgst -> putTLSA u s m dgst - UnknownRData bytes -> putByteString bytes - where - putSOA mn mr serial refresh retry expire minttl = mconcat - [ putDomain mn - , putMailbox mr - , put32 serial - , put32 refresh - , put32 retry - , put32 expire - , put32 minttl - ] - -- TXT record string fragments are at most 255 bytes - putTXT textstring = - let (!h, !t) = BS.splitAt 255 textstring - in putByteStringWithLength h <> if BS.null t - then mempty - else putTXT t - putSRV priority weight port target = mconcat - [ put16 priority - , put16 weight - , put16 port - , putDomain target - ] - putDS keytag keyalg digestType digest = mconcat - [ put16 keytag - , put8 keyalg - , put8 digestType - , putByteString digest - ] - putRRSIG RDREP_RRSIG{..} = mconcat - [ put16 $ fromTYPE rrsigType - , put8 rrsigKeyAlg - , put8 rrsigNumLabels - , put32 rrsigTTL - , put32 $ fromIntegral rrsigExpiration - , put32 $ fromIntegral rrsigInception - , put16 rrsigKeyTag - , putDomain rrsigZone - , putByteString rrsigValue - ] - putDNSKEY flags protocol alg key = mconcat - [ put16 flags - , put8 protocol - , put8 alg - , putByteString key - ] - putNSEC3 alg flags iterations salt hash types = mconcat - [ put8 alg - , put8 flags - , put16 iterations - , putByteStringWithLength salt - , putByteStringWithLength hash - , putNsecTypes types - ] - putNSEC3PARAM alg flags iterations salt = mconcat - [ put8 alg - , put8 flags - , put16 iterations - , putByteStringWithLength salt - ] - putTLSA usage selector mtype assocData = mconcat - [ put8 usage - , put8 selector - , put8 mtype - , putByteString assocData - ] - --- | Encode DNSSEC NSEC type bits -putNsecTypes :: [TYPE] -> SPut -putNsecTypes types = putTypeList $ map fromTYPE types - where - putTypeList :: [Word16] -> SPut - putTypeList ts = - mconcat [ putWindow (the top8) bot8 | - t <- ts, - let top8 = fromIntegral t `shiftR` 8, - let bot8 = fromIntegral t .&. 0xff, - then group by top8 - using groupWith ] - - putWindow :: Int -> [Int] -> SPut - putWindow top8 bot8s = - let blks = maximum bot8s `shiftR` 3 - in putInt8 top8 - <> put8 (1 + fromIntegral blks) - <> putBits 0 [ (the block, foldl' mergeBits 0 bot8) | - bot8 <- bot8s, - let block = bot8 `shiftR` 3, - then group by block - using groupWith ] - where - -- | Combine type bits in network bit order, i.e. bit 0 first. - mergeBits acc b = setBit acc (7 - b.&.0x07) - - putBits :: Int -> [(Int, Word8)] -> SPut - putBits _ [] = pure mempty - putBits n ((block, octet) : rest) = - putReplicate (block-n) 0 - <> put8 octet - <> putBits (block + 1) rest - --- | Encode EDNS OPTION consisting of a list of octets. -putODWords :: Word16 -> [Word8] -> SPut -putODWords code ws = - mconcat [ put16 code - , putInt16 $ length ws - , mconcat $ map put8 ws - ] - --- | Encode an EDNS OPTION byte string. -putODBytes :: Word16 -> ByteString -> SPut -putODBytes code bs = - mconcat [ put16 code - , putInt16 $ BS.length bs - , putByteString bs - ] - -putOData :: OData -> SPut -putOData (OD_NSID nsid) = putODBytes (fromOptCode NSID) nsid -putOData (OD_DAU as) = putODWords (fromOptCode DAU) as -putOData (OD_DHU hs) = putODWords (fromOptCode DHU) hs -putOData (OD_N3U hs) = putODWords (fromOptCode N3U) hs -putOData (OD_ClientSubnet srcBits scpBits ip) = - -- https://tools.ietf.org/html/rfc7871#section-6 - -- - -- o ADDRESS, variable number of octets, contains either an IPv4 or - -- IPv6 address, depending on FAMILY, which MUST be truncated to the - -- number of bits indicated by the SOURCE PREFIX-LENGTH field, - -- padding with 0 bits to pad to the end of the last octet needed. - -- - -- o A server receiving an ECS option that uses either too few or too - -- many ADDRESS octets, or that has non-zero ADDRESS bits set beyond - -- SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet, - -- as a signal to the software developer making the request to fix - -- their implementation. - -- - let octets = fromIntegral $ (srcBits + 7) `div` 8 - prefix addr = Data.IP.addr $ makeAddrRange addr $ fromIntegral srcBits - (family, raw) = case ip of - IPv4 ip4 -> (1, take octets $ fromIPv4 $ prefix ip4) - IPv6 ip6 -> (2, take octets $ fromIPv6b $ prefix ip6) - dataLen = 2 + 2 + octets - in mconcat [ put16 $ fromOptCode ClientSubnet - , putInt16 dataLen - , put16 family - , put8 srcBits - , put8 scpBits - , mconcat $ fmap putInt8 raw - ] -putOData (OD_ECSgeneric family srcBits scpBits addr) = - mconcat [ put16 $ fromOptCode ClientSubnet - , putInt16 $ 4 + BS.length addr - , put16 family - , put8 srcBits - , put8 scpBits - , putByteString addr - ] -putOData (UnknownOData code bs) = putODBytes code bs - --- In the case of the TXT record, we need to put the string length --- fixme : What happens with the length > 256 ? -putByteStringWithLength :: BS.ByteString -> SPut -putByteStringWithLength bs = putInt8 (fromIntegral $ BS.length bs) -- put the length of the given string - <> putByteString bs - ----------------------------------------------------------------- - -rootDomain :: Domain -rootDomain = BS.pack "." - -putDomain :: Domain -> SPut -putDomain = putDomain' '.' - -putMailbox :: Mailbox -> SPut -putMailbox = putDomain' '@' - -putDomain' :: Char -> ByteString -> SPut -putDomain' sep dom - | BS.null dom || dom == rootDomain = put8 0 - | otherwise = do - mpos <- wsPop dom - cur <- gets wsPosition - case mpos of - Just pos -> putPointer pos - Nothing -> wsPush dom cur >> - mconcat [ putPartialDomain hd - , putDomain' '.' tl - ] - where - -- Try with the preferred separator if present, else fall back to '.'. - (hd, tl) = - let p = parseLabel (c2w sep) dom - in if sep /= '.' && BS.null (snd p) - then parseLabel (c2w '.') dom - else p - c2w = fromIntegral . fromEnum - -putPointer :: Int -> SPut -putPointer pos = putInt16 (pos .|. 0xc000) - -putPartialDomain :: Domain -> SPut -putPartialDomain = putByteStringWithLength diff --git a/Network/DNS/Encode/Internal.hs b/Network/DNS/Encode/Internal.hs deleted file mode 100644 --- a/Network/DNS/Encode/Internal.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - --- | Internal DNS message component encoders for the test-suite. -module Network.DNS.Encode.Internal ( - encodeDNSHeader - , encodeDNSFlags - , encodeDomain - , encodeMailbox - , encodeResourceRecord - ) where - -import Network.DNS.Encode.Builders -import Network.DNS.Imports -import Network.DNS.StateBinary -import Network.DNS.Types - --- | Encode DNS flags. -encodeDNSFlags :: DNSFlags -> ByteString -encodeDNSFlags = runSPut . putDNSFlags - --- | Encode DNS header. -encodeDNSHeader :: DNSHeader -> ByteString -encodeDNSHeader = runSPut . putHeader - --- | Encode a domain. -encodeDomain :: Domain -> ByteString -encodeDomain = runSPut . putDomain - --- | Encode a mailbox name. The first label is separated from the remaining --- labels by an @'\@'@ rather than a @.@. This is used for the contact --- address in the @SOA@ record. --- -encodeMailbox :: Mailbox -> ByteString -encodeMailbox = runSPut . putMailbox - --- | Encode a ResourceRecord. -encodeResourceRecord :: ResourceRecord -> ByteString -encodeResourceRecord rr = runSPut $ putResourceRecord rr diff --git a/Network/DNS/IO.hs b/Network/DNS/IO.hs --- a/Network/DNS/IO.hs +++ b/Network/DNS/IO.hs @@ -18,7 +18,6 @@ ) where import qualified Control.Exception as E -import Control.Monad (void) import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BS @@ -31,11 +30,10 @@ import qualified Network.Socket.ByteString as Socket import System.IO.Error - import Network.DNS.Decode (decodeAt) import Network.DNS.Encode (encode) import Network.DNS.Imports -import Network.DNS.Types +import Network.DNS.Types.Internal ---------------------------------------------------------------- diff --git a/Network/DNS/Imports.hs b/Network/DNS/Imports.hs deleted file mode 100644 --- a/Network/DNS/Imports.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Network.DNS.Imports ( - ByteString - , Int64 - , NonEmpty(..) - , module Control.Applicative - , module Control.Monad - , module Data.Bits - , module Data.List - , module Data.Maybe - , module Data.Monoid - , module Data.Ord - , module Data.Typeable - , module Data.Word - , module Numeric - ) where - -import Control.Applicative -import Control.Monad -import Data.Bits -import Data.ByteString (ByteString) -import Data.Int (Int64) -import Data.List -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe -import Data.Monoid -import Data.Ord -import Data.Typeable -import Data.Word -import Numeric diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs --- a/Network/DNS/Lookup.hs +++ b/Network/DNS/Lookup.hs @@ -78,10 +78,7 @@ import Network.DNS.Imports import Network.DNS.LookupRaw as DNS import Network.DNS.Resolver as DNS -import Network.DNS.Types - --- $setup --- >>> :set -XOverloadedStrings +import Network.DNS.Types.Internal ---------------------------------------------------------------- @@ -90,11 +87,11 @@ -- A straightforward example: -- -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupA resolver "www.mew.org" --- Right [210.130.207.72] +-- >>> withResolver rs $ \resolver -> lookupA resolver "192.0.2.1.nip.io" +-- Right [192.0.2.1] -- -- This function will also follow a CNAME and resolve its target if --- one exists for the queries hostname: +-- one exists for the queried hostname: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupA resolver "www.kame.net" @@ -139,15 +136,15 @@ -- constitute an MX record: a hostname , and an integer priority. We -- therefore return each record as a @('Domain', Int)@. -- --- In this first example, we look up the MX for the domain --- \"example.com\". It has no MX (to prevent a deluge of spam from --- examples posted on the internet). But remember, \"no results\" is --- still a successful result. +-- In this first example, we look up the MX for the domain \"example.com\". +-- It has an RFC7505 NULL MX (to prevent a deluge of spam from examples +-- posted on the internet). -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupMX resolver "example.com" --- Right [] +-- Right [(".",0)] -- +-- -- The domain \"mew.org\" does however have a single MX: -- -- >>> rs <- makeResolvSeed defaultResolvConf @@ -157,6 +154,13 @@ -- Also note that all hostnames are returned with a trailing dot to -- indicate the DNS root. -- +-- However the MX host itself has no need for an MX record, so its MX RRset +-- is empty. But, \"no results\" is still a successful result. +-- +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupMX resolver "mail.mew.org" +-- Right [] +-- lookupMX :: Resolver -> Domain -> IO (Either DNSError [(Domain,Int)]) lookupMX rlv dom = do erds <- DNS.lookup rlv dom MX @@ -323,8 +327,9 @@ -- using the \'rname\` as a contact email address. -- -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupSOA resolver "mew.org" --- Right [("ns1.mew.org.","kazu@mew.org.",201406240,3600,300,3600000,3600)] +-- >>> soa <- withResolver rs $ \resolver -> lookupSOA resolver "mew.org" +-- >>> map (\ (mn, rn, _, _, _, _, _) -> (mn, rn)) <$> soa +-- Right [("ns1.mew.org.","kazu@mew.org.")] -- lookupSOA :: Resolver -> Domain -> IO (Either DNSError [(Domain,Mailbox,Word32,Word32,Word32,Word32,Word32)]) lookupSOA rlv dom = do diff --git a/Network/DNS/LookupRaw.hs b/Network/DNS/LookupRaw.hs --- a/Network/DNS/LookupRaw.hs +++ b/Network/DNS/LookupRaw.hs @@ -12,18 +12,17 @@ ) where import Data.Hourglass (timeAdd, Seconds) -import Time.System (timeCurrent) import Prelude hiding (lookup) +import Time.System (timeCurrent) import Network.DNS.IO import Network.DNS.Imports hiding (lookup) import Network.DNS.Memo import Network.DNS.Transport -import Network.DNS.Types import Network.DNS.Types.Internal +import Network.DNS.Types.Resolver -- $setup --- >>> :set -XOverloadedStrings -- >>> import Network.DNS.Resolver ---------------------------------------------------------------- diff --git a/Network/DNS/Memo.hs b/Network/DNS/Memo.hs deleted file mode 100644 --- a/Network/DNS/Memo.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Network.DNS.Memo where - -import qualified Control.Reaper as R -import qualified Data.ByteString as B -import Data.Hourglass (Elapsed) -import Data.OrdPSQ (OrdPSQ) -import qualified Data.OrdPSQ as PSQ -import Time.System (timeCurrent) - -import Network.DNS.Imports -import Network.DNS.Types - -data Section = Answer | Authority deriving (Eq, Ord, Show) - -type Key = (ByteString - ,TYPE) -type Prio = Elapsed - -type Entry = Either DNSError [RData] - -type DB = OrdPSQ Key Prio Entry - -type Cache = R.Reaper DB (Key,Prio,Entry) - -newCache :: Int -> IO Cache -newCache delay = R.mkReaper R.defaultReaperSettings { - R.reaperEmpty = PSQ.empty - , R.reaperCons = \(k, tim, v) psq -> PSQ.insert k tim v psq - , R.reaperAction = prune - , R.reaperDelay = delay * 1000000 - , R.reaperNull = PSQ.null - } - -lookupCache :: Key -> Cache -> IO (Maybe (Prio, Entry)) -lookupCache key reaper = PSQ.lookup key <$> R.reaperRead reaper - -insertCache :: Key -> Prio -> Entry -> Cache -> IO () -insertCache (dom,typ) tim ent0 reaper = R.reaperAdd reaper (key,tim,ent) - where - key = (B.copy dom,typ) - ent = case ent0 of - l@(Left _) -> l - (Right rds) -> Right $ map copy rds - --- Theoretically speaking, atMostView itself is good enough for pruning. --- But auto-update assumes a list based db which does not provide atMost --- functions. So, we need to do this redundant way. -prune :: DB -> IO (DB -> DB) -prune oldpsq = do - tim <- timeCurrent - let (_, pruned) = PSQ.atMostView tim oldpsq - return $ \newpsq -> foldl' ins pruned $ PSQ.toList newpsq - where - ins psq (k,p,v) = PSQ.insert k p v psq - -copy :: RData -> RData -copy r@(RD_A _) = r -copy (RD_NS dom) = RD_NS $ B.copy dom -copy (RD_CNAME dom) = RD_CNAME $ B.copy dom -copy (RD_SOA mn mr a b c d e) = RD_SOA (B.copy mn) (B.copy mr) a b c d e -copy (RD_PTR dom) = RD_PTR $ B.copy dom -copy (RD_NULL bytes) = RD_NULL $ B.copy bytes -copy (RD_MX prf dom) = RD_MX prf $ B.copy dom -copy (RD_TXT txt) = RD_TXT $ B.copy txt -copy r@(RD_AAAA _) = r -copy (RD_SRV a b c dom) = RD_SRV a b c $ B.copy dom -copy (RD_DNAME dom) = RD_DNAME $ B.copy dom -copy (RD_OPT od) = RD_OPT $ map copyOData od -copy (RD_DS t a dt dv) = RD_DS t a dt $ B.copy dv -copy (RD_NSEC dom ts) = RD_NSEC (B.copy dom) ts -copy (RD_DNSKEY f p a k) = RD_DNSKEY f p a $ B.copy k -copy (RD_TLSA a b c dgst) = RD_TLSA a b c $ B.copy dgst -copy (RD_NSEC3 a b c s h t) = RD_NSEC3 a b c (B.copy s) (B.copy h) t -copy (RD_NSEC3PARAM a b c salt) = RD_NSEC3PARAM a b c $ B.copy salt -copy (RD_RRSIG sig) = RD_RRSIG $ copysig sig - where - copysig s@RDREP_RRSIG{..} = - s { rrsigZone = B.copy rrsigZone - , rrsigValue = B.copy rrsigValue } -copy (UnknownRData is) = UnknownRData $ B.copy is - -copyOData :: OData -> OData -copyOData (OD_ECSgeneric family srcBits scpBits bs) = - OD_ECSgeneric family srcBits scpBits $ B.copy bs -copyOData (OD_NSID nsid) = OD_NSID $ B.copy nsid -copyOData (UnknownOData c b) = UnknownOData c $ B.copy b - --- No copying required for the rest, but avoiding a wildcard pattern match --- so that if more option types are added in the future, the compiler will --- complain about a partial function. --- -copyOData o@OD_ClientSubnet {} = o -copyOData o@OD_DAU {} = o -copyOData o@OD_DHU {} = o -copyOData o@OD_N3U {} = o diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs --- a/Network/DNS/Resolver.hs +++ b/Network/DNS/Resolver.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} @@ -30,12 +29,6 @@ , withResolvers ) where -#if !defined(mingw32_HOST_OS) -#define POSIX -#else -#define WIN -#endif - import Control.Exception as E import qualified Crypto.Random as C import qualified Data.ByteString as BS @@ -45,19 +38,12 @@ import Network.Socket (AddrInfoFlag(..), AddrInfo(..), PortNumber, HostName, SocketType(Datagram), getAddrInfo, defaultHints) import Prelude -#if defined(WIN) -import qualified Data.List.Split as Split -import Foreign.C.String -import Foreign.Marshal.Alloc (allocaBytes) -#else -import Data.Char (isSpace) -#endif - import Network.DNS.Imports import Network.DNS.Memo +import Network.DNS.Resolver.Internal import Network.DNS.Transport -import Network.DNS.Types import Network.DNS.Types.Internal +import Network.DNS.Types.Resolver ---------------------------------------------------------------- @@ -78,27 +64,6 @@ RCFilePath file -> getDefaultDnsServers file >>= mkAddrs mkAddrs [] = E.throwIO BadConfiguration mkAddrs (l:ls) = (:|) <$> makeAddrInfo l Nothing <*> forM ls (`makeAddrInfo` Nothing) - -getDefaultDnsServers :: FilePath -> IO [String] -#if defined(WIN) -foreign import ccall "getWindowsDefDnsServers" getWindowsDefDnsServers :: CString -> Int -> IO Word32 -getDefaultDnsServers _ = do - allocaBytes 128 $ \cString -> do - res <- getWindowsDefDnsServers cString 128 - case res of - 0 -> do - addresses <- peekCString cString - return $ filter (not . null) . Split.splitOn "," $ addresses - _ -> do - -- TODO: Do proper error handling here. - return mempty -#else -getDefaultDnsServers file = toAddresses <$> readFile file - where - toAddresses :: String -> [String] - toAddresses cs = map extract (filter ("nameserver" `isPrefixOf`) (lines cs)) - extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11 -#endif makeAddrInfo :: HostName -> Maybe PortNumber -> IO AddrInfo makeAddrInfo addr mport = do diff --git a/Network/DNS/StateBinary.hs b/Network/DNS/StateBinary.hs deleted file mode 100644 --- a/Network/DNS/StateBinary.hs +++ /dev/null @@ -1,444 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Network.DNS.StateBinary ( - PState(..) - , initialState - , SPut - , runSPut - , put8 - , put16 - , put32 - , putInt8 - , putInt16 - , putInt32 - , putByteString - , putReplicate - , SGet - , failSGet - , fitSGet - , runSGet - , runSGetAt - , runSGetWithLeftovers - , runSGetWithLeftoversAt - , get8 - , get16 - , get32 - , getInt8 - , getInt16 - , getInt32 - , getNByteString - , sGetMany - , getPosition - , getInput - , getAtTime - , wsPop - , wsPush - , wsPosition - , addPositionW - , push - , pop - , getNBytes - , getNoctets - , skipNBytes - , parseLabel - , unparseLabel - ) where - -import qualified Control.Exception as E -import Control.Monad.State.Strict (State, StateT) -import qualified Control.Monad.State.Strict as ST -import qualified Data.Attoparsec.ByteString as A -import qualified Data.Attoparsec.Types as T -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as S8 -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as LB -import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.IntMap (IntMap) -import qualified Data.IntMap as IM -import Data.Map (Map) -import qualified Data.Map as M -import Data.Semigroup as Sem - -import Network.DNS.Imports -import Network.DNS.Types - ----------------------------------------------------------------- - -type SPut = State WState Builder - -data WState = WState { - wsDomain :: Map Domain Int - , wsPosition :: Int -} - -initialWState :: WState -initialWState = WState M.empty 0 - -instance Sem.Semigroup SPut where - p1 <> p2 = (Sem.<>) <$> p1 <*> p2 - -instance Monoid SPut where - mempty = return mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (Sem.<>) -#endif - -put8 :: Word8 -> SPut -put8 = fixedSized 1 BB.word8 - -put16 :: Word16 -> SPut -put16 = fixedSized 2 BB.word16BE - -put32 :: Word32 -> SPut -put32 = fixedSized 4 BB.word32BE - -putInt8 :: Int -> SPut -putInt8 = fixedSized 1 (BB.int8 . fromIntegral) - -putInt16 :: Int -> SPut -putInt16 = fixedSized 2 (BB.int16BE . fromIntegral) - -putInt32 :: Int -> SPut -putInt32 = fixedSized 4 (BB.int32BE . fromIntegral) - -putByteString :: ByteString -> SPut -putByteString = writeSized BS.length BB.byteString - -putReplicate :: Int -> Word8 -> SPut -putReplicate n w = - fixedSized n BB.lazyByteString $ LB.replicate (fromIntegral n) w - -addPositionW :: Int -> State WState () -addPositionW n = do - (WState m cur) <- ST.get - ST.put $ WState m (cur+n) - -fixedSized :: Int -> (a -> Builder) -> a -> SPut -fixedSized n f a = do addPositionW n - return (f a) - -writeSized :: (a -> Int) -> (a -> Builder) -> a -> SPut -writeSized n f a = do addPositionW (n a) - return (f a) - -wsPop :: Domain -> State WState (Maybe Int) -wsPop dom = do - doms <- ST.gets wsDomain - return $ M.lookup dom doms - -wsPush :: Domain -> Int -> State WState () -wsPush dom pos = do - (WState m cur) <- ST.get - ST.put $ WState (M.insert dom pos m) cur - ----------------------------------------------------------------- - -type SGet = StateT PState (T.Parser ByteString) - -data PState = PState { - psDomain :: IntMap Domain - , psPosition :: Int - , psInput :: ByteString - , psAtTime :: Int64 - } - ----------------------------------------------------------------- - -getPosition :: SGet Int -getPosition = ST.gets psPosition - -getInput :: SGet ByteString -getInput = ST.gets psInput - -getAtTime :: SGet Int64 -getAtTime = ST.gets psAtTime - -addPosition :: Int -> SGet () -addPosition n | n < 0 = failSGet "internal error: negative position increment" - | otherwise = do - PState dom pos inp t <- ST.get - let !pos' = pos + n - when (pos' > BS.length inp) $ - failSGet "malformed or truncated input" - ST.put $ PState dom pos' inp t - -push :: Int -> Domain -> SGet () -push n d = do - PState dom pos inp t <- ST.get - ST.put $ PState (IM.insert n d dom) pos inp t - -pop :: Int -> SGet (Maybe Domain) -pop n = ST.gets (IM.lookup n . psDomain) - ----------------------------------------------------------------- - -get8 :: SGet Word8 -get8 = ST.lift A.anyWord8 <* addPosition 1 - -get16 :: SGet Word16 -get16 = ST.lift getWord16be <* addPosition 2 - where - word8' = fromIntegral <$> A.anyWord8 - getWord16be = do - a <- word8' - b <- word8' - return $ a * 0x100 + b - -get32 :: SGet Word32 -get32 = ST.lift getWord32be <* addPosition 4 - where - word8' = fromIntegral <$> A.anyWord8 - getWord32be = do - a <- word8' - b <- word8' - c <- word8' - d <- word8' - return $ a * 0x1000000 + b * 0x10000 + c * 0x100 + d - -getInt8 :: SGet Int -getInt8 = fromIntegral <$> get8 - -getInt16 :: SGet Int -getInt16 = fromIntegral <$> get16 - -getInt32 :: SGet Int -getInt32 = fromIntegral <$> get32 - ----------------------------------------------------------------- - -overrun :: SGet a -overrun = failSGet "malformed or truncated input" - -getNBytes :: Int -> SGet [Int] -getNBytes n | n < 0 = overrun - | otherwise = toInts <$> getNByteString n - where - toInts = map fromIntegral . BS.unpack - -getNoctets :: Int -> SGet [Word8] -getNoctets n | n < 0 = overrun - | otherwise = BS.unpack <$> getNByteString n - -skipNBytes :: Int -> SGet () -skipNBytes n | n < 0 = overrun - | otherwise = ST.lift (A.take n) >> addPosition n - -getNByteString :: Int -> SGet ByteString -getNByteString n | n < 0 = overrun - | otherwise = ST.lift (A.take n) <* addPosition n - -fitSGet :: Int -> SGet a -> SGet a -fitSGet len parser | len < 0 = overrun - | otherwise = do - pos0 <- getPosition - ret <- parser - pos' <- getPosition - if pos' == pos0 + len - then return $! ret - else if pos' > pos0 + len - then failSGet "element size exceeds declared size" - else failSGet "element shorter than declared size" - --- | Parse a list of elements that takes up exactly a given number of bytes. --- In order to avoid infinite loops, if an element parser succeeds without --- moving the buffer offset forward, an error will be returned. --- -sGetMany :: String -- ^ element type for error messages - -> Int -- ^ input buffer length - -> SGet a -- ^ element parser - -> SGet [a] -sGetMany elemname len parser | len < 0 = overrun - | otherwise = go len [] - where - go n xs - | n < 0 = failSGet $ elemname ++ " longer than declared size" - | n == 0 = pure $ reverse xs - | otherwise = do - pos0 <- getPosition - x <- parser - pos1 <- getPosition - if pos1 <= pos0 - then failSGet $ "internal error: in-place success for " ++ elemname - else go (n + pos0 - pos1) (x : xs) - ----------------------------------------------------------------- - --- | To get a broad range of correct RRSIG inception and expiration times --- without over or underflow, we choose a time half way between midnight PDT --- 2010-07-15 (the day the root zone was signed) and 2^32 seconds later on --- 2146-08-21. Since 'decode' and 'runSGet' are pure, we can't peek at the --- current time while parsing. Outside this date range the output is off by --- some non-zero multiple 2\^32 seconds. --- -dnsTimeMid :: Int64 -dnsTimeMid = 3426660848 - -initialState :: Int64 -> ByteString -> PState -initialState t inp = PState IM.empty 0 inp t - --- Construct our own error message, without the unhelpful AttoParsec --- \"Failed reading: \" prefix. --- -failSGet :: String -> SGet a -failSGet msg = ST.lift (fail "" A. msg) - -runSGetAt :: Int64 -> SGet a -> ByteString -> Either DNSError (a, PState) -runSGetAt t parser inp = - toResult $ A.parse (ST.runStateT parser $ initialState t inp) inp - where - toResult :: A.Result r -> Either DNSError r - toResult (A.Done _ r) = Right r - toResult (A.Fail _ ctx msg) = Left $ DecodeError $ head $ ctx ++ [msg] - toResult (A.Partial _) = Left $ DecodeError "incomplete input" - -runSGet :: SGet a -> ByteString -> Either DNSError (a, PState) -runSGet = runSGetAt dnsTimeMid - -runSGetWithLeftoversAt :: Int64 -- ^ Reference time for DNS clock arithmetic - -> SGet a -- ^ Parser - -> ByteString -- ^ Encoded message - -> Either DNSError ((a, PState), ByteString) -runSGetWithLeftoversAt t parser inp = - toResult $ A.parse (ST.runStateT parser $ initialState t inp) inp - where - toResult :: A.Result r -> Either DNSError (r, ByteString) - toResult (A.Done i r) = Right (r, i) - toResult (A.Partial f) = toResult $ f BS.empty - toResult (A.Fail _ ctx e) = Left $ DecodeError $ head $ ctx ++ [e] - -runSGetWithLeftovers :: SGet a -> ByteString -> Either DNSError ((a, PState), ByteString) -runSGetWithLeftovers = runSGetWithLeftoversAt dnsTimeMid - -runSPut :: SPut -> ByteString -runSPut = LBS.toStrict . BB.toLazyByteString . flip ST.evalState initialWState - ----------------------------------------------------------------- - --- | Decode a domain name in A-label form to a leading label and a tail with --- the remaining labels, unescaping backlashed chars and decimal triples along --- the way. Any U-label conversion belongs at the layer above this code. --- --- This function is pure, but is not total, it throws an error when presented --- with malformed input --- -parseLabel :: Word8 -> ByteString -> (ByteString, ByteString) -parseLabel sep dom = - if BS.any (== bslash) dom - then toResult $ A.parse (labelParser sep mempty) dom - else check $ safeTail <$> BS.break (== sep) dom - where - toResult (A.Partial c) = toResult (c mempty) - toResult (A.Done tl hd) = check (hd, tl) - toResult _ = bottom - safeTail bs | BS.null bs = mempty - | otherwise = BS.tail bs - check r@(hd, tl) | not (BS.null hd) || BS.null tl = r - | otherwise = bottom - bottom = E.throw $ DecodeError $ "invalid domain: " ++ S8.unpack dom - -labelParser :: Word8 -> ByteString -> A.Parser ByteString -labelParser sep acc = do - acc' <- mappend acc <$> A.option mempty simple - labelEnd sep acc' <|> (escaped >>= labelParser sep . BS.snoc acc') - where - simple = fst <$> A.match skipUnescaped - where - skipUnescaped = A.skipMany1 $ A.satisfy notSepOrBslash - notSepOrBslash w = w /= sep && w /= bslash - - escaped = do - A.skip (== bslash) - either decodeDec pure =<< A.eitherP digit A.anyWord8 - where - digit = fromIntegral <$> A.satisfyWith (\n -> n - zero) (<=9) - decodeDec d = - safeWord8 =<< trigraph d <$> digit <*> digit - where - trigraph :: Word -> Word -> Word -> Word - trigraph x y z = 100 * x + 10 * y + z - - safeWord8 :: Word -> A.Parser Word8 - safeWord8 n | n > 255 = mzero - | otherwise = pure $ fromIntegral n - -labelEnd :: Word8 -> ByteString -> A.Parser ByteString -labelEnd sep acc = - A.satisfy (== sep) *> pure acc <|> - A.endOfInput *> pure acc - ----------------------------------------------------------------- - --- | Convert a wire-form label to presentation-form by escaping --- the separator, special and non-printing characters. For simple --- labels with no bytes that require escaping we get back the input --- bytestring asis with no copying or re-construction. --- --- Note: the separator is required to be either \'.\' or \'\@\', but this --- constraint is the caller's responsibility and is not checked here. --- -unparseLabel :: Word8 -> ByteString -> ByteString -unparseLabel sep label = - if BS.all (isPlain sep) label - then label - else toResult $ A.parse (labelUnparser sep mempty) label - where - toResult (A.Partial c) = toResult (c mempty) - toResult (A.Done _ r) = r - toResult _ = E.throw UnknownDNSError -- can't happen - -labelUnparser :: Word8 -> ByteString -> A.Parser ByteString -labelUnparser sep acc = do - acc' <- mappend acc <$> A.option mempty asis - A.endOfInput *> pure acc' <|> (esc >>= labelUnparser sep . mappend acc') - where - -- Non-printables are escaped as decimal trigraphs, while printable - -- specials just get a backslash prefix. - esc = do - w <- A.anyWord8 - if w <= 32 || w >= 127 - then let (q100, r100) = w `divMod` 100 - (q10, r10) = r100 `divMod` 10 - in pure $ BS.pack [ bslash, zero + q100, zero + q10, zero + r10 ] - else pure $ BS.pack [ bslash, w ] - - -- Runs of plain bytes are recognized as a single chunk, which is then - -- returned as-is. - asis = fmap fst $ A.match $ A.skipMany1 $ A.satisfy $ isPlain sep - --- | In the presentation form of DNS labels, these characters are escaped by --- prepending a backlash. (They have special meaning in zone files). Whitespace --- and other non-printable or non-ascii characters are encoded via "\DDD" --- decimal escapes. The separator character is also quoted in each label. Note --- that '@' is quoted even when not the separator. -escSpecials :: ByteString -escSpecials = "\"$();@\\" - --- | Is the given byte the separator or one of the specials? -isSpecial :: Word8 -> Word8 -> Bool -isSpecial sep w = w == sep || BS.elemIndex w escSpecials /= Nothing - --- | Is the given byte a plain byte that reqires no escaping. The tests are --- ordered to succeed or fail quickly in the most common cases. The test --- ranges assume the expected numeric values of the named special characters. --- Note: the separator is assumed to be either '.' or '@' and so not matched by --- any of the first three fast-path 'True' cases. -isPlain :: Word8 -> Word8 -> Bool -isPlain sep w | w >= 127 = False -- + non-ASCII - | w > bslash = True -- ']'..'_'..'a'..'z'..'~' - | w >= zero && w < semi = True -- '0'..'9'..':' - | w > atsign && w < bslash = True -- 'A'..'Z'..'[' - | w <= 32 = False -- non-printables - | isSpecial sep w = False -- one of the specials - | otherwise = True -- plain punctuation - --- | Some numeric byte constants. -zero, semi, atsign, bslash :: Word8 -zero = fromIntegral $ fromEnum '0' -- 48 -semi = fromIntegral $ fromEnum ';' -- 59 -atsign = fromIntegral $ fromEnum '@' -- 64 -bslash = fromIntegral $ fromEnum '\\' -- 92 diff --git a/Network/DNS/Transport.hs b/Network/DNS/Transport.hs --- a/Network/DNS/Transport.hs +++ b/Network/DNS/Transport.hs @@ -16,18 +16,24 @@ import Network.DNS.IO import Network.DNS.Imports -import Network.DNS.Types import Network.DNS.Types.Internal +import Network.DNS.Types.Resolver -- | Check response for a matching identifier and question. If we ever do -- pipelined TCP, we'll need to handle out of order responses. See: -- https://tools.ietf.org/html/rfc7766#section-7 +-- checkResp :: Question -> Identifier -> DNSMessage -> Bool checkResp q seqno = isNothing . checkRespM q seqno +-- When the response 'RCODE' is 'FormatErr', the server did not understand our +-- query packet, and so is not expected to return a matching question. +-- checkRespM :: Question -> Identifier -> DNSMessage -> Maybe DNSError checkRespM q seqno resp | identifier (header resp) /= seqno = Just SequenceNumberMismatch + | FormatErr <- rcode $ flags $ header resp + , [] <- question resp = Nothing | [q] /= question resp = Just QuestionMismatch | otherwise = Nothing @@ -133,9 +139,10 @@ ---------------------------------------------------------------- ioErrorToDNSError :: AddrInfo -> String -> IOError -> IO DNSMessage -ioErrorToDNSError ai tag ioe = throwIO $ NetworkFailure aioe +ioErrorToDNSError ai protoName ioe = throwIO $ NetworkFailure aioe where - aioe = annotateIOError ioe (show ai) Nothing $ Just tag + loc = protoName ++ "@" ++ show (addrAddress ai) + aioe = annotateIOError ioe loc Nothing Nothing ---------------------------------------------------------------- @@ -149,7 +156,7 @@ udpLookup :: Identifier -> UdpRslv udpLookup ident retry rcv ai q tm ctls = do let qry = encodeQuestion ident q ctls - E.handle (ioErrorToDNSError ai "UDP") $ + E.handle (ioErrorToDNSError ai "udp") $ bracket (udpOpen ai) close (loop qry ctls 0 RetryLimitExceeded) where loop qry lctls cnt err sock @@ -178,9 +185,9 @@ -- instead we'll time out if no matching answer arrives. -- getAns sock = do - mres <- rcv sock - if checkResp q ident mres - then return mres + resp <- rcv sock + if checkResp q ident resp + then return resp else getAns sock ---------------------------------------------------------------- @@ -197,7 +204,7 @@ -- This throws DNSError only. tcpLookup :: IO Identifier -> TcpRslv tcpLookup gen ai q tm ctls = - E.handle (ioErrorToDNSError ai "TCP") $ do + E.handle (ioErrorToDNSError ai "tcp") $ do res <- bracket (tcpOpen addr) close (perform ctls) let rc = rcode $ flags $ header res eh = ednsHeader res diff --git a/Network/DNS/Types.hs b/Network/DNS/Types.hs --- a/Network/DNS/Types.hs +++ b/Network/DNS/Types.hs @@ -1,1781 +1,134 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} - --- | Data types for DNS Query and Response. --- For more information, see . - -module Network.DNS.Types ( - -- * Resource Records - ResourceRecord (..) - , Answers - , AuthorityRecords - , AdditionalRecords - -- ** Types - , Domain - , CLASS - , classIN - , TTL - -- ** Resource Record Types - , TYPE ( - A - , NS - , CNAME - , SOA - , NULL - , PTR - , MX - , TXT - , AAAA - , SRV - , DNAME - , OPT - , DS - , RRSIG - , NSEC - , DNSKEY - , NSEC3 - , NSEC3PARAM - , TLSA - , CDS - , CDNSKEY - , CSYNC - , AXFR - , ANY - , CAA - ) - , fromTYPE - , toTYPE - -- ** Resource Data - , RData (..) - , RD_RRSIG(..) - , dnsTime - -- * DNS Message - , DNSMessage (..) - -- ** Query - , makeQuery - , makeEmptyQuery - , defaultQuery - -- ** Query Controls - , QueryControls - , rdFlag - , adFlag - , cdFlag - , doFlag - , ednsEnabled - , ednsSetVersion - , ednsSetUdpSize - , ednsSetOptions - -- *** Flag and OData control operations - , FlagOp(..) - , ODataOp(..) - -- ** Response - , defaultResponse - , makeResponse - -- ** DNS Header - , DNSHeader (..) - , Identifier - -- *** DNS flags - , DNSFlags (..) - , QorR (..) - , defaultDNSFlags - -- *** OPCODE and RCODE - , OPCODE (..) - , fromOPCODE - , toOPCODE - , RCODE ( - NoErr - , FormatErr - , ServFail - , NameErr - , NotImpl - , Refused - , YXDomain - , YXRRSet - , NXRRSet - , NotAuth - , NotZone - , BadVers - , BadKey - , BadTime - , BadMode - , BadName - , BadAlg - , BadTrunc - , BadCookie - , BadRCODE - ) - , fromRCODE - , toRCODE - -- ** EDNS Pseudo-Header - , EDNSheader(..) - , ifEDNS - , mapEDNS - -- *** EDNS record - , EDNS(..) - , defaultEDNS - , maxUdpSize - , minUdpSize - -- *** EDNS options - , OData (..) - , OptCode ( - ClientSubnet - , DAU - , DHU - , N3U - , NSID - ) - , fromOptCode - , toOptCode - -- ** DNS Body - , Question (..) - -- * DNS Error - , DNSError (..) - -- * Other types - , Mailbox - ) where - -import Control.Exception (Exception, IOException) -import Control.Applicative ((<|>)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BS -import Data.Char (intToDigit) -import Data.Function (on) -import qualified Data.Hourglass as H -import Data.IP (IP(..), IPv4, IPv6) -import qualified Data.List as List -import Data.Maybe (fromMaybe) -import qualified Data.Semigroup as Sem - -import qualified Data.ByteString.Base16 as B16 -import qualified Network.DNS.Base32Hex as B32 -import qualified Data.ByteString.Base64 as B64 - -import Network.DNS.Imports - --- $setup --- >>> :set -XOverloadedStrings --- >>> import Network.DNS - ----------------------------------------------------------------- - --- | This type holds the /presentation form/ of fully-qualified DNS domain --- names encoded as ASCII A-labels, with \'.\' separators between labels. --- Non-printing characters are escaped as @\\DDD@ (a backslash, followed by --- three decimal digits). The special characters: @ \", \$, (, ), ;, \@,@ and --- @\\@ are escaped by prepending a backslash. The trailing \'.\' is optional --- on input, but is recommended, and is always added when decoding from --- /wire form/. --- --- The encoding of domain names to /wire form/, e.g. for transmission in a --- query, requires the input encodings to be valid, otherwise a 'DecodeError' --- may be thrown. Domain names received in wire form in DNS messages are --- escaped to this presentation form as part of decoding the 'DNSMessage'. --- --- This form is ASCII-only. Any conversion between A-label 'ByteString's, --- and U-label 'Text' happens at whatever layer maps user input to DNS --- names, or presents /friendly/ DNS names to the user. Not all users --- can read all scripts, and applications that default to U-label form --- should ideally give the user a choice to see the A-label form. --- Examples: --- --- @ --- www.example.org. -- Ordinary DNS name. --- \_25.\_tcp.mx1.example.net. -- TLSA RR initial labels have \_ prefixes. --- \\001.exotic.example. -- First label is Ctrl-A! --- just\\.one\\.label.example. -- First label is \"just.one.label\" --- @ --- -type Domain = ByteString - --- | Type for a mailbox encoded on the wire as a DNS name, but the first label --- is conceptually the local part of an email address, and may contain internal --- periods that are not label separators. Therefore, in mailboxes \@ is used as --- the separator between the first and second labels, and any \'.\' characters --- in the first label are not escaped. The encoding is otherwise the same as --- 'Domain' above. This is most commonly seen in the /mrname/ of @SOA@ records. --- On input, if there is no unescaped \@ character in the 'Mailbox', it is --- reparsed with \'.\' as the first label separator. Thus the traditional --- format with all labels separated by dots is also accepted, but decoding from --- wire form always uses \@ between the first label and the domain-part of the --- address. Examples: --- --- @ --- hostmaster\@example.org. -- First label is simply @hostmaster@ --- john.smith\@examle.com. -- First label is @john.smith@ --- @ --- -type Mailbox = ByteString - ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 800 --- | Types for resource records. -newtype TYPE = TYPE { - -- | From type to number. - fromTYPE :: Word16 - } deriving (Eq, Ord) - --- https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-4 - --- | IPv4 address -pattern A :: TYPE -pattern A = TYPE 1 --- | An authoritative name serve -pattern NS :: TYPE -pattern NS = TYPE 2 --- | The canonical name for an alias -pattern CNAME :: TYPE -pattern CNAME = TYPE 5 --- | Marks the start of a zone of authority -pattern SOA :: TYPE -pattern SOA = TYPE 6 --- | A null RR (EXPERIMENTAL) -pattern NULL :: TYPE -pattern NULL = TYPE 10 --- | A domain name pointer -pattern PTR :: TYPE -pattern PTR = TYPE 12 --- | Mail exchange -pattern MX :: TYPE -pattern MX = TYPE 15 --- | Text strings -pattern TXT :: TYPE -pattern TXT = TYPE 16 --- | IPv6 Address -pattern AAAA :: TYPE -pattern AAAA = TYPE 28 --- | Server Selection (RFC2782) -pattern SRV :: TYPE -pattern SRV = TYPE 33 --- | DNAME (RFC6672) -pattern DNAME :: TYPE -pattern DNAME = TYPE 39 -- RFC 6672 --- | OPT (RFC6891) -pattern OPT :: TYPE -pattern OPT = TYPE 41 -- RFC 6891 --- | Delegation Signer (RFC4034) -pattern DS :: TYPE -pattern DS = TYPE 43 -- RFC 4034 --- | RRSIG (RFC4034) -pattern RRSIG :: TYPE -pattern RRSIG = TYPE 46 -- RFC 4034 --- | NSEC (RFC4034) -pattern NSEC :: TYPE -pattern NSEC = TYPE 47 -- RFC 4034 --- | DNSKEY (RFC4034) -pattern DNSKEY :: TYPE -pattern DNSKEY = TYPE 48 -- RFC 4034 --- | NSEC3 (RFC5155) -pattern NSEC3 :: TYPE -pattern NSEC3 = TYPE 50 -- RFC 5155 --- | NSEC3PARAM (RFC5155) -pattern NSEC3PARAM :: TYPE -pattern NSEC3PARAM = TYPE 51 -- RFC 5155 --- | TLSA (RFC6698) -pattern TLSA :: TYPE -pattern TLSA = TYPE 52 -- RFC 6698 --- | Child DS (RFC7344) -pattern CDS :: TYPE -pattern CDS = TYPE 59 -- RFC 7344 --- | DNSKEY(s) the Child wants reflected in DS (RFC7344) -pattern CDNSKEY :: TYPE -pattern CDNSKEY = TYPE 60 -- RFC 7344 --- | Child-To-Parent Synchronization (RFC7477) -pattern CSYNC :: TYPE -pattern CSYNC = TYPE 62 -- RFC 7477 --- | Zone transfer (RFC5936) -pattern AXFR :: TYPE -pattern AXFR = TYPE 252 -- RFC 5936 --- | A request for all records the server/cache has available -pattern ANY :: TYPE -pattern ANY = TYPE 255 --- | Certification Authority Authorization (RFC6844) -pattern CAA :: TYPE -pattern CAA = TYPE 257 -- RFC 6844 - --- | From number to type. -toTYPE :: Word16 -> TYPE -toTYPE = TYPE -#else --- | Types for resource records. -data TYPE = A -- ^ IPv4 address - | NS -- ^ An authoritative name serve - | CNAME -- ^ The canonical name for an alias - | SOA -- ^ Marks the start of a zone of authority - | NULL -- ^ A null RR (EXPERIMENTAL) - | PTR -- ^ A domain name pointer - | MX -- ^ Mail exchange - | TXT -- ^ Text strings - | AAAA -- ^ IPv6 Address - | SRV -- ^ Server Selection (RFC2782) - | DNAME -- ^ DNAME (RFC6672) - | OPT -- ^ OPT (RFC6891) - | DS -- ^ Delegation Signer (RFC4034) - | RRSIG -- ^ RRSIG (RFC4034) - | NSEC -- ^ NSEC (RFC4034) - | DNSKEY -- ^ DNSKEY (RFC4034) - | NSEC3 -- ^ NSEC3 (RFC5155) - | NSEC3PARAM -- ^ NSEC3PARAM (RFC5155) - | TLSA -- ^ TLSA (RFC6698) - | CDS -- ^ Child DS (RFC7344) - | CDNSKEY -- ^ DNSKEY(s) the Child wants reflected in DS (RFC7344) - | CSYNC -- ^ Child-To-Parent Synchronization (RFC7477) - | AXFR -- ^ Zone transfer (RFC5936) - | ANY -- ^ A request for all records the server/cache - -- has available - | CAA -- ^ Certification Authority Authorization (RFC6844) - | UnknownTYPE Word16 -- ^ Unknown type - deriving (Eq, Ord, Read) - --- | From type to number. -fromTYPE :: TYPE -> Word16 -fromTYPE A = 1 -fromTYPE NS = 2 -fromTYPE CNAME = 5 -fromTYPE SOA = 6 -fromTYPE NULL = 10 -fromTYPE PTR = 12 -fromTYPE MX = 15 -fromTYPE TXT = 16 -fromTYPE AAAA = 28 -fromTYPE SRV = 33 -fromTYPE DNAME = 39 -fromTYPE OPT = 41 -fromTYPE DS = 43 -fromTYPE RRSIG = 46 -fromTYPE NSEC = 47 -fromTYPE DNSKEY = 48 -fromTYPE NSEC3 = 50 -fromTYPE NSEC3PARAM = 51 -fromTYPE TLSA = 52 -fromTYPE CDS = 59 -fromTYPE CDNSKEY = 60 -fromTYPE CSYNC = 62 -fromTYPE AXFR = 252 -fromTYPE ANY = 255 -fromTYPE CAA = 257 -fromTYPE (UnknownTYPE x) = x - --- | From number to type. -toTYPE :: Word16 -> TYPE -toTYPE 1 = A -toTYPE 2 = NS -toTYPE 5 = CNAME -toTYPE 6 = SOA -toTYPE 10 = NULL -toTYPE 12 = PTR -toTYPE 15 = MX -toTYPE 16 = TXT -toTYPE 28 = AAAA -toTYPE 33 = SRV -toTYPE 39 = DNAME -toTYPE 41 = OPT -toTYPE 43 = DS -toTYPE 46 = RRSIG -toTYPE 47 = NSEC -toTYPE 48 = DNSKEY -toTYPE 50 = NSEC3 -toTYPE 51 = NSEC3PARAM -toTYPE 52 = TLSA -toTYPE 59 = CDS -toTYPE 60 = CDNSKEY -toTYPE 62 = CSYNC -toTYPE 252 = AXFR -toTYPE 255 = ANY -toTYPE 257 = CAA -toTYPE x = UnknownTYPE x -#endif - -instance Show TYPE where - show A = "A" - show NS = "NS" - show CNAME = "CNAME" - show SOA = "SOA" - show NULL = "NULL" - show PTR = "PTR" - show MX = "MX" - show TXT = "TXT" - show AAAA = "AAAA" - show SRV = "SRV" - show DNAME = "DNAME" - show OPT = "OPT" - show DS = "DS" - show RRSIG = "RRSIG" - show NSEC = "NSEC" - show DNSKEY = "DNSKEY" - show NSEC3 = "NSEC3" - show NSEC3PARAM = "NSEC3PARAM" - show TLSA = "TLSA" - show CDS = "CDS" - show CDNSKEY = "CDNSKEY" - show CSYNC = "CSYNC" - show AXFR = "AXFR" - show ANY = "ANY" - show CAA = "CAA" - show x = "TYPE" ++ show (fromTYPE x) - ----------------------------------------------------------------- - --- | An enumeration of all possible DNS errors that can occur. -data DNSError = - -- | The sequence number of the answer doesn't match our query. This - -- could indicate foul play. - SequenceNumberMismatch - -- | The question section of the response doesn't match our query. This - -- could indicate foul play. - | QuestionMismatch - -- | A zone tranfer, i.e., a request of type AXFR, was attempted with the - -- "lookup" interface. Zone transfer is different enough from "normal" - -- requests that it requires a different interface. - | InvalidAXFRLookup - -- | The number of retries for the request was exceeded. - | RetryLimitExceeded - -- | TCP fallback request timed out. - | TimeoutExpired - -- | The answer has the correct sequence number, but returned an - -- unexpected RDATA format. - | UnexpectedRDATA - -- | The domain for query is illegal. - | IllegalDomain - -- | The name server was unable to interpret the query. - | FormatError - -- | The name server was unable to process this query due to a - -- problem with the name server. - | ServerFailure - -- | This code signifies that the domain name referenced in the - -- query does not exist. - | NameError - -- | The name server does not support the requested kind of query. - | NotImplemented - -- | The name server refuses to perform the specified operation for - -- policy reasons. For example, a name - -- server may not wish to provide the - -- information to the particular requester, - -- or a name server may not wish to perform - -- a particular operation (e.g., zone transfer) for particular data. - | OperationRefused - -- | The server does not support the OPT RR version or content - | BadOptRecord - -- | Configuration is wrong. - | BadConfiguration - -- | Network failure. - | NetworkFailure IOException - -- | Error is unknown - | DecodeError String - | UnknownDNSError - deriving (Eq, Show, Typeable) - -instance Exception DNSError - - --- | Data type representing the optional EDNS pseudo-header of a 'DNSMessage' --- When a single well-formed @OPT@ 'ResourceRecord' was present in the --- message's additional section, it is decoded to an 'EDNS' record and and --- stored in the message 'ednsHeader' field. The corresponding @OPT RR@ is --- then removed from the additional section. --- --- When the constructor is 'NoEDNS', no @EDNS OPT@ record was present in the --- message additional section. When 'InvalidEDNS', the message holds either a --- malformed OPT record or more than one OPT record, which can still be found --- in (have not been removed from) the message additional section. --- --- The EDNS OPT record augments the message error status with an 8-bit field --- that forms 12-bit extended RCODE when combined with the 4-bit RCODE from the --- unextended DNS header. In EDNS messages it is essential to not use just the --- bare 4-bit 'RCODE' from the original DNS header. Therefore, in order to --- avoid potential misinterpretation of the response 'RCODE', when the OPT --- record is decoded, the upper eight bits of the error status are --- automatically combined with the 'rcode' of the message header, so that there --- is only one place in which to find the full 12-bit result. Therefore, the --- decoded 'EDNS' pseudo-header, does not hold any error status bits. --- --- The reverse process occurs when encoding messages. The low four bits of the --- message header 'rcode' are encoded into the wire-form DNS header, while the --- upper eight bits are encoded as part of the OPT record. In DNS responses with --- an 'rcode' larger than 15, EDNS extensions SHOULD be enabled by providing a --- value for 'ednsHeader' with a constructor of 'EDNSheader'. If EDNS is not --- enabled in such a message, in order to avoid truncation of 'RCODE' values --- that don't fit in the non-extended DNS header, the encoded wire-form 'RCODE' --- is set to 'FormatErr'. --- --- When encoding messages for transmission, the 'ednsHeader' is used to --- generate the additional OPT record. Do not add explicit @OPT@ records --- to the aditional section, configure EDNS via the 'EDNSheader' instead. --- --- >>> let getopts eh = mapEDNS eh ednsOptions [] --- >>> let optsin = [OD_ClientSubnet 24 0 $ read "192.0.2.1"] --- >>> let masked = [OD_ClientSubnet 24 0 $ read "192.0.2.0"] --- >>> let message = makeEmptyQuery $ ednsSetOptions $ ODataSet optsin --- >>> let optsout = getopts. ednsHeader <$> (decode $ encode message) --- >>> optsout == Right masked --- True --- -data EDNSheader = EDNSheader EDNS -- ^ A valid EDNS message - | NoEDNS -- ^ A valid non-EDNS message - | InvalidEDNS -- ^ Multiple or bad additional @OPT@ RRs - deriving (Eq, Show) - - --- | Return the second argument for EDNS messages, otherwise the third. -ifEDNS :: EDNSheader -- ^ EDNS pseudo-header - -> a -- ^ Value to return for EDNS messages - -> a -- ^ Value to return for non-EDNS messages - -> a -ifEDNS (EDNSheader _) a _ = a -ifEDNS _ _ b = b -{-# INLINE ifEDNS #-} - - --- | Return the output of a function applied to the EDNS pseudo-header if EDNS --- is enabled, otherwise return a default value. -mapEDNS :: EDNSheader -- ^ EDNS pseudo-header - -> (EDNS -> a) -- ^ Function to apply to 'EDNS' value - -> a -- ^ Default result for non-EDNS messages - -> a -mapEDNS (EDNSheader eh) f _ = f eh -mapEDNS _ _ a = a -{-# INLINE mapEDNS #-} - - --- | DNS message format for queries and replies. --- -data DNSMessage = DNSMessage { - header :: !DNSHeader -- ^ Header with extended 'RCODE' - , ednsHeader :: EDNSheader -- ^ EDNS pseudo-header - , question :: [Question] -- ^ The question for the name server - , answer :: Answers -- ^ RRs answering the question - , authority :: AuthorityRecords -- ^ RRs pointing toward an authority - , additional :: AdditionalRecords -- ^ RRs holding additional information - } deriving (Eq, Show) - --- | An identifier assigned by the program that --- generates any kind of query. -type Identifier = Word16 - --- | Raw data format for the header of DNS Query and Response. -data DNSHeader = DNSHeader { - identifier :: !Identifier -- ^ Query or reply identifier. - , flags :: !DNSFlags -- ^ Flags, OPCODE, and RCODE - } deriving (Eq, Show) - --- | Raw data format for the flags of DNS Query and Response. -data DNSFlags = DNSFlags { - qOrR :: !QorR -- ^ Query or response. - , opcode :: !OPCODE -- ^ Kind of query. - , authAnswer :: !Bool -- ^ AA (Authoritative Answer) bit - this bit is valid in responses, - -- and specifies that the responding name server is an - -- authority for the domain name in question section. - , trunCation :: !Bool -- ^ TC (Truncated Response) bit - specifies that this message was truncated - -- due to length greater than that permitted on the - -- transmission channel. - , recDesired :: !Bool -- ^ RD (Recursion Desired) bit - this bit may be set in a query and - -- is copied into the response. If RD is set, it directs - -- the name server to pursue the query recursively. - -- Recursive query support is optional. - , recAvailable :: !Bool -- ^ RA (Recursion Available) bit - this be is set or cleared in a - -- response, and denotes whether recursive query support is - -- available in the name server. - - , rcode :: !RCODE -- ^ The full 12-bit extended RCODE when EDNS is in use. - -- Should always be zero in well-formed requests. - -- When decoding replies, the high eight bits from - -- any EDNS response are combined with the 4-bit - -- RCODE from the DNS header. When encoding - -- replies, if no EDNS OPT record is provided, RCODE - -- values > 15 are mapped to 'FormatErr'. - , authenData :: !Bool -- ^ AD (Authenticated Data) bit - (RFC4035, Section 3.2.3). - , chkDisable :: !Bool -- ^ CD (Checking Disabled) bit - (RFC4035, Section 3.2.2). - } deriving (Eq, Show) - - --- | Default 'DNSFlags' record suitable for making recursive queries. By default --- the RD bit is set, and the AD and CD bits are cleared. --- -defaultDNSFlags :: DNSFlags -defaultDNSFlags = DNSFlags - { qOrR = QR_Query - , opcode = OP_STD - , authAnswer = False - , trunCation = False - , recDesired = True - , recAvailable = False - , authenData = False - , chkDisable = False - , rcode = NoErr - } - ----------------------------------------------------------------- - --- | Boolean flag operations. These form a 'Monoid'. When combined via --- `mappend`, as with function composition, the left-most value has --- the last say. --- --- >>> mempty :: FlagOp --- FlagKeep --- >>> FlagSet <> mempty --- FlagSet --- >>> FlagClear <> FlagSet <> mempty --- FlagClear --- >>> FlagReset <> FlagClear <> FlagSet <> mempty --- FlagReset -data FlagOp = FlagSet -- ^ Set the flag to 1 - | FlagClear -- ^ Clear the flag to 0 - | FlagReset -- ^ Reset the flag to its default value - | FlagKeep -- ^ Leave the flag unchanged - deriving (Eq, Show) - --- | Apply the given 'FlagOp' to a default boolean value to produce the final --- setting. --- -applyFlag :: FlagOp -> Bool -> Bool -applyFlag FlagSet _ = True -applyFlag FlagClear _ = False -applyFlag _ v = v - --- $ --- Test associativity of the semigroup operation: --- --- >>> let ops = [FlagSet, FlagClear, FlagReset, FlagKeep] --- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops] --- True --- -instance Sem.Semigroup FlagOp where - FlagKeep <> op = op - op <> _ = op - -instance Monoid FlagOp where - mempty = FlagKeep -#if !(MIN_VERSION_base(4,11,0)) - -- this is redundant starting with base-4.11 / GHC 8.4 - -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally - mappend = (Sem.<>) -#endif - --- | We don't show options left at their default value. --- -skipDefault :: String -skipDefault = "" - --- | Show non-default flag values --- -showFlag :: String -> FlagOp -> String -showFlag nm FlagSet = nm ++ ":1" -showFlag nm FlagClear = nm ++ ":0" -showFlag _ FlagReset = skipDefault -showFlag _ FlagKeep = skipDefault - --- | Combine a list of options for display, skipping default values --- -showOpts :: [String] -> String -showOpts os = List.intercalate "," $ List.filter (/= skipDefault) os - ----------------------------------------------------------------- - --- | Control over query-related DNS header flags. As with function composition, --- the left-most value has the last say. --- -data HeaderControls = HeaderControls - { rdBit :: !FlagOp - , adBit :: !FlagOp - , cdBit :: !FlagOp - } - deriving (Eq) - -instance Sem.Semigroup HeaderControls where - (HeaderControls rd1 ad1 cd1) <> (HeaderControls rd2 ad2 cd2) = - HeaderControls (rd1 <> rd2) (ad1 <> ad2) (cd1 <> cd2) - -instance Monoid HeaderControls where - mempty = HeaderControls FlagKeep FlagKeep FlagKeep -#if !(MIN_VERSION_base(4,11,0)) - -- this is redundant starting with base-4.11 / GHC 8.4 - -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally - mappend = (Sem.<>) -#endif - -instance Show HeaderControls where - show (HeaderControls rd ad cd) = - showOpts - [ showFlag "rd" rd - , showFlag "ad" ad - , showFlag "cd" cd ] - --- | Apply all the query flag overrides to 'defaultDNSFlags', returning the --- resulting 'DNSFlags' suitable for making queries with the requested flag --- settings. This is only needed if you're creating your own 'DNSMessage', --- the 'Network.DNS.LookupRaw.lookupRawCtl' function takes a 'QueryControls' --- argument and handles this conversion internally. --- --- Default overrides can be specified in the resolver configuration by setting --- the 'Network.DNS.resolvQueryControls' field of the --- 'Network.DNS.Resolver.ResolvConf' argument to --- 'Network.DNS.Resolver.makeResolvSeed'. These then apply to lookups via --- resolvers based on the resulting configuration, with the exception of --- 'Network.DNS.LookupRaw.lookupRawCtl' which takes an additional --- 'QueryControls' argument to augment the default overrides. --- -queryDNSFlags :: HeaderControls -> DNSFlags -queryDNSFlags (HeaderControls rd ad cd) = d { - recDesired = applyFlag rd $ recDesired d - , authenData = applyFlag ad $ authenData d - , chkDisable = applyFlag cd $ chkDisable d - } - where - d = defaultDNSFlags - ----------------------------------------------------------------- - --- | The default EDNS Option list is empty. We define two operations, one to --- prepend a list of options, and another to set a specific list of options. --- -data ODataOp = ODataAdd [OData] -- ^ Add the specified options to the list. - | ODataSet [OData] -- ^ Set the option list as specified. - deriving (Eq) - --- | Since any given option code can appear at most once in the list, we --- de-duplicate by the OPTION CODE when combining lists. --- -odataDedup :: ODataOp -> [OData] -odataDedup op = - List.nubBy ((==) `on` odataToOptCode) $ - case op of - ODataAdd os -> os - ODataSet os -> os - --- $ --- Test associativity of the OData semigroup operation: --- --- >>> let ip1 = IPv4 $ read "127.0.0.0" --- >>> let ip2 = IPv4 $ read "192.0.2.0" --- >>> let cs1 = OD_ClientSubnet 8 0 ip1 --- >>> let cs2 = OD_ClientSubnet 24 0 ip2 --- >>> let cs3 = OD_ECSgeneric 0 24 0 "foo" --- >>> let dau1 = OD_DAU [3,5,7,8] --- >>> let dau2 = OD_DAU [13,14] --- >>> let dhu1 = OD_DHU [1,2] --- >>> let dhu2 = OD_DHU [3,4] --- >>> let nsid = OD_NSID "" --- >>> let ops1 = [ODataAdd [dau1, dau2, cs1], ODataAdd [dau2, cs2, dhu1]] --- >>> let ops2 = [ODataSet [], ODataSet [dhu2, cs3], ODataSet [nsid]] --- >>> let ops = ops1 ++ ops2 --- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops] --- True - -instance Sem.Semigroup ODataOp where - ODataAdd as <> ODataAdd bs = ODataAdd $ as ++ bs - ODataAdd as <> ODataSet bs = ODataSet $ as ++ bs - ODataSet as <> _ = ODataSet as - -instance Monoid ODataOp where - mempty = ODataAdd [] -#if !(MIN_VERSION_base(4,11,0)) - -- this is redundant starting with base-4.11 / GHC 8.4 - -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally - mappend = (Sem.<>) -#endif - ----------------------------------------------------------------- - --- | EDNS query controls. When EDNS is disabled via @ednsEnabled FlagClear@, --- all the other EDNS-related overrides have no effect. --- --- >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet --- NoEDNS -data EdnsControls = EdnsControls - { extEn :: !FlagOp -- ^ Enabled - , extVn :: !(Maybe Word8) -- ^ Version - , extSz :: !(Maybe Word16) -- ^ UDP Size - , extDO :: !FlagOp -- ^ DNSSEC OK (DO) bit - , extOd :: !ODataOp -- ^ EDNS option list tweaks - } - deriving (Eq) - --- | Apply all the query flag overrides to 'defaultDNSFlags', returning the - -instance Sem.Semigroup EdnsControls where - (EdnsControls en1 vn1 sz1 do1 od1) <> (EdnsControls en2 vn2 sz2 do2 od2) = - EdnsControls (en1 <> en2) (vn1 <|> vn2) (sz1 <|> sz2) - (do1 <> do2) (od1 <> od2) - -instance Monoid EdnsControls where - mempty = EdnsControls FlagKeep Nothing Nothing FlagKeep mempty -#if !(MIN_VERSION_base(4,11,0)) - -- this is redundant starting with base-4.11 / GHC 8.4 - -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally - mappend = (Sem.<>) -#endif - -instance Show EdnsControls where - show (EdnsControls en vn sz d0 od) = - showOpts - [ showFlag "edns.enabled" en - , showWord "edns.version" vn - , showWord "edns.udpsize" sz - , showFlag "edns.dobit" d0 - , showOdOp "edns.options" $ map (show. odataToOptCode) - $ odataDedup od ] - where - showWord :: Show a => String -> Maybe a -> String - showWord nm w = maybe skipDefault (\s -> nm ++ ":" ++ show s) w - - showOdOp :: String -> [String] -> String - showOdOp nm os = case os of - [] -> "" - _ -> nm ++ ":[" ++ List.intercalate "," os ++ "]" - --- | Construct a list of 0 or 1 EDNS OPT RRs based on EdnsControls setting. --- -queryEdns :: EdnsControls -> EDNSheader -queryEdns (EdnsControls en vn sz d0 od) = - let d = defaultEDNS - in if en == FlagClear - then NoEDNS - else EDNSheader $ d { ednsVersion = fromMaybe (ednsVersion d) vn - , ednsUdpSize = fromMaybe (ednsUdpSize d) sz - , ednsDnssecOk = applyFlag d0 (ednsDnssecOk d) - , ednsOptions = odataDedup od - } - ----------------------------------------------------------------- - --- | Query controls form a 'Monoid', as with function composition, the --- left-most value has the last say. The 'Monoid' is generated by two sets of --- combinators, one that controls query-related DNS header flags, and another --- that controls EDNS features. --- --- The header flag controls are: 'rdFlag', 'adFlag' and 'cdFlag'. --- --- The EDNS feature controls are: 'doFlag', 'ednsEnabled', 'ednsSetVersion', --- 'ednsSetUdpSize' and 'ednsSetOptions'. When EDNS is disabled, all the other --- EDNS-related controls have no effect. --- --- __Example:__ Disable DNSSEC checking on the server, and request signatures and --- NSEC records, perhaps for your own independent validation. The UDP buffer --- size is set large, for use with a local loopback nameserver on the same host. --- --- >>> :{ --- mconcat [ adFlag FlagClear --- , cdFlag FlagSet --- , doFlag FlagSet --- , ednsSetUdpSize (Just 8192) -- IPv4 loopback server? --- ] --- :} --- ad:0,cd:1,edns.udpsize:8192,edns.dobit:1 --- --- __Example:__ Use EDNS version 1 (yet to be specified), request nameserver --- ids from the server, and indicate a client subnet of "192.0.2.1/24". --- --- >>> :set -XOverloadedStrings --- >>> let emptyNSID = "" --- >>> let mask = 24 --- >>> let ipaddr = read "192.0.2.1" --- >>> :{ --- mconcat [ ednsSetVersion (Just 1) --- , ednsSetOptions (ODataAdd [OD_NSID emptyNSID]) --- , ednsSetOptions (ODataAdd [OD_ClientSubnet mask 0 ipaddr]) --- ] --- :} --- edns.version:1,edns.options:[NSID,ClientSubnet] - -data QueryControls = QueryControls - { qctlHeader :: !HeaderControls - , qctlEdns :: !EdnsControls - } - deriving (Eq) - -instance Sem.Semigroup QueryControls where - (QueryControls fl1 ex1) <> (QueryControls fl2 ex2) = - QueryControls (fl1 <> fl2) (ex1 <> ex2) - -instance Monoid QueryControls where - mempty = QueryControls mempty mempty -#if !(MIN_VERSION_base(4,11,0)) - -- this is redundant starting with base-4.11 / GHC 8.4 - -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally - mappend = (Sem.<>) -#endif - -instance Show QueryControls where - show (QueryControls fl ex) = showOpts [ show fl, show ex ] - ----------------------------------------------------------------- - --- | Generator of 'QueryControls' that adjusts the RD bit. --- --- >>> rdFlag FlagClear --- rd:0 -rdFlag :: FlagOp -> QueryControls -rdFlag rd = mempty { qctlHeader = mempty { rdBit = rd } } - --- | Generator of 'QueryControls' that adjusts the AD bit. --- --- >>> adFlag FlagSet --- ad:1 -adFlag :: FlagOp -> QueryControls -adFlag ad = mempty { qctlHeader = mempty { adBit = ad } } - --- | Generator of 'QueryControls' that adjusts the CD bit. --- --- >>> cdFlag FlagSet --- cd:1 -cdFlag :: FlagOp -> QueryControls -cdFlag cd = mempty { qctlHeader = mempty { cdBit = cd } } - --- | Generator of 'QueryControls' that enables or disables EDNS support. --- When EDNS is disabled, the rest of the 'EDNS' controls are ignored. --- --- >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet --- NoEDNS -ednsEnabled :: FlagOp -> QueryControls -ednsEnabled en = mempty { qctlEdns = mempty { extEn = en } } - --- | Generator of 'QueryControls' that adjusts the 'EDNS' version. --- A value of 'Nothing' makes no changes, while 'Just' @v@ sets --- the EDNS version to @v@. --- --- >>> ednsSetVersion (Just 1) --- edns.version:1 -ednsSetVersion :: Maybe Word8 -> QueryControls -ednsSetVersion vn = mempty { qctlEdns = mempty { extVn = vn } } - --- | Generator of 'QueryControls' that adjusts the 'EDNS' UDP buffer size. --- A value of 'Nothing' makes no changes, while 'Just' @n@ sets the EDNS UDP --- buffer size to @n@. --- --- >>> ednsSetUdpSize (Just 2048) --- edns.udpsize:2048 -ednsSetUdpSize :: Maybe Word16 -> QueryControls -ednsSetUdpSize sz = mempty { qctlEdns = mempty { extSz = sz } } - --- | Generator of 'QueryControls' that adjusts the 'EDNS' DnssecOk (DO) bit. --- --- >>> doFlag FlagSet --- edns.dobit:1 -doFlag :: FlagOp -> QueryControls -doFlag d0 = mempty { qctlEdns = mempty { extDO = d0 } } - --- | Generator of 'QueryControls' that adjusts the list of 'EDNS' options. --- --- >>> :set -XOverloadedStrings --- >>> ednsSetOptions (ODataAdd [OD_NSID ""]) --- edns.options:[NSID] -ednsSetOptions :: ODataOp -> QueryControls -ednsSetOptions od = mempty { qctlEdns = mempty { extOd = od } } - ----------------------------------------------------------------- - --- | Query or response. -data QorR = QR_Query -- ^ Query. - | QR_Response -- ^ Response. - deriving (Eq, Show, Enum, Bounded) - --- | Kind of query. -data OPCODE - = OP_STD -- ^ A standard query. - | OP_INV -- ^ An inverse query (inverse queries are deprecated). - | OP_SSR -- ^ A server status request. - | OP_NOTIFY -- ^ A zone change notification (RFC1996) - | OP_UPDATE -- ^ An update request (RFC2136) - deriving (Eq, Show, Enum, Bounded) - --- | Convert a 16-bit DNS OPCODE number to its internal representation --- -toOPCODE :: Word16 -> Maybe OPCODE -toOPCODE i = case i of - 0 -> Just OP_STD - 1 -> Just OP_INV - 2 -> Just OP_SSR - -- OPCODE 3 is unassigned - 4 -> Just OP_NOTIFY - 5 -> Just OP_UPDATE - _ -> Nothing - --- | Convert the internal representation of a DNS OPCODE to its 16-bit numeric --- value. --- -fromOPCODE :: OPCODE -> Word16 -fromOPCODE OP_STD = 0 -fromOPCODE OP_INV = 1 -fromOPCODE OP_SSR = 2 -fromOPCODE OP_NOTIFY = 4 -fromOPCODE OP_UPDATE = 5 - ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 800 --- | EDNS extended 12-bit response code. Non-EDNS messages use only the low 4 --- bits. With EDNS this stores the combined error code from the DNS header and --- and the EDNS psuedo-header. See 'EDNSheader' for more detail. -newtype RCODE = RCODE { - -- | Convert an 'RCODE' to its numeric value. - fromRCODE :: Word16 - } deriving (Eq) - --- | Provide an Enum instance for backwards compatibility -instance Enum RCODE where - fromEnum = fromIntegral . fromRCODE - toEnum = RCODE . fromIntegral - --- | No error condition. -pattern NoErr :: RCODE -pattern NoErr = RCODE 0 --- | Format error - The name server was --- unable to interpret the query. -pattern FormatErr :: RCODE -pattern FormatErr = RCODE 1 --- | Server failure - The name server was --- unable to process this query due to a --- problem with the name server. -pattern ServFail :: RCODE -pattern ServFail = RCODE 2 --- | Name Error - Meaningful only for --- responses from an authoritative name --- server, this code signifies that the --- domain name referenced in the query does --- not exist. -pattern NameErr :: RCODE -pattern NameErr = RCODE 3 --- | Not Implemented - The name server does --- not support the requested kind of query. -pattern NotImpl :: RCODE -pattern NotImpl = RCODE 4 --- | Refused - The name server refuses to --- perform the specified operation for --- policy reasons. For example, a name --- server may not wish to provide the --- information to the particular requester, --- or a name server may not wish to perform --- a particular operation (e.g., zone --- transfer) for particular data. -pattern Refused :: RCODE -pattern Refused = RCODE 5 --- | YXDomain - Dynamic update response, a pre-requisite domain that should not --- exist, does exist. -pattern YXDomain :: RCODE -pattern YXDomain = RCODE 6 --- | YXRRSet - Dynamic update response, a pre-requisite RRSet that should not --- exist, does exist. -pattern YXRRSet :: RCODE -pattern YXRRSet = RCODE 7 --- | NXRRSet - Dynamic update response, a pre-requisite RRSet that should --- exist, does not exist. -pattern NXRRSet :: RCODE -pattern NXRRSet = RCODE 8 --- | NotAuth - Dynamic update response, the server is not authoritative for the --- zone named in the Zone Section. -pattern NotAuth :: RCODE -pattern NotAuth = RCODE 9 --- | NotZone - Dynamic update response, a name used in the Prerequisite or --- Update Section is not within the zone denoted by the Zone Section. -pattern NotZone :: RCODE -pattern NotZone = RCODE 10 --- | Bad OPT Version (BADVERS, RFC 6891). -pattern BadVers :: RCODE -pattern BadVers = RCODE 16 --- | Key not recognized [RFC2845] -pattern BadKey :: RCODE -pattern BadKey = RCODE 17 --- | Signature out of time window [RFC2845] -pattern BadTime :: RCODE -pattern BadTime = RCODE 18 --- | Bad TKEY Mode [RFC2930] -pattern BadMode :: RCODE -pattern BadMode = RCODE 19 --- | Duplicate key name [RFC2930] -pattern BadName :: RCODE -pattern BadName = RCODE 20 --- | Algorithm not supported [RFC2930] -pattern BadAlg :: RCODE -pattern BadAlg = RCODE 21 --- | Bad Truncation [RFC4635] -pattern BadTrunc :: RCODE -pattern BadTrunc = RCODE 22 --- | Bad/missing Server Cookie [RFC7873] -pattern BadCookie :: RCODE -pattern BadCookie = RCODE 23 --- | Malformed (peer) EDNS message, no RCODE available. This is not an RCODE --- that can be sent by a peer. It lies outside the 12-bit range expressible --- via EDNS. The low 12-bits are chosen to coincide with 'FormatErr'. When --- an EDNS message is malformed, and we're unable to extract the extended RCODE, --- the header 'rcode' is set to 'BadRCODE'. -pattern BadRCODE :: RCODE -pattern BadRCODE = RCODE 0x1001 - --- | Use https://tools.ietf.org/html/rfc2929#section-2.3 names for DNS RCODEs -instance Show RCODE where - show NoErr = "NoError" - show FormatErr = "FormErr" - show ServFail = "ServFail" - show NameErr = "NXDomain" - show NotImpl = "NotImp" - show Refused = "Refused" - show YXDomain = "YXDomain" - show YXRRSet = "YXRRSet" - show NotAuth = "NotAuth" - show NotZone = "NotZone" - show BadVers = "BadVers" - show BadKey = "BadKey" - show BadTime = "BadTime" - show BadMode = "BadMode" - show BadName = "BadName" - show BadAlg = "BadAlg" - show BadTrunc = "BadTrunc" - show BadCookie = "BadCookie" - show x = "RCODE " ++ (show $ fromRCODE x) - --- | Convert a numeric value to a corresponding 'RCODE'. The behaviour is --- undefined for values outside the range @[0 .. 0xFFF]@ since the EDNS --- extended RCODE is a 12-bit value. Values in the range @[0xF01 .. 0xFFF]@ --- are reserved for private use. -toRCODE :: Word16 -> RCODE -toRCODE = RCODE -#else --- | EDNS extended 12-bit response code. Non-EDNS messages use only the low 4 --- bits. With EDNS this stores the combined error code from the DNS header and --- and the EDNS psuedo-header. See 'EDNSheader' for more detail. -data RCODE - = NoErr -- ^ No error condition. - | FormatErr -- ^ Format error - The name server was - -- unable to interpret the query. - | ServFail -- ^ Server failure - The name server was - -- unable to process this query due to a - -- problem with the name server. - | NameErr -- ^ Name Error - Meaningful only for - -- responses from an authoritative name - -- server, this code signifies that the - -- domain name referenced in the query does - -- not exist. - | NotImpl -- ^ Not Implemented - The name server does - -- not support the requested kind of query. - | Refused -- ^ Refused - The name server refuses to - -- perform the specified operation for - -- policy reasons. For example, a name - -- server may not wish to provide the - -- information to the particular requester, - -- or a name server may not wish to perform - -- a particular operation (e.g., zone - -- transfer) for particular data. - | YXDomain -- ^ Dynamic update response, a pre-requisite - -- domain that should not exist, does exist. - | YXRRSet -- ^ Dynamic update response, a pre-requisite - -- RRSet that should not exist, does exist. - | NXRRSet -- ^ Dynamic update response, a pre-requisite - -- RRSet that should exist, does not exist. - | NotAuth -- ^ Dynamic update response, the server is not - -- authoritative for the zone named in the Zone Section. - | NotZone -- ^ Dynamic update response, a name used in the - -- Prerequisite or Update Section is not within the zone - -- denoted by the Zone Section. - | BadVers -- ^ Bad OPT Version (RFC 6891) - | BadKey -- ^ Key not recognized [RFC2845] - | BadTime -- ^ Signature out of time window [RFC2845] - | BadMode -- ^ Bad TKEY Mode [RFC2930] - | BadName -- ^ Duplicate key name [RFC2930] - | BadAlg -- ^ Algorithm not supported [RFC2930] - | BadTrunc -- ^ Bad Truncation [RFC4635] - | BadCookie -- ^ Bad/missing Server Cookie [RFC7873] - | BadRCODE -- ^ Malformed (peer) EDNS message, no RCODE available. This is - -- not an RCODE that can be sent by a peer. It lies outside the - -- 12-bit range expressible via EDNS. The low bits are chosen to - -- coincide with 'FormatErr'. When an EDNS message is malformed, - -- and we're unable to extract the extended RCODE, the header - -- 'rcode' is set to 'BadRCODE'. - | UnknownRCODE Word16 - deriving (Eq, Ord, Show) - --- | Convert an 'RCODE' to its numeric value. -fromRCODE :: RCODE -> Word16 -fromRCODE NoErr = 0 -fromRCODE FormatErr = 1 -fromRCODE ServFail = 2 -fromRCODE NameErr = 3 -fromRCODE NotImpl = 4 -fromRCODE Refused = 5 -fromRCODE YXDomain = 6 -fromRCODE YXRRSet = 7 -fromRCODE NXRRSet = 8 -fromRCODE NotAuth = 9 -fromRCODE NotZone = 10 -fromRCODE BadVers = 16 -fromRCODE BadKey = 17 -fromRCODE BadTime = 18 -fromRCODE BadMode = 19 -fromRCODE BadName = 20 -fromRCODE BadAlg = 21 -fromRCODE BadTrunc = 22 -fromRCODE BadCookie = 23 -fromRCODE BadRCODE = 0x1001 -fromRCODE (UnknownRCODE x) = x - --- | Convert a numeric value to a corresponding 'RCODE'. The behaviour --- is undefined for values outside the range @[0 .. 0xFFF]@ since the --- EDNS extended RCODE is a 12-bit value. Values in the range --- @[0xF01 .. 0xFFF]@ are reserved for private use. --- -toRCODE :: Word16 -> RCODE -toRCODE 0 = NoErr -toRCODE 1 = FormatErr -toRCODE 2 = ServFail -toRCODE 3 = NameErr -toRCODE 4 = NotImpl -toRCODE 5 = Refused -toRCODE 6 = YXDomain -toRCODE 7 = YXRRSet -toRCODE 8 = NXRRSet -toRCODE 9 = NotAuth -toRCODE 10 = NotZone -toRCODE 16 = BadVers -toRCODE 17 = BadKey -toRCODE 18 = BadTime -toRCODE 19 = BadMode -toRCODE 20 = BadName -toRCODE 21 = BadAlg -toRCODE 22 = BadTrunc -toRCODE 23 = BadCookie -toRCODE 0x1001 = BadRCODE -toRCODE x = UnknownRCODE x -#endif - ----------------------------------------------------------------- - --- XXX: The Question really should also include the CLASS --- --- | Raw data format for DNS questions. -data Question = Question { - qname :: Domain -- ^ A domain name - , qtype :: TYPE -- ^ The type of the query - } deriving (Eq, Show) - ----------------------------------------------------------------- - --- | Resource record class. -type CLASS = Word16 - --- | Resource record class for the Internet. -classIN :: CLASS -classIN = 1 - --- | Time to live in second. -type TTL = Word32 - --- | Raw data format for resource records. -data ResourceRecord = ResourceRecord { - rrname :: !Domain -- ^ Name - , rrtype :: !TYPE -- ^ Resource record type - , rrclass :: !CLASS -- ^ Resource record class - , rrttl :: !TTL -- ^ Time to live - , rdata :: !RData -- ^ Resource data - } deriving (Eq,Show) - ----------------------------------------------------------------- - --- | Given a 32-bit circle-arithmetic DNS time, and the current absolute epoch --- time, return the epoch time corresponding to the DNS timestamp. --- -dnsTime :: Word32 -- ^ DNS circle-arithmetic timestamp - -> Int64 -- ^ current epoch time - -> Int64 -- ^ absolute DNS timestamp -dnsTime tdns tnow = - let delta = tdns - fromIntegral tnow - in if delta > 0x7FFFFFFF -- tdns is in the past? - then tnow - (0x100000000 - fromIntegral delta) - else tnow + fromIntegral delta - --- | Convert epoch time to a YYYYMMDDHHMMSS string: --- --- >>> :{ --- let testVector = --- [ ( "19230704085602", -1467299038) --- , ( "19331017210945", -1142563815) --- , ( "19480919012827", -671668293 ) --- , ( "19631210171455", -191227505 ) --- , ( "20060819001740", 1155946660 ) --- , ( "20180723061122", 1532326282 ) --- , ( "20281019005024", 1855529424 ) --- , ( "20751108024632", 3340406792 ) --- , ( "21240926071415", 4883008455 ) --- , ( "21270331070215", 4962150135 ) --- , ( "21371220015305", 5300560385 ) --- , ( "21680118121052", 6249787852 ) --- , ( "21811012210032", 6683202032 ) --- , ( "22060719093224", 7464648744 ) --- , ( "22100427121648", 7583717808 ) --- , ( "22530821173957", 8950757997 ) --- , ( "23010804210243", 10463979763) --- , ( "23441111161706", 11829514626) --- , ( "23750511175551", 12791843751) --- , ( "23860427060801", 13137746881) ] --- in (==) <$> map (showTime.snd) <*> map fst $ testVector --- :} --- True --- - -showTime :: Int64 -> String -showTime t = H.timePrint fmt $ H.Elapsed $ H.Seconds t - where - fmt = [ H.Format_Year4, H.Format_Month2, H.Format_Day2 - , H.Format_Hour, H.Format_Minute, H.Format_Second ] - --- | RRSIG representation. --- --- As noted in --- --- the RRsig inception and expiration times use serial number arithmetic. As a --- result these timestamps /are not/ pure values, their meaning is --- time-dependent! They depend on the present time and are both at most --- approximately +\/-68 years from the present. This ambiguity is not a --- problem because cached RRSIG records should only persist a few days, --- signature lifetimes should be *much* shorter than 68 years, and key rotation --- should result any misconstrued 136-year-old signatures fail to validate. --- This also means that the interpretation of a time that is exactly half-way --- around the clock at @now +\/-0x80000000@ is not important, the signature --- should never be valid. --- --- The upshot for us is that we need to convert these *impure* relative values --- to pure absolute values at the moment they are received from from the network --- (or read from files, ... in some impure I/O context), and convert them back to --- 32-bit values when encoding. Therefore, the constructor takes absolute --- 64-bit representations of the inception and expiration times. --- --- The 'dnsTime' function performs the requisite conversion. --- -data RD_RRSIG = RDREP_RRSIG - { rrsigType :: !TYPE -- ^ RRtype of RRset signed - , rrsigKeyAlg :: !Word8 -- ^ DNSKEY algorithm - , rrsigNumLabels :: !Word8 -- ^ Number of labels signed - , rrsigTTL :: !Word32 -- ^ Maximum origin TTL - , rrsigExpiration :: !Int64 -- ^ Time last valid - , rrsigInception :: !Int64 -- ^ Time first valid - , rrsigKeyTag :: !Word16 -- ^ Signing key tag - , rrsigZone :: !Domain -- ^ Signing domain - , rrsigValue :: !ByteString -- ^ Opaque signature - } - deriving (Eq, Ord) - -instance Show RD_RRSIG where - show RDREP_RRSIG{..} = unwords - [ show rrsigType - , show rrsigKeyAlg - , show rrsigNumLabels - , show rrsigTTL - , showTime rrsigExpiration - , showTime rrsigInception - , show rrsigKeyTag - , BS.unpack rrsigZone - , b64encode rrsigValue - ] - --- | Raw data format for each type. -data RData = RD_A IPv4 -- ^ IPv4 address - | RD_NS Domain -- ^ An authoritative name serve - | RD_CNAME Domain -- ^ The canonical name for an alias - | RD_SOA Domain Mailbox Word32 Word32 Word32 Word32 Word32 - -- ^ Marks the start of a zone of authority - | RD_NULL ByteString -- ^ NULL RR (EXPERIMENTAL, RFC1035). - | RD_PTR Domain -- ^ A domain name pointer - | RD_MX Word16 Domain -- ^ Mail exchange - | RD_TXT ByteString -- ^ Text strings - | RD_AAAA IPv6 -- ^ IPv6 Address - | RD_SRV Word16 Word16 Word16 Domain - -- ^ Server Selection (RFC2782) - | RD_DNAME Domain -- ^ DNAME (RFC6672) - | RD_OPT [OData] -- ^ OPT (RFC6891) - | RD_DS Word16 Word8 Word8 ByteString -- ^ Delegation Signer (RFC4034) - | RD_RRSIG RD_RRSIG -- ^ DNSSEC signature - | RD_NSEC Domain [TYPE] -- ^ DNSSEC denial of existence NSEC record - | RD_DNSKEY Word16 Word8 Word8 ByteString - -- ^ DNSKEY (RFC4034) - | RD_NSEC3 Word8 Word8 Word16 ByteString ByteString [TYPE] - -- ^ DNSSEC hashed denial of existence (RFC5155) - | RD_NSEC3PARAM Word8 Word8 Word16 ByteString - -- ^ NSEC3 zone parameters (RFC5155) - | RD_TLSA Word8 Word8 Word8 ByteString - -- ^ TLSA (RFC6698) - --RD_CDS - --RD_CDNSKEY - --RD_CSYNC - | UnknownRData ByteString -- ^ Unknown resource data - deriving (Eq, Ord) - -instance Show RData where - show rd = case rd of - RD_A address -> show address - RD_NS nsdname -> showDomain nsdname - RD_CNAME cname -> showDomain cname - RD_SOA a b c d e f g -> showSOA a b c d e f g - RD_NULL bytes -> showOpaque bytes - RD_PTR ptrdname -> showDomain ptrdname - RD_MX pref exch -> showMX pref exch - RD_TXT textstring -> showTXT textstring - RD_AAAA address -> show address - RD_SRV pri wei prt tgt -> showSRV pri wei prt tgt - RD_DNAME target -> showDomain target - RD_OPT options -> show options - RD_DS tag alg dalg d -> showDS tag alg dalg d - RD_RRSIG rrsig -> show rrsig - RD_NSEC next types -> showNSEC next types - RD_DNSKEY f p a k -> showDNSKEY f p a k - RD_NSEC3 a f i s h types -> showNSEC3 a f i s h types - RD_NSEC3PARAM a f i s -> showNSEC3PARAM a f i s - RD_TLSA u s m d -> showTLSA u s m d - UnknownRData bytes -> showOpaque bytes - where - showSalt "" = "-" - showSalt salt = b16encode salt - showDomain = BS.unpack - showSOA mname mrname serial refresh retry expire minttl = - showDomain mname ++ " " ++ showDomain mrname ++ " " ++ - show serial ++ " " ++ show refresh ++ " " ++ - show retry ++ " " ++ show expire ++ " " ++ show minttl - showMX preference exchange = - show preference ++ " " ++ showDomain exchange - showTXT bs = '"' : B.foldr dnsesc ['"'] bs - where - c2w = fromIntegral . fromEnum - w2c = toEnum . fromIntegral - doubleQuote = c2w '"' - backSlash = c2w '\\' - dnsesc c s - | c == doubleQuote = '\\' : w2c c : s - | c == backSlash = '\\' : w2c c : s - | c >= 32 && c < 127 = w2c c : s - | otherwise = '\\' : ddd c s - ddd c s = - let (q100, r100) = divMod (fromIntegral c) 100 - (q10, r10) = divMod r100 10 - in intToDigit q100 : intToDigit q10 : intToDigit r10 : s - showSRV priority weight port target = - show priority ++ " " ++ show weight ++ " " ++ - show port ++ BS.unpack target - showDS keytag alg digestType digest = - show keytag ++ " " ++ show alg ++ " " ++ - show digestType ++ " " ++ b16encode digest - showNSEC next types = - unwords $ showDomain next : map show types - showDNSKEY flags protocol alg key = - show flags ++ " " ++ show protocol ++ " " ++ - show alg ++ " " ++ b64encode key - -- | - showNSEC3 hashalg flags iterations salt nexthash types = - unwords $ show hashalg : show flags : show iterations : - showSalt salt : b32encode nexthash : map show types - showNSEC3PARAM hashAlg flags iterations salt = - show hashAlg ++ " " ++ show flags ++ " " ++ - show iterations ++ " " ++ showSalt salt - showTLSA usage selector mtype digest = - show usage ++ " " ++ show selector ++ " " ++ - show mtype ++ " " ++ b16encode digest - -- | Opaque RData: - showOpaque bs = unwords ["\\#", show (BS.length bs), b16encode bs] - -b16encode, b32encode, b64encode :: ByteString -> String -b16encode = BS.unpack. B16.encode -b32encode = BS.unpack. B32.encode -b64encode = BS.unpack. B64.encode - --- | Type alias for resource records in the answer section. -type Answers = [ResourceRecord] - --- | Type alias for resource records in the answer section. -type AuthorityRecords = [ResourceRecord] - --- | Type for resource records in the additional section. -type AdditionalRecords = [ResourceRecord] - ----------------------------------------------------------------- - --- | A 'DNSMessage' template for queries with default settings for --- the message 'DNSHeader' and 'EDNSheader'. This is the initial --- query message state, before customization via 'QueryControls'. --- -defaultQuery :: DNSMessage -defaultQuery = DNSMessage { - header = DNSHeader { - identifier = 0 - , flags = defaultDNSFlags - } - , ednsHeader = EDNSheader defaultEDNS - , question = [] - , answer = [] - , authority = [] - , additional = [] - } - --- | Default response. When responding to EDNS queries, the response must --- either be an EDNS response, or else FormatErr must be returned. The default --- response message has EDNS disabled ('ednsHeader' set to 'NoEDNS'), it should --- be updated as appropriate. --- --- Do not explicitly add OPT RRs to the additional section, instead let the --- encoder compute and add the OPT record based on the EDNS pseudo-header. --- --- The 'RCODE' in the 'DNSHeader' should be set to the appropriate 12-bit --- extended value, which will be split between the primary header and EDNS OPT --- record during message encoding (low 4 bits in DNS header, high 8 bits in --- EDNS OPT record). See 'EDNSheader' for more details. --- -defaultResponse :: DNSMessage -defaultResponse = DNSMessage { - header = DNSHeader { - identifier = 0 - , flags = defaultDNSFlags { - qOrR = QR_Response - , authAnswer = True - , recAvailable = True - , authenData = False - } - } - , ednsHeader = NoEDNS - , question = [] - , answer = [] - , authority = [] - , additional = [] - } - --- | A query template with 'QueryControls' overrides applied, --- with just the 'Question' and query 'Identifier' remaining --- to be filled in. --- -makeEmptyQuery :: QueryControls -- ^ Flag and EDNS overrides - -> DNSMessage -makeEmptyQuery ctls = defaultQuery { - header = header' - , ednsHeader = queryEdns ehctls - } - where - hctls = qctlHeader ctls - ehctls = qctlEdns ctls - header' = (header defaultQuery) { flags = queryDNSFlags hctls } - --- | Construct a complete query 'DNSMessage', by combining the 'defaultQuery' --- template with the specified 'Identifier', and 'Question'. The --- 'QueryControls' can be 'mempty' to leave all header and EDNS settings at --- their default values, or some combination of overrides. A default set of --- overrides can be enabled via the 'Network.DNS.Resolver.resolvQueryControls' --- field of 'Network.DNS.Resolver.ResolvConf'. Per-query overrides are --- possible by using 'Network.DNS.LookupRaw.loookupRawCtl'. --- -makeQuery :: Identifier -- ^ Crypto random request id - -> Question -- ^ Question name and type - -> QueryControls -- ^ Custom RD\/AD\/CD flags and EDNS settings - -> DNSMessage -makeQuery idt q ctls = empqry { - header = (header empqry) { identifier = idt } - , question = [q] - } - where - empqry = makeEmptyQuery ctls - --- | Construct a query response 'DNSMessage'. -makeResponse :: Identifier - -> Question - -> Answers - -> DNSMessage -makeResponse idt q as = defaultResponse { - header = header' { identifier = idt } - , question = [q] - , answer = as - } - where - header' = header defaultResponse - ----------------------------------------------------------------- --- EDNS (RFC 6891, EDNS(0)) ----------------------------------------------------------------- - --- | EDNS information defined in RFC 6891. -data EDNS = EDNS { - -- | EDNS version, presently only version 0 is defined. - ednsVersion :: !Word8 - -- | Supported UDP payload size. - , ednsUdpSize :: !Word16 - -- | Request DNSSEC replies (with RRSIG and NSEC records as as appropriate) - -- from the server. Generally, not needed (except for diagnostic purposes) - -- unless the signatures will be validated. Just setting the 'AD' bit in - -- the query and checking it in the response is sufficient (but often - -- subject to man-in-the-middle forgery) if all that's wanted is whether - -- the server validated the response. - , ednsDnssecOk :: !Bool - -- | EDNS options (e.g. 'OD_NSID', 'OD_ClientSubnet', ...) - , ednsOptions :: ![OData] - } deriving (Eq, Show) - --- | The default EDNS pseudo-header for queries. The UDP buffer size is set to --- 1216 bytes, which should result in replies that fit into the 1280 byte --- IPv6 minimum MTU. Since IPv6 only supports fragmentation at the source, --- and even then not all gateways forward IPv6 pre-fragmented IPv6 packets, --- it is best to keep DNS packet sizes below this limit when using IPv6 --- nameservers. A larger value may be practical when using IPv4 exclusively. --- --- @ --- defaultEDNS = EDNS --- { ednsVersion = 0 -- The default EDNS version is 0 --- , ednsUdpSize = 1216 -- IPv6-safe UDP MTU --- , ednsDnssecOk = False -- We don't do DNSSEC validation --- , ednsOptions = [] -- No EDNS options by default --- } --- @ --- -defaultEDNS :: EDNS -defaultEDNS = EDNS - { ednsVersion = 0 -- The default EDNS version is 0 - , ednsUdpSize = 1216 -- IPv6-safe UDP MTU - , ednsDnssecOk = False -- We don't do DNSSEC validation - , ednsOptions = [] -- No EDNS options by default - } - --- | Maximum UDP size that can be advertised. If the 'ednsUdpSize' of 'EDNS' --- is larger, then this value is sent instead. This value is likely to work --- only for local nameservers on the loopback network. Servers may enforce --- a smaller limit. --- --- >>> maxUdpSize --- 16384 -maxUdpSize :: Word16 -maxUdpSize = 16384 - --- | Minimum UDP size to advertise. If 'ednsUdpSize' of 'EDNS' is smaller, --- then this value is sent instead. --- --- >>> minUdpSize --- 512 -minUdpSize :: Word16 -minUdpSize = 512 - ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 800 --- | EDNS Option Code (RFC 6891). -newtype OptCode = OptCode { - -- | From option code to number. - fromOptCode :: Word16 - } deriving (Eq,Ord) - --- | NSID (RFC5001, section 2.3) -pattern NSID :: OptCode -pattern NSID = OptCode 3 - --- | DNSSEC algorithm support (RFC6974, section 3) -pattern DAU :: OptCode -pattern DAU = OptCode 5 -pattern DHU :: OptCode -pattern DHU = OptCode 6 -pattern N3U :: OptCode -pattern N3U = OptCode 7 - --- | Client subnet (RFC7871) -pattern ClientSubnet :: OptCode -pattern ClientSubnet = OptCode 8 - -instance Show OptCode where - show NSID = "NSID" - show DAU = "DAU" - show DHU = "DHU" - show N3U = "N3U" - show ClientSubnet = "ClientSubnet" - show x = "OptCode" ++ (show $ fromOptCode x) - --- | From number to option code. -toOptCode :: Word16 -> OptCode -toOptCode = OptCode -#else --- | Option Code (RFC 6891). -data OptCode = NSID -- ^ Name Server Identifier (RFC5001) - | DAU -- ^ DNSSEC Algorithm understood (RFC6975) - | DHU -- ^ DNSSEC Hash Understood (RFC6975) - | N3U -- ^ NSEC3 Hash Understood (RFC6975) - | ClientSubnet -- ^ Client subnet (RFC7871) - | UnknownOptCode Word16 -- ^ Unknown option code - deriving (Eq, Ord, Show) - --- | From option code to number. -fromOptCode :: OptCode -> Word16 -fromOptCode NSID = 3 -fromOptCode DAU = 5 -fromOptCode DHU = 6 -fromOptCode N3U = 7 -fromOptCode ClientSubnet = 8 -fromOptCode (UnknownOptCode x) = x - --- | From number to option code. -toOptCode :: Word16 -> OptCode -toOptCode 3 = NSID -toOptCode 5 = DAU -toOptCode 6 = DHU -toOptCode 7 = N3U -toOptCode 8 = ClientSubnet -toOptCode x = UnknownOptCode x -#endif - ----------------------------------------------------------------- - --- | RData formats for a few EDNS options, and an opaque catcall -data OData = - -- | Name Server Identifier (RFC5001). Bidirectional, empty from client. - -- (opaque octet-string). May contain binary data, which MUST be empty - -- in queries. - OD_NSID ByteString - -- | DNSSEC Algorithm Understood (RFC6975). Client to server. - -- (array of 8-bit numbers). Lists supported DNSKEY algorithms. - | OD_DAU [Word8] - -- | DS Hash Understood (RFC6975). Client to server. - -- (array of 8-bit numbers). Lists supported DS hash algorithms. - | OD_DHU [Word8] - -- | NSEC3 Hash Understood (RFC6975). Client to server. - -- (array of 8-bit numbers). Lists supported NSEC3 hash algorithms. - | OD_N3U [Word8] - -- | Client subnet (RFC7871). Bidirectional. - -- (source bits, scope bits, address). - -- The address is masked and truncated when encoding queries. The - -- address is zero-padded when decoding. Invalid input encodings - -- result in an 'OD_ECSgeneric' value instead. - -- - | OD_ClientSubnet Word8 Word8 IP - -- | Unsupported or malformed IP client subnet option. Bidirectional. - -- (address family, source bits, scope bits, opaque address). - | OD_ECSgeneric Word16 Word8 Word8 ByteString - -- | Generic EDNS option. - -- (numeric 'OptCode', opaque content) - | UnknownOData Word16 ByteString - deriving (Eq,Ord) - - --- | Recover the (often implicit) 'OptCode' from a value of the 'OData' sum --- type. -odataToOptCode :: OData -> OptCode -odataToOptCode OD_NSID {} = NSID -odataToOptCode OD_DAU {} = DAU -odataToOptCode OD_DHU {} = DHU -odataToOptCode OD_N3U {} = N3U -odataToOptCode OD_ClientSubnet {} = ClientSubnet -odataToOptCode OD_ECSgeneric {} = ClientSubnet -odataToOptCode (UnknownOData code _) = toOptCode code - -instance Show OData where - show (OD_NSID nsid) = showNSID nsid - show (OD_DAU as) = showAlgList "DAU" as - show (OD_DHU hs) = showAlgList "DHU" hs - show (OD_N3U hs) = showAlgList "N3U" hs - show (OD_ClientSubnet b1 b2 ip@(IPv4 _)) = showECS 1 b1 b2 $ show ip - show (OD_ClientSubnet b1 b2 ip@(IPv6 _)) = showECS 2 b1 b2 $ show ip - show (OD_ECSgeneric fam b1 b2 a) = showECS fam b1 b2 $ b16encode a - show (UnknownOData code bs) = showUnknown code bs - -showAlgList :: String -> [Word8] -> String -showAlgList nm ws = nm ++ " " ++ List.intercalate "," (map show ws) - -showNSID :: ByteString -> String -showNSID nsid = "NSID" ++ " " ++ b16encode nsid ++ ";" ++ printable nsid - where - printable = BS.unpack. BS.map (\c -> if c < ' ' || c > '~' then '?' else c) - -showECS :: Word16 -> Word8 -> Word8 -> String -> String -showECS family srcBits scpBits address = - show family ++ " " ++ show srcBits - ++ " " ++ show scpBits ++ " " ++ address - -showUnknown :: Word16 -> ByteString -> String -showUnknown code bs = "UnknownOData " ++ show code ++ " " ++ b16encode bs +-- | Data types for DNS Query and Response. +-- For more information, see . + +module Network.DNS.Types ( + -- * Resource Records + ResourceRecord (..) + , Answers + , AuthorityRecords + , AdditionalRecords + -- ** Types + , Domain + , CLASS + , classIN + , TTL + -- ** Resource Record Types + , TYPE ( + A + , NS + , CNAME + , SOA + , NULL + , PTR + , MX + , TXT + , AAAA + , SRV + , DNAME + , OPT + , DS + , RRSIG + , NSEC + , DNSKEY + , NSEC3 + , NSEC3PARAM + , TLSA + , CDS + , CDNSKEY + , CSYNC + , AXFR + , ANY + , CAA + ) + , fromTYPE + , toTYPE + -- ** Resource Data + , RData (..) + , RD_RRSIG(..) + , dnsTime + -- * DNS Message + , DNSMessage (..) + -- ** Query + , makeQuery + , makeEmptyQuery + , defaultQuery + -- ** Query Controls + , QueryControls + , rdFlag + , adFlag + , cdFlag + , doFlag + , ednsEnabled + , ednsSetVersion + , ednsSetUdpSize + , ednsSetOptions + -- *** Flag and OData control operations + , FlagOp(..) + , ODataOp(..) + -- ** Response + , defaultResponse + , makeResponse + -- ** DNS Header + , DNSHeader (..) + , Identifier + -- *** DNS flags + , DNSFlags (..) + , QorR (..) + , defaultDNSFlags + -- *** OPCODE and RCODE + , OPCODE (..) + , fromOPCODE + , toOPCODE + , RCODE ( + NoErr + , FormatErr + , ServFail + , NameErr + , NotImpl + , Refused + , YXDomain + , YXRRSet + , NXRRSet + , NotAuth + , NotZone + , BadVers + , BadKey + , BadTime + , BadMode + , BadName + , BadAlg + , BadTrunc + , BadCookie + , BadRCODE + ) + , fromRCODE + , toRCODE + -- ** EDNS Pseudo-Header + , EDNSheader(..) + , ifEDNS + , mapEDNS + -- *** EDNS record + , EDNS(..) + , defaultEDNS + , maxUdpSize + , minUdpSize + -- *** EDNS options + , OData (..) + , OptCode ( + ClientSubnet + , DAU + , DHU + , N3U + , NSID + ) + , fromOptCode + , toOptCode + -- ** DNS Body + , Question (..) + -- * DNS Error + , DNSError (..) + -- * Other types + , Mailbox + ) where + +import Network.DNS.Types.Internal diff --git a/Network/DNS/Types/Internal.hs b/Network/DNS/Types/Internal.hs deleted file mode 100644 --- a/Network/DNS/Types/Internal.hs +++ /dev/null @@ -1,136 +0,0 @@ -module Network.DNS.Types.Internal where - -import Network.Socket (AddrInfo(..), PortNumber, HostName) - -import Network.DNS.Imports -import Network.DNS.Memo -import Network.DNS.Types - ----------------------------------------------------------------- - --- | The type to specify a cache server. -data FileOrNumericHost = RCFilePath FilePath -- ^ A path for \"resolv.conf\" - -- where one or more IP addresses - -- of DNS servers should be found - -- on Unix. - -- Default DNS servers are - -- automatically detected - -- on Windows regardless of - -- the value of the file name. - | RCHostName HostName -- ^ A numeric IP address. /Warning/: host names are invalid. - | RCHostNames [HostName] -- ^ Numeric IP addresses. /Warning/: host names are invalid. - | RCHostPort HostName PortNumber -- ^ A numeric IP address and port number. /Warning/: host names are invalid. - deriving Show - ----------------------------------------------------------------- - --- | Cache configuration for responses. -data CacheConf = CacheConf { - -- | If RR's TTL is higher than this value, this value is used instead. - maximumTTL :: TTL - -- | Cache pruning interval in seconds. - , pruningDelay :: Int - } deriving Show - --- | Default cache configuration. --- --- >>> defaultCacheConf --- CacheConf {maximumTTL = 300, pruningDelay = 10} -defaultCacheConf :: CacheConf -defaultCacheConf = CacheConf 300 10 - ----------------------------------------------------------------- - --- | Type for resolver configuration. --- Use 'defaultResolvConf' to create a new value. --- --- An example to use Google's public DNS cache instead of resolv.conf: --- --- >>> let conf = defaultResolvConf { resolvInfo = RCHostName "8.8.8.8" } --- --- An example to use multiple Google's public DNS cache concurrently: --- --- >>> let conf = defaultResolvConf { resolvInfo = RCHostNames ["8.8.8.8","8.8.4.4"], resolvConcurrent = True } --- --- An example to disable EDNS: --- --- >>> let conf = defaultResolvConf { resolvQueryControls = ednsEnabled FlagClear } --- --- An example to enable query result caching: --- --- >>> let conf = defaultResolvConf { resolvCache = Just defaultCacheConf } --- --- An example to disable requesting recursive service. --- --- >>> let conf = defaultResolvConf { resolvQueryControls = rdFlag FlagClear } --- --- An example to set the AD bit in all queries by default. --- --- >>> let conf = defaultResolvConf { resolvQueryControls = adFlag FlagSet } --- --- An example to set the both the AD and CD bits in all queries by default. --- --- >>> let conf = defaultResolvConf { resolvQueryControls = adFlag FlagSet <> cdFlag FlagSet } --- --- An example with an EDNS buffer size of 1216 bytes, which is more robust with --- IPv6, and the DO bit set to request DNSSEC responses. --- --- >>> let conf = defaultResolvConf { resolvQueryControls = ednsSetUdpSize (Just 1216) <> doFlag FlagSet } --- -data ResolvConf = ResolvConf { - -- | Server information. - resolvInfo :: FileOrNumericHost - -- | Timeout in micro seconds. - , resolvTimeout :: Int - -- | The number of retries including the first try. - , resolvRetry :: Int - -- | Concurrent queries if multiple DNS servers are specified. - , resolvConcurrent :: Bool - -- | Cache configuration. - , resolvCache :: Maybe CacheConf - -- | Overrides for the default flags used for queries via resolvers that use - -- this configuration. - , resolvQueryControls :: QueryControls -} deriving Show - --- | Return a default 'ResolvConf': --- --- * 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\". --- * 'resolvTimeout' is 3,000,000 micro seconds. --- * 'resolvRetry' is 3. --- * 'resolvConcurrent' is False. --- * 'resolvCache' is Nothing. --- * 'resolvQueryControls' is an empty set of overrides. -defaultResolvConf :: ResolvConf -defaultResolvConf = ResolvConf { - resolvInfo = RCFilePath "/etc/resolv.conf" - , resolvTimeout = 3 * 1000 * 1000 - , resolvRetry = 3 - , resolvConcurrent = False - , resolvCache = Nothing - , resolvQueryControls = mempty -} - ----------------------------------------------------------------- - --- | Intermediate abstract data type for resolvers. --- IP address information of DNS servers is generated --- according to 'resolvInfo' internally. --- This value can be safely reused for 'withResolver'. --- --- The naming is confusing for historical reasons. -data ResolvSeed = ResolvSeed { - resolvconf :: ResolvConf - , nameservers :: NonEmpty AddrInfo -} - ----------------------------------------------------------------- - --- | Abstract data type of DNS Resolver. --- This includes newly seeded identifier generators for all --- specified DNS servers and a cache database. -data Resolver = Resolver { - resolvseed :: ResolvSeed - , genIds :: NonEmpty (IO Word16) - , cache :: Maybe Cache -} diff --git a/Network/DNS/Utils.hs b/Network/DNS/Utils.hs --- a/Network/DNS/Utils.hs +++ b/Network/DNS/Utils.hs @@ -9,7 +9,7 @@ import qualified Data.ByteString.Char8 as BS import Data.Char (toLower) -import Network.DNS.Types (Domain) +import Network.DNS.Types.Internal (Domain) -- | Perform both 'normalizeCase' and 'normalizeRoot' on the given diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,33 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -#warning You are configuring this package without cabal-doctest installed. \ - The doctests test-suite will not work as a result. \ - To fix this, install cabal-doctest before configuring. -#endif - import Distribution.Simple main :: IO () main = defaultMain - -#endif diff --git a/cabal.project b/cabal.project new file mode 100644 --- /dev/null +++ b/cabal.project @@ -0,0 +1,3 @@ +packages: . +optimization: True +write-ghc-environment-files: always diff --git a/dns.cabal b/dns.cabal --- a/dns.cabal +++ b/dns.cabal @@ -1,5 +1,5 @@ Name: dns -Version: 4.0.0 +Version: 4.0.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -9,18 +9,50 @@ A thread-safe DNS library for both clients and servers written in pure Haskell. Category: Network -Cabal-Version: >= 1.10 -Build-Type: Custom +Cabal-Version: 2.0 +Build-Type: Simple Extra-Source-Files: Changelog.md + cabal.project cbits/dns.c -Tested-With: GHC == 7.10.3 - , GHC == 8.0.2 +Tested-With: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 + , GHC == 8.8.1 -Custom-Setup - Setup-Depends: base, Cabal, cabal-doctest >=1.0.6 && <1.1 +Library dns-internal + Default-Language: Haskell2010 + GHC-Options: -Wall + Hs-Source-Dirs: internal + Exposed-Modules: Network.DNS.Imports + Network.DNS.Types.Internal + Network.DNS.Types.Resolver + Network.DNS.Resolver.Internal + Network.DNS.Decode.Parsers + Network.DNS.Decode.Internal + Network.DNS.Encode.Builders + Network.DNS.Encode.Internal + Network.DNS.StateBinary + Network.DNS.Memo + Network.DNS.Base32Hex + Build-Depends: base + , array + , async + , attoparsec + , auto-update + , base16-bytestring + , base64-bytestring + , bytestring + , containers + , cryptonite + , hourglass + , iproute + , mtl + , network + , psqueues + if os(windows) + C-Sources: cbits/dns.c + Extra-Libraries: iphlpapi Library Default-Language: Haskell2010 @@ -32,21 +64,11 @@ Network.DNS.Utils Network.DNS.Types Network.DNS.Decode - Network.DNS.Decode.Internal Network.DNS.Encode - Network.DNS.Encode.Internal Network.DNS.IO - Other-Modules: Network.DNS.Base32Hex - Network.DNS.Decode.Parsers - Network.DNS.Encode.Builders - Network.DNS.Imports - Network.DNS.Memo - Network.DNS.StateBinary - Network.DNS.Transport - Network.DNS.Types.Internal - if impl(ghc < 8) - Build-Depends: semigroups - Build-Depends: base >= 4 && < 5 + Other-Modules: Network.DNS.Transport + Build-Depends: dns-internal + , base >= 4 && < 5 , array , async , attoparsec @@ -61,12 +83,8 @@ , mtl , network >= 2.3 , psqueues - if os(windows) - Build-Depends: split - C-Sources: cbits/dns.c - Extra-Libraries: iphlpapi -Test-Suite network +Test-Suite network-tests Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: test2 @@ -75,11 +93,12 @@ Other-Modules: LookupSpec IOSpec Build-Depends: dns + , dns-internal , base , hspec , network -Test-Suite spec +Test-Suite spec-tests Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: test @@ -89,19 +108,22 @@ DecodeSpec RoundTripSpec Build-Depends: dns + , dns-internal , QuickCheck >= 2.9 , base , bytestring , hspec - , iproute >= 1.2.4 + , iproute >= 1.3.2 , word8 Test-Suite doctests Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: test2 - Ghc-Options: -Wall + Ghc-Options: -Wall -threaded Main-Is: doctests.hs + Other-Modules: Paths_dns + Autogen-Modules: Paths_dns Build-Depends: base , doctest diff --git a/internal/Network/DNS/Base32Hex.hs b/internal/Network/DNS/Base32Hex.hs new file mode 100644 --- /dev/null +++ b/internal/Network/DNS/Base32Hex.hs @@ -0,0 +1,50 @@ +module Network.DNS.Base32Hex (encode) where + +import qualified Data.Array.MArray as A +import qualified Data.Array.IArray as A +import qualified Data.Array.ST as A +import qualified Data.ByteString as B + +import Network.DNS.Imports + +-- | Encode ByteString using the +-- +-- encoding with no padding as specified for the +-- +-- field. +-- +encode :: B.ByteString -- ^ input buffer + -> B.ByteString -- ^ base32hex output +encode bs = + let len = (8 * B.length bs + 4) `div` 5 + ws = B.unpack bs + in B.pack $ A.elems $ A.runSTUArray $ do + a <- A.newArray (0 :: Int, len-1) 0 + go ws a 0 + where + toHex32 w | w < 10 = 48 + w + | otherwise = 55 + w + + load8 a i = A.readArray a i + store8 a i v = A.writeArray a i v + + -- Encode a list of 8-bit words at bit offset @n@ + -- into an array 'a' of 5-bit words. + go [] a _ = A.mapArray toHex32 a + go (w:ws) a n = do + -- Split 8 bits into left, middle and right parts. The + -- right part only gets written when the 8-bit input word + -- splits across three different 5-bit words. + -- + let (q, r) = n `divMod` 5 + wl = w `shiftR` ( 3 + r) + wm = (w `shiftL` ( 5 - r)) `shiftR` 3 + wr = (w `shiftL` (10 - r)) `shiftR` 3 + al <- case r of + 0 -> pure wl + _ -> (wl .|.) <$> load8 a q + store8 a q al + store8 a (q + 1) wm + when (r > 2) $ store8 a (q+2) wr + go ws a $ n + 8 +{-# INLINE encode #-} diff --git a/internal/Network/DNS/Decode/Internal.hs b/internal/Network/DNS/Decode/Internal.hs new file mode 100644 --- /dev/null +++ b/internal/Network/DNS/Decode/Internal.hs @@ -0,0 +1,64 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Network.DNS.Decode.Internal ( + -- ** Internal message component decoders for tests + decodeDNSHeader + , decodeDNSFlags + , decodeDomain + , decodeMailbox + , decodeResourceRecordAt + , decodeResourceRecord + ) where + +import Network.DNS.Decode.Parsers +import Network.DNS.Imports +import Network.DNS.StateBinary +import Network.DNS.Types.Internal + +---------------------------------------------------------------- + +-- | Decode the 'DNSFlags' field of 'DNSHeader'. This is an internal function +-- exposed only for testing. +-- +decodeDNSFlags :: ByteString -> Either DNSError DNSFlags +decodeDNSFlags bs = fst <$> runSGet getDNSFlags bs + +-- | Decode the 'DNSHeader' of a message. This is an internal function. +-- exposed only for testing. +-- +decodeDNSHeader :: ByteString -> Either DNSError DNSHeader +decodeDNSHeader bs = fst <$> runSGet getHeader bs + +-- | Decode a domain name. Since DNS names may use name compression, it is not +-- generally possible to decode the names separately from the enclosing DNS +-- message. This is an internal function exposed only for testing. +-- +decodeDomain :: ByteString -> Either DNSError Domain +decodeDomain bs = fst <$> runSGet getDomain bs + +-- | Decode a mailbox name (the SOA record /mrname/ field). Since DNS names +-- may use name compression, it is not generally possible to decode the names +-- separately from the enclosing DNS message. This is an internal function. +-- +decodeMailbox :: ByteString -> Either DNSError Mailbox +decodeMailbox bs = fst <$> runSGet getMailbox bs + +-- | Decoding resource records. + +-- | Decode a resource record (RR) with any DNS timestamps interpreted at the +-- nominal epoch time (see 'decodeAt'). Since RRs may use name compression, +-- it is not generally possible to decode resource record separately from the +-- enclosing DNS message. This is an internal function. +-- +decodeResourceRecord :: ByteString -> Either DNSError ResourceRecord +decodeResourceRecord bs = fst <$> runSGet getResourceRecord bs + +-- | Decode a resource record (RR) with DNS timestamps interpreted at the +-- supplied epoch time. Since RRs may use DNS name compression, it is not +-- generally possible to decode resource record separately from the enclosing +-- DNS message. This is an internal function. +-- +decodeResourceRecordAt :: Int64 -- ^ current epoch time + -> ByteString -- ^ encoded resource record + -> Either DNSError ResourceRecord +decodeResourceRecordAt t bs = fst <$> runSGetAt t getResourceRecord bs diff --git a/internal/Network/DNS/Decode/Parsers.hs b/internal/Network/DNS/Decode/Parsers.hs new file mode 100644 --- /dev/null +++ b/internal/Network/DNS/Decode/Parsers.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +module Network.DNS.Decode.Parsers ( + getResponse + , getDNSFlags + , getHeader + , getResourceRecord + , getResourceRecords + , getDomain + , getMailbox + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BS +import qualified Data.IP +import Data.IP (IP(..), toIPv4, toIPv6b, makeAddrRange) + +import Network.DNS.Imports +import Network.DNS.StateBinary +import Network.DNS.Types.Internal + +---------------------------------------------------------------- + +getResponse :: SGet DNSMessage +getResponse = do + hm <- getHeader + qdCount <- getInt16 + anCount <- getInt16 + nsCount <- getInt16 + arCount <- getInt16 + queries <- getQueries qdCount + answers <- getResourceRecords anCount + authrrs <- getResourceRecords nsCount + addnrrs <- getResourceRecords arCount + let (opts, rest) = partition ((==) OPT. rrtype) addnrrs + flgs = flags hm + rc = fromRCODE $ rcode flgs + (eh, erc) = getEDNS rc opts + hd = hm { flags = flgs { rcode = erc } } + pure $ DNSMessage hd eh queries answers authrrs $ ifEDNS eh rest addnrrs + + where + + -- | Get EDNS pseudo-header and the high eight bits of the extended RCODE. + -- + getEDNS :: Word16 -> AdditionalRecords -> (EDNSheader, RCODE) + getEDNS rc rrs = case rrs of + [rr] | Just (edns, erc) <- optEDNS rr + -> (EDNSheader edns, toRCODE erc) + [] -> (NoEDNS, toRCODE rc) + _ -> (InvalidEDNS, BadRCODE) + + where + + -- | Extract EDNS information from an OPT RR. + -- + optEDNS :: ResourceRecord -> Maybe (EDNS, Word16) + optEDNS (ResourceRecord "." OPT udpsiz ttl' (RD_OPT opts)) = + let hrc = fromIntegral rc .&. 0x0f + erc = shiftR (ttl' .&. 0xff000000) 20 .|. hrc + secok = ttl' `testBit` 15 + vers = fromIntegral $ shiftR (ttl' .&. 0x00ff0000) 16 + in Just (EDNS vers udpsiz secok opts, fromIntegral erc) + optEDNS _ = Nothing + +---------------------------------------------------------------- + +getDNSFlags :: SGet DNSFlags +getDNSFlags = do + flgs <- get16 + oc <- getOpcode flgs + return $ DNSFlags (getQorR flgs) + oc + (getAuthAnswer flgs) + (getTrunCation flgs) + (getRecDesired flgs) + (getRecAvailable flgs) + (getRcode flgs) + (getAuthenData flgs) + (getChkDisable flgs) + where + getQorR w = if testBit w 15 then QR_Response else QR_Query + getOpcode w = + case shiftR w 11 .&. 0x0f of + n | Just opc <- toOPCODE n + -> pure opc + | otherwise + -> failSGet $ "Unsupported header opcode: " ++ show n + getAuthAnswer w = testBit w 10 + getTrunCation w = testBit w 9 + getRecDesired w = testBit w 8 + getRecAvailable w = testBit w 7 + getRcode w = toRCODE $ w .&. 0x0f + getAuthenData w = testBit w 5 + getChkDisable w = testBit w 4 + +---------------------------------------------------------------- + +getHeader :: SGet DNSHeader +getHeader = + DNSHeader <$> decodeIdentifier <*> getDNSFlags + where + decodeIdentifier = get16 + +---------------------------------------------------------------- + +getQueries :: Int -> SGet [Question] +getQueries n = replicateM n getQuery + +getTYPE :: SGet TYPE +getTYPE = toTYPE <$> get16 + +-- XXX: Include the class when implemented, or otherwise perhaps check the +-- implicit assumption that the class is classIN. +-- +getQuery :: SGet Question +getQuery = Question <$> getDomain + <*> getTYPE + <* ignoreClass + where + ignoreClass = get16 + +getResourceRecords :: Int -> SGet [ResourceRecord] +getResourceRecords n = replicateM n getResourceRecord + +getResourceRecord :: SGet ResourceRecord +getResourceRecord = do + dom <- getDomain + typ <- getTYPE + cls <- get16 + ttl <- get32 + len <- getInt16 + dat <- fitSGet len $ getRData typ len + return $ ResourceRecord dom typ cls ttl dat + +---------------------------------------------------------------- + +-- | Helper to find position of RData end, that is, the offset of the first +-- byte /after/ the current RData. +-- +rdataEnd :: Int -- ^ number of bytes left from current position + -> SGet Int -- ^ end position +rdataEnd !len = (+) len <$> getPosition + +getRData :: TYPE -> Int -> SGet RData +getRData NS _ = RD_NS <$> getDomain +getRData MX _ = RD_MX <$> get16 <*> getDomain +getRData CNAME _ = RD_CNAME <$> getDomain +getRData DNAME _ = RD_DNAME <$> getDomain +getRData TXT len = RD_TXT <$> getTXT len +getRData A _ = RD_A . toIPv4 <$> getNBytes 4 +getRData AAAA _ = RD_AAAA . toIPv6b <$> getNBytes 16 +getRData SOA _ = RD_SOA <$> getDomain + <*> getMailbox + <*> decodeSerial + <*> decodeRefesh + <*> decodeRetry + <*> decodeExpire + <*> decodeMinimum + where + decodeSerial = get32 + decodeRefesh = get32 + decodeRetry = get32 + decodeExpire = get32 + decodeMinimum = get32 +getRData PTR _ = RD_PTR <$> getDomain +getRData SRV _ = RD_SRV <$> decodePriority + <*> decodeWeight + <*> decodePort + <*> getDomain + where + decodePriority = get16 + decodeWeight = get16 + decodePort = get16 +getRData OPT len = RD_OPT <$> getOpts len +-- +getRData TLSA len = RD_TLSA <$> decodeUsage + <*> decodeSelector + <*> decodeMType + <*> decodeADF + where + decodeUsage = get8 + decodeSelector = get8 + decodeMType = get8 + decodeADF = getNByteString (len - 3) +-- +getRData DS len = RD_DS <$> decodeTag + <*> decodeAlg + <*> decodeDtyp + <*> decodeDval + where + decodeTag = get16 + decodeAlg = get8 + decodeDtyp = get8 + decodeDval = getNByteString (len - 4) +-- +getRData CDS len = RD_CDS <$> decodeTag + <*> decodeAlg + <*> decodeDtyp + <*> decodeDval + where + decodeTag = get16 + decodeAlg = get8 + decodeDtyp = get8 + decodeDval = getNByteString (len - 4) +-- +getRData RRSIG len = RD_RRSIG <$> decodeRRSIG + where + decodeRRSIG = do + -- The signature follows a variable length zone name + -- and occupies the rest of the RData. Simplest to + -- checkpoint the position at the start of the RData, + -- and after reading the zone name, and subtract that + -- from the RData length. + -- + end <- rdataEnd len + typ <- getTYPE + alg <- get8 + cnt <- get8 + ttl <- get32 + tex <- getDnsTime + tin <- getDnsTime + tag <- get16 + dom <- getDomain -- XXX: Enforce no compression? + pos <- getPosition + val <- getNByteString $ end - pos + return $ RDREP_RRSIG typ alg cnt ttl tex tin tag dom val + getDnsTime = do + tnow <- getAtTime + tdns <- get32 + return $! dnsTime tdns tnow +-- +getRData NULL len = RD_NULL <$> getNByteString len +getRData NSEC len = do + end <- rdataEnd len + dom <- getDomain + pos <- getPosition + RD_NSEC dom <$> getNsecTypes (end - pos) +-- +getRData DNSKEY len = RD_DNSKEY <$> decodeKeyFlags + <*> decodeKeyProto + <*> decodeKeyAlg + <*> decodeKeyBytes + where + decodeKeyFlags = get16 + decodeKeyProto = get8 + decodeKeyAlg = get8 + decodeKeyBytes = getNByteString (len - 4) +-- +getRData CDNSKEY len = RD_CDNSKEY <$> decodeKeyFlags + <*> decodeKeyProto + <*> decodeKeyAlg + <*> decodeKeyBytes + where + decodeKeyFlags = get16 + decodeKeyProto = get8 + decodeKeyAlg = get8 + decodeKeyBytes = getNByteString (len - 4) +-- +getRData NSEC3 len = do + dend <- rdataEnd len + halg <- get8 + flgs <- get8 + iter <- get16 + salt <- getInt8 >>= getNByteString + hash <- getInt8 >>= getNByteString + tpos <- getPosition + RD_NSEC3 halg flgs iter salt hash <$> getNsecTypes (dend - tpos) +-- +getRData NSEC3PARAM _ = RD_NSEC3PARAM <$> decodeHashAlg + <*> decodeFlags + <*> decodeIterations + <*> decodeSalt + where + decodeHashAlg = get8 + decodeFlags = get8 + decodeIterations = get16 + decodeSalt = getInt8 >>= getNByteString +-- +getRData _ len = UnknownRData <$> getNByteString len + +---------------------------------------------------------------- + +-- $ +-- +-- >>> import Network.DNS.StateBinary +-- >>> let Right ((t,_),l) = runSGetWithLeftovers (getTXT 8) "\3foo\3barbaz" +-- >>> (t, l) == ("foobar", "baz") +-- True + +-- | Concatenate a sequence of length-prefixed strings of text +-- https://tools.ietf.org/html/rfc1035#section-3.3 +-- +getTXT :: Int -> SGet ByteString +getTXT !len = B.concat <$> sGetMany "TXT RR string" len getstring + where + getstring = getInt8 >>= getNByteString + +-- +-- Parse a list of EDNS options +-- +getOpts :: Int -> SGet [OData] +getOpts !len = sGetMany "EDNS option" len getoption + where + getoption = do + code <- toOptCode <$> get16 + olen <- getInt16 + getOData code olen + +-- +-- Parse a list of NSEC type bitmaps +-- +getNsecTypes :: Int -> SGet [TYPE] +getNsecTypes !len = concat <$> sGetMany "NSEC type bitmap" len getbits + where + getbits = do + window <- flip shiftL 8 <$> getInt8 + blocks <- getInt8 + when (blocks > 32) $ + failSGet $ "NSEC bitmap block too long: " ++ show blocks + concatMap blkTypes. zip [window, window + 8..] <$> getNBytes blocks + where + blkTypes (bitOffset, byte) = + [ toTYPE $ fromIntegral $ bitOffset + i | + i <- [0..7], byte .&. bit (7-i) /= 0 ] + +---------------------------------------------------------------- + +getOData :: OptCode -> Int -> SGet OData +getOData NSID len = OD_NSID <$> getNByteString len +getOData DAU len = OD_DAU <$> getNoctets len +getOData DHU len = OD_DHU <$> getNoctets len +getOData N3U len = OD_N3U <$> getNoctets len +getOData ClientSubnet len = do + family <- get16 + srcBits <- get8 + scpBits <- get8 + addrbs <- getNByteString (len - 4) -- 4 = 2 + 1 + 1 + -- + -- https://tools.ietf.org/html/rfc7871#section-6 + -- + -- o ADDRESS, variable number of octets, contains either an IPv4 or + -- IPv6 address, depending on FAMILY, which MUST be truncated to the + -- number of bits indicated by the SOURCE PREFIX-LENGTH field, + -- padding with 0 bits to pad to the end of the last octet needed. + -- + -- o A server receiving an ECS option that uses either too few or too + -- many ADDRESS octets, or that has non-zero ADDRESS bits set beyond + -- SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet, + -- as a signal to the software developer making the request to fix + -- their implementation. + -- + -- In order to avoid needless decoding errors, when the ECS encoding + -- requirements are violated, we construct an OD_ECSgeneric OData, + -- instread of an IP-specific OD_ClientSubnet OData, which will only + -- be used for valid inputs. When the family is neither IPv4(1) nor + -- IPv6(2), or the address prefix is not correctly encoded (too long + -- or too short), the OD_ECSgeneric data contains the verbatim input + -- from the peer. + -- + case BS.length addrbs == (fromIntegral srcBits + 7) `div` 8 of + True | Just ip <- bstoip family addrbs srcBits scpBits + -> pure $ OD_ClientSubnet srcBits scpBits ip + _ -> pure $ OD_ECSgeneric family srcBits scpBits addrbs + where + prefix addr bits = Data.IP.addr $ makeAddrRange addr $ fromIntegral bits + zeropad = (++ repeat 0). map fromIntegral. B.unpack + checkBits fromBytes toIP srcBits scpBits bytes = + let addr = fromBytes bytes + maskedAddr = prefix addr srcBits + maxBits = fromIntegral $ 8 * length bytes + in if addr == maskedAddr && scpBits <= maxBits + then Just $ toIP addr + else Nothing + bstoip :: Word16 -> B.ByteString -> Word8 -> Word8 -> Maybe IP + bstoip family bs srcBits scpBits = case family of + 1 -> checkBits toIPv4 IPv4 srcBits scpBits $ take 4 $ zeropad bs + 2 -> checkBits toIPv6b IPv6 srcBits scpBits $ take 16 $ zeropad bs + _ -> Nothing +getOData opc len = UnknownOData (fromOptCode opc) <$> getNByteString len + +---------------------------------------------------------------- + +-- | Pointers MUST point back into the packet per RFC1035 Section 4.1.4. This +-- is further interpreted by the DNS community (from a discussion on the IETF +-- DNSOP mailing list) to mean that they don't point back into the same domain. +-- Therefore, when starting to parse a domain, the current offset is also a +-- strict upper bound on the targets of any pointers that arise while processing +-- the domain. When following a pointer, the target again becomes a stict upper +-- bound for any subsequent pointers. This results in a simple loop-prevention +-- algorithm, each sequence of valid pointer values is necessarily strictly +-- decreasing! The third argument to 'getDomain'' is a strict pointer upper +-- bound, and is set here to the position at the start of parsing the domain +-- or mailbox. +-- +-- Note: the separator passed to 'getDomain'' is required to be either \'.\' or +-- \'\@\', or else 'unparseLabel' needs to be modified to handle the new value. +-- + +getDomain :: SGet Domain +getDomain = getPosition >>= getDomain' dot + +getMailbox :: SGet Mailbox +getMailbox = getPosition >>= getDomain' atsign + +dot, atsign :: Word8 +dot = fromIntegral $ fromEnum '.' -- 46 +atsign = fromIntegral $ fromEnum '@' -- 64 + +-- $ +-- Pathological case: pointer embedded inside a label! The pointer points +-- behind the start of the domain and is then absorbed into the initial label! +-- Though we don't IMHO have to support this, it is not manifestly illegal, and +-- does exercise the code in an interesting way. Ugly as this is, it also +-- "works" the same in Perl's Net::DNS and reportedly in ISC's BIND. +-- +-- >>> :{ +-- let input = "\6\3foo\192\0\3bar\0" +-- parser = skipNBytes 1 >> getDomain' dot 1 +-- Right (output, _) = runSGet parser input +-- in output == "foo.\\003foo\\192\\000.bar." +-- :} +-- True +-- +-- The case below fails to point far enough back, and triggers the loop +-- prevention code-path. +-- +-- >>> :{ +-- let input = "\6\3foo\192\1\3bar\0" +-- parser = skipNBytes 1 >> getDomain' dot 1 +-- Left (DecodeError err) = runSGet parser input +-- in err +-- :} +-- "invalid name compression pointer" + +-- | Get a domain name, using sep1 as the separator between the 1st and 2nd +-- label. Subsequent labels (and always the trailing label) are terminated +-- with a ".". +-- +-- Note: the separator is required to be either \'.\' or \'\@\', or else +-- 'unparseLabel' needs to be modified to handle the new value. +-- +-- Domain name compression pointers must always refer to a position that +-- precedes the start of the current domain name. The starting offsets form a +-- strictly decreasing sequence, which prevents pointer loops. +-- +getDomain' :: Word8 -> Int -> SGet ByteString +getDomain' sep1 ptrLimit = do + pos <- getPosition + c <- getInt8 + let n = getValue c + getdomain pos c n + where + getdomain pos c n + | c == 0 = return "." -- Perhaps the root domain? + | isPointer c = do + d <- getInt8 + let offset = n * 256 + d + when (offset >= ptrLimit) $ + failSGet "invalid name compression pointer" + mo <- pop offset + case mo of + Nothing -> do + msg <- getInput + -- Reprocess the same ByteString starting at the pointer + -- target (offset). + let parser = skipNBytes offset >> getDomain' sep1 offset + case runSGet parser msg of + Left (DecodeError err) -> failSGet err + Left err -> fail $ show err + Right o -> push pos (fst o) >> return (fst o) + Just o -> push pos o >> return o + -- As for now, extended labels have no use. + -- This may change some time in the future. + | isExtLabel c = return "" + | otherwise = do + hs <- unparseLabel sep1 <$> getNByteString n + ds <- getDomain' dot ptrLimit + let dom = case ds of -- avoid trailing ".." + "." -> hs <> "." + _ -> hs <> B.singleton sep1 <> ds + push pos dom + return dom + getValue c = c .&. 0x3f + isPointer c = testBit c 7 && testBit c 6 + isExtLabel c = not (testBit c 7) && testBit c 6 diff --git a/internal/Network/DNS/Encode/Builders.hs b/internal/Network/DNS/Encode/Builders.hs new file mode 100644 --- /dev/null +++ b/internal/Network/DNS/Encode/Builders.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE + BangPatterns + , RecordWildCards + , TransformListComp + #-} + +-- | DNS Message builder. +module Network.DNS.Encode.Builders ( + putDNSMessage + , putDNSFlags + , putHeader + , putDomain + , putMailbox + , putResourceRecord + ) where + +import Control.Monad.State (State, modify, execState, gets) +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.IP +import Data.IP (IP(..), fromIPv4, fromIPv6b, makeAddrRange) +import GHC.Exts (the, groupWith) + +import Network.DNS.Imports +import Network.DNS.StateBinary +import Network.DNS.Types.Internal + +---------------------------------------------------------------- + +putDNSMessage :: DNSMessage -> SPut +putDNSMessage msg = putHeader hd + <> putNums + <> mconcat (map putQuestion qs) + <> mconcat (map putResourceRecord an) + <> mconcat (map putResourceRecord au) + <> mconcat (map putResourceRecord ad) + where + putNums = mconcat $ fmap putInt16 [ length qs + , length an + , length au + , length ad + ] + hm = header msg + fl = flags hm + eh = ednsHeader msg + qs = question msg + an = answer msg + au = authority msg + hd = ifEDNS eh hm $ hm { flags = fl { rcode = rc } } + rc = ifEDNS eh <$> id <*> nonEDNSrcode $ rcode fl + where + nonEDNSrcode code | fromRCODE code < 16 = code + | otherwise = FormatErr + ad = prependOpt $ additional msg + where + prependOpt ads = mapEDNS eh (fromEDNS ads $ fromRCODE rc) ads + where + fromEDNS :: AdditionalRecords -> Word16 -> EDNS -> AdditionalRecords + fromEDNS rrs rc' edns = ResourceRecord name' type' class' ttl' rdata' : rrs + where + name' = BS.singleton '.' + type' = OPT + class' = maxUdpSize `min` (minUdpSize `max` ednsUdpSize edns) + ttl0' = fromIntegral (rc' .&. 0xff0) `shiftL` 20 + vers' = fromIntegral (ednsVersion edns) `shiftL` 16 + ttl' + | ednsDnssecOk edns = ttl0' `setBit` 15 .|. vers' + | otherwise = ttl0' .|. vers' + rdata' = RD_OPT $ ednsOptions edns + +putHeader :: DNSHeader -> SPut +putHeader hdr = putIdentifier (identifier hdr) + <> putDNSFlags (flags hdr) + where + putIdentifier = put16 + +putDNSFlags :: DNSFlags -> SPut +putDNSFlags DNSFlags{..} = put16 word + where + set :: Word16 -> State Word16 () + set byte = modify (.|. byte) + + st :: State Word16 () + st = sequence_ + [ set (fromRCODE rcode .&. 0x0f) + , when chkDisable $ set (bit 4) + , when authenData $ set (bit 5) + , when recAvailable $ set (bit 7) + , when recDesired $ set (bit 8) + , when trunCation $ set (bit 9) + , when authAnswer $ set (bit 10) + , set (fromOPCODE opcode `shiftL` 11) + , when (qOrR==QR_Response) $ set (bit 15) + ] + + word = execState st 0 + +-- XXX: Use question class when implemented +-- +putQuestion :: Question -> SPut +putQuestion Question{..} = putDomain qname + <> put16 (fromTYPE qtype) + <> put16 classIN + +putResourceRecord :: ResourceRecord -> SPut +putResourceRecord ResourceRecord{..} = mconcat [ + putDomain rrname + , put16 (fromTYPE rrtype) + , put16 rrclass + , put32 rrttl + , putResourceRData rdata + ] + where + putResourceRData :: RData -> SPut + putResourceRData rd = do + addPositionW 2 -- "simulate" putInt16 + rDataBuilder <- putRData rd + let rdataLength = fromIntegral . LBS.length . BB.toLazyByteString $ rDataBuilder + let rlenBuilder = BB.int16BE rdataLength + return $ rlenBuilder <> rDataBuilder + + +putRData :: RData -> SPut +putRData rd = case rd of + RD_A address -> mconcat $ map putInt8 (fromIPv4 address) + RD_NS nsdname -> putDomain nsdname + RD_CNAME cname -> putDomain cname + RD_SOA a b c d e f g -> putSOA a b c d e f g + RD_NULL bytes -> putByteString bytes + RD_PTR ptrdname -> putDomain ptrdname + RD_MX pref exch -> mconcat [put16 pref, putDomain exch] + RD_TXT textstring -> putTXT textstring + RD_AAAA address -> mconcat $ map putInt8 (fromIPv6b address) + RD_SRV pri wei prt tgt -> putSRV pri wei prt tgt + RD_DNAME dname -> putDomain dname + RD_OPT options -> mconcat $ fmap putOData options + RD_DS kt ka dt d -> putDS kt ka dt d + RD_CDS kt ka dt d -> putDS kt ka dt d + RD_RRSIG rrsig -> putRRSIG rrsig + RD_NSEC next types -> putDomain next <> putNsecTypes types + RD_DNSKEY f p alg key -> putDNSKEY f p alg key + RD_CDNSKEY f p alg key -> putDNSKEY f p alg key + RD_NSEC3 a f i s h types -> putNSEC3 a f i s h types + RD_NSEC3PARAM a f iter salt -> putNSEC3PARAM a f iter salt + RD_TLSA u s m dgst -> putTLSA u s m dgst + UnknownRData bytes -> putByteString bytes + where + putSOA mn mr serial refresh retry expire minttl = mconcat + [ putDomain mn + , putMailbox mr + , put32 serial + , put32 refresh + , put32 retry + , put32 expire + , put32 minttl + ] + -- TXT record string fragments are at most 255 bytes + putTXT textstring = + let (!h, !t) = BS.splitAt 255 textstring + in putByteStringWithLength h <> if BS.null t + then mempty + else putTXT t + putSRV priority weight port target = mconcat + [ put16 priority + , put16 weight + , put16 port + , putDomain target + ] + putDS keytag keyalg digestType digest = mconcat + [ put16 keytag + , put8 keyalg + , put8 digestType + , putByteString digest + ] + putRRSIG RDREP_RRSIG{..} = mconcat + [ put16 $ fromTYPE rrsigType + , put8 rrsigKeyAlg + , put8 rrsigNumLabels + , put32 rrsigTTL + , put32 $ fromIntegral rrsigExpiration + , put32 $ fromIntegral rrsigInception + , put16 rrsigKeyTag + , putDomain rrsigZone + , putByteString rrsigValue + ] + putDNSKEY flags protocol alg key = mconcat + [ put16 flags + , put8 protocol + , put8 alg + , putByteString key + ] + putNSEC3 alg flags iterations salt hash types = mconcat + [ put8 alg + , put8 flags + , put16 iterations + , putByteStringWithLength salt + , putByteStringWithLength hash + , putNsecTypes types + ] + putNSEC3PARAM alg flags iterations salt = mconcat + [ put8 alg + , put8 flags + , put16 iterations + , putByteStringWithLength salt + ] + putTLSA usage selector mtype assocData = mconcat + [ put8 usage + , put8 selector + , put8 mtype + , putByteString assocData + ] + +-- | Encode DNSSEC NSEC type bits +putNsecTypes :: [TYPE] -> SPut +putNsecTypes types = putTypeList $ map fromTYPE types + where + putTypeList :: [Word16] -> SPut + putTypeList ts = + mconcat [ putWindow (the top8) bot8 | + t <- ts, + let top8 = fromIntegral t `shiftR` 8, + let bot8 = fromIntegral t .&. 0xff, + then group by top8 + using groupWith ] + + putWindow :: Int -> [Int] -> SPut + putWindow top8 bot8s = + let blks = maximum bot8s `shiftR` 3 + in putInt8 top8 + <> put8 (1 + fromIntegral blks) + <> putBits 0 [ (the block, foldl' mergeBits 0 bot8) | + bot8 <- bot8s, + let block = bot8 `shiftR` 3, + then group by block + using groupWith ] + where + -- | Combine type bits in network bit order, i.e. bit 0 first. + mergeBits acc b = setBit acc (7 - b.&.0x07) + + putBits :: Int -> [(Int, Word8)] -> SPut + putBits _ [] = pure mempty + putBits n ((block, octet) : rest) = + putReplicate (block-n) 0 + <> put8 octet + <> putBits (block + 1) rest + +-- | Encode EDNS OPTION consisting of a list of octets. +putODWords :: Word16 -> [Word8] -> SPut +putODWords code ws = + mconcat [ put16 code + , putInt16 $ length ws + , mconcat $ map put8 ws + ] + +-- | Encode an EDNS OPTION byte string. +putODBytes :: Word16 -> ByteString -> SPut +putODBytes code bs = + mconcat [ put16 code + , putInt16 $ BS.length bs + , putByteString bs + ] + +putOData :: OData -> SPut +putOData (OD_NSID nsid) = putODBytes (fromOptCode NSID) nsid +putOData (OD_DAU as) = putODWords (fromOptCode DAU) as +putOData (OD_DHU hs) = putODWords (fromOptCode DHU) hs +putOData (OD_N3U hs) = putODWords (fromOptCode N3U) hs +putOData (OD_ClientSubnet srcBits scpBits ip) = + -- https://tools.ietf.org/html/rfc7871#section-6 + -- + -- o ADDRESS, variable number of octets, contains either an IPv4 or + -- IPv6 address, depending on FAMILY, which MUST be truncated to the + -- number of bits indicated by the SOURCE PREFIX-LENGTH field, + -- padding with 0 bits to pad to the end of the last octet needed. + -- + -- o A server receiving an ECS option that uses either too few or too + -- many ADDRESS octets, or that has non-zero ADDRESS bits set beyond + -- SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet, + -- as a signal to the software developer making the request to fix + -- their implementation. + -- + let octets = fromIntegral $ (srcBits + 7) `div` 8 + prefix addr = Data.IP.addr $ makeAddrRange addr $ fromIntegral srcBits + (family, raw) = case ip of + IPv4 ip4 -> (1, take octets $ fromIPv4 $ prefix ip4) + IPv6 ip6 -> (2, take octets $ fromIPv6b $ prefix ip6) + dataLen = 2 + 2 + octets + in mconcat [ put16 $ fromOptCode ClientSubnet + , putInt16 dataLen + , put16 family + , put8 srcBits + , put8 scpBits + , mconcat $ fmap putInt8 raw + ] +putOData (OD_ECSgeneric family srcBits scpBits addr) = + mconcat [ put16 $ fromOptCode ClientSubnet + , putInt16 $ 4 + BS.length addr + , put16 family + , put8 srcBits + , put8 scpBits + , putByteString addr + ] +putOData (UnknownOData code bs) = putODBytes code bs + +-- In the case of the TXT record, we need to put the string length +-- fixme : What happens with the length > 256 ? +putByteStringWithLength :: BS.ByteString -> SPut +putByteStringWithLength bs = putInt8 (fromIntegral $ BS.length bs) -- put the length of the given string + <> putByteString bs + +---------------------------------------------------------------- + +rootDomain :: Domain +rootDomain = BS.pack "." + +putDomain :: Domain -> SPut +putDomain = putDomain' '.' + +putMailbox :: Mailbox -> SPut +putMailbox = putDomain' '@' + +putDomain' :: Char -> ByteString -> SPut +putDomain' sep dom + | BS.null dom || dom == rootDomain = put8 0 + | otherwise = do + mpos <- wsPop dom + cur <- gets wsPosition + case mpos of + Just pos -> putPointer pos + Nothing -> wsPush dom cur >> + mconcat [ putPartialDomain hd + , putDomain' '.' tl + ] + where + -- Try with the preferred separator if present, else fall back to '.'. + (hd, tl) = + let p = parseLabel (c2w sep) dom + in if sep /= '.' && BS.null (snd p) + then parseLabel (c2w '.') dom + else p + c2w = fromIntegral . fromEnum + +putPointer :: Int -> SPut +putPointer pos = putInt16 (pos .|. 0xc000) + +putPartialDomain :: Domain -> SPut +putPartialDomain = putByteStringWithLength diff --git a/internal/Network/DNS/Encode/Internal.hs b/internal/Network/DNS/Encode/Internal.hs new file mode 100644 --- /dev/null +++ b/internal/Network/DNS/Encode/Internal.hs @@ -0,0 +1,38 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | Internal DNS message component encoders for the test-suite. +module Network.DNS.Encode.Internal ( + encodeDNSHeader + , encodeDNSFlags + , encodeDomain + , encodeMailbox + , encodeResourceRecord + ) where + +import Network.DNS.Encode.Builders +import Network.DNS.Imports +import Network.DNS.StateBinary +import Network.DNS.Types.Internal + +-- | Encode DNS flags. +encodeDNSFlags :: DNSFlags -> ByteString +encodeDNSFlags = runSPut . putDNSFlags + +-- | Encode DNS header. +encodeDNSHeader :: DNSHeader -> ByteString +encodeDNSHeader = runSPut . putHeader + +-- | Encode a domain. +encodeDomain :: Domain -> ByteString +encodeDomain = runSPut . putDomain + +-- | Encode a mailbox name. The first label is separated from the remaining +-- labels by an @'\@'@ rather than a @.@. This is used for the contact +-- address in the @SOA@ record. +-- +encodeMailbox :: Mailbox -> ByteString +encodeMailbox = runSPut . putMailbox + +-- | Encode a ResourceRecord. +encodeResourceRecord :: ResourceRecord -> ByteString +encodeResourceRecord rr = runSPut $ putResourceRecord rr diff --git a/internal/Network/DNS/Imports.hs b/internal/Network/DNS/Imports.hs new file mode 100644 --- /dev/null +++ b/internal/Network/DNS/Imports.hs @@ -0,0 +1,31 @@ +module Network.DNS.Imports ( + ByteString + , Int64 + , NonEmpty(..) + , module Control.Applicative + , module Control.Monad + , module Data.Bits + , module Data.Function + , module Data.List + , module Data.Maybe + , module Data.Monoid + , module Data.Ord + , module Data.Typeable + , module Data.Word + , module Numeric + ) where + +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.ByteString (ByteString) +import Data.Function +import Data.Int (Int64) +import Data.List +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Typeable +import Data.Word +import Numeric diff --git a/internal/Network/DNS/Memo.hs b/internal/Network/DNS/Memo.hs new file mode 100644 --- /dev/null +++ b/internal/Network/DNS/Memo.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE RecordWildCards #-} + +module Network.DNS.Memo where + +import qualified Control.Reaper as R +import qualified Data.ByteString as B +import Data.Hourglass (Elapsed) +import Data.OrdPSQ (OrdPSQ) +import qualified Data.OrdPSQ as PSQ +import Time.System (timeCurrent) + +import Network.DNS.Imports +import Network.DNS.Types.Internal + +data Section = Answer | Authority deriving (Eq, Ord, Show) + +type Key = (ByteString + ,TYPE) +type Prio = Elapsed + +type Entry = Either DNSError [RData] + +type DB = OrdPSQ Key Prio Entry + +type Cache = R.Reaper DB (Key,Prio,Entry) + +newCache :: Int -> IO Cache +newCache delay = R.mkReaper R.defaultReaperSettings { + R.reaperEmpty = PSQ.empty + , R.reaperCons = \(k, tim, v) psq -> PSQ.insert k tim v psq + , R.reaperAction = prune + , R.reaperDelay = delay * 1000000 + , R.reaperNull = PSQ.null + } + +lookupCache :: Key -> Cache -> IO (Maybe (Prio, Entry)) +lookupCache key reaper = PSQ.lookup key <$> R.reaperRead reaper + +insertCache :: Key -> Prio -> Entry -> Cache -> IO () +insertCache (dom,typ) tim ent0 reaper = R.reaperAdd reaper (key,tim,ent) + where + key = (B.copy dom,typ) + ent = case ent0 of + l@(Left _) -> l + (Right rds) -> Right $ map copy rds + +-- Theoretically speaking, atMostView itself is good enough for pruning. +-- But auto-update assumes a list based db which does not provide atMost +-- functions. So, we need to do this redundant way. +prune :: DB -> IO (DB -> DB) +prune oldpsq = do + tim <- timeCurrent + let (_, pruned) = PSQ.atMostView tim oldpsq + return $ \newpsq -> foldl' ins pruned $ PSQ.toList newpsq + where + ins psq (k,p,v) = PSQ.insert k p v psq + +copy :: RData -> RData +copy r@(RD_A _) = r +copy (RD_NS dom) = RD_NS $ B.copy dom +copy (RD_CNAME dom) = RD_CNAME $ B.copy dom +copy (RD_SOA mn mr a b c d e) = RD_SOA (B.copy mn) (B.copy mr) a b c d e +copy (RD_PTR dom) = RD_PTR $ B.copy dom +copy (RD_NULL bytes) = RD_NULL $ B.copy bytes +copy (RD_MX prf dom) = RD_MX prf $ B.copy dom +copy (RD_TXT txt) = RD_TXT $ B.copy txt +copy r@(RD_AAAA _) = r +copy (RD_SRV a b c dom) = RD_SRV a b c $ B.copy dom +copy (RD_DNAME dom) = RD_DNAME $ B.copy dom +copy (RD_OPT od) = RD_OPT $ map copyOData od +copy (RD_DS t a dt dv) = RD_DS t a dt $ B.copy dv +copy (RD_CDS t a dt dv) = RD_CDS t a dt $ B.copy dv +copy (RD_NSEC dom ts) = RD_NSEC (B.copy dom) ts +copy (RD_DNSKEY f p a k) = RD_DNSKEY f p a $ B.copy k +copy (RD_CDNSKEY f p a k) = RD_CDNSKEY f p a $ B.copy k +copy (RD_TLSA a b c dgst) = RD_TLSA a b c $ B.copy dgst +copy (RD_NSEC3 a b c s h t) = RD_NSEC3 a b c (B.copy s) (B.copy h) t +copy (RD_NSEC3PARAM a b c salt) = RD_NSEC3PARAM a b c $ B.copy salt +copy (RD_RRSIG sig) = RD_RRSIG $ copysig sig + where + copysig s@RDREP_RRSIG{..} = + s { rrsigZone = B.copy rrsigZone + , rrsigValue = B.copy rrsigValue } +copy (UnknownRData is) = UnknownRData $ B.copy is + +copyOData :: OData -> OData +copyOData (OD_ECSgeneric family srcBits scpBits bs) = + OD_ECSgeneric family srcBits scpBits $ B.copy bs +copyOData (OD_NSID nsid) = OD_NSID $ B.copy nsid +copyOData (UnknownOData c b) = UnknownOData c $ B.copy b + +-- No copying required for the rest, but avoiding a wildcard pattern match +-- so that if more option types are added in the future, the compiler will +-- complain about a partial function. +-- +copyOData o@OD_ClientSubnet {} = o +copyOData o@OD_DAU {} = o +copyOData o@OD_DHU {} = o +copyOData o@OD_N3U {} = o diff --git a/internal/Network/DNS/Resolver/Internal.hs b/internal/Network/DNS/Resolver/Internal.hs new file mode 100644 --- /dev/null +++ b/internal/Network/DNS/Resolver/Internal.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} + +module Network.DNS.Resolver.Internal ( + getDefaultDnsServers + ) where + +import Network.DNS.Imports + +#if !defined(mingw32_HOST_OS) +#define POSIX +#else +#define WIN +#endif + +#if defined(WIN) +import Foreign.C.String +import Foreign.Marshal.Alloc (allocaBytes) +#else +import Data.Char (isSpace) +#endif + +getDefaultDnsServers :: FilePath -> IO [String] + +#if defined(WIN) + +foreign import ccall "getWindowsDefDnsServers" getWindowsDefDnsServers :: CString -> Int -> IO Word32 + +getDefaultDnsServers _ = do + allocaBytes 256 $ \cString -> do + res <- getWindowsDefDnsServers cString 256 + case res of + 0 -> split ',' <$> peekCString cString + _ -> return [] -- TODO: Do proper error handling here. + where + split :: Char -> String -> [String] + split c cs = + let (h, t) = dropWhile (== c) <$> break (== c) cs + in if null t + then if null h then [] else [h] + else if null h + then split c t + else h : split c t + +#else + +getDefaultDnsServers file = toAddresses <$> readFile file + where + toAddresses :: String -> [String] + toAddresses cs = map extract (filter ("nameserver" `isPrefixOf`) (lines cs)) + extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11 + +#endif diff --git a/internal/Network/DNS/StateBinary.hs b/internal/Network/DNS/StateBinary.hs new file mode 100644 --- /dev/null +++ b/internal/Network/DNS/StateBinary.hs @@ -0,0 +1,444 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module Network.DNS.StateBinary ( + PState(..) + , initialState + , SPut + , runSPut + , put8 + , put16 + , put32 + , putInt8 + , putInt16 + , putInt32 + , putByteString + , putReplicate + , SGet + , failSGet + , fitSGet + , runSGet + , runSGetAt + , runSGetWithLeftovers + , runSGetWithLeftoversAt + , get8 + , get16 + , get32 + , getInt8 + , getInt16 + , getInt32 + , getNByteString + , sGetMany + , getPosition + , getInput + , getAtTime + , wsPop + , wsPush + , wsPosition + , addPositionW + , push + , pop + , getNBytes + , getNoctets + , skipNBytes + , parseLabel + , unparseLabel + ) where + +import qualified Control.Exception as E +import Control.Monad.State.Strict (State, StateT) +import qualified Control.Monad.State.Strict as ST +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.Types as T +import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.Map (Map) +import qualified Data.Map as M +import Data.Semigroup as Sem + +import Network.DNS.Imports +import Network.DNS.Types.Internal + +---------------------------------------------------------------- + +type SPut = State WState Builder + +data WState = WState { + wsDomain :: Map Domain Int + , wsPosition :: Int +} + +initialWState :: WState +initialWState = WState M.empty 0 + +instance Sem.Semigroup SPut where + p1 <> p2 = (Sem.<>) <$> p1 <*> p2 + +instance Monoid SPut where + mempty = return mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (Sem.<>) +#endif + +put8 :: Word8 -> SPut +put8 = fixedSized 1 BB.word8 + +put16 :: Word16 -> SPut +put16 = fixedSized 2 BB.word16BE + +put32 :: Word32 -> SPut +put32 = fixedSized 4 BB.word32BE + +putInt8 :: Int -> SPut +putInt8 = fixedSized 1 (BB.int8 . fromIntegral) + +putInt16 :: Int -> SPut +putInt16 = fixedSized 2 (BB.int16BE . fromIntegral) + +putInt32 :: Int -> SPut +putInt32 = fixedSized 4 (BB.int32BE . fromIntegral) + +putByteString :: ByteString -> SPut +putByteString = writeSized BS.length BB.byteString + +putReplicate :: Int -> Word8 -> SPut +putReplicate n w = + fixedSized n BB.lazyByteString $ LB.replicate (fromIntegral n) w + +addPositionW :: Int -> State WState () +addPositionW n = do + (WState m cur) <- ST.get + ST.put $ WState m (cur+n) + +fixedSized :: Int -> (a -> Builder) -> a -> SPut +fixedSized n f a = do addPositionW n + return (f a) + +writeSized :: (a -> Int) -> (a -> Builder) -> a -> SPut +writeSized n f a = do addPositionW (n a) + return (f a) + +wsPop :: Domain -> State WState (Maybe Int) +wsPop dom = do + doms <- ST.gets wsDomain + return $ M.lookup dom doms + +wsPush :: Domain -> Int -> State WState () +wsPush dom pos = do + (WState m cur) <- ST.get + ST.put $ WState (M.insert dom pos m) cur + +---------------------------------------------------------------- + +type SGet = StateT PState (T.Parser ByteString) + +data PState = PState { + psDomain :: IntMap Domain + , psPosition :: Int + , psInput :: ByteString + , psAtTime :: Int64 + } + +---------------------------------------------------------------- + +getPosition :: SGet Int +getPosition = ST.gets psPosition + +getInput :: SGet ByteString +getInput = ST.gets psInput + +getAtTime :: SGet Int64 +getAtTime = ST.gets psAtTime + +addPosition :: Int -> SGet () +addPosition n | n < 0 = failSGet "internal error: negative position increment" + | otherwise = do + PState dom pos inp t <- ST.get + let !pos' = pos + n + when (pos' > BS.length inp) $ + failSGet "malformed or truncated input" + ST.put $ PState dom pos' inp t + +push :: Int -> Domain -> SGet () +push n d = do + PState dom pos inp t <- ST.get + ST.put $ PState (IM.insert n d dom) pos inp t + +pop :: Int -> SGet (Maybe Domain) +pop n = ST.gets (IM.lookup n . psDomain) + +---------------------------------------------------------------- + +get8 :: SGet Word8 +get8 = ST.lift A.anyWord8 <* addPosition 1 + +get16 :: SGet Word16 +get16 = ST.lift getWord16be <* addPosition 2 + where + word8' = fromIntegral <$> A.anyWord8 + getWord16be = do + a <- word8' + b <- word8' + return $ a * 0x100 + b + +get32 :: SGet Word32 +get32 = ST.lift getWord32be <* addPosition 4 + where + word8' = fromIntegral <$> A.anyWord8 + getWord32be = do + a <- word8' + b <- word8' + c <- word8' + d <- word8' + return $ a * 0x1000000 + b * 0x10000 + c * 0x100 + d + +getInt8 :: SGet Int +getInt8 = fromIntegral <$> get8 + +getInt16 :: SGet Int +getInt16 = fromIntegral <$> get16 + +getInt32 :: SGet Int +getInt32 = fromIntegral <$> get32 + +---------------------------------------------------------------- + +overrun :: SGet a +overrun = failSGet "malformed or truncated input" + +getNBytes :: Int -> SGet [Int] +getNBytes n | n < 0 = overrun + | otherwise = toInts <$> getNByteString n + where + toInts = map fromIntegral . BS.unpack + +getNoctets :: Int -> SGet [Word8] +getNoctets n | n < 0 = overrun + | otherwise = BS.unpack <$> getNByteString n + +skipNBytes :: Int -> SGet () +skipNBytes n | n < 0 = overrun + | otherwise = ST.lift (A.take n) >> addPosition n + +getNByteString :: Int -> SGet ByteString +getNByteString n | n < 0 = overrun + | otherwise = ST.lift (A.take n) <* addPosition n + +fitSGet :: Int -> SGet a -> SGet a +fitSGet len parser | len < 0 = overrun + | otherwise = do + pos0 <- getPosition + ret <- parser + pos' <- getPosition + if pos' == pos0 + len + then return $! ret + else if pos' > pos0 + len + then failSGet "element size exceeds declared size" + else failSGet "element shorter than declared size" + +-- | Parse a list of elements that takes up exactly a given number of bytes. +-- In order to avoid infinite loops, if an element parser succeeds without +-- moving the buffer offset forward, an error will be returned. +-- +sGetMany :: String -- ^ element type for error messages + -> Int -- ^ input buffer length + -> SGet a -- ^ element parser + -> SGet [a] +sGetMany elemname len parser | len < 0 = overrun + | otherwise = go len [] + where + go n xs + | n < 0 = failSGet $ elemname ++ " longer than declared size" + | n == 0 = pure $ reverse xs + | otherwise = do + pos0 <- getPosition + x <- parser + pos1 <- getPosition + if pos1 <= pos0 + then failSGet $ "internal error: in-place success for " ++ elemname + else go (n + pos0 - pos1) (x : xs) + +---------------------------------------------------------------- + +-- | To get a broad range of correct RRSIG inception and expiration times +-- without over or underflow, we choose a time half way between midnight PDT +-- 2010-07-15 (the day the root zone was signed) and 2^32 seconds later on +-- 2146-08-21. Since 'decode' and 'runSGet' are pure, we can't peek at the +-- current time while parsing. Outside this date range the output is off by +-- some non-zero multiple 2\^32 seconds. +-- +dnsTimeMid :: Int64 +dnsTimeMid = 3426660848 + +initialState :: Int64 -> ByteString -> PState +initialState t inp = PState IM.empty 0 inp t + +-- Construct our own error message, without the unhelpful AttoParsec +-- \"Failed reading: \" prefix. +-- +failSGet :: String -> SGet a +failSGet msg = ST.lift (fail "" A. msg) + +runSGetAt :: Int64 -> SGet a -> ByteString -> Either DNSError (a, PState) +runSGetAt t parser inp = + toResult $ A.parse (ST.runStateT parser $ initialState t inp) inp + where + toResult :: A.Result r -> Either DNSError r + toResult (A.Done _ r) = Right r + toResult (A.Fail _ ctx msg) = Left $ DecodeError $ head $ ctx ++ [msg] + toResult (A.Partial _) = Left $ DecodeError "incomplete input" + +runSGet :: SGet a -> ByteString -> Either DNSError (a, PState) +runSGet = runSGetAt dnsTimeMid + +runSGetWithLeftoversAt :: Int64 -- ^ Reference time for DNS clock arithmetic + -> SGet a -- ^ Parser + -> ByteString -- ^ Encoded message + -> Either DNSError ((a, PState), ByteString) +runSGetWithLeftoversAt t parser inp = + toResult $ A.parse (ST.runStateT parser $ initialState t inp) inp + where + toResult :: A.Result r -> Either DNSError (r, ByteString) + toResult (A.Done i r) = Right (r, i) + toResult (A.Partial f) = toResult $ f BS.empty + toResult (A.Fail _ ctx e) = Left $ DecodeError $ head $ ctx ++ [e] + +runSGetWithLeftovers :: SGet a -> ByteString -> Either DNSError ((a, PState), ByteString) +runSGetWithLeftovers = runSGetWithLeftoversAt dnsTimeMid + +runSPut :: SPut -> ByteString +runSPut = LBS.toStrict . BB.toLazyByteString . flip ST.evalState initialWState + +---------------------------------------------------------------- + +-- | Decode a domain name in A-label form to a leading label and a tail with +-- the remaining labels, unescaping backlashed chars and decimal triples along +-- the way. Any U-label conversion belongs at the layer above this code. +-- +-- This function is pure, but is not total, it throws an error when presented +-- with malformed input +-- +parseLabel :: Word8 -> ByteString -> (ByteString, ByteString) +parseLabel sep dom = + if BS.any (== bslash) dom + then toResult $ A.parse (labelParser sep mempty) dom + else check $ safeTail <$> BS.break (== sep) dom + where + toResult (A.Partial c) = toResult (c mempty) + toResult (A.Done tl hd) = check (hd, tl) + toResult _ = bottom + safeTail bs | BS.null bs = mempty + | otherwise = BS.tail bs + check r@(hd, tl) | not (BS.null hd) || BS.null tl = r + | otherwise = bottom + bottom = E.throw $ DecodeError $ "invalid domain: " ++ S8.unpack dom + +labelParser :: Word8 -> ByteString -> A.Parser ByteString +labelParser sep acc = do + acc' <- mappend acc <$> A.option mempty simple + labelEnd sep acc' <|> (escaped >>= labelParser sep . BS.snoc acc') + where + simple = fst <$> A.match skipUnescaped + where + skipUnescaped = A.skipMany1 $ A.satisfy notSepOrBslash + notSepOrBslash w = w /= sep && w /= bslash + + escaped = do + A.skip (== bslash) + either decodeDec pure =<< A.eitherP digit A.anyWord8 + where + digit = fromIntegral <$> A.satisfyWith (\n -> n - zero) (<=9) + decodeDec d = + safeWord8 =<< trigraph d <$> digit <*> digit + where + trigraph :: Word -> Word -> Word -> Word + trigraph x y z = 100 * x + 10 * y + z + + safeWord8 :: Word -> A.Parser Word8 + safeWord8 n | n > 255 = mzero + | otherwise = pure $ fromIntegral n + +labelEnd :: Word8 -> ByteString -> A.Parser ByteString +labelEnd sep acc = + A.satisfy (== sep) *> pure acc <|> + A.endOfInput *> pure acc + +---------------------------------------------------------------- + +-- | Convert a wire-form label to presentation-form by escaping +-- the separator, special and non-printing characters. For simple +-- labels with no bytes that require escaping we get back the input +-- bytestring asis with no copying or re-construction. +-- +-- Note: the separator is required to be either \'.\' or \'\@\', but this +-- constraint is the caller's responsibility and is not checked here. +-- +unparseLabel :: Word8 -> ByteString -> ByteString +unparseLabel sep label = + if BS.all (isPlain sep) label + then label + else toResult $ A.parse (labelUnparser sep mempty) label + where + toResult (A.Partial c) = toResult (c mempty) + toResult (A.Done _ r) = r + toResult _ = E.throw UnknownDNSError -- can't happen + +labelUnparser :: Word8 -> ByteString -> A.Parser ByteString +labelUnparser sep acc = do + acc' <- mappend acc <$> A.option mempty asis + A.endOfInput *> pure acc' <|> (esc >>= labelUnparser sep . mappend acc') + where + -- Non-printables are escaped as decimal trigraphs, while printable + -- specials just get a backslash prefix. + esc = do + w <- A.anyWord8 + if w <= 32 || w >= 127 + then let (q100, r100) = w `divMod` 100 + (q10, r10) = r100 `divMod` 10 + in pure $ BS.pack [ bslash, zero + q100, zero + q10, zero + r10 ] + else pure $ BS.pack [ bslash, w ] + + -- Runs of plain bytes are recognized as a single chunk, which is then + -- returned as-is. + asis = fmap fst $ A.match $ A.skipMany1 $ A.satisfy $ isPlain sep + +-- | In the presentation form of DNS labels, these characters are escaped by +-- prepending a backlash. (They have special meaning in zone files). Whitespace +-- and other non-printable or non-ascii characters are encoded via "\DDD" +-- decimal escapes. The separator character is also quoted in each label. Note +-- that '@' is quoted even when not the separator. +escSpecials :: ByteString +escSpecials = "\"$();@\\" + +-- | Is the given byte the separator or one of the specials? +isSpecial :: Word8 -> Word8 -> Bool +isSpecial sep w = w == sep || BS.elemIndex w escSpecials /= Nothing + +-- | Is the given byte a plain byte that reqires no escaping. The tests are +-- ordered to succeed or fail quickly in the most common cases. The test +-- ranges assume the expected numeric values of the named special characters. +-- Note: the separator is assumed to be either '.' or '@' and so not matched by +-- any of the first three fast-path 'True' cases. +isPlain :: Word8 -> Word8 -> Bool +isPlain sep w | w >= 127 = False -- + non-ASCII + | w > bslash = True -- ']'..'_'..'a'..'z'..'~' + | w >= zero && w < semi = True -- '0'..'9'..':' + | w > atsign && w < bslash = True -- 'A'..'Z'..'[' + | w <= 32 = False -- non-printables + | isSpecial sep w = False -- one of the specials + | otherwise = True -- plain punctuation + +-- | Some numeric byte constants. +zero, semi, atsign, bslash :: Word8 +zero = fromIntegral $ fromEnum '0' -- 48 +semi = fromIntegral $ fromEnum ';' -- 59 +atsign = fromIntegral $ fromEnum '@' -- 64 +bslash = fromIntegral $ fromEnum '\\' -- 92 diff --git a/internal/Network/DNS/Types/Internal.hs b/internal/Network/DNS/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/internal/Network/DNS/Types/Internal.hs @@ -0,0 +1,1618 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} + +module Network.DNS.Types.Internal where + +import Control.Exception (Exception, IOException) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BS +import Data.Char (intToDigit) +import qualified Data.Hourglass as H +import Data.IP (IP(..), IPv4, IPv6) +import qualified Data.Semigroup as Sem + +import qualified Network.DNS.Base32Hex as B32 +import Network.DNS.Imports + +-- $setup +-- >>> import Network.DNS + +---------------------------------------------------------------- + +-- | This type holds the /presentation form/ of fully-qualified DNS domain +-- names encoded as ASCII A-labels, with \'.\' separators between labels. +-- Non-printing characters are escaped as @\\DDD@ (a backslash, followed by +-- three decimal digits). The special characters: @ \", \$, (, ), ;, \@,@ and +-- @\\@ are escaped by prepending a backslash. The trailing \'.\' is optional +-- on input, but is recommended, and is always added when decoding from +-- /wire form/. +-- +-- The encoding of domain names to /wire form/, e.g. for transmission in a +-- query, requires the input encodings to be valid, otherwise a 'DecodeError' +-- may be thrown. Domain names received in wire form in DNS messages are +-- escaped to this presentation form as part of decoding the 'DNSMessage'. +-- +-- This form is ASCII-only. Any conversion between A-label 'ByteString's, +-- and U-label 'Text' happens at whatever layer maps user input to DNS +-- names, or presents /friendly/ DNS names to the user. Not all users +-- can read all scripts, and applications that default to U-label form +-- should ideally give the user a choice to see the A-label form. +-- Examples: +-- +-- @ +-- www.example.org. -- Ordinary DNS name. +-- \_25.\_tcp.mx1.example.net. -- TLSA RR initial labels have \_ prefixes. +-- \\001.exotic.example. -- First label is Ctrl-A! +-- just\\.one\\.label.example. -- First label is \"just.one.label\" +-- @ +-- +type Domain = ByteString + +-- | Type for a mailbox encoded on the wire as a DNS name, but the first label +-- is conceptually the local part of an email address, and may contain internal +-- periods that are not label separators. Therefore, in mailboxes \@ is used as +-- the separator between the first and second labels, and any \'.\' characters +-- in the first label are not escaped. The encoding is otherwise the same as +-- 'Domain' above. This is most commonly seen in the /mrname/ of @SOA@ records. +-- On input, if there is no unescaped \@ character in the 'Mailbox', it is +-- reparsed with \'.\' as the first label separator. Thus the traditional +-- format with all labels separated by dots is also accepted, but decoding from +-- wire form always uses \@ between the first label and the domain-part of the +-- address. Examples: +-- +-- @ +-- hostmaster\@example.org. -- First label is simply @hostmaster@ +-- john.smith\@examle.com. -- First label is @john.smith@ +-- @ +-- +type Mailbox = ByteString + +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 800 +-- | Types for resource records. +newtype TYPE = TYPE { + -- | From type to number. + fromTYPE :: Word16 + } deriving (Eq, Ord) + +-- https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-4 + +-- | IPv4 address +pattern A :: TYPE +pattern A = TYPE 1 +-- | An authoritative name serve +pattern NS :: TYPE +pattern NS = TYPE 2 +-- | The canonical name for an alias +pattern CNAME :: TYPE +pattern CNAME = TYPE 5 +-- | Marks the start of a zone of authority +pattern SOA :: TYPE +pattern SOA = TYPE 6 +-- | A null RR (EXPERIMENTAL) +pattern NULL :: TYPE +pattern NULL = TYPE 10 +-- | A domain name pointer +pattern PTR :: TYPE +pattern PTR = TYPE 12 +-- | Mail exchange +pattern MX :: TYPE +pattern MX = TYPE 15 +-- | Text strings +pattern TXT :: TYPE +pattern TXT = TYPE 16 +-- | IPv6 Address +pattern AAAA :: TYPE +pattern AAAA = TYPE 28 +-- | Server Selection (RFC2782) +pattern SRV :: TYPE +pattern SRV = TYPE 33 +-- | DNAME (RFC6672) +pattern DNAME :: TYPE +pattern DNAME = TYPE 39 -- RFC 6672 +-- | OPT (RFC6891) +pattern OPT :: TYPE +pattern OPT = TYPE 41 -- RFC 6891 +-- | Delegation Signer (RFC4034) +pattern DS :: TYPE +pattern DS = TYPE 43 -- RFC 4034 +-- | RRSIG (RFC4034) +pattern RRSIG :: TYPE +pattern RRSIG = TYPE 46 -- RFC 4034 +-- | NSEC (RFC4034) +pattern NSEC :: TYPE +pattern NSEC = TYPE 47 -- RFC 4034 +-- | DNSKEY (RFC4034) +pattern DNSKEY :: TYPE +pattern DNSKEY = TYPE 48 -- RFC 4034 +-- | NSEC3 (RFC5155) +pattern NSEC3 :: TYPE +pattern NSEC3 = TYPE 50 -- RFC 5155 +-- | NSEC3PARAM (RFC5155) +pattern NSEC3PARAM :: TYPE +pattern NSEC3PARAM = TYPE 51 -- RFC 5155 +-- | TLSA (RFC6698) +pattern TLSA :: TYPE +pattern TLSA = TYPE 52 -- RFC 6698 +-- | Child DS (RFC7344) +pattern CDS :: TYPE +pattern CDS = TYPE 59 -- RFC 7344 +-- | DNSKEY(s) the Child wants reflected in DS (RFC7344) +pattern CDNSKEY :: TYPE +pattern CDNSKEY = TYPE 60 -- RFC 7344 +-- | Child-To-Parent Synchronization (RFC7477) +pattern CSYNC :: TYPE +pattern CSYNC = TYPE 62 -- RFC 7477 +-- | Zone transfer (RFC5936) +pattern AXFR :: TYPE +pattern AXFR = TYPE 252 -- RFC 5936 +-- | A request for all records the server/cache has available +pattern ANY :: TYPE +pattern ANY = TYPE 255 +-- | Certification Authority Authorization (RFC6844) +pattern CAA :: TYPE +pattern CAA = TYPE 257 -- RFC 6844 + +-- | From number to type. +toTYPE :: Word16 -> TYPE +toTYPE = TYPE +#else +-- | Types for resource records. +data TYPE = A -- ^ IPv4 address + | NS -- ^ An authoritative name serve + | CNAME -- ^ The canonical name for an alias + | SOA -- ^ Marks the start of a zone of authority + | NULL -- ^ A null RR (EXPERIMENTAL) + | PTR -- ^ A domain name pointer + | MX -- ^ Mail exchange + | TXT -- ^ Text strings + | AAAA -- ^ IPv6 Address + | SRV -- ^ Server Selection (RFC2782) + | DNAME -- ^ DNAME (RFC6672) + | OPT -- ^ OPT (RFC6891) + | DS -- ^ Delegation Signer (RFC4034) + | RRSIG -- ^ RRSIG (RFC4034) + | NSEC -- ^ NSEC (RFC4034) + | DNSKEY -- ^ DNSKEY (RFC4034) + | NSEC3 -- ^ NSEC3 (RFC5155) + | NSEC3PARAM -- ^ NSEC3PARAM (RFC5155) + | TLSA -- ^ TLSA (RFC6698) + | CDS -- ^ Child DS (RFC7344) + | CDNSKEY -- ^ DNSKEY(s) the Child wants reflected in DS (RFC7344) + | CSYNC -- ^ Child-To-Parent Synchronization (RFC7477) + | AXFR -- ^ Zone transfer (RFC5936) + | ANY -- ^ A request for all records the server/cache + -- has available + | CAA -- ^ Certification Authority Authorization (RFC6844) + | UnknownTYPE Word16 -- ^ Unknown type + deriving (Eq, Ord, Read) + +-- | From type to number. +fromTYPE :: TYPE -> Word16 +fromTYPE A = 1 +fromTYPE NS = 2 +fromTYPE CNAME = 5 +fromTYPE SOA = 6 +fromTYPE NULL = 10 +fromTYPE PTR = 12 +fromTYPE MX = 15 +fromTYPE TXT = 16 +fromTYPE AAAA = 28 +fromTYPE SRV = 33 +fromTYPE DNAME = 39 +fromTYPE OPT = 41 +fromTYPE DS = 43 +fromTYPE RRSIG = 46 +fromTYPE NSEC = 47 +fromTYPE DNSKEY = 48 +fromTYPE NSEC3 = 50 +fromTYPE NSEC3PARAM = 51 +fromTYPE TLSA = 52 +fromTYPE CDS = 59 +fromTYPE CDNSKEY = 60 +fromTYPE CSYNC = 62 +fromTYPE AXFR = 252 +fromTYPE ANY = 255 +fromTYPE CAA = 257 +fromTYPE (UnknownTYPE x) = x + +-- | From number to type. +toTYPE :: Word16 -> TYPE +toTYPE 1 = A +toTYPE 2 = NS +toTYPE 5 = CNAME +toTYPE 6 = SOA +toTYPE 10 = NULL +toTYPE 12 = PTR +toTYPE 15 = MX +toTYPE 16 = TXT +toTYPE 28 = AAAA +toTYPE 33 = SRV +toTYPE 39 = DNAME +toTYPE 41 = OPT +toTYPE 43 = DS +toTYPE 46 = RRSIG +toTYPE 47 = NSEC +toTYPE 48 = DNSKEY +toTYPE 50 = NSEC3 +toTYPE 51 = NSEC3PARAM +toTYPE 52 = TLSA +toTYPE 59 = CDS +toTYPE 60 = CDNSKEY +toTYPE 62 = CSYNC +toTYPE 252 = AXFR +toTYPE 255 = ANY +toTYPE 257 = CAA +toTYPE x = UnknownTYPE x +#endif + +instance Show TYPE where + show A = "A" + show NS = "NS" + show CNAME = "CNAME" + show SOA = "SOA" + show NULL = "NULL" + show PTR = "PTR" + show MX = "MX" + show TXT = "TXT" + show AAAA = "AAAA" + show SRV = "SRV" + show DNAME = "DNAME" + show OPT = "OPT" + show DS = "DS" + show RRSIG = "RRSIG" + show NSEC = "NSEC" + show DNSKEY = "DNSKEY" + show NSEC3 = "NSEC3" + show NSEC3PARAM = "NSEC3PARAM" + show TLSA = "TLSA" + show CDS = "CDS" + show CDNSKEY = "CDNSKEY" + show CSYNC = "CSYNC" + show AXFR = "AXFR" + show ANY = "ANY" + show CAA = "CAA" + show x = "TYPE" ++ show (fromTYPE x) + +---------------------------------------------------------------- + +-- | An enumeration of all possible DNS errors that can occur. +data DNSError = + -- | The sequence number of the answer doesn't match our query. This + -- could indicate foul play. + SequenceNumberMismatch + -- | The question section of the response doesn't match our query. This + -- could indicate foul play. + | QuestionMismatch + -- | A zone tranfer, i.e., a request of type AXFR, was attempted with the + -- "lookup" interface. Zone transfer is different enough from "normal" + -- requests that it requires a different interface. + | InvalidAXFRLookup + -- | The number of retries for the request was exceeded. + | RetryLimitExceeded + -- | TCP fallback request timed out. + | TimeoutExpired + -- | The answer has the correct sequence number, but returned an + -- unexpected RDATA format. + | UnexpectedRDATA + -- | The domain for query is illegal. + | IllegalDomain + -- | The name server was unable to interpret the query. + | FormatError + -- | The name server was unable to process this query due to a + -- problem with the name server. + | ServerFailure + -- | This code signifies that the domain name referenced in the + -- query does not exist. + | NameError + -- | The name server does not support the requested kind of query. + | NotImplemented + -- | The name server refuses to perform the specified operation for + -- policy reasons. For example, a name + -- server may not wish to provide the + -- information to the particular requester, + -- or a name server may not wish to perform + -- a particular operation (e.g., zone transfer) for particular data. + | OperationRefused + -- | The server does not support the OPT RR version or content + | BadOptRecord + -- | Configuration is wrong. + | BadConfiguration + -- | Network failure. + | NetworkFailure IOException + -- | Error is unknown + | DecodeError String + | UnknownDNSError + deriving (Eq, Show, Typeable) + +instance Exception DNSError + + +-- | Data type representing the optional EDNS pseudo-header of a 'DNSMessage' +-- When a single well-formed @OPT@ 'ResourceRecord' was present in the +-- message's additional section, it is decoded to an 'EDNS' record and and +-- stored in the message 'ednsHeader' field. The corresponding @OPT RR@ is +-- then removed from the additional section. +-- +-- When the constructor is 'NoEDNS', no @EDNS OPT@ record was present in the +-- message additional section. When 'InvalidEDNS', the message holds either a +-- malformed OPT record or more than one OPT record, which can still be found +-- in (have not been removed from) the message additional section. +-- +-- The EDNS OPT record augments the message error status with an 8-bit field +-- that forms 12-bit extended RCODE when combined with the 4-bit RCODE from the +-- unextended DNS header. In EDNS messages it is essential to not use just the +-- bare 4-bit 'RCODE' from the original DNS header. Therefore, in order to +-- avoid potential misinterpretation of the response 'RCODE', when the OPT +-- record is decoded, the upper eight bits of the error status are +-- automatically combined with the 'rcode' of the message header, so that there +-- is only one place in which to find the full 12-bit result. Therefore, the +-- decoded 'EDNS' pseudo-header, does not hold any error status bits. +-- +-- The reverse process occurs when encoding messages. The low four bits of the +-- message header 'rcode' are encoded into the wire-form DNS header, while the +-- upper eight bits are encoded as part of the OPT record. In DNS responses with +-- an 'rcode' larger than 15, EDNS extensions SHOULD be enabled by providing a +-- value for 'ednsHeader' with a constructor of 'EDNSheader'. If EDNS is not +-- enabled in such a message, in order to avoid truncation of 'RCODE' values +-- that don't fit in the non-extended DNS header, the encoded wire-form 'RCODE' +-- is set to 'FormatErr'. +-- +-- When encoding messages for transmission, the 'ednsHeader' is used to +-- generate the additional OPT record. Do not add explicit @OPT@ records +-- to the aditional section, configure EDNS via the 'EDNSheader' instead. +-- +-- >>> let getopts eh = mapEDNS eh ednsOptions [] +-- >>> let optsin = [OD_ClientSubnet 24 0 $ read "192.0.2.1"] +-- >>> let masked = [OD_ClientSubnet 24 0 $ read "192.0.2.0"] +-- >>> let message = makeEmptyQuery $ ednsSetOptions $ ODataSet optsin +-- >>> let optsout = getopts. ednsHeader <$> (decode $ encode message) +-- >>> optsout == Right masked +-- True +-- +data EDNSheader = EDNSheader EDNS -- ^ A valid EDNS message + | NoEDNS -- ^ A valid non-EDNS message + | InvalidEDNS -- ^ Multiple or bad additional @OPT@ RRs + deriving (Eq, Show) + + +-- | Return the second argument for EDNS messages, otherwise the third. +ifEDNS :: EDNSheader -- ^ EDNS pseudo-header + -> a -- ^ Value to return for EDNS messages + -> a -- ^ Value to return for non-EDNS messages + -> a +ifEDNS (EDNSheader _) a _ = a +ifEDNS _ _ b = b +{-# INLINE ifEDNS #-} + + +-- | Return the output of a function applied to the EDNS pseudo-header if EDNS +-- is enabled, otherwise return a default value. +mapEDNS :: EDNSheader -- ^ EDNS pseudo-header + -> (EDNS -> a) -- ^ Function to apply to 'EDNS' value + -> a -- ^ Default result for non-EDNS messages + -> a +mapEDNS (EDNSheader eh) f _ = f eh +mapEDNS _ _ a = a +{-# INLINE mapEDNS #-} + + +-- | DNS message format for queries and replies. +-- +data DNSMessage = DNSMessage { + header :: !DNSHeader -- ^ Header with extended 'RCODE' + , ednsHeader :: EDNSheader -- ^ EDNS pseudo-header + , question :: [Question] -- ^ The question for the name server + , answer :: Answers -- ^ RRs answering the question + , authority :: AuthorityRecords -- ^ RRs pointing toward an authority + , additional :: AdditionalRecords -- ^ RRs holding additional information + } deriving (Eq, Show) + +-- | An identifier assigned by the program that +-- generates any kind of query. +type Identifier = Word16 + +-- | Raw data format for the header of DNS Query and Response. +data DNSHeader = DNSHeader { + identifier :: !Identifier -- ^ Query or reply identifier. + , flags :: !DNSFlags -- ^ Flags, OPCODE, and RCODE + } deriving (Eq, Show) + +-- | Raw data format for the flags of DNS Query and Response. +data DNSFlags = DNSFlags { + qOrR :: !QorR -- ^ Query or response. + , opcode :: !OPCODE -- ^ Kind of query. + , authAnswer :: !Bool -- ^ AA (Authoritative Answer) bit - this bit is valid in responses, + -- and specifies that the responding name server is an + -- authority for the domain name in question section. + , trunCation :: !Bool -- ^ TC (Truncated Response) bit - specifies that this message was truncated + -- due to length greater than that permitted on the + -- transmission channel. + , recDesired :: !Bool -- ^ RD (Recursion Desired) bit - this bit may be set in a query and + -- is copied into the response. If RD is set, it directs + -- the name server to pursue the query recursively. + -- Recursive query support is optional. + , recAvailable :: !Bool -- ^ RA (Recursion Available) bit - this be is set or cleared in a + -- response, and denotes whether recursive query support is + -- available in the name server. + + , rcode :: !RCODE -- ^ The full 12-bit extended RCODE when EDNS is in use. + -- Should always be zero in well-formed requests. + -- When decoding replies, the high eight bits from + -- any EDNS response are combined with the 4-bit + -- RCODE from the DNS header. When encoding + -- replies, if no EDNS OPT record is provided, RCODE + -- values > 15 are mapped to 'FormatErr'. + , authenData :: !Bool -- ^ AD (Authenticated Data) bit - (RFC4035, Section 3.2.3). + , chkDisable :: !Bool -- ^ CD (Checking Disabled) bit - (RFC4035, Section 3.2.2). + } deriving (Eq, Show) + + +-- | Default 'DNSFlags' record suitable for making recursive queries. By default +-- the RD bit is set, and the AD and CD bits are cleared. +-- +defaultDNSFlags :: DNSFlags +defaultDNSFlags = DNSFlags + { qOrR = QR_Query + , opcode = OP_STD + , authAnswer = False + , trunCation = False + , recDesired = True + , recAvailable = False + , authenData = False + , chkDisable = False + , rcode = NoErr + } + +---------------------------------------------------------------- + +-- | Boolean flag operations. These form a 'Monoid'. When combined via +-- `mappend`, as with function composition, the left-most value has +-- the last say. +-- +-- >>> mempty :: FlagOp +-- FlagKeep +-- >>> FlagSet <> mempty +-- FlagSet +-- >>> FlagClear <> FlagSet <> mempty +-- FlagClear +-- >>> FlagReset <> FlagClear <> FlagSet <> mempty +-- FlagReset +data FlagOp = FlagSet -- ^ Set the flag to 1 + | FlagClear -- ^ Clear the flag to 0 + | FlagReset -- ^ Reset the flag to its default value + | FlagKeep -- ^ Leave the flag unchanged + deriving (Eq, Show) + +-- $ +-- Test associativity of the semigroup operation: +-- +-- >>> let ops = [FlagSet, FlagClear, FlagReset, FlagKeep] +-- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops] +-- True +-- +instance Sem.Semigroup FlagOp where + FlagKeep <> op = op + op <> _ = op + +instance Monoid FlagOp where + mempty = FlagKeep +#if !(MIN_VERSION_base(4,11,0)) + -- this is redundant starting with base-4.11 / GHC 8.4 + -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally + mappend = (Sem.<>) +#endif + +-- | We don't show options left at their default value. +-- +_skipDefault :: String +_skipDefault = "" + +-- | Show non-default flag values +-- +_showFlag :: String -> FlagOp -> String +_showFlag nm FlagSet = nm ++ ":1" +_showFlag nm FlagClear = nm ++ ":0" +_showFlag _ FlagReset = _skipDefault +_showFlag _ FlagKeep = _skipDefault + +-- | Combine a list of options for display, skipping default values +-- +_showOpts :: [String] -> String +_showOpts os = intercalate "," $ filter (/= _skipDefault) os + +---------------------------------------------------------------- + +-- | Control over query-related DNS header flags. As with function composition, +-- the left-most value has the last say. +-- +data HeaderControls = HeaderControls + { rdBit :: !FlagOp + , adBit :: !FlagOp + , cdBit :: !FlagOp + } + deriving (Eq) + +instance Sem.Semigroup HeaderControls where + (HeaderControls rd1 ad1 cd1) <> (HeaderControls rd2 ad2 cd2) = + HeaderControls (rd1 <> rd2) (ad1 <> ad2) (cd1 <> cd2) + +instance Monoid HeaderControls where + mempty = HeaderControls FlagKeep FlagKeep FlagKeep +#if !(MIN_VERSION_base(4,11,0)) + -- this is redundant starting with base-4.11 / GHC 8.4 + -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally + mappend = (Sem.<>) +#endif + +instance Show HeaderControls where + show (HeaderControls rd ad cd) = + _showOpts + [ _showFlag "rd" rd + , _showFlag "ad" ad + , _showFlag "cd" cd ] + +---------------------------------------------------------------- + +-- | The default EDNS Option list is empty. We define two operations, one to +-- prepend a list of options, and another to set a specific list of options. +-- +data ODataOp = ODataAdd [OData] -- ^ Add the specified options to the list. + | ODataSet [OData] -- ^ Set the option list as specified. + deriving (Eq) + +-- | Since any given option code can appear at most once in the list, we +-- de-duplicate by the OPTION CODE when combining lists. +-- +_odataDedup :: ODataOp -> [OData] +_odataDedup op = + nubBy ((==) `on` _odataToOptCode) $ + case op of + ODataAdd os -> os + ODataSet os -> os + +-- $ +-- Test associativity of the OData semigroup operation: +-- +-- >>> let ip1 = IPv4 $ read "127.0.0.0" +-- >>> let ip2 = IPv4 $ read "192.0.2.0" +-- >>> let cs1 = OD_ClientSubnet 8 0 ip1 +-- >>> let cs2 = OD_ClientSubnet 24 0 ip2 +-- >>> let cs3 = OD_ECSgeneric 0 24 0 "foo" +-- >>> let dau1 = OD_DAU [3,5,7,8] +-- >>> let dau2 = OD_DAU [13,14] +-- >>> let dhu1 = OD_DHU [1,2] +-- >>> let dhu2 = OD_DHU [3,4] +-- >>> let nsid = OD_NSID "" +-- >>> let ops1 = [ODataAdd [dau1, dau2, cs1], ODataAdd [dau2, cs2, dhu1]] +-- >>> let ops2 = [ODataSet [], ODataSet [dhu2, cs3], ODataSet [nsid]] +-- >>> let ops = ops1 ++ ops2 +-- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops] +-- True + +instance Sem.Semigroup ODataOp where + ODataAdd as <> ODataAdd bs = ODataAdd $ as ++ bs + ODataAdd as <> ODataSet bs = ODataSet $ as ++ bs + ODataSet as <> _ = ODataSet as + +instance Monoid ODataOp where + mempty = ODataAdd [] +#if !(MIN_VERSION_base(4,11,0)) + -- this is redundant starting with base-4.11 / GHC 8.4 + -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally + mappend = (Sem.<>) +#endif + +---------------------------------------------------------------- + +-- | EDNS query controls. When EDNS is disabled via @ednsEnabled FlagClear@, +-- all the other EDNS-related overrides have no effect. +-- +-- >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet +-- NoEDNS +data EdnsControls = EdnsControls + { extEn :: !FlagOp -- ^ Enabled + , extVn :: !(Maybe Word8) -- ^ Version + , extSz :: !(Maybe Word16) -- ^ UDP Size + , extDO :: !FlagOp -- ^ DNSSEC OK (DO) bit + , extOd :: !ODataOp -- ^ EDNS option list tweaks + } + deriving (Eq) + +-- | Apply all the query flag overrides to 'defaultDNSFlags', returning the + +instance Sem.Semigroup EdnsControls where + (EdnsControls en1 vn1 sz1 do1 od1) <> (EdnsControls en2 vn2 sz2 do2 od2) = + EdnsControls (en1 <> en2) (vn1 <|> vn2) (sz1 <|> sz2) + (do1 <> do2) (od1 <> od2) + +instance Monoid EdnsControls where + mempty = EdnsControls FlagKeep Nothing Nothing FlagKeep mempty +#if !(MIN_VERSION_base(4,11,0)) + -- this is redundant starting with base-4.11 / GHC 8.4 + -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally + mappend = (Sem.<>) +#endif + +instance Show EdnsControls where + show (EdnsControls en vn sz d0 od) = + _showOpts + [ _showFlag "edns.enabled" en + , _showWord "edns.version" vn + , _showWord "edns.udpsize" sz + , _showFlag "edns.dobit" d0 + , _showOdOp "edns.options" $ map (show. _odataToOptCode) + $ _odataDedup od ] + where + _showWord :: Show a => String -> Maybe a -> String + _showWord nm w = maybe _skipDefault (\s -> nm ++ ":" ++ show s) w + + _showOdOp :: String -> [String] -> String + _showOdOp nm os = case os of + [] -> "" + _ -> nm ++ ":[" ++ intercalate "," os ++ "]" + +---------------------------------------------------------------- + +-- | Query controls form a 'Monoid', as with function composition, the +-- left-most value has the last say. The 'Monoid' is generated by two sets of +-- combinators, one that controls query-related DNS header flags, and another +-- that controls EDNS features. +-- +-- The header flag controls are: 'rdFlag', 'adFlag' and 'cdFlag'. +-- +-- The EDNS feature controls are: 'doFlag', 'ednsEnabled', 'ednsSetVersion', +-- 'ednsSetUdpSize' and 'ednsSetOptions'. When EDNS is disabled, all the other +-- EDNS-related controls have no effect. +-- +-- __Example:__ Disable DNSSEC checking on the server, and request signatures and +-- NSEC records, perhaps for your own independent validation. The UDP buffer +-- size is set large, for use with a local loopback nameserver on the same host. +-- +-- >>> :{ +-- mconcat [ adFlag FlagClear +-- , cdFlag FlagSet +-- , doFlag FlagSet +-- , ednsSetUdpSize (Just 8192) -- IPv4 loopback server? +-- ] +-- :} +-- ad:0,cd:1,edns.udpsize:8192,edns.dobit:1 +-- +-- __Example:__ Use EDNS version 1 (yet to be specified), request nameserver +-- ids from the server, and indicate a client subnet of "192.0.2.1/24". +-- +-- >>> :set -XOverloadedStrings +-- >>> let emptyNSID = "" +-- >>> let mask = 24 +-- >>> let ipaddr = read "192.0.2.1" +-- >>> :{ +-- mconcat [ ednsSetVersion (Just 1) +-- , ednsSetOptions (ODataAdd [OD_NSID emptyNSID]) +-- , ednsSetOptions (ODataAdd [OD_ClientSubnet mask 0 ipaddr]) +-- ] +-- :} +-- edns.version:1,edns.options:[NSID,ClientSubnet] + +data QueryControls = QueryControls + { qctlHeader :: !HeaderControls + , qctlEdns :: !EdnsControls + } + deriving (Eq) + +instance Sem.Semigroup QueryControls where + (QueryControls fl1 ex1) <> (QueryControls fl2 ex2) = + QueryControls (fl1 <> fl2) (ex1 <> ex2) + +instance Monoid QueryControls where + mempty = QueryControls mempty mempty +#if !(MIN_VERSION_base(4,11,0)) + -- this is redundant starting with base-4.11 / GHC 8.4 + -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally + mappend = (Sem.<>) +#endif + +instance Show QueryControls where + show (QueryControls fl ex) = _showOpts [ show fl, show ex ] + +---------------------------------------------------------------- + +-- | Generator of 'QueryControls' that adjusts the RD bit. +-- +-- >>> rdFlag FlagClear +-- rd:0 +rdFlag :: FlagOp -> QueryControls +rdFlag rd = mempty { qctlHeader = mempty { rdBit = rd } } + +-- | Generator of 'QueryControls' that adjusts the AD bit. +-- +-- >>> adFlag FlagSet +-- ad:1 +adFlag :: FlagOp -> QueryControls +adFlag ad = mempty { qctlHeader = mempty { adBit = ad } } + +-- | Generator of 'QueryControls' that adjusts the CD bit. +-- +-- >>> cdFlag FlagSet +-- cd:1 +cdFlag :: FlagOp -> QueryControls +cdFlag cd = mempty { qctlHeader = mempty { cdBit = cd } } + +-- | Generator of 'QueryControls' that enables or disables EDNS support. +-- When EDNS is disabled, the rest of the 'EDNS' controls are ignored. +-- +-- >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet +-- NoEDNS +ednsEnabled :: FlagOp -> QueryControls +ednsEnabled en = mempty { qctlEdns = mempty { extEn = en } } + +-- | Generator of 'QueryControls' that adjusts the 'EDNS' version. +-- A value of 'Nothing' makes no changes, while 'Just' @v@ sets +-- the EDNS version to @v@. +-- +-- >>> ednsSetVersion (Just 1) +-- edns.version:1 +ednsSetVersion :: Maybe Word8 -> QueryControls +ednsSetVersion vn = mempty { qctlEdns = mempty { extVn = vn } } + +-- | Generator of 'QueryControls' that adjusts the 'EDNS' UDP buffer size. +-- A value of 'Nothing' makes no changes, while 'Just' @n@ sets the EDNS UDP +-- buffer size to @n@. +-- +-- >>> ednsSetUdpSize (Just 2048) +-- edns.udpsize:2048 +ednsSetUdpSize :: Maybe Word16 -> QueryControls +ednsSetUdpSize sz = mempty { qctlEdns = mempty { extSz = sz } } + +-- | Generator of 'QueryControls' that adjusts the 'EDNS' DnssecOk (DO) bit. +-- +-- >>> doFlag FlagSet +-- edns.dobit:1 +doFlag :: FlagOp -> QueryControls +doFlag d0 = mempty { qctlEdns = mempty { extDO = d0 } } + +-- | Generator of 'QueryControls' that adjusts the list of 'EDNS' options. +-- +-- >>> :set -XOverloadedStrings +-- >>> ednsSetOptions (ODataAdd [OD_NSID ""]) +-- edns.options:[NSID] +ednsSetOptions :: ODataOp -> QueryControls +ednsSetOptions od = mempty { qctlEdns = mempty { extOd = od } } + +---------------------------------------------------------------- + +-- | Query or response. +data QorR = QR_Query -- ^ Query. + | QR_Response -- ^ Response. + deriving (Eq, Show, Enum, Bounded) + +-- | Kind of query. +data OPCODE + = OP_STD -- ^ A standard query. + | OP_INV -- ^ An inverse query (inverse queries are deprecated). + | OP_SSR -- ^ A server status request. + | OP_NOTIFY -- ^ A zone change notification (RFC1996) + | OP_UPDATE -- ^ An update request (RFC2136) + deriving (Eq, Show, Enum, Bounded) + +-- | Convert a 16-bit DNS OPCODE number to its internal representation +-- +toOPCODE :: Word16 -> Maybe OPCODE +toOPCODE i = case i of + 0 -> Just OP_STD + 1 -> Just OP_INV + 2 -> Just OP_SSR + -- OPCODE 3 is unassigned + 4 -> Just OP_NOTIFY + 5 -> Just OP_UPDATE + _ -> Nothing + +-- | Convert the internal representation of a DNS OPCODE to its 16-bit numeric +-- value. +-- +fromOPCODE :: OPCODE -> Word16 +fromOPCODE OP_STD = 0 +fromOPCODE OP_INV = 1 +fromOPCODE OP_SSR = 2 +fromOPCODE OP_NOTIFY = 4 +fromOPCODE OP_UPDATE = 5 + +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 800 +-- | EDNS extended 12-bit response code. Non-EDNS messages use only the low 4 +-- bits. With EDNS this stores the combined error code from the DNS header and +-- and the EDNS psuedo-header. See 'EDNSheader' for more detail. +newtype RCODE = RCODE { + -- | Convert an 'RCODE' to its numeric value. + fromRCODE :: Word16 + } deriving (Eq) + +-- | Provide an Enum instance for backwards compatibility +instance Enum RCODE where + fromEnum = fromIntegral . fromRCODE + toEnum = RCODE . fromIntegral + +-- | No error condition. +pattern NoErr :: RCODE +pattern NoErr = RCODE 0 +-- | Format error - The name server was +-- unable to interpret the query. +pattern FormatErr :: RCODE +pattern FormatErr = RCODE 1 +-- | Server failure - The name server was +-- unable to process this query due to a +-- problem with the name server. +pattern ServFail :: RCODE +pattern ServFail = RCODE 2 +-- | Name Error - Meaningful only for +-- responses from an authoritative name +-- server, this code signifies that the +-- domain name referenced in the query does +-- not exist. +pattern NameErr :: RCODE +pattern NameErr = RCODE 3 +-- | Not Implemented - The name server does +-- not support the requested kind of query. +pattern NotImpl :: RCODE +pattern NotImpl = RCODE 4 +-- | Refused - The name server refuses to +-- perform the specified operation for +-- policy reasons. For example, a name +-- server may not wish to provide the +-- information to the particular requester, +-- or a name server may not wish to perform +-- a particular operation (e.g., zone +-- transfer) for particular data. +pattern Refused :: RCODE +pattern Refused = RCODE 5 +-- | YXDomain - Dynamic update response, a pre-requisite domain that should not +-- exist, does exist. +pattern YXDomain :: RCODE +pattern YXDomain = RCODE 6 +-- | YXRRSet - Dynamic update response, a pre-requisite RRSet that should not +-- exist, does exist. +pattern YXRRSet :: RCODE +pattern YXRRSet = RCODE 7 +-- | NXRRSet - Dynamic update response, a pre-requisite RRSet that should +-- exist, does not exist. +pattern NXRRSet :: RCODE +pattern NXRRSet = RCODE 8 +-- | NotAuth - Dynamic update response, the server is not authoritative for the +-- zone named in the Zone Section. +pattern NotAuth :: RCODE +pattern NotAuth = RCODE 9 +-- | NotZone - Dynamic update response, a name used in the Prerequisite or +-- Update Section is not within the zone denoted by the Zone Section. +pattern NotZone :: RCODE +pattern NotZone = RCODE 10 +-- | Bad OPT Version (BADVERS, RFC 6891). +pattern BadVers :: RCODE +pattern BadVers = RCODE 16 +-- | Key not recognized [RFC2845] +pattern BadKey :: RCODE +pattern BadKey = RCODE 17 +-- | Signature out of time window [RFC2845] +pattern BadTime :: RCODE +pattern BadTime = RCODE 18 +-- | Bad TKEY Mode [RFC2930] +pattern BadMode :: RCODE +pattern BadMode = RCODE 19 +-- | Duplicate key name [RFC2930] +pattern BadName :: RCODE +pattern BadName = RCODE 20 +-- | Algorithm not supported [RFC2930] +pattern BadAlg :: RCODE +pattern BadAlg = RCODE 21 +-- | Bad Truncation [RFC4635] +pattern BadTrunc :: RCODE +pattern BadTrunc = RCODE 22 +-- | Bad/missing Server Cookie [RFC7873] +pattern BadCookie :: RCODE +pattern BadCookie = RCODE 23 +-- | Malformed (peer) EDNS message, no RCODE available. This is not an RCODE +-- that can be sent by a peer. It lies outside the 12-bit range expressible +-- via EDNS. The low 12-bits are chosen to coincide with 'FormatErr'. When +-- an EDNS message is malformed, and we're unable to extract the extended RCODE, +-- the header 'rcode' is set to 'BadRCODE'. +pattern BadRCODE :: RCODE +pattern BadRCODE = RCODE 0x1001 + +-- | Use https://tools.ietf.org/html/rfc2929#section-2.3 names for DNS RCODEs +instance Show RCODE where + show NoErr = "NoError" + show FormatErr = "FormErr" + show ServFail = "ServFail" + show NameErr = "NXDomain" + show NotImpl = "NotImp" + show Refused = "Refused" + show YXDomain = "YXDomain" + show YXRRSet = "YXRRSet" + show NotAuth = "NotAuth" + show NotZone = "NotZone" + show BadVers = "BadVers" + show BadKey = "BadKey" + show BadTime = "BadTime" + show BadMode = "BadMode" + show BadName = "BadName" + show BadAlg = "BadAlg" + show BadTrunc = "BadTrunc" + show BadCookie = "BadCookie" + show x = "RCODE " ++ (show $ fromRCODE x) + +-- | Convert a numeric value to a corresponding 'RCODE'. The behaviour is +-- undefined for values outside the range @[0 .. 0xFFF]@ since the EDNS +-- extended RCODE is a 12-bit value. Values in the range @[0xF01 .. 0xFFF]@ +-- are reserved for private use. +toRCODE :: Word16 -> RCODE +toRCODE = RCODE +#else +-- | EDNS extended 12-bit response code. Non-EDNS messages use only the low 4 +-- bits. With EDNS this stores the combined error code from the DNS header and +-- and the EDNS psuedo-header. See 'EDNSheader' for more detail. +data RCODE + = NoErr -- ^ No error condition. + | FormatErr -- ^ Format error - The name server was + -- unable to interpret the query. + | ServFail -- ^ Server failure - The name server was + -- unable to process this query due to a + -- problem with the name server. + | NameErr -- ^ Name Error - Meaningful only for + -- responses from an authoritative name + -- server, this code signifies that the + -- domain name referenced in the query does + -- not exist. + | NotImpl -- ^ Not Implemented - The name server does + -- not support the requested kind of query. + | Refused -- ^ Refused - The name server refuses to + -- perform the specified operation for + -- policy reasons. For example, a name + -- server may not wish to provide the + -- information to the particular requester, + -- or a name server may not wish to perform + -- a particular operation (e.g., zone + -- transfer) for particular data. + | YXDomain -- ^ Dynamic update response, a pre-requisite + -- domain that should not exist, does exist. + | YXRRSet -- ^ Dynamic update response, a pre-requisite + -- RRSet that should not exist, does exist. + | NXRRSet -- ^ Dynamic update response, a pre-requisite + -- RRSet that should exist, does not exist. + | NotAuth -- ^ Dynamic update response, the server is not + -- authoritative for the zone named in the Zone Section. + | NotZone -- ^ Dynamic update response, a name used in the + -- Prerequisite or Update Section is not within the zone + -- denoted by the Zone Section. + | BadVers -- ^ Bad OPT Version (RFC 6891) + | BadKey -- ^ Key not recognized [RFC2845] + | BadTime -- ^ Signature out of time window [RFC2845] + | BadMode -- ^ Bad TKEY Mode [RFC2930] + | BadName -- ^ Duplicate key name [RFC2930] + | BadAlg -- ^ Algorithm not supported [RFC2930] + | BadTrunc -- ^ Bad Truncation [RFC4635] + | BadCookie -- ^ Bad/missing Server Cookie [RFC7873] + | BadRCODE -- ^ Malformed (peer) EDNS message, no RCODE available. This is + -- not an RCODE that can be sent by a peer. It lies outside the + -- 12-bit range expressible via EDNS. The low bits are chosen to + -- coincide with 'FormatErr'. When an EDNS message is malformed, + -- and we're unable to extract the extended RCODE, the header + -- 'rcode' is set to 'BadRCODE'. + | UnknownRCODE Word16 + deriving (Eq, Ord, Show) + +-- | Convert an 'RCODE' to its numeric value. +fromRCODE :: RCODE -> Word16 +fromRCODE NoErr = 0 +fromRCODE FormatErr = 1 +fromRCODE ServFail = 2 +fromRCODE NameErr = 3 +fromRCODE NotImpl = 4 +fromRCODE Refused = 5 +fromRCODE YXDomain = 6 +fromRCODE YXRRSet = 7 +fromRCODE NXRRSet = 8 +fromRCODE NotAuth = 9 +fromRCODE NotZone = 10 +fromRCODE BadVers = 16 +fromRCODE BadKey = 17 +fromRCODE BadTime = 18 +fromRCODE BadMode = 19 +fromRCODE BadName = 20 +fromRCODE BadAlg = 21 +fromRCODE BadTrunc = 22 +fromRCODE BadCookie = 23 +fromRCODE BadRCODE = 0x1001 +fromRCODE (UnknownRCODE x) = x + +-- | Convert a numeric value to a corresponding 'RCODE'. The behaviour +-- is undefined for values outside the range @[0 .. 0xFFF]@ since the +-- EDNS extended RCODE is a 12-bit value. Values in the range +-- @[0xF01 .. 0xFFF]@ are reserved for private use. +-- +toRCODE :: Word16 -> RCODE +toRCODE 0 = NoErr +toRCODE 1 = FormatErr +toRCODE 2 = ServFail +toRCODE 3 = NameErr +toRCODE 4 = NotImpl +toRCODE 5 = Refused +toRCODE 6 = YXDomain +toRCODE 7 = YXRRSet +toRCODE 8 = NXRRSet +toRCODE 9 = NotAuth +toRCODE 10 = NotZone +toRCODE 16 = BadVers +toRCODE 17 = BadKey +toRCODE 18 = BadTime +toRCODE 19 = BadMode +toRCODE 20 = BadName +toRCODE 21 = BadAlg +toRCODE 22 = BadTrunc +toRCODE 23 = BadCookie +toRCODE 0x1001 = BadRCODE +toRCODE x = UnknownRCODE x +#endif + +---------------------------------------------------------------- + +-- XXX: The Question really should also include the CLASS +-- +-- | Raw data format for DNS questions. +data Question = Question { + qname :: Domain -- ^ A domain name + , qtype :: TYPE -- ^ The type of the query + } deriving (Eq, Show) + +---------------------------------------------------------------- + +-- | Resource record class. +type CLASS = Word16 + +-- | Resource record class for the Internet. +classIN :: CLASS +classIN = 1 + +-- | Time to live in second. +type TTL = Word32 + +-- | Raw data format for resource records. +data ResourceRecord = ResourceRecord { + rrname :: !Domain -- ^ Name + , rrtype :: !TYPE -- ^ Resource record type + , rrclass :: !CLASS -- ^ Resource record class + , rrttl :: !TTL -- ^ Time to live + , rdata :: !RData -- ^ Resource data + } deriving (Eq,Show) + +---------------------------------------------------------------- + +-- | Given a 32-bit circle-arithmetic DNS time, and the current absolute epoch +-- time, return the epoch time corresponding to the DNS timestamp. +-- +dnsTime :: Word32 -- ^ DNS circle-arithmetic timestamp + -> Int64 -- ^ current epoch time + -> Int64 -- ^ absolute DNS timestamp +dnsTime tdns tnow = + let delta = tdns - fromIntegral tnow + in if delta > 0x7FFFFFFF -- tdns is in the past? + then tnow - (0x100000000 - fromIntegral delta) + else tnow + fromIntegral delta + +-- | RRSIG representation. +-- +-- As noted in +-- +-- the RRsig inception and expiration times use serial number arithmetic. As a +-- result these timestamps /are not/ pure values, their meaning is +-- time-dependent! They depend on the present time and are both at most +-- approximately +\/-68 years from the present. This ambiguity is not a +-- problem because cached RRSIG records should only persist a few days, +-- signature lifetimes should be *much* shorter than 68 years, and key rotation +-- should result any misconstrued 136-year-old signatures fail to validate. +-- This also means that the interpretation of a time that is exactly half-way +-- around the clock at @now +\/-0x80000000@ is not important, the signature +-- should never be valid. +-- +-- The upshot for us is that we need to convert these *impure* relative values +-- to pure absolute values at the moment they are received from from the network +-- (or read from files, ... in some impure I/O context), and convert them back to +-- 32-bit values when encoding. Therefore, the constructor takes absolute +-- 64-bit representations of the inception and expiration times. +-- +-- The 'dnsTime' function performs the requisite conversion. +-- +data RD_RRSIG = RDREP_RRSIG + { rrsigType :: !TYPE -- ^ RRtype of RRset signed + , rrsigKeyAlg :: !Word8 -- ^ DNSKEY algorithm + , rrsigNumLabels :: !Word8 -- ^ Number of labels signed + , rrsigTTL :: !Word32 -- ^ Maximum origin TTL + , rrsigExpiration :: !Int64 -- ^ Time last valid + , rrsigInception :: !Int64 -- ^ Time first valid + , rrsigKeyTag :: !Word16 -- ^ Signing key tag + , rrsigZone :: !Domain -- ^ Signing domain + , rrsigValue :: !ByteString -- ^ Opaque signature + } + deriving (Eq, Ord) + +instance Show RD_RRSIG where + show RDREP_RRSIG{..} = unwords + [ show rrsigType + , show rrsigKeyAlg + , show rrsigNumLabels + , show rrsigTTL + , showTime rrsigExpiration + , showTime rrsigInception + , show rrsigKeyTag + , BS.unpack rrsigZone + , _b64encode rrsigValue + ] + where + showTime :: Int64 -> String + showTime t = H.timePrint fmt $ H.Elapsed $ H.Seconds t + where + fmt = [ H.Format_Year4, H.Format_Month2, H.Format_Day2 + , H.Format_Hour, H.Format_Minute, H.Format_Second ] + +-- | Raw data format for each type. +data RData = RD_A IPv4 -- ^ IPv4 address + | RD_NS Domain -- ^ An authoritative name serve + | RD_CNAME Domain -- ^ The canonical name for an alias + | RD_SOA Domain Mailbox Word32 Word32 Word32 Word32 Word32 + -- ^ Marks the start of a zone of authority + | RD_NULL ByteString -- ^ NULL RR (EXPERIMENTAL, RFC1035). + | RD_PTR Domain -- ^ A domain name pointer + | RD_MX Word16 Domain -- ^ Mail exchange + | RD_TXT ByteString -- ^ Text strings + | RD_AAAA IPv6 -- ^ IPv6 Address + | RD_SRV Word16 Word16 Word16 Domain + -- ^ Server Selection (RFC2782) + | RD_DNAME Domain -- ^ DNAME (RFC6672) + | RD_OPT [OData] -- ^ OPT (RFC6891) + | RD_DS Word16 Word8 Word8 ByteString -- ^ Delegation Signer (RFC4034) + | RD_RRSIG RD_RRSIG -- ^ DNSSEC signature + | RD_NSEC Domain [TYPE] -- ^ DNSSEC denial of existence NSEC record + | RD_DNSKEY Word16 Word8 Word8 ByteString + -- ^ DNSKEY (RFC4034) + | RD_NSEC3 Word8 Word8 Word16 ByteString ByteString [TYPE] + -- ^ DNSSEC hashed denial of existence (RFC5155) + | RD_NSEC3PARAM Word8 Word8 Word16 ByteString + -- ^ NSEC3 zone parameters (RFC5155) + | RD_TLSA Word8 Word8 Word8 ByteString + -- ^ TLSA (RFC6698) + | RD_CDS Word16 Word8 Word8 ByteString + -- ^ Child DS (RFC7344) + | RD_CDNSKEY Word16 Word8 Word8 ByteString + -- ^ Child DNSKEY (RFC7344) + --RD_CSYNC + | UnknownRData ByteString -- ^ Unknown resource data + deriving (Eq, Ord) + +instance Show RData where + show rd = case rd of + RD_A address -> show address + RD_NS nsdname -> showDomain nsdname + RD_CNAME cname -> showDomain cname + RD_SOA a b c d e f g -> showSOA a b c d e f g + RD_NULL bytes -> showOpaque bytes + RD_PTR ptrdname -> showDomain ptrdname + RD_MX pref exch -> showMX pref exch + RD_TXT textstring -> showTXT textstring + RD_AAAA address -> show address + RD_SRV pri wei prt tgt -> showSRV pri wei prt tgt + RD_DNAME target -> showDomain target + RD_OPT options -> show options + RD_DS tag alg dalg d -> showDS tag alg dalg d + RD_RRSIG rrsig -> show rrsig + RD_NSEC next types -> showNSEC next types + RD_DNSKEY f p a k -> showDNSKEY f p a k + RD_NSEC3 a f i s h types -> showNSEC3 a f i s h types + RD_NSEC3PARAM a f i s -> showNSEC3PARAM a f i s + RD_TLSA u s m d -> showTLSA u s m d + RD_CDS tag alg dalg d -> showDS tag alg dalg d + RD_CDNSKEY f p a k -> showDNSKEY f p a k + UnknownRData bytes -> showOpaque bytes + where + showSalt "" = "-" + showSalt salt = _b16encode salt + showDomain = BS.unpack + showSOA mname mrname serial refresh retry expire minttl = + showDomain mname ++ " " ++ showDomain mrname ++ " " ++ + show serial ++ " " ++ show refresh ++ " " ++ + show retry ++ " " ++ show expire ++ " " ++ show minttl + showMX preference exchange = + show preference ++ " " ++ showDomain exchange + showTXT bs = '"' : B.foldr dnsesc ['"'] bs + where + c2w = fromIntegral . fromEnum + w2c = toEnum . fromIntegral + doubleQuote = c2w '"' + backSlash = c2w '\\' + dnsesc c s + | c == doubleQuote = '\\' : w2c c : s + | c == backSlash = '\\' : w2c c : s + | c >= 32 && c < 127 = w2c c : s + | otherwise = '\\' : ddd c s + ddd c s = + let (q100, r100) = divMod (fromIntegral c) 100 + (q10, r10) = divMod r100 10 + in intToDigit q100 : intToDigit q10 : intToDigit r10 : s + showSRV priority weight port target = + show priority ++ " " ++ show weight ++ " " ++ + show port ++ BS.unpack target + showDS keytag alg digestType digest = + show keytag ++ " " ++ show alg ++ " " ++ + show digestType ++ " " ++ _b16encode digest + showNSEC next types = + unwords $ showDomain next : map show types + showDNSKEY flags protocol alg key = + show flags ++ " " ++ show protocol ++ " " ++ + show alg ++ " " ++ _b64encode key + -- | + showNSEC3 hashalg flags iterations salt nexthash types = + unwords $ show hashalg : show flags : show iterations : + showSalt salt : _b32encode nexthash : map show types + showNSEC3PARAM hashAlg flags iterations salt = + show hashAlg ++ " " ++ show flags ++ " " ++ + show iterations ++ " " ++ showSalt salt + showTLSA usage selector mtype digest = + show usage ++ " " ++ show selector ++ " " ++ + show mtype ++ " " ++ _b16encode digest + -- | Opaque RData: + showOpaque bs = unwords ["\\#", show (BS.length bs), _b16encode bs] + +_b16encode, _b32encode, _b64encode :: ByteString -> String +_b16encode = BS.unpack. B16.encode +_b32encode = BS.unpack. B32.encode +_b64encode = BS.unpack. B64.encode + +-- | Type alias for resource records in the answer section. +type Answers = [ResourceRecord] + +-- | Type alias for resource records in the answer section. +type AuthorityRecords = [ResourceRecord] + +-- | Type for resource records in the additional section. +type AdditionalRecords = [ResourceRecord] + +---------------------------------------------------------------- + +-- | A 'DNSMessage' template for queries with default settings for +-- the message 'DNSHeader' and 'EDNSheader'. This is the initial +-- query message state, before customization via 'QueryControls'. +-- +defaultQuery :: DNSMessage +defaultQuery = DNSMessage { + header = DNSHeader { + identifier = 0 + , flags = defaultDNSFlags + } + , ednsHeader = EDNSheader defaultEDNS + , question = [] + , answer = [] + , authority = [] + , additional = [] + } + +-- | Default response. When responding to EDNS queries, the response must +-- either be an EDNS response, or else FormatErr must be returned. The default +-- response message has EDNS disabled ('ednsHeader' set to 'NoEDNS'), it should +-- be updated as appropriate. +-- +-- Do not explicitly add OPT RRs to the additional section, instead let the +-- encoder compute and add the OPT record based on the EDNS pseudo-header. +-- +-- The 'RCODE' in the 'DNSHeader' should be set to the appropriate 12-bit +-- extended value, which will be split between the primary header and EDNS OPT +-- record during message encoding (low 4 bits in DNS header, high 8 bits in +-- EDNS OPT record). See 'EDNSheader' for more details. +-- +defaultResponse :: DNSMessage +defaultResponse = DNSMessage { + header = DNSHeader { + identifier = 0 + , flags = defaultDNSFlags { + qOrR = QR_Response + , authAnswer = True + , recAvailable = True + , authenData = False + } + } + , ednsHeader = NoEDNS + , question = [] + , answer = [] + , authority = [] + , additional = [] + } + +-- | A query template with 'QueryControls' overrides applied, +-- with just the 'Question' and query 'Identifier' remaining +-- to be filled in. +-- +makeEmptyQuery :: QueryControls -- ^ Flag and EDNS overrides + -> DNSMessage +makeEmptyQuery ctls = defaultQuery { + header = header' + , ednsHeader = queryEdns ehctls + } + where + hctls = qctlHeader ctls + ehctls = qctlEdns ctls + header' = (header defaultQuery) { flags = queryDNSFlags hctls } + + -- | Apply the given 'FlagOp' to a default boolean value to produce the final + -- setting. + -- + applyFlag :: FlagOp -> Bool -> Bool + applyFlag FlagSet _ = True + applyFlag FlagClear _ = False + applyFlag _ v = v + + -- | Construct a list of 0 or 1 EDNS OPT RRs based on EdnsControls setting. + -- + queryEdns :: EdnsControls -> EDNSheader + queryEdns (EdnsControls en vn sz d0 od) = + let d = defaultEDNS + in if en == FlagClear + then NoEDNS + else EDNSheader $ d { ednsVersion = fromMaybe (ednsVersion d) vn + , ednsUdpSize = fromMaybe (ednsUdpSize d) sz + , ednsDnssecOk = applyFlag d0 (ednsDnssecOk d) + , ednsOptions = _odataDedup od + } + + -- | Apply all the query flag overrides to 'defaultDNSFlags', returning the + -- resulting 'DNSFlags' suitable for making queries with the requested flag + -- settings. This is only needed if you're creating your own 'DNSMessage', + -- the 'Network.DNS.LookupRaw.lookupRawCtl' function takes a 'QueryControls' + -- argument and handles this conversion internally. + -- + -- Default overrides can be specified in the resolver configuration by setting + -- the 'Network.DNS.resolvQueryControls' field of the + -- 'Network.DNS.Resolver.ResolvConf' argument to + -- 'Network.DNS.Resolver.makeResolvSeed'. These then apply to lookups via + -- resolvers based on the resulting configuration, with the exception of + -- 'Network.DNS.LookupRaw.lookupRawCtl' which takes an additional + -- 'QueryControls' argument to augment the default overrides. + -- + queryDNSFlags :: HeaderControls -> DNSFlags + queryDNSFlags (HeaderControls rd ad cd) = d { + recDesired = applyFlag rd $ recDesired d + , authenData = applyFlag ad $ authenData d + , chkDisable = applyFlag cd $ chkDisable d + } + where + d = defaultDNSFlags + +-- | Construct a complete query 'DNSMessage', by combining the 'defaultQuery' +-- template with the specified 'Identifier', and 'Question'. The +-- 'QueryControls' can be 'mempty' to leave all header and EDNS settings at +-- their default values, or some combination of overrides. A default set of +-- overrides can be enabled via the 'Network.DNS.Resolver.resolvQueryControls' +-- field of 'Network.DNS.Resolver.ResolvConf'. Per-query overrides are +-- possible by using 'Network.DNS.LookupRaw.loookupRawCtl'. +-- +makeQuery :: Identifier -- ^ Crypto random request id + -> Question -- ^ Question name and type + -> QueryControls -- ^ Custom RD\/AD\/CD flags and EDNS settings + -> DNSMessage +makeQuery idt q ctls = empqry { + header = (header empqry) { identifier = idt } + , question = [q] + } + where + empqry = makeEmptyQuery ctls + +-- | Construct a query response 'DNSMessage'. +makeResponse :: Identifier + -> Question + -> Answers + -> DNSMessage +makeResponse idt q as = defaultResponse { + header = header' { identifier = idt } + , question = [q] + , answer = as + } + where + header' = header defaultResponse + +---------------------------------------------------------------- +-- EDNS (RFC 6891, EDNS(0)) +---------------------------------------------------------------- + +-- | EDNS information defined in RFC 6891. +data EDNS = EDNS { + -- | EDNS version, presently only version 0 is defined. + ednsVersion :: !Word8 + -- | Supported UDP payload size. + , ednsUdpSize :: !Word16 + -- | Request DNSSEC replies (with RRSIG and NSEC records as as appropriate) + -- from the server. Generally, not needed (except for diagnostic purposes) + -- unless the signatures will be validated. Just setting the 'AD' bit in + -- the query and checking it in the response is sufficient (but often + -- subject to man-in-the-middle forgery) if all that's wanted is whether + -- the server validated the response. + , ednsDnssecOk :: !Bool + -- | EDNS options (e.g. 'OD_NSID', 'OD_ClientSubnet', ...) + , ednsOptions :: ![OData] + } deriving (Eq, Show) + +-- | The default EDNS pseudo-header for queries. The UDP buffer size is set to +-- 1216 bytes, which should result in replies that fit into the 1280 byte +-- IPv6 minimum MTU. Since IPv6 only supports fragmentation at the source, +-- and even then not all gateways forward IPv6 pre-fragmented IPv6 packets, +-- it is best to keep DNS packet sizes below this limit when using IPv6 +-- nameservers. A larger value may be practical when using IPv4 exclusively. +-- +-- @ +-- defaultEDNS = EDNS +-- { ednsVersion = 0 -- The default EDNS version is 0 +-- , ednsUdpSize = 1232 -- IPv6-safe UDP MTU (RIPE recommendation) +-- , ednsDnssecOk = False -- We don't do DNSSEC validation +-- , ednsOptions = [] -- No EDNS options by default +-- } +-- @ +-- +defaultEDNS :: EDNS +defaultEDNS = EDNS + { ednsVersion = 0 -- The default EDNS version is 0 + , ednsUdpSize = 1232 -- IPv6-safe UDP MTU + , ednsDnssecOk = False -- We don't do DNSSEC validation + , ednsOptions = [] -- No EDNS options by default + } + +-- | Maximum UDP size that can be advertised. If the 'ednsUdpSize' of 'EDNS' +-- is larger, then this value is sent instead. This value is likely to work +-- only for local nameservers on the loopback network. Servers may enforce +-- a smaller limit. +-- +-- >>> maxUdpSize +-- 16384 +maxUdpSize :: Word16 +maxUdpSize = 16384 + +-- | Minimum UDP size to advertise. If 'ednsUdpSize' of 'EDNS' is smaller, +-- then this value is sent instead. +-- +-- >>> minUdpSize +-- 512 +minUdpSize :: Word16 +minUdpSize = 512 + +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 800 +-- | EDNS Option Code (RFC 6891). +newtype OptCode = OptCode { + -- | From option code to number. + fromOptCode :: Word16 + } deriving (Eq,Ord) + +-- | NSID (RFC5001, section 2.3) +pattern NSID :: OptCode +pattern NSID = OptCode 3 + +-- | DNSSEC algorithm support (RFC6974, section 3) +pattern DAU :: OptCode +pattern DAU = OptCode 5 +pattern DHU :: OptCode +pattern DHU = OptCode 6 +pattern N3U :: OptCode +pattern N3U = OptCode 7 + +-- | Client subnet (RFC7871) +pattern ClientSubnet :: OptCode +pattern ClientSubnet = OptCode 8 + +instance Show OptCode where + show NSID = "NSID" + show DAU = "DAU" + show DHU = "DHU" + show N3U = "N3U" + show ClientSubnet = "ClientSubnet" + show x = "OptCode" ++ (show $ fromOptCode x) + +-- | From number to option code. +toOptCode :: Word16 -> OptCode +toOptCode = OptCode +#else +-- | Option Code (RFC 6891). +data OptCode = NSID -- ^ Name Server Identifier (RFC5001) + | DAU -- ^ DNSSEC Algorithm understood (RFC6975) + | DHU -- ^ DNSSEC Hash Understood (RFC6975) + | N3U -- ^ NSEC3 Hash Understood (RFC6975) + | ClientSubnet -- ^ Client subnet (RFC7871) + | UnknownOptCode Word16 -- ^ Unknown option code + deriving (Eq, Ord, Show) + +-- | From option code to number. +fromOptCode :: OptCode -> Word16 +fromOptCode NSID = 3 +fromOptCode DAU = 5 +fromOptCode DHU = 6 +fromOptCode N3U = 7 +fromOptCode ClientSubnet = 8 +fromOptCode (UnknownOptCode x) = x + +-- | From number to option code. +toOptCode :: Word16 -> OptCode +toOptCode 3 = NSID +toOptCode 5 = DAU +toOptCode 6 = DHU +toOptCode 7 = N3U +toOptCode 8 = ClientSubnet +toOptCode x = UnknownOptCode x +#endif + +---------------------------------------------------------------- + +-- | RData formats for a few EDNS options, and an opaque catchall +data OData = + -- | Name Server Identifier (RFC5001). Bidirectional, empty from client. + -- (opaque octet-string). May contain binary data, which MUST be empty + -- in queries. + OD_NSID ByteString + -- | DNSSEC Algorithm Understood (RFC6975). Client to server. + -- (array of 8-bit numbers). Lists supported DNSKEY algorithms. + | OD_DAU [Word8] + -- | DS Hash Understood (RFC6975). Client to server. + -- (array of 8-bit numbers). Lists supported DS hash algorithms. + | OD_DHU [Word8] + -- | NSEC3 Hash Understood (RFC6975). Client to server. + -- (array of 8-bit numbers). Lists supported NSEC3 hash algorithms. + | OD_N3U [Word8] + -- | Client subnet (RFC7871). Bidirectional. + -- (source bits, scope bits, address). + -- The address is masked and truncated when encoding queries. The + -- address is zero-padded when decoding. Invalid input encodings + -- result in an 'OD_ECSgeneric' value instead. + -- + | OD_ClientSubnet Word8 Word8 IP + -- | Unsupported or malformed IP client subnet option. Bidirectional. + -- (address family, source bits, scope bits, opaque address). + | OD_ECSgeneric Word16 Word8 Word8 ByteString + -- | Generic EDNS option. + -- (numeric 'OptCode', opaque content) + | UnknownOData Word16 ByteString + deriving (Eq,Ord) + + +-- | Recover the (often implicit) 'OptCode' from a value of the 'OData' sum +-- type. +_odataToOptCode :: OData -> OptCode +_odataToOptCode OD_NSID {} = NSID +_odataToOptCode OD_DAU {} = DAU +_odataToOptCode OD_DHU {} = DHU +_odataToOptCode OD_N3U {} = N3U +_odataToOptCode OD_ClientSubnet {} = ClientSubnet +_odataToOptCode OD_ECSgeneric {} = ClientSubnet +_odataToOptCode (UnknownOData code _) = toOptCode code + +instance Show OData where + show (OD_NSID nsid) = _showNSID nsid + show (OD_DAU as) = _showAlgList "DAU" as + show (OD_DHU hs) = _showAlgList "DHU" hs + show (OD_N3U hs) = _showAlgList "N3U" hs + show (OD_ClientSubnet b1 b2 ip@(IPv4 _)) = _showECS 1 b1 b2 $ show ip + show (OD_ClientSubnet b1 b2 ip@(IPv6 _)) = _showECS 2 b1 b2 $ show ip + show (OD_ECSgeneric fam b1 b2 a) = _showECS fam b1 b2 $ _b16encode a + show (UnknownOData code bs) = + "UnknownOData " ++ show code ++ " " ++ _b16encode bs + +_showAlgList :: String -> [Word8] -> String +_showAlgList nm ws = nm ++ " " ++ intercalate "," (map show ws) + +_showNSID :: ByteString -> String +_showNSID nsid = "NSID" ++ " " ++ _b16encode nsid ++ ";" ++ printable nsid + where + printable = BS.unpack. BS.map (\c -> if c < ' ' || c > '~' then '?' else c) + +_showECS :: Word16 -> Word8 -> Word8 -> String -> String +_showECS family srcBits scpBits address = + show family ++ " " ++ show srcBits + ++ " " ++ show scpBits ++ " " ++ address diff --git a/internal/Network/DNS/Types/Resolver.hs b/internal/Network/DNS/Types/Resolver.hs new file mode 100644 --- /dev/null +++ b/internal/Network/DNS/Types/Resolver.hs @@ -0,0 +1,136 @@ +module Network.DNS.Types.Resolver where + +import Network.Socket (AddrInfo(..), PortNumber, HostName) + +import Network.DNS.Imports +import Network.DNS.Memo +import Network.DNS.Types.Internal + +---------------------------------------------------------------- + +-- | The type to specify a cache server. +data FileOrNumericHost = RCFilePath FilePath -- ^ A path for \"resolv.conf\" + -- where one or more IP addresses + -- of DNS servers should be found + -- on Unix. + -- Default DNS servers are + -- automatically detected + -- on Windows regardless of + -- the value of the file name. + | RCHostName HostName -- ^ A numeric IP address. /Warning/: host names are invalid. + | RCHostNames [HostName] -- ^ Numeric IP addresses. /Warning/: host names are invalid. + | RCHostPort HostName PortNumber -- ^ A numeric IP address and port number. /Warning/: host names are invalid. + deriving Show + +---------------------------------------------------------------- + +-- | Cache configuration for responses. +data CacheConf = CacheConf { + -- | If RR's TTL is higher than this value, this value is used instead. + maximumTTL :: TTL + -- | Cache pruning interval in seconds. + , pruningDelay :: Int + } deriving Show + +-- | Default cache configuration. +-- +-- >>> defaultCacheConf +-- CacheConf {maximumTTL = 300, pruningDelay = 10} +defaultCacheConf :: CacheConf +defaultCacheConf = CacheConf 300 10 + +---------------------------------------------------------------- + +-- | Type for resolver configuration. +-- Use 'defaultResolvConf' to create a new value. +-- +-- An example to use Google's public DNS cache instead of resolv.conf: +-- +-- >>> let conf = defaultResolvConf { resolvInfo = RCHostName "8.8.8.8" } +-- +-- An example to use multiple Google's public DNS cache concurrently: +-- +-- >>> let conf = defaultResolvConf { resolvInfo = RCHostNames ["8.8.8.8","8.8.4.4"], resolvConcurrent = True } +-- +-- An example to disable EDNS: +-- +-- >>> let conf = defaultResolvConf { resolvQueryControls = ednsEnabled FlagClear } +-- +-- An example to enable query result caching: +-- +-- >>> let conf = defaultResolvConf { resolvCache = Just defaultCacheConf } +-- +-- An example to disable requesting recursive service. +-- +-- >>> let conf = defaultResolvConf { resolvQueryControls = rdFlag FlagClear } +-- +-- An example to set the AD bit in all queries by default. +-- +-- >>> let conf = defaultResolvConf { resolvQueryControls = adFlag FlagSet } +-- +-- An example to set the both the AD and CD bits in all queries by default. +-- +-- >>> let conf = defaultResolvConf { resolvQueryControls = adFlag FlagSet <> cdFlag FlagSet } +-- +-- An example with an EDNS buffer size of 1216 bytes, which is more robust with +-- IPv6, and the DO bit set to request DNSSEC responses. +-- +-- >>> let conf = defaultResolvConf { resolvQueryControls = ednsSetUdpSize (Just 1216) <> doFlag FlagSet } +-- +data ResolvConf = ResolvConf { + -- | Server information. + resolvInfo :: FileOrNumericHost + -- | Timeout in micro seconds. + , resolvTimeout :: Int + -- | The number of retries including the first try. + , resolvRetry :: Int + -- | Concurrent queries if multiple DNS servers are specified. + , resolvConcurrent :: Bool + -- | Cache configuration. + , resolvCache :: Maybe CacheConf + -- | Overrides for the default flags used for queries via resolvers that use + -- this configuration. + , resolvQueryControls :: QueryControls +} deriving Show + +-- | Return a default 'ResolvConf': +-- +-- * 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\". +-- * 'resolvTimeout' is 3,000,000 micro seconds. +-- * 'resolvRetry' is 3. +-- * 'resolvConcurrent' is False. +-- * 'resolvCache' is Nothing. +-- * 'resolvQueryControls' is an empty set of overrides. +defaultResolvConf :: ResolvConf +defaultResolvConf = ResolvConf { + resolvInfo = RCFilePath "/etc/resolv.conf" + , resolvTimeout = 3 * 1000 * 1000 + , resolvRetry = 3 + , resolvConcurrent = False + , resolvCache = Nothing + , resolvQueryControls = mempty +} + +---------------------------------------------------------------- + +-- | Intermediate abstract data type for resolvers. +-- IP address information of DNS servers is generated +-- according to 'resolvInfo' internally. +-- This value can be safely reused for 'withResolver'. +-- +-- The naming is confusing for historical reasons. +data ResolvSeed = ResolvSeed { + resolvconf :: ResolvConf + , nameservers :: NonEmpty AddrInfo +} + +---------------------------------------------------------------- + +-- | Abstract data type of DNS Resolver. +-- This includes newly seeded identifier generators for all +-- specified DNS servers and a cache database. +data Resolver = Resolver { + resolvseed :: ResolvSeed + , genIds :: NonEmpty (IO Word16) + , cache :: Maybe Cache +} diff --git a/test/DecodeSpec.hs b/test/DecodeSpec.hs --- a/test/DecodeSpec.hs +++ b/test/DecodeSpec.hs @@ -7,13 +7,14 @@ #if !MIN_VERSION_bytestring(0,10,0) import qualified Data.ByteString as BS #endif -import Data.Monoid ((<>)) import Data.Word8 import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (plusPtr) import Foreign.Storable (peek, poke, peekByteOff) -import Network.DNS import Test.Hspec + +import Network.DNS +import Network.DNS.Imports ---------------------------------------------------------------- diff --git a/test/EncodeSpec.hs b/test/EncodeSpec.hs --- a/test/EncodeSpec.hs +++ b/test/EncodeSpec.hs @@ -3,9 +3,9 @@ module EncodeSpec where import Data.IP -import Network.DNS -import Network.DNS.Types (defaultQuery, Question(..)) import Test.Hspec + +import Network.DNS spec :: Spec spec = do diff --git a/test/RoundTripSpec.hs b/test/RoundTripSpec.hs --- a/test/RoundTripSpec.hs +++ b/test/RoundTripSpec.hs @@ -2,27 +2,21 @@ module RoundTripSpec where -import Control.Monad (replicateM) import qualified Data.IP import Data.IP (Addr, IP(..), IPv4, IPv6, toIPv4, toIPv6, makeAddrRange) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BS -import Network.DNS.Decode -import Network.DNS.Decode.Internal -import Network.DNS.Encode -import Network.DNS.Encode.Internal -import Network.DNS.Types import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck (Gen, arbitrary, elements, forAll, frequency, listOf, oneof) -import Data.Word (Word8, Word16, Word32) -import Data.Monoid ((<>)) import GHC.Exts (the, groupWith) -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -#endif - +import Network.DNS.Decode +import Network.DNS.Decode.Internal +import Network.DNS.Encode +import Network.DNS.Encode.Internal +import Network.DNS.Imports +import Network.DNS.Types spec :: Spec spec = do diff --git a/test2/IOSpec.hs b/test2/IOSpec.hs --- a/test2/IOSpec.hs +++ b/test2/IOSpec.hs @@ -2,11 +2,12 @@ module IOSpec where -import Data.Monoid ((<>)) +import Network.Socket +import Test.Hspec + import Network.DNS.IO as DNS +import Network.DNS.Imports import Network.DNS.Types as DNS -import Network.Socket hiding (send) -import Test.Hspec spec :: Spec spec = describe "send/receive" $ do diff --git a/test2/LookupSpec.hs b/test2/LookupSpec.hs --- a/test2/LookupSpec.hs +++ b/test2/LookupSpec.hs @@ -2,8 +2,9 @@ module LookupSpec where -import Network.DNS as DNS import Test.Hspec + +import Network.DNS as DNS spec :: Spec spec = describe "lookup" $ do diff --git a/test2/doctests.hs b/test2/doctests.hs --- a/test2/doctests.hs +++ b/test2/doctests.hs @@ -1,14 +1,34 @@ +{-# LANGUAGE CPP #-} + +-- | Run doctests only on non-Windows systems with GHC 8.4 or later. +-- +-- The Windows doctests now compile and run, but either succeed quickly or +-- randomly hang (before AppVeyor kills them after an hour). So we disable +-- these for now. This can be tested again at some point in the future. +-- module Main where -import Build_doctests (flags, pkgs, module_sources) -import Test.DocTest (doctest) +#if !defined(mingw32_HOST_OS) && MIN_TOOL_VERSION_ghc(8,4,0) +import Test.DocTest +import System.Environment +-- | Expose precompiled library modules. +modules :: [String] +modules = + [ "-XOverloadedStrings" + , "-XCPP" + , "-i","-i.","-iinternal" + , "-threaded" + , "-package=dns" + , "Network/DNS.hs" + ] + main :: IO () -main = do - putStrLn $ unwords $ "\ndoctest args: " : args - doctest args - where - args = [ "-XCPP" ] ++ - flags ++ - pkgs ++ - module_sources +main = getArgs >>= doctest . (++ modules) + +#else + +main :: IO () +main = return () + +#endif