diff --git a/Changelog b/Changelog deleted file mode 100644 --- a/Changelog +++ /dev/null @@ -1,41 +0,0 @@ -2.0.13 - - Testing with AppVeyor. - - Fixing sendAll on Windows [#72](https://github.com/kazu-yamamoto/dns/pull/72) - - Implementing RetryLimitExceeded [#73](https://github.com/kazu-yamamoto/dns/pull/73) - -2.0.12 - - Fixing Windows build again -2.0.11 - - Fixing the StateBinary.get32 parser [#57](https://github.com/kazu-yamamoto/dns/pull/57) - - Removing bytestring-builder dependency [#61](https://github.com/kazu-yamamoto/dns/pull/61) - - Fixing Windows build [#62](https://github.com/kazu-yamamoto/dns/pull/62) -2.0.10 - - Cleaning up the code. [#47](https://github.com/kazu-yamamoto/dns/pull/47) -2.0.9 - - Implemented TCP fallback after a truncated UDP response. [#46](https://github.com/kazu-yamamoto/dns/pull/46) -2.0.8 - - Better handling of encoding and decoding the "root" domain ".". [#45](https://github.com/kazu-yamamoto/dns/pull/45) -2.0.7 - - Add length checks for A and AAAA records. [#43](https://github.com/kazu-yamamoto/dns/pull/43) -2.0.6 - - Adding Ord instance. [#41](https://github.com/kazu-yamamoto/dns/pull/41) - - Adding DNSSEC-related RRTYPEs [#40](https://github.com/kazu-yamamoto/dns/pull/40) -2.0.5 - - Supporting DNS-SEC AD (authenticated data). [#38](https://github.com/kazu-yamamoto/dns/pull/38) - - Removing the dependency to blaze-builder. -2.0.4 - - Renaming a variable to fix preprocessor conflicts [#37](https://github.com/kazu-yamamoto/dns/pull/37) -2.0.3 - - Handle invalid opcodes gracefully. [#36](https://github.com/kazu-yamamoto/dns/pull/36) -2.0.2 - - Providing a new API: decodeMany. -2.0.1 - - Updating document. -2.0.0 - - DNSMessage is now monomorphic - - RDATA is now monomorphic - - Removed traversal instance for DNSMessage - - EDNS0 encoding/decoding is now supported - - Removed dnsMapWithType and dnsTraverseWithType functions - - responseA and responseAAAA now take lists of IP addresses as their arguments - - DNSHeader type no longer has qdCount, anCount, nsCount, and arCount fields diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,279 @@ +# ChangeLog + +## 4.2.0 + +- Switching cryptonite to crypton. + +## 4.1.1 + +- Adding encoder/decoder for CAA RR. + +## 4.1.0 + +- Breaking change: GHC 7.x and earlier no longer supported. + We now require support for PatternSynonyms, available since + GHC 8.0. +- Feature: relaxed lookup-raw interface + [#167](https://github.com/kazu-yamamoto/dns/pull/167) +- Using "53" instead of "domain". + [#166](ttps://github.com/kazu-yamamoto/dns/pull/166) +- UDP ReceiveFrom, sendTo with SockAddr + [#165](https://github.com/kazu-yamamoto/dns/pull/165) +- Feature: Support for RP resource record type + [#161](https://github.com/kazu-yamamoto/dns/pull/161) +- Feature: New `splitDomain` function splits a domain name + at the first label break, unescaping the first label to + a raw ByteString. +- Feature: New `splitMailbox` function splits a domain name + at the first label break, unescaping the first label to + a raw ByteString. + [#155](https://github.com/kazu-yamamoto/dns/pull/155) +- Bugfix: Encoding of large packets could produce invalid + compression pointers. + [#156](https://github.com/kazu-yamamoto/dns/pull/156) +- Bugfix: SRV record presentation form (RD_SRV show instance) + was missing a space between the port and the target. + +## 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 + parsed as a sequence of DNS labels, backslashed escapes + (single-character and 3-digit decimal) are decoded to + the corresponding character or byte. Therefore, `encode` + is not a total function, it may raise a `DecodeError` + when a `ResourceRecord` contains a malformed `Domain`. +- Breaking change: when wire-form DNS names are converted + to `Domain` ByteStrings, special characters in DNS labels + are now encoded as `\c` (single-character backslash escapes) + and non-printing characters as `\DDD` (3-digit decimal escapes). +- Output format change: `show` for TXT RDATA now includes + enclosing double quotes, and escapes special characters. + This is consistent with the format of TXT records in zone + files and, e.g., dig(1) output. The DNS string quoting + syntax is similar to a proper subset of the Haskell string + quoting syntax, but its decimal escapes require exactly + three digits, while Haskell accepts 1 or more, and uses + `'\&'` as a null. Therefore, `read @String` does not + reliably decode the DNS text string presentation form. +- Breaking change: the DNSMessage __component__ encoding + functions are now internal. They're still exported from + the new 'Nework.DNS.Encode.Internal' module, but this + is only to make them available for the test-suite. +- Added the TYPE definition, but not yet RData, for CAA. +- Added decode, encode and show for NSEC3 RRs. +- Added base16-bytestring as a new dependency. +- Added decode, encode and show for NSEC RRs. +- New RData constructor RD\_NSEC. +- Correct presentation form of unknown RR types. +- Corrected encoding of long TXT records +- RD\_NULL now has an opaque data payload. +- Safety: Both 'decode' and 'decodeAt' must now consume exactly + the complete input buffer or a DecodeError is returned. + * The same applies to each complete message with 'decodeMany' + and 'decodeManyAt'. Any final encoded message segment at the + end of the input buffer is still returned as the second + element of the result pair. +- Bugfix: fixed incorrect decoding of TXT records, and corrected + the associated test. +- Cleanup: More precise control over decoder error messages via + 'failSGet', which avoids the unhelpful Attoparsec "Failure + reading: " error prefix. +- Cleanup: Simplified loop detection in name decompression, making + use of a monotone strictly decreasing limit on valid "pointer" + targets. +- Breaking change: In the "Decode" module, expose only the + decode{,Many}{,At} functions. The rest of the "Decode" module's + functions are now internal, exposed only for testing. These + include: + * decodeDNSHeader + * decodeDNSFlags + * decodeResourceRecord + * decodeDomain + * decodeMailbox +- Cleanup: Reworked Decode module structure: + * Moved Decode.Internal to Decode.Parsers + * Created a new Decode.Internal which is now exposed, and + moved some functions there from Decode which are only + exposed for testing, since they could not reliably be used + except as part of decoding a full message. +- Feature: RRSIG support, we can now encode, decode and show RRSIG + records. This uses the new 'decodeAt' and 'decodeManyAt' API. +- New API: 'decodeAt' and 'decodeManyAt' make it possible for + the decoder to get the current time, in order to decode some + RR types (like RRSIG) whose full meaning is time-dependent. +- Re-export 'sendAll' and export 'encodeVC' for use with TCP. +- No longer using sendAll with UDP, UDP datagrams must not be sent + piece-by-piece +- Removed socket I/O work-around for no longer supported GHC versions + on Windows. +- TCP queries now also use EDNS, since the DO bit and other options + may be relevant, even when the UDP buffer size is not. Therefore, + TCP now also does a non-EDNS fallback. +- The resolvEDNS field is subsumed in resolvQueryControls and + removed. The encodeQuestion function changes to no longer take + an explicit "EDNSheader" argument, instead the EDNS record is + built based on the supplied options. Also the encodeQuestions + function has been removed, since we're deprecating it, but the + legacy interface can no longer be maintained. +- New API: lookupRawCtl +- New API: ODataOp, doFlag, ednsEnable, ednsSetVersion, ednsSetSize + and ednsSetOptions make it possible for 'QueryControls' to adjust + EDNS settings. +- New API: FlagOp, rdFlag, adFlag and cdFlag make it possible to + override the default settings of the query-related DNS header + flags. +- Breaking change: the decoded EDNS record no longer contains + an error field. Instead the header of decoded messages is + updated hold the extended error code when valid EDNS OPT records + (EDNS pseudo-headers) are found. The remaining EDNS record + fields have been renamed: + * udpSize -> ednsBufferSize + * dnssecOk -> ednsDnssecOk + * options -> ednsOptions + The reverse process happens on output with the 12-bit header + RCODE split across the wire-form DNS header and the OPT record. + When EDNS is not enabled, and the RCODE > 15, it is mapped to + FormatErr instead. +- Breaking change: The fromRCODEforHeader and toRCODEforHeader + functions have been removed. +- Breaking change: DNSFormat and fromDNSFormat + have been removed. +- The fromDNSMessage function now distinguishes between FormatErr + responses without an OPT record (which signal no EDNS support), + and FormatErr with an OPT record, which signal problems + (malformed or unsupported version) with the OPT record received + in the request. For the latter the 'BadOptRecord' error is + returned. +- Added more RCODEs, including a BadRCODE that is generated + locally, rather than parsed from the message. The value + lies just above the EDNS 12-bit range, with the bottom + 12-bits matching FormatErr. +- Breaking change: The DNSMessage structure now has an + "ednsHeader" field, initialized to "EDNSheader defaultEDNS" + in "defaultQuery" and to "NoEDNS" in "defaultResponse". + The former enables EDNS(0) with default options, the latter + leaves EDNS unconfigured. +- The BadOpt RCODE is renamed to BadVers to better resemble + the term used in RFCs. +- Added EDNS OPTIONS: NSID, DAU, DHU, N3U +- Decoding of the ClientSubnet option is now a total function, + provided the RDATA is structurally sound. Unexpected values + just yield OD\_ECSgeneric results. +- Breaking change: New OD\_ECSgeneric EDNS constructor, represents + ClientSubnet values whose address family is not IP or that violate + the specification. The "family" field distinguishes the two cases. +- The ClientSubnet EDNS option is now encoded correctly even when the + source bits match some trailing all-zero bytes. +- Breaking change: EDNS0 is renamed to EDNS. +- Breaking change: lookupRawAD, composeQuery, composeQueryAD are removed. +- New OP codes: OP\_NOTIFY and OP\_UPDATE. + [#113](https://github.com/kazu-yamamoto/dns/pull/113) + +## 3.0.4 + +- Drop unexpected UDP answers [#112](https://github.com/kazu-yamamoto/dns/pull/112) + +## 3.0.3 + +- Implementing NSEC3PARAM [#109](https://github.com/kazu-yamamoto/dns/pull/109) +- Fixing an example of DNS server. +- Improving DNS decoder [#111](https://github.com/kazu-yamamoto/dns/pull/111) + +## 3.0.2 + +- Supporting conduit 1.3 [#105](https://github.com/kazu-yamamoto/dns/pull/105) +- Supporting GHC 8.4 with semigroup hack. + +## 3.0.1 + +- Supporting GHC 7.8 again. + +## 3.0.0 + +- The version introduces some breaking changes internally. But upper layer APIs in the `Lookup` module remain the same. +- Breaking change: `Network.DNS.Types` is redesigned. `ResourceRecord` is not a sum type anymore. It holds only normal RRs. For EDNS0, a new scheme is implemented. [#63](https://github.com/kazu-yamamoto/dns/issues/63) +- Breaking change: the `Encode` and `Decode` modules use strict ByteString instead of lazy one. [#59](https://github.com/kazu-yamamoto/dns/issues/59) +- Default DNS servers are detected automatically on Windows if `RCFilePath` is used. Use vanilla `defaultResolvConf` on Windows! [#83](https://github.com/kazu-yamamoto/dns/pull/83) +- Multiple DNS servers can be used. You can choose either sequential lookup or concurrent lookup. See `resolvConcurrent`. [#81](https://github.com/kazu-yamamoto/dns/pull/81) +- EDNS0 queries are used by default. [#95](https://github.com/kazu-yamamoto/dns/pull/95) +- `lookupSOA` is defined. [#93](https://github.com/kazu-yamamoto/dns/pull/93) +- Cache mechanism is provided. See `resolvCache`. +- Some constructors such as ANY are added in the `Types` module. +- Some bug fixes and code clean-up. + +## 2.0.13 +- Testing with AppVeyor. +- Detecting a default DNS server on Windows. +- Fixing sendAll on Windows [#72](https://github.com/kazu-yamamoto/dns/pull/72) + +## 2.0.12 +- Fixing Windows build again + +## 2.0.11 +- Fixing the StateBinary.get32 parser [#57](https://github.com/kazu-yamamoto/dns/pull/57) +- Removing bytestring-builder dependency [#61](https://github.com/kazu-yamamoto/dns/pull/61) +- Fixing Windows build [#62](https://github.com/kazu-yamamoto/dns/pull/62) + +## 2.0.10 +- Cleaning up the code. [#47](https://github.com/kazu-yamamoto/dns/pull/47) + +## 2.0.9 +- Implemented TCP fallback after a truncated UDP response. [#46](https://github.com/kazu-yamamoto/dns/pull/46) + +## 2.0.8 +- Better handling of encoding and decoding the "root" domain ".". [#45](https://github.com/kazu-yamamoto/dns/pull/45) + +## 2.0.7 +- Add length checks for A and AAAA records. [#43](https://github.com/kazu-yamamoto/dns/pull/43) + +## 2.0.6 +- Adding Ord instance. [#41](https://github.com/kazu-yamamoto/dns/pull/41) +- Adding DNSSEC-related RRTYPEs [#40](https://github.com/kazu-yamamoto/dns/pull/40) + +## 2.0.5 +- Supporting DNS-SEC AD (authenticated data). [#38](https://github.com/kazu-yamamoto/dns/pull/38) +- Removing the dependency to blaze-builder. + +## 2.0.4 +- Renaming a variable to fix preprocessor conflicts [#37](https://github.com/kazu-yamamoto/dns/pull/37) + +## 2.0.3 +- Handle invalid opcodes gracefully. [#36](https://github.com/kazu-yamamoto/dns/pull/36) + +## 2.0.2 +- Providing a new API: decodeMany. + +## 2.0.1 +- Updating document. + +## 2.0.0 +- DNSMessage is now monomorphic +- RDATA is now monomorphic +- Removed traversal instance for DNSMessage +- EDNS0 encoding/decoding is now supported +- Removed dnsMapWithType and dnsTraverseWithType functions +- responseA and responseAAAA now take lists of IP addresses as their arguments +- DNSHeader type no longer has qdCount, anCount, nsCount, and arCount fields diff --git a/Network/DNS.hs b/Network/DNS.hs --- a/Network/DNS.hs +++ b/Network/DNS.hs @@ -4,41 +4,53 @@ -- convenience. -- Applications will most likely use the high-level interface, while -- library/daemon authors may need to use the lower-level one. --- EDNS0 and TCP fallback are not supported yet. +-- EDNS and TCP fallback are supported. -- +-- Examples: +-- +-- >>> :set -XOverloadedStrings +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> 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 - -- | The "Network.DNS.Lookup" module contains simple functions to + -- | This module contains simple functions to -- perform various DNS lookups. If you simply want to resolve a -- hostname ('lookupA'), or find a domain's MX record -- ('lookupMX'), this is the easiest way to do it. , module Network.DNS.Resolver - -- | The "Network.DNS.Resolver" module is slightly more low-level - -- than "Network.DNS.Lookup". If you need to do something unusual, - -- you may need to use the 'lookup', 'lookupAuth', or 'lookupRaw' - -- functions. + -- | Resolver related data types. + , module Network.DNS.Types + -- | All of the types that the other modules use. + , module Network.DNS.Utils - -- | The "Network.DNS.Utils" module contains utility functions used + -- | This module contains utility functions used -- for processing DNS data. - , module Network.DNS.Types - -- | All of the types that the other modules use. + -- * Middle level + , module Network.DNS.LookupRaw + -- | This provides the 'lookup', 'lookupAuth', 'lookupRaw' and + -- 'lookupRawCtl' functions for any resource records. -- * Low level - , module Network.DNS.Decode - -- | Decoding a response. - , module Network.DNS.Encode - -- | Encoding a query. + -- | Encoding a query or response. - ) where + , module Network.DNS.Decode + -- | Decoding a qurey or response. + , module Network.DNS.IO + -- | Sending and receiving. +) where + +import Network.DNS.Decode +import Network.DNS.Encode +import Network.DNS.IO import Network.DNS.Lookup +import Network.DNS.LookupRaw import Network.DNS.Resolver -import Network.DNS.Utils import Network.DNS.Types -import Network.DNS.Decode -import Network.DNS.Encode +import Network.DNS.Utils diff --git a/Network/DNS/Decode.hs b/Network/DNS/Decode.hs --- a/Network/DNS/Decode.hs +++ b/Network/DNS/Decode.hs @@ -1,315 +1,103 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, CPP #-} - +-- | DNS message decoders. +-- +-- When in doubt, use the 'decodeAt' or 'decodeManyAt' functions, which +-- correctly handle /circle-arithmetic/ DNS timestamps, e.g., in @RRSIG@ +-- resource records. The 'decode', and 'decodeMany' functions are only +-- appropriate in pure contexts when the current time is not available, and +-- @RRSIG@ records are not expected or desired. +-- +-- The 'decodeMany' and 'decodeManyAt' functions decode a buffer holding one or +-- more messages, each preceded by 16-bit length in network byte order. This +-- encoding is generally only appropriate for DNS TCP, and because TCP does not +-- preserve message boundaries, the decode is prepared to return a trailing +-- message fragment to be completed and retried when more input arrives from +-- network. +-- module Network.DNS.Decode ( - decode + -- * Decoding a single DNS message + decodeAt + , decode + -- * Decoding multple length-encoded DNS messages, + -- e.g., from TCP traffic. + , decodeManyAt , decodeMany - , receive - , receiveVC ) where -import Control.Applicative (many) -import Control.Monad (replicateM) -import Control.Monad.Trans.Resource (ResourceT, runResourceT) -import qualified Control.Exception as ControlException -import Data.Bits ((.&.), shiftR, testBit) -import Data.ByteString (ByteString) import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BL -import Data.Conduit (($$), ($$+), ($$+-), (=$), Source) -import Data.Conduit.Network (sourceSocket) -import qualified Data.Conduit.Binary as CB -import Data.IP (IP(..), toIPv4, toIPv6b) -import Data.Typeable (Typeable) -import Data.Word (Word16) -import Network (Socket) -import Network.DNS.Internal -import Network.DNS.StateBinary -import qualified Safe -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -#endif +import Network.DNS.Decode.Parsers +import Network.DNS.Imports +import Network.DNS.StateBinary +import Network.DNS.Types.Internal ---------------------------------------------------------------- +-- | Decode an input buffer containing a single encoded DNS message. If the +-- input buffer has excess content beyond the end of the message an error is +-- returned. DNS /circle-arithmetic/ timestamps (e.g. in RRSIG records) are +-- interpreted at the supplied epoch time. +-- +decodeAt :: Int64 -- ^ current epoch time + -> ByteString -- ^ encoded input buffer + -> Either DNSError DNSMessage -- ^ decoded message or error +decodeAt t bs = fst <$> runSGetAt t (fitSGet (B.length bs) getResponse) bs -data RDATAParseError = RDATAParseError String - deriving (Show, Typeable) +-- | Decode an input buffer containing a single encoded DNS message. If the +-- input buffer has excess content beyond the end of the message an error is +-- returned. DNS /circle-arithmetic/ timestamps (e.g. in RRSIG records) are +-- interpreted based on a nominal time in the year 2073 chosen to maximize +-- the time range for which this gives correct translations of 32-bit epoch +-- times to absolute 64-bit epoch times. This will yield incorrect results +-- starting circa 2141. +-- +decode :: ByteString -- ^ encoded input buffer + -> Either DNSError DNSMessage -- ^ decoded message or error +decode bs = fst <$> runSGet (fitSGet (B.length bs) getResponse) bs -instance ControlException.Exception RDATAParseError +-- | Decode a buffer containing multiple encoded DNS messages each preceded by +-- a 16-bit length in network byte order. Any left-over bytes of a partial +-- message after the last complete message are returned as the second element +-- of the result tuple. DNS /circle-arithmetic/ timestamps (e.g. in RRSIG +-- records) are interpreted at the supplied epoch time. +-- +decodeManyAt :: Int64 -- ^ current epoch time + -> ByteString -- ^ encoded input buffer + -> Either DNSError ([DNSMessage], ByteString) + -- ^ decoded messages and left-over partial message + -- or error if any complete message fails to parse. +decodeManyAt t bs = decodeMParse (decodeAt t) bs +-- | Decode a buffer containing multiple encoded DNS messages each preceded by +-- a 16-bit length in network byte order. Any left-over bytes of a partial +-- message after the last complete message are returned as the second element +-- of the result tuple. DNS /circle-arithmetic/ timestamps (e.g. in RRSIG +-- records) are interpreted based on a nominal time in the year 2078 chosen to +-- give correct dates for DNS timestamps over a 136 year time range from the +-- date the root zone was signed on the 15th of July 2010 until the 21st of +-- August in 2146. Outside this date range the output is off by some non-zero +-- multiple 2\^32 seconds. +-- +decodeMany :: ByteString -- ^ encoded input buffer + -> Either DNSError ([DNSMessage], ByteString) + -- ^ decoded messages and left-over partial message + -- or error if any complete message fails to parse. +decodeMany bs = decodeMParse decode bs --- | Receiving DNS data from 'Socket' and parse it. -receive :: Socket -> IO DNSMessage -receive = receiveDNSFormat . sourceSocket - --- | Receive and parse a single virtual-circuit (TCP) response. It --- is up to the caller to implement any desired timeout. This --- (and the other response decoding functions) may throw ParseError --- when the server response is incomplete or malformed. - -receiveVC :: Socket -> IO DNSMessage -receiveVC sock = runResourceT $ do - (src, lenbytes) <- sourceSocket sock $$+ CB.take 2 - let len = case (map fromIntegral $ BL.unpack lenbytes) of - hi:lo:[] -> 256 * hi + lo - _ -> 0 - src $$+- CB.isolate len =$ sinkSGet decodeResponse >>= return . fst - ----------------------------------------------------------------- - --- | Parsing DNS data. - -decode :: BL.ByteString -> Either String DNSMessage -decode bs = fst <$> runSGet decodeResponse bs - --- | Parse many length-encoded DNS records, for example, from TCP traffic. - -decodeMany :: BL.ByteString -> Either String ([DNSMessage], BL.ByteString) -decodeMany bs = do +-- | Decode multiple messages using the given parser. +-- +decodeMParse :: (ByteString -> Either DNSError DNSMessage) + -- ^ message decoder + -> ByteString + -- ^ enoded input buffer + -> Either DNSError ([DNSMessage], ByteString) + -- ^ decoded messages and left-over partial message + -- or error if any complete message fails to parse. +decodeMParse decoder bs = do ((bss, _), leftovers) <- runSGetWithLeftovers lengthEncoded bs - msgs <- mapM decode bss + msgs <- mapM decoder bss return (msgs, leftovers) where - -- Read a list of length-encoded lazy bytestrings - lengthEncoded :: SGet [BL.ByteString] - lengthEncoded = many $ do - len <- getInt16 - fmap BL.fromStrict (getNByteString len) - ----------------------------------------------------------------- -receiveDNSFormat :: Source (ResourceT IO) ByteString -> IO DNSMessage -receiveDNSFormat src = fst <$> runResourceT (src $$ sink) - where - sink = sinkSGet decodeResponse - ----------------------------------------------------------------- - -decodeResponse :: SGet DNSMessage -decodeResponse = do - (hd,qdCount,anCount,nsCount,arCount) <- decodeHeader - DNSMessage hd <$> decodeQueries qdCount - <*> decodeRRs anCount - <*> decodeRRs nsCount - <*> decodeRRs arCount - ----------------------------------------------------------------- - -decodeFlags :: SGet DNSFlags -decodeFlags = do - word <- get16 - maybe (fail "Unsupported flags") pure (toFlags word) - where - toFlags :: Word16 -> Maybe DNSFlags - toFlags flgs = do - opcode_ <- getOpcode flgs - rcode_ <- getRcode flgs - return $ DNSFlags (getQorR flgs) - opcode_ - (getAuthAnswer flgs) - (getTrunCation flgs) - (getRecDesired flgs) - (getRecAvailable flgs) - rcode_ - (getAuthenData flgs) - getQorR w = if testBit w 15 then QR_Response else QR_Query - getOpcode w = Safe.toEnumMay (fromIntegral (shiftR w 11 .&. 0x0f)) - getAuthAnswer w = testBit w 10 - getTrunCation w = testBit w 9 - getRecDesired w = testBit w 8 - getRecAvailable w = testBit w 7 - getRcode w = Safe.toEnumMay (fromIntegral (w .&. 0x0f)) - getAuthenData w = testBit w 5 - ----------------------------------------------------------------- - -decodeHeader :: SGet (DNSHeader,Int,Int,Int,Int) -decodeHeader = do - hd <- DNSHeader <$> decodeIdentifier - <*> decodeFlags - qdCount <- decodeQdCount - anCount <- decodeAnCount - nsCount <- decodeNsCount - arCount <- decodeArCount - pure (hd - ,qdCount - ,anCount - ,nsCount - ,arCount - ) - where - decodeIdentifier = getInt16 - decodeQdCount = getInt16 - decodeAnCount = getInt16 - decodeNsCount = getInt16 - decodeArCount = getInt16 - ----------------------------------------------------------------- - -decodeQueries :: Int -> SGet [Question] -decodeQueries n = replicateM n decodeQuery - -decodeType :: SGet TYPE -decodeType = intToType <$> getInt16 - -decodeOptType :: SGet OPTTYPE -decodeOptType = intToOptType <$> getInt16 - -decodeQuery :: SGet Question -decodeQuery = Question <$> decodeDomain - <*> decodeType - <* ignoreClass - -decodeRRs :: Int -> SGet [ResourceRecord] -decodeRRs n = replicateM n decodeRR - -decodeRR :: SGet ResourceRecord -decodeRR = do - dom <- decodeDomain - typ <- decodeType - decodeRR' dom typ - where - decodeRR' _ OPT = do - udps <- decodeUDPSize - _ <- decodeERCode - ver <- decodeOPTVer - dok <- decodeDNSOK - len <- decodeRLen - dat <- decodeRData OPT len - return OptRecord { orudpsize = udps - , ordnssecok = dok - , orversion = ver - , rdata = dat - } - - decodeRR' dom t = do - ignoreClass - ttl <- decodeTTL - len <- decodeRLen - dat <- decodeRData t len - return ResourceRecord { rrname = dom - , rrtype = t - , rrttl = ttl - , rdata = dat - } - decodeUDPSize = fromIntegral <$> getInt16 - decodeERCode = getInt8 - decodeOPTVer = fromIntegral <$> getInt8 - decodeDNSOK = flip testBit 15 <$> getInt16 - decodeTTL = fromIntegral <$> get32 - decodeRLen = getInt16 - -decodeRData :: TYPE -> Int -> SGet RData -decodeRData NS _ = RD_NS <$> decodeDomain -decodeRData MX _ = RD_MX <$> decodePreference <*> decodeDomain - where - decodePreference = getInt16 -decodeRData CNAME _ = RD_CNAME <$> decodeDomain -decodeRData DNAME _ = RD_DNAME <$> decodeDomain -decodeRData TXT len = (RD_TXT . ignoreLength) <$> getNByteString len - where - ignoreLength = BS.tail -decodeRData A len - | len == 4 = (RD_A . toIPv4) <$> getNBytes len - | otherwise = fail "IPv4 addresses must be 4 bytes long" -decodeRData AAAA len - | len == 16 = (RD_AAAA . toIPv6b) <$> getNBytes len - | otherwise = fail "IPv6 addresses must be 16 bytes long" -decodeRData SOA _ = RD_SOA <$> decodeDomain - <*> decodeDomain - <*> decodeSerial - <*> decodeRefesh - <*> decodeRetry - <*> decodeExpire - <*> decodeMinumun - where - decodeSerial = getInt32 - decodeRefesh = getInt32 - decodeRetry = getInt32 - decodeExpire = getInt32 - decodeMinumun = getInt32 -decodeRData PTR _ = RD_PTR <$> decodeDomain -decodeRData SRV _ = RD_SRV <$> decodePriority - <*> decodeWeight - <*> decodePort - <*> decodeDomain - where - decodePriority = getInt16 - decodeWeight = getInt16 - decodePort = getInt16 -decodeRData OPT ol = RD_OPT <$> decode' ol - where - decode' :: Int -> SGet [OData] - decode' l - | l < 0 = fail "decodeOPTData: length inconsistency" - | l == 0 = pure [] - | otherwise = do - optCode <- decodeOptType - optLen <- getInt16 - dat <- decodeOData optCode optLen - (dat:) <$> decode' (l - optLen - 4) --- -decodeRData TLSA len = RD_TLSA <$> decodeUsage - <*> decodeSelector - <*> decodeMType - <*> decodeADF - where - decodeUsage = get8 - decodeSelector = get8 - decodeMType = get8 - decodeADF = getNByteString (len - 3) -decodeRData _ len = RD_OTH <$> getNByteString len - -decodeOData :: OPTTYPE -> Int -> SGet OData -decodeOData ClientSubnet len = do - fam <- getInt16 - srcMask <- getInt8 - scpMask <- getInt8 - rawip <- fmap fromIntegral . B.unpack <$> getNByteString (len - 4) -- 4 = 2 + 1 + 1 - ip <- case fam of - 1 -> pure . IPv4 . toIPv4 $ take 4 (rawip ++ repeat 0) - 2 -> pure . IPv6 . toIPv6b $ take 16 (rawip ++ repeat 0) - _ -> fail "Unsupported address family" - pure $ OD_ClientSubnet srcMask scpMask ip -decodeOData (OUNKNOWN i) len = OD_Unknown i <$> getNByteString len - ----------------------------------------------------------------- - -decodeDomain :: SGet Domain -decodeDomain = do - pos <- getPosition - c <- getInt8 - let n = getValue c - -- Syntax hack to avoid using MultiWayIf - case () of - _ | c == 0 -> return "." -- Perhaps the root domain? - _ | isPointer c -> do - d <- getInt8 - let offset = n * 256 + d - mo <- pop offset - case mo of - Nothing -> fail $ "decodeDomain: " ++ show offset - -- A pointer may refer to another pointer. - -- So, register this position for the domain. - 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 <- getNByteString n - ds <- decodeDomain - let dom = - case ds of -- avoid trailing ".." - "." -> hs `BS.append` "." - _ -> hs `BS.append` "." `BS.append` ds - push pos dom - return dom - where - getValue c = c .&. 0x3f - isPointer c = testBit c 7 && testBit c 6 - isExtLabel c = (not $ testBit c 7) && testBit c 6 - -ignoreClass :: SGet () -ignoreClass = () <$ get16 + -- Read a list of length-encoded bytestrings + lengthEncoded :: SGet [ByteString] + lengthEncoded = many $ getInt16 >>= getNByteString diff --git a/Network/DNS/Encode.hs b/Network/DNS/Encode.hs --- a/Network/DNS/Encode.hs +++ b/Network/DNS/Encode.hs @@ -1,233 +1,34 @@ -{-# LANGUAGE RecordWildCards, CPP #-} - +-- | DNS message encoder. +-- +-- Note: 'Nework.DNS' is a client library, and its focus is on /sending/ +-- /queries/, and /receiving/ /replies/. Thefore, while this module is +-- reasonably adept at query generation, building a DNS server with this +-- module requires additional work to handle message size limits, correct UDP +-- truncation, proper EDNS negotiation, and so on. Support for server-side DNS +-- is at best rudimentary. +-- +-- For sending queries, in most cases you should be using one of the functions +-- from 'Network.DNS.Lookup' and 'Network.DNS.LookupRaw', or lastly, if you +-- want to handle the network reads and writes for yourself (with your own code +-- for UDP retries, TCP fallback, EDNS fallback, ...), then perhaps +-- 'Network.DNS.IO.encodeQuestion' (letting 'Network.DNS' do the lookups for +-- you in an @async@ thread is likely much simpler). +-- module Network.DNS.Encode ( + -- * Encode a DNS query (or response). encode - , encodeVC - , composeQuery - , composeQueryAD ) where -import Control.Monad (when) -import Control.Monad.State (State, modify, execState, gets) -import Data.Binary (Word16) -import Data.Bits ((.|.), bit, shiftL, setBit) -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BL -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.IP (IP(..),fromIPv4, fromIPv6b) -import Data.List (dropWhileEnd) -import Data.Monoid ((<>)) -import Network.DNS.Internal +import Network.DNS.Imports import Network.DNS.StateBinary - -#if __GLASGOW_HASKELL__ < 709 -import Data.Monoid (mconcat) -#endif - ----------------------------------------------------------------- - --- | Composing query. First argument is a number to identify response. - -composeQuery :: Int -> [Question] -> ByteString -composeQuery idt qs = encode qry - where - hdr = header defaultQuery - qry = defaultQuery { - header = hdr { - identifier = idt - } - , question = qs - } - -composeQueryAD :: Int -> [Question] -> ByteString -composeQueryAD idt qs = encode qry - where - hdr = header defaultQuery - flg = flags hdr - qry = defaultQuery { - header = hdr { - identifier = idt, - flags = flg { - authenData = True - } - } - , question = qs - } - ----------------------------------------------------------------- - --- | Composing DNS data. +import Network.DNS.Types.Internal +import Network.DNS.Encode.Builders +-- | Encode a 'DNSMessage' for transmission over UDP. For transmission over +-- TCP encapsulate the result via 'Network.DNS.IO.encodeVC', or use +-- 'Network.DNS.IO.sendVC', which handles this internally. If any +-- 'ResourceRecord' in the message contains incorrectly encoded 'Domain' name +-- ByteStrings, this function may raise a 'DecodeError'. +-- encode :: DNSMessage -> ByteString -encode msg = runSPut (encodeDNSMessage msg) - -encodeVC :: ByteString -> ByteString -encodeVC query = - let len = BB.toLazyByteString $ BB.int16BE $ fromIntegral $ BL.length query - in len <> query - ----------------------------------------------------------------- - -encodeDNSMessage :: DNSMessage -> SPut -encodeDNSMessage msg = encodeHeader hdr - <> encodeNums - <> mconcat (map encodeQuestion qs) - <> mconcat (map encodeRR an) - <> mconcat (map encodeRR au) - <> mconcat (map encodeRR ad) - where - encodeNums = mconcat $ fmap putInt16 [length qs - ,length an - ,length au - ,length ad - ] - hdr = header msg - qs = question msg - an = answer msg - au = authority msg - ad = additional msg - -encodeHeader :: DNSHeader -> SPut -encodeHeader hdr = encodeIdentifier (identifier hdr) - <> encodeFlags (flags hdr) - where - encodeIdentifier = putInt16 - -encodeFlags :: DNSFlags -> SPut -encodeFlags DNSFlags{..} = put16 word - where - word16 :: Enum a => a -> Word16 - word16 = toEnum . fromEnum - - set :: Word16 -> State Word16 () - set byte = modify (.|. byte) - - st :: State Word16 () - st = sequence_ - [ set (word16 rcode) - , 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 (word16 opcode `shiftL` 11) - , when (qOrR==QR_Response) $ set (bit 15) - ] - - word = execState st 0 - -encodeQuestion :: Question -> SPut -encodeQuestion Question{..} = encodeDomain qname - <> putInt16 (typeToInt qtype) - <> put16 1 - -putRData :: RData -> SPut -putRData rd = do - addPositionW 2 -- "simulate" putInt16 - rDataBuilder <- encodeRDATA rd - -- fixmed: SPut must hold length - let rdataLength = fromIntegral . BL.length . BB.toLazyByteString $ rDataBuilder - let rlenBuilder = BB.int16BE rdataLength - return rlenBuilder <> return rDataBuilder - -encodeRR :: ResourceRecord -> SPut -encodeRR ResourceRecord{..} = mconcat [ encodeDomain rrname - , putInt16 (typeToInt rrtype) - , put16 1 - , putInt32 rrttl - , putRData rdata - ] - -encodeRR OptRecord{..} = mconcat [ encodeDomain BS.empty - , putInt16 (typeToInt OPT) - , putInt16 orudpsize - , putInt32 $ if ordnssecok - then setBit 0 15 - else 0 - , putRData rdata - ] - -encodeRDATA :: RData -> SPut -encodeRDATA rd = case rd of - (RD_A ip) -> mconcat $ map putInt8 (fromIPv4 ip) - (RD_AAAA ip) -> mconcat $ map putInt8 (fromIPv6b ip) - (RD_NS dom) -> encodeDomain dom - (RD_CNAME dom) -> encodeDomain dom - (RD_DNAME dom) -> encodeDomain dom - (RD_PTR dom) -> encodeDomain dom - (RD_MX prf dom) -> mconcat [putInt16 prf, encodeDomain dom] - (RD_TXT txt) -> putByteStringWithLength txt - (RD_OTH bytes) -> putByteString bytes - (RD_OPT opts) -> mconcat $ fmap encodeOData opts - (RD_SOA d1 d2 serial refresh retry expire min') -> mconcat - [ encodeDomain d1 - , encodeDomain d2 - , putInt32 serial - , putInt32 refresh - , putInt32 retry - , putInt32 expire - , putInt32 min' - ] - (RD_SRV prio weight port dom) -> mconcat - [ putInt16 prio - , putInt16 weight - , putInt16 port - , encodeDomain dom - ] - (RD_TLSA u s m d) -> mconcat - [ put8 u - , put8 s - , put8 m - , putByteString d - ] - -encodeOData :: OData -> SPut -encodeOData (OD_ClientSubnet srcNet scpNet ip) = let dropZeroes = dropWhileEnd (==0) - (fam,raw) = case ip of - IPv4 ip4 -> (1,dropZeroes $ fromIPv4 ip4) - IPv6 ip6 -> (2,dropZeroes $ fromIPv6b ip6) - dataLen = 2 + 2 + length raw - in mconcat [putInt16 (optTypeToInt ClientSubnet) - ,putInt16 dataLen - ,putInt16 fam - ,putInt8 srcNet - ,putInt8 scpNet - ,mconcat $ fmap putInt8 raw - ] -encodeOData (OD_Unknown code bs) = mconcat [putInt16 code - ,putInt16 $ BS.length bs - ,putByteString bs - ] - --- In the case of the TXT record, we need to put the string length -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 "." - -encodeDomain :: Domain -> SPut -encodeDomain dom - | (BS.null dom || dom == rootDomain) = put8 0 - | otherwise = do - mpos <- wsPop dom - cur <- gets wsPosition - case mpos of - Just pos -> encodePointer pos - Nothing -> wsPush dom cur >> - mconcat [ encodePartialDomain hd - , encodeDomain tl - ] - where - (hd, tl') = BS.break (=='.') dom - tl = if BS.null tl' then tl' else BS.drop 1 tl' - -encodePointer :: Int -> SPut -encodePointer pos = putInt16 (pos .|. 0xc000) - -encodePartialDomain :: Domain -> SPut -encodePartialDomain = putByteStringWithLength +encode = runSPut . putDNSMessage diff --git a/Network/DNS/IO.hs b/Network/DNS/IO.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/IO.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.DNS.IO ( + -- * Receiving DNS messages + receive + , receiveFrom + , receiveVC + -- * Sending pre-encoded messages + , send + , sendTo + , sendVC + , sendAll + -- ** Encoding queries for transmission + , encodeQuestion + , encodeVC + -- ** Creating query response messages + , responseA + , responseAAAA + ) where + +import qualified Control.Exception as E +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.IP (IPv4, IPv6) +import Time.System (timeCurrent) +import Time.Types (Elapsed(..), Seconds(..)) +import Network.Socket (Socket, SockAddr) +import Network.Socket.ByteString (recv, recvFrom) +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.Internal + +---------------------------------------------------------------- + +-- | Receive and decode a single 'DNSMessage' from a UDP 'Socket', throwing away +-- the client address. Messages longer than 'maxUdpSize' are silently +-- truncated, but this should not occur in practice, since we cap the advertised +-- EDNS UDP buffer size limit at the same value. A 'DNSError' is raised if I/O +-- or message decoding fails. +-- +receive :: Socket -> IO DNSMessage +receive sock = do + let bufsiz = fromIntegral maxUdpSize + bs <- recv sock bufsiz `E.catch` \e -> E.throwIO $ NetworkFailure e + Elapsed (Seconds now) <- timeCurrent + case decodeAt now bs of + Left e -> E.throwIO e + Right msg -> return msg + +-- | Receive and decode a single 'DNSMessage' from a UDP 'Socket'. Messages +-- longer than 'maxUdpSize' are silently truncated, but this should not occur +-- in practice, since we cap the advertised EDNS UDP buffer size limit at the +-- same value. A 'DNSError' is raised if I/O or message decoding fails. +-- +receiveFrom :: Socket -> IO (DNSMessage, SockAddr) +receiveFrom sock = do + let bufsiz = fromIntegral maxUdpSize + (bs, client) <- recvFrom sock bufsiz `E.catch` \e -> E.throwIO $ NetworkFailure e + Elapsed (Seconds now) <- timeCurrent + case decodeAt now bs of + Left e -> E.throwIO e + Right msg -> return (msg, client) + +-- | Receive and decode a single 'DNSMesage' from a virtual-circuit (TCP). It +-- is up to the caller to implement any desired timeout. An 'DNSError' is +-- raised if I/O or message decoding fails. +-- +receiveVC :: Socket -> IO DNSMessage +receiveVC sock = do + len <- toLen <$> recvDNS sock 2 + bs <- recvDNS sock len + Elapsed (Seconds now) <- timeCurrent + case decodeAt now bs of + Left e -> E.throwIO e + Right msg -> return msg + where + toLen bs = case B.unpack bs of + [hi, lo] -> 256 * (fromIntegral hi) + (fromIntegral lo) + _ -> 0 -- never reached + +recvDNS :: Socket -> Int -> IO ByteString +recvDNS sock len = recv1 `E.catch` \e -> E.throwIO $ NetworkFailure e + where + recv1 = do + bs1 <- recvCore len + if BS.length bs1 == len then + return bs1 + else do + loop bs1 + loop bs0 = do + let left = len - BS.length bs0 + bs1 <- recvCore left + let bs = bs0 `BS.append` bs1 + if BS.length bs == len then + return bs + else + loop bs + eofE = mkIOError eofErrorType "connection terminated" Nothing Nothing + recvCore len0 = do + bs <- recv sock len0 + if bs == "" then + E.throwIO eofE + else + return bs + +---------------------------------------------------------------- + +-- | Send an encoded 'DNSMessage' datagram over UDP. The message length is +-- implicit in the size of the UDP datagram. With TCP you must use 'sendVC', +-- because TCP does not have message boundaries, and each message needs to be +-- prepended with an explicit length. The socket must be explicitly connected +-- to the destination nameserver. +-- +send :: Socket -> ByteString -> IO () +send = (void .). Socket.send +{-# INLINE send #-} + +-- | Send an encoded 'DNSMessage' datagram over UDP to a given address. The +-- message length is implicit in the size of the UDP datagram. With TCP you +-- must use 'sendVC', because TCP does not have message boundaries, and each +-- message needs to be prepended with an explicit length. +-- +sendTo :: Socket -> ByteString -> SockAddr -> IO () +sendTo sock str addr = Socket.sendTo sock str addr >> return () +{-# INLINE sendTo #-} + +-- | Send a single encoded 'DNSMessage' over TCP. An explicit length is +-- prepended to the encoded buffer before transmission. If you want to +-- send a batch of multiple encoded messages back-to-back over a single +-- TCP connection, and then loop to collect the results, use 'encodeVC' +-- to prefix each message with a length, and then use 'sendAll' to send +-- a concatenated batch of the resulting encapsulated messages. +-- +sendVC :: Socket -> ByteString -> IO () +sendVC = (. encodeVC). sendAll +{-# INLINE sendVC #-} + +-- | Send one or more encoded 'DNSMessage' buffers over TCP, each allready +-- encapsulated with an explicit length prefix (perhaps via 'encodeVC') and +-- then concatenated into a single buffer. DO NOT use 'sendAll' with UDP. +-- +sendAll :: Socket -> BS.ByteString -> IO () +sendAll = Socket.sendAll +{-# INLINE sendAll #-} + +-- | The encoded 'DNSMessage' has the specified request ID. The default values +-- of the RD, AD, CD and DO flag bits, as well as various EDNS features, can be +-- adjusted via the 'QueryControls' parameter. +-- +-- The caller is responsible for generating the ID via a securely seeded +-- CSPRNG. +-- +encodeQuestion :: Identifier -- ^ Crypto random request id + -> Question -- ^ Query name and type + -> QueryControls -- ^ Query flag and EDNS overrides + -> ByteString +encodeQuestion idt q ctls = encode $ makeQuery idt q ctls + +-- | Encapsulate an encoded 'DNSMessage' buffer for transmission over a TCP +-- virtual circuit. With TCP the buffer needs to start with an explicit +-- length (the length is implicit with UDP). +-- +encodeVC :: ByteString -> ByteString +encodeVC legacyQuery = + let len = LBS.toStrict . BB.toLazyByteString $ BB.int16BE $ fromIntegral $ BS.length legacyQuery + in len <> legacyQuery +{-# INLINE encodeVC #-} + +---------------------------------------------------------------- + +-- | Compose a response with a single IPv4 RRset. If the query +-- had an EDNS pseudo-header, a suitable EDNS pseudo-header must +-- be added to the response message, or else a 'FormatErr' response +-- must be sent. The response TTL defaults to 300 seconds, and +-- should be updated (to the same value across all the RRs) if some +-- other TTL value is more appropriate. +-- +responseA :: Identifier -> Question -> [IPv4] -> DNSMessage +responseA idt q ips = makeResponse idt q as + where + dom = qname q + as = ResourceRecord dom A classIN 300 . RD_A <$> ips + +-- | Compose a response with a single IPv6 RRset. If the query +-- had an EDNS pseudo-header, a suitable EDNS pseudo-header must +-- be added to the response message, or else a 'FormatErr' response +-- must be sent. The response TTL defaults to 300 seconds, and +-- should be updated (to the same value across all the RRs) if some +-- other TTL value is more appropriate. +-- +responseAAAA :: Identifier -> Question -> [IPv6] -> DNSMessage +responseAAAA idt q ips = makeResponse idt q as + where + dom = qname q + as = ResourceRecord dom AAAA classIN 300 . RD_AAAA <$> ips diff --git a/Network/DNS/Internal.hs b/Network/DNS/Internal.hs deleted file mode 100644 --- a/Network/DNS/Internal.hs +++ /dev/null @@ -1,315 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Network.DNS.Internal where - -import Control.Exception (Exception) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Builder as L -import qualified Data.ByteString.Lazy as L -import Data.IP (IP, IPv4, IPv6) -import Data.Maybe (fromMaybe) -import Data.Typeable (Typeable) -import Data.Word (Word8) - ----------------------------------------------------------------- - --- | Type for domain. -type Domain = ByteString - --- | Return type of composeQuery from Encode, needed in Resolver -type Query = L.ByteString - ----------------------------------------------------------------- - --- | Types for resource records. -data TYPE = A - | AAAA - | NS - | TXT - | MX - | CNAME - | SOA - | PTR - | SRV - | DNAME - | OPT - | DS - | RRSIG - | NSEC - | DNSKEY - | NSEC3 - | NSEC3PARAM - | TLSA - | CDS - | CDNSKEY - | CSYNC - | UNKNOWN Int deriving (Eq, Show, Read) - --- https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-4 --- -rrDB :: [(TYPE, Int)] -rrDB = [ - (A, 1) - , (NS, 2) - , (CNAME, 5) - , (SOA, 6) - , (PTR, 12) - , (MX, 15) - , (TXT, 16) - , (AAAA, 28) - , (SRV, 33) - , (DNAME, 39) -- RFC 6672 - , (OPT, 41) -- RFC 6891 - , (DS, 43) -- RFC 4034 - , (RRSIG, 46) -- RFC 4034 - , (NSEC, 47) -- RFC 4034 - , (DNSKEY, 48) -- RFC 4034 - , (NSEC3, 40) -- RFC 5155 - , (NSEC3PARAM, 51) -- RFC 5155 - , (TLSA, 52) -- RFC 6698 - , (CDS, 59) -- RFC 7344 - , (CDNSKEY, 60) -- RFC 7344 - , (CSYNC, 62) -- RFC 7477 - ] - -data OPTTYPE = ClientSubnet - | OUNKNOWN Int - deriving (Eq) - -orDB :: [(OPTTYPE, Int)] -orDB = [ - (ClientSubnet, 8) - ] - -rookup :: (Eq b) => b -> [(a,b)] -> Maybe a -rookup _ [] = Nothing -rookup key ((x,y):xys) - | key == y = Just x - | otherwise = rookup key xys - -intToType :: Int -> TYPE -intToType n = fromMaybe (UNKNOWN n) $ rookup n rrDB -typeToInt :: TYPE -> Int -typeToInt (UNKNOWN x) = x -typeToInt t = fromMaybe (error "typeToInt") $ lookup t rrDB - -intToOptType :: Int -> OPTTYPE -intToOptType n = fromMaybe (OUNKNOWN n) $ rookup n orDB -optTypeToInt :: OPTTYPE -> Int -optTypeToInt (OUNKNOWN x) = x -optTypeToInt t = fromMaybe (error "optTypeToInt") $ lookup t orDB - ----------------------------------------------------------------- - --- | 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 number of retries for the request was exceeded. - | RetryLimitExceeded - -- | The request simply 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 detected a malformed OPT RR. - | BadOptRecord - deriving (Eq, Show, Typeable) - -instance Exception DNSError - --- | Raw data format for DNS Query and Response. -data DNSMessage = DNSMessage { - header :: DNSHeader - , question :: [Question] - , answer :: [ResourceRecord] - , authority :: [ResourceRecord] - , additional :: [ResourceRecord] - } deriving (Eq, Show) - --- | For backward compatibility. -type DNSFormat = DNSMessage - --- | Raw data format for the header of DNS Query and Response. -data DNSHeader = DNSHeader { - identifier :: Int - , flags :: DNSFlags - } deriving (Eq, Show) - --- | Raw data format for the flags of DNS Query and Response. -data DNSFlags = DNSFlags { - qOrR :: QorR - , opcode :: OPCODE - , authAnswer :: Bool - , trunCation :: Bool - , recDesired :: Bool - , recAvailable :: Bool - , rcode :: RCODE - , authenData :: Bool - } deriving (Eq, Show) - ----------------------------------------------------------------- - -data QorR = QR_Query | QR_Response deriving (Eq, Show) - -data OPCODE - = OP_STD - | OP_INV - | OP_SSR - deriving (Eq, Show, Enum, Bounded) - -data RCODE - = NoErr - | FormatErr - | ServFail - | NameErr - | NotImpl - | Refused - | BadOpt - deriving (Eq, Ord, Show, Enum, Bounded) - ----------------------------------------------------------------- - --- | Raw data format for DNS questions. -data Question = Question { - qname :: Domain - , qtype :: TYPE - } deriving (Eq, Show) - --- | Making "Question". -makeQuestion :: Domain -> TYPE -> Question -makeQuestion = Question - ----------------------------------------------------------------- - --- | Raw data format for resource records. -data ResourceRecord = ResourceRecord { - rrname :: Domain - , rrtype :: TYPE - , rrttl :: Int - , rdata :: RData - } - | OptRecord { - orudpsize :: Int - , ordnssecok :: Bool - , orversion :: Int - , rdata :: RData - } - deriving (Eq,Show) - --- | Raw data format for each type. -data RData = RD_NS Domain - | RD_CNAME Domain - | RD_DNAME Domain - | RD_MX Int Domain - | RD_PTR Domain - | RD_SOA Domain Domain Int Int Int Int Int - | RD_A IPv4 - | RD_AAAA IPv6 - | RD_TXT ByteString - | RD_SRV Int Int Int Domain - | RD_OPT [OData] - | RD_OTH ByteString - | RD_TLSA Word8 Word8 Word8 ByteString - deriving (Eq, Ord) - -instance Show RData where - show (RD_NS dom) = BS.unpack dom - show (RD_MX prf dom) = show prf ++ " " ++ BS.unpack dom - show (RD_CNAME dom) = BS.unpack dom - show (RD_DNAME dom) = BS.unpack dom - show (RD_A a) = show a - show (RD_AAAA aaaa) = show aaaa - show (RD_TXT txt) = BS.unpack txt - show (RD_SOA mn _ _ _ _ _ mi) = BS.unpack mn ++ " " ++ show mi - show (RD_PTR dom) = BS.unpack dom - show (RD_SRV pri wei prt dom) = show pri ++ " " ++ show wei ++ " " ++ show prt ++ BS.unpack dom - show (RD_OPT od) = show od - show (RD_OTH is) = show is - show (RD_TLSA use sel mtype dgst) = show use ++ " " ++ show sel ++ " " ++ show mtype ++ " " ++ (BS.unpack $ L.toStrict . L.toLazyByteString . L.byteStringHex $ dgst) - - -data OData = OD_ClientSubnet Int Int IP - | OD_Unknown Int ByteString - deriving (Eq,Show,Ord) - ----------------------------------------------------------------- - -defaultQuery :: DNSMessage -defaultQuery = DNSMessage { - header = DNSHeader { - identifier = 0 - , flags = DNSFlags { - qOrR = QR_Query - , opcode = OP_STD - , authAnswer = False - , trunCation = False - , recDesired = True - , recAvailable = False - , rcode = NoErr - , authenData = False - } - } - , question = [] - , answer = [] - , authority = [] - , additional = [] - } - -defaultResponse :: DNSMessage -defaultResponse = - let hd = header defaultQuery - flg = flags hd - in defaultQuery { - header = hd { - flags = flg { - qOrR = QR_Response - , authAnswer = True - , recAvailable = True - , authenData = False - } - } - } - -responseA :: Int -> Question -> [IPv4] -> DNSMessage -responseA ident q ips = - let hd = header defaultResponse - dom = qname q - an = fmap (ResourceRecord dom A 300 . RD_A) ips - in defaultResponse { - header = hd { identifier=ident } - , question = [q] - , answer = an - } - -responseAAAA :: Int -> Question -> [IPv6] -> DNSMessage -responseAAAA ident q ips = - let hd = header defaultResponse - dom = qname q - an = fmap (ResourceRecord dom AAAA 300 . RD_AAAA) ips - in defaultResponse { - header = hd { identifier=ident } - , question = [q] - , answer = an - } diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs --- a/Network/DNS/Lookup.hs +++ b/Network/DNS/Lookup.hs @@ -1,13 +1,13 @@ --- | Simple, high-level DNS lookup functions. +-- | Simple, high-level DNS lookup functions for clients. -- --- All of the lookup functions necessary run in IO, since they +-- All of the lookup functions necessary run in IO since they -- interact with the network. The return types are similar, but -- differ in what can be returned from a successful lookup. -- --- We can think of the return type as \"either what I asked for, or --- an error\". For example, the 'lookupA' function, if successful, +-- We can think of the return type as either \"what I asked for\" or +-- \"an error\". For example, the 'lookupA' function, if successful, -- will return a list of 'IPv4'. The 'lookupMX' function will --- instead return a list of @('Domain',Int)@ pairs, where each pair +-- instead return a list of @('Domain','Int')@ pairs, where each pair -- represents a hostname and its associated priority. -- -- The order of multiple results may not be consistent between @@ -41,59 +41,64 @@ -- by creating and utilizing a 'ResolvConf' which has a timeout of -- one millisecond and a very limited number of retries: -- --- >>> let hostname = Data.ByteString.Char8.pack "www.example.com" --- >>> let badrc = defaultResolvConf { resolvTimeout = 1, resolvRetry = 1 } +-- >>> let hostname2 = Data.ByteString.Char8.pack "www.example.com" +-- >>> let badrc = defaultResolvConf { resolvTimeout = 0, resolvRetry = 1 } -- >>> --- >>> rs <- makeResolvSeed badrc --- >>> withResolver rs $ \resolver -> lookupA resolver hostname +-- >>> rs2 <- makeResolvSeed badrc +-- >>> withResolver rs2 $ \resolver -> lookupA resolver hostname2 -- Left RetryLimitExceeded -- -- As is the convention, successful results will always be wrapped --- in a 'Right', while errors will be wrapped in a 'Left'. +-- in a 'Right' while errors will be wrapped in a 'Left'. -- --- For convenience, you may wish to enable GHC's OverloadedStrings +-- For convenience, you may wish to enable GHC\'s OverloadedStrings -- extension. This will allow you to avoid calling -- 'Data.ByteString.Char8.pack' on each domain name. See --- --- for more information. +-- +-- for more information. In the following examples, +-- we assuem this extension is enabled. -- +-- All lookup functions eventually call 'lookupRaw'. See its documentation +-- to understand the concrete lookup behavior. module Network.DNS.Lookup ( lookupA, lookupAAAA , lookupMX, lookupAviaMX, lookupAAAAviaMX , lookupNS , lookupNSAuth , lookupTXT + , lookupSOA , lookupPTR , lookupRDNS , lookupSRV ) where -import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.IP (IPv4, IPv6) + +import Network.DNS.Imports +import Network.DNS.LookupRaw as DNS import Network.DNS.Resolver as DNS -import Network.DNS.Types +import Network.DNS.Types.Internal +-- $setup +-- >>> :set -XOverloadedStrings + ---------------------------------------------------------------- -- | Look up all \'A\' records for the given hostname. -- -- A straightforward example: -- --- >>> let hostname = Data.ByteString.Char8.pack "www.mew.org" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupA resolver hostname --- 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: -- --- >>> let hostname = Data.ByteString.Char8.pack "www.kame.net" --- >>> --- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupA resolver hostname --- Right [203.178.141.194] +-- >>> rs2 <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs2 $ \resolver -> lookupA resolver "www.kame.net" +-- Right [210.155.141.200] -- lookupA :: Resolver -> Domain -> IO (Either DNSError [IPv4]) lookupA rlv dom = do @@ -112,11 +117,9 @@ -- -- Examples: -- --- >>> let hostname = Data.ByteString.Char8.pack "www.wide.ad.jp" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupAAAA resolver hostname --- Right [2001:200:dff:fff1:216:3eff:fe4b:651c] +-- >>> withResolver rs $ \resolver -> lookupAAAA resolver "www.wide.ad.jp" +-- Right [2001:200:0:180c:20c:29ff:fec9:9d61] -- lookupAAAA :: Resolver -> Domain -> IO (Either DNSError [IPv6]) lookupAAAA rlv dom = do @@ -136,28 +139,31 @@ -- 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). -- --- >>> let hostname = Data.ByteString.Char8.pack "example.com" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupMX resolver hostname --- Right [] +-- >>> withResolver rs $ \resolver -> lookupMX resolver "example.com" +-- Right [(".",0)] -- +-- -- The domain \"mew.org\" does however have a single MX: -- --- >>> let hostname = Data.ByteString.Char8.pack "mew.org" --- >>> --- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupMX resolver hostname +-- >>> rs2 <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs2 $ \resolver -> lookupMX resolver "mew.org" -- Right [("mail.mew.org.",10)] -- -- 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. +-- +-- >>> rs3 <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs3 $ \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 @@ -167,7 +173,7 @@ Right rds -> return $ mapM unTag rds where unTag :: RData -> Either DNSError (Domain,Int) - unTag (RD_MX pr dm) = Right (dm,pr) + unTag (RD_MX pr dm) = Right (dm, fromIntegral pr) unTag _ = Left UnexpectedRDATA -- | Look up all \'MX\' records for the given hostname, and then @@ -177,12 +183,10 @@ -- Examples: -- -- >>> import Data.List (sort) --- >>> let hostname = Data.ByteString.Char8.pack "wide.ad.jp" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> ips <- withResolver rs $ \resolver -> lookupAviaMX resolver hostname +-- >>> ips <- withResolver rs $ \resolver -> lookupAviaMX resolver "wide.ad.jp" -- >>> fmap sort ips --- Right [133.138.10.39,203.178.136.30] +-- Right [203.178.136.30] -- -- Since there is more than one result, it is necessary to sort the -- list in order to check for equality. @@ -253,10 +257,8 @@ -- Examples: -- -- >>> import Data.List (sort) --- >>> let hostname = Data.ByteString.Char8.pack "mew.org" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> ns <- withResolver rs $ \resolver -> lookupNS resolver hostname +-- >>> ns <- withResolver rs $ \resolver -> lookupNS resolver "mew.org" -- >>> fmap sort ns -- Right ["ns1.mew.org.","ns2.mew.org."] -- @@ -277,12 +279,10 @@ -- the IP address of which was found beforehand: -- -- >>> import Data.List (sort) --- >>> let hostname = Data.ByteString.Char8.pack "example.com" --- >>> -- >>> let ri = RCHostName "192.5.6.30" -- a.gtld-servers.net -- >>> let rc = defaultResolvConf { resolvInfo = ri } -- >>> rs <- makeResolvSeed rc --- >>> ns <- withResolver rs $ \resolver -> lookupNSAuth resolver hostname +-- >>> ns <- withResolver rs $ \resolver -> lookupNSAuth resolver "example.com" -- >>> fmap sort ns -- Right ["a.iana-servers.net.","b.iana-servers.net."] -- @@ -300,10 +300,8 @@ -- . As an -- example, we find the SPF record for \"mew.org\": -- --- >>> let hostname = Data.ByteString.Char8.pack "mew.org" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupTXT resolver hostname +-- >>> withResolver rs $ \resolver -> lookupTXT resolver "mew.org" -- Right ["v=spf1 +mx -all"] -- lookupTXT :: Resolver -> Domain -> IO (Either DNSError [ByteString]) @@ -320,6 +318,36 @@ ---------------------------------------------------------------- +-- | Look up the \'SOA\' record for the given domain. The result 7-tuple +-- consists of the \'mname\', \'rname\', \'serial\', \'refresh\', \'retry\', +-- \'expire\' and \'minimum\' fields of the SOA record. +-- +-- An \@ separator is used between the first and second labels of the +-- \'rname\' field. Since \'rname\' is an email address, it often contains +-- periods within its first label. Presently, the trailing period is not +-- removed from the domain part of the \'rname\', but this may change in the +-- future. Users should be prepared to remove any trailing period before +-- using the \'rname\` as a contact email address. +-- +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> 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 + erds <- DNS.lookup rlv dom SOA + case erds of + -- See lookupXviaMX for an explanation of this construct. + Left err -> return (Left err) + Right rds -> return $ mapM unTag rds + where + unTag :: RData -> Either DNSError (Domain,Mailbox,Word32,Word32,Word32,Word32,Word32) + unTag (RD_SOA mn mr serial refresh retry expire mini) = Right (mn, mr, serial, refresh, retry, expire, mini) + unTag _ = Left UnexpectedRDATA + +---------------------------------------------------------------- + -- | Look up all \'PTR\' records for the given hostname. To perform a -- reverse lookup on an IP address, you must first reverse its -- octets and then append the suffix \".in-addr.arpa.\" @@ -327,10 +355,8 @@ -- We look up the PTR associated with the IP address -- 210.130.137.80, i.e., 80.137.130.210.in-addr.arpa: -- --- >>> let hostname = Data.ByteString.Char8.pack "164.2.232.202.in-addr.arpa" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupPTR resolver hostname +-- >>> withResolver rs $ \resolver -> lookupPTR resolver "180.2.232.202.in-addr.arpa" -- Right ["www.iij.ad.jp."] -- -- The 'lookupRDNS' function is more suited to this particular task. @@ -354,10 +380,8 @@ -- We repeat the example from 'lookupPTR', except now we pass the IP -- address directly: -- --- >>> let hostname = Data.ByteString.Char8.pack "202.232.2.164" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupRDNS resolver hostname +-- >>> withResolver rs $ \resolver -> lookupRDNS resolver "202.232.2.180" -- Right ["www.iij.ad.jp."] -- lookupRDNS :: Resolver -> Domain -> IO (Either DNSError [Domain]) @@ -392,11 +416,9 @@ -- -- Examples: -- --- >>> let q = Data.ByteString.Char8.pack "_xmpp-server._tcp.jabber.ietf.org" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupSRV resolver q --- Right [(5,0,5269,"jabber.ietf.org.")] +-- >>> withResolver rs $ \resolver -> lookupSRV resolver "_xmpp-server._tcp.jabber.ietf.org" +-- Right [(5,0,5269,"_dc-srv.6661af51975d._xmpp-server._tcp.jabber.ietf.org.")] -- Though the "jabber.ietf.orgs" SRV record may prove reasonably stable, as -- with anything else published in DNS it is subject to change. Also, this @@ -404,7 +426,7 @@ -- example should be displayed in a format that is not recognized as a test -- by "doctest". -lookupSRV :: Resolver -> Domain -> IO (Either DNSError [(Int,Int,Int,Domain)]) +lookupSRV :: Resolver -> Domain -> IO (Either DNSError [(Word16, Word16, Word16, Domain)]) lookupSRV rlv dom = do erds <- DNS.lookup rlv dom SRV case erds of @@ -412,6 +434,6 @@ Left err -> return (Left err) Right rds -> return $ mapM unTag rds where - unTag :: RData -> Either DNSError (Int,Int,Int,Domain) + unTag :: RData -> Either DNSError (Word16, Word16, Word16, Domain) unTag (RD_SRV pri wei prt dm) = Right (pri,wei,prt,dm) unTag _ = Left UnexpectedRDATA diff --git a/Network/DNS/LookupRaw.hs b/Network/DNS/LookupRaw.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/LookupRaw.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE RecordWildCards #-} + +module Network.DNS.LookupRaw ( + -- * Lookups returning requested RData + lookup + , lookupAuth + -- * Lookups returning DNS Messages + , lookupRaw + , lookupRawCtl + , lookupRawCtlRecv + -- * DNS Message procesing + , fromDNSMessage + ) where + +import Data.Hourglass (timeAdd, Seconds) +import Prelude hiding (lookup) +import Time.System (timeCurrent) +import Network.Socket (Socket) + +import Network.DNS.IO +import Network.DNS.Imports hiding (lookup) +import Network.DNS.Memo +import Network.DNS.Transport +import Network.DNS.Types.Internal +import Network.DNS.Types.Resolver + +-- $setup +-- >>> import Network.DNS.Resolver + +---------------------------------------------------------------- + +-- | Look up resource records of a specified type for a domain, +-- collecting the results +-- from the ANSWER section of the response. +-- See the documentation of 'lookupRaw' +-- to understand the concrete behavior. +-- Cache is used if 'resolvCache' is 'Just'. +-- +-- Example: +-- +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookup resolver "www.example.com" A +-- Right [93.184.216.34] +-- +lookup :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData]) +lookup = lookupSection Answer + +-- | Look up resource records of a specified type for a domain, +-- collecting the results +-- from the AUTHORITY section of the response. +-- See the documentation of 'lookupRaw' +-- to understand the concrete behavior. +-- Cache is used even if 'resolvCache' is 'Just'. +lookupAuth :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData]) +lookupAuth = lookupSection Authority + +---------------------------------------------------------------- + +-- | Looking up resource records of a domain. The first parameter is one of +-- the field accessors of the 'DNSMessage' type -- this allows you to +-- choose which section (answer, authority, or additional) you would like +-- to inspect for the result. + +lookupSection :: Section + -> Resolver + -> Domain + -> TYPE + -> IO (Either DNSError [RData]) +lookupSection section rlv dom typ + | section == Authority = lookupFreshSection rlv dom typ section + | otherwise = case mcacheConf of + Nothing -> lookupFreshSection rlv dom typ section + Just cacheconf -> lookupCacheSection rlv dom typ cacheconf + where + mcacheConf = resolvCache $ resolvconf $ resolvseed rlv + +lookupFreshSection :: Resolver + -> Domain + -> TYPE + -> Section + -> IO (Either DNSError [RData]) +lookupFreshSection rlv dom typ section = do + eans <- lookupRaw rlv dom typ + case eans of + Left err -> return $ Left err + Right ans -> return $ fromDNSMessage ans toRData + where + correct ResourceRecord{..} = rrtype == typ + toRData = map rdata . filter correct . sectionF + sectionF = case section of + Answer -> answer + Authority -> authority + +lookupCacheSection :: Resolver + -> Domain + -> TYPE + -> CacheConf + -> IO (Either DNSError [RData]) +lookupCacheSection rlv dom typ cconf = do + mx <- lookupCache (dom,typ) c + case mx of + Nothing -> do + eans <- lookupRaw rlv dom typ + case eans of + Left err -> + -- Probably a network error happens. + -- We do not cache anything. + return $ Left err + Right ans -> do + let ex = fromDNSMessage ans toRR + case ex of + Left NameError -> do + let v = Left NameError + cacheNegative cconf c key v ans + return v + Left e -> return $ Left e + Right [] -> do + let v = Right [] + cacheNegative cconf c key v ans + return v + Right rss -> do + cachePositive cconf c key rss + return $ Right $ map rdata rss + Just (_,x) -> return x + where + toRR = filter (typ `isTypeOf`) . answer + Just c = cache rlv + key = (dom,typ) + +cachePositive :: CacheConf -> Cache -> Key -> [ResourceRecord] -> IO () +cachePositive cconf c key rss + | ttl == 0 = return () -- does not cache anything + | otherwise = insertPositive cconf c key (Right rds) ttl + where + rds = map rdata rss + ttl = minimum $ map rrttl rss -- rss is non-empty + +insertPositive :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO () +insertPositive CacheConf{..} c k v ttl = when (ttl /= 0) $ do + ctime <- timeCurrent + let tim = ctime `timeAdd` life + insertCache k tim v c + where + life :: Seconds + life = fromIntegral (maximumTTL `min` ttl) + +cacheNegative :: CacheConf -> Cache -> Key -> Entry -> DNSMessage -> IO () +cacheNegative cconf c key v ans = case soas of + [] -> return () -- does not cache anything + soa:_ -> insertNegative cconf c key v $ rrttl soa + where + soas = filter (SOA `isTypeOf`) $ authority ans + +insertNegative :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO () +insertNegative _ c k v ttl = when (ttl /= 0) $ do + ctime <- timeCurrent + let tim = ctime `timeAdd` life + insertCache k tim v c + where + life :: Seconds + life = fromIntegral ttl + +isTypeOf :: TYPE -> ResourceRecord -> Bool +isTypeOf t ResourceRecord{..} = rrtype == t + +---------------------------------------------------------------- + +-- | Look up a name and return the entire DNS Response. +-- +-- For a given DNS server, the queries are done: +-- +-- * A new UDP socket bound to a new local port is created and +-- a new identifier is created atomically from the cryptographically +-- secure pseudo random number generator for the target DNS server. +-- Then UDP queries are tried with the limitation of 'resolvRetry' +-- (use EDNS if specifiecd). +-- If it appears that the target DNS server does not support EDNS, +-- it falls back to traditional queries. +-- +-- * If the response is truncated, a new TCP socket bound to a new +-- local port is created. Then exactly one TCP query is retried. +-- +-- +-- If multiple DNS servers are specified 'ResolvConf' ('RCHostNames ') +-- or found ('RCFilePath'), either sequential lookup or +-- concurrent lookup is carried out: +-- +-- * In sequential lookup ('resolvConcurrent' is False), +-- the query procedure above is processed +-- in the order of the DNS servers sequentially until a successful +-- response is received. +-- +-- * In concurrent lookup ('resolvConcurrent' is True), +-- the query procedure above is processed +-- for each DNS server concurrently. +-- The first received response is accepted even if +-- it is an error. +-- +-- Cache is not used even if 'resolvCache' is 'Just'. +-- +-- +-- The example code: +-- +-- @ +-- rs <- makeResolvSeed defaultResolvConf +-- withResolver rs $ \\resolver -> lookupRaw resolver \"www.example.com\" A +-- @ +-- +-- And the (formatted) expected output: +-- +-- @ +-- Right (DNSMessage +-- { header = DNSHeader +-- { identifier = 1, +-- flags = DNSFlags +-- { qOrR = QR_Response, +-- opcode = OP_STD, +-- authAnswer = False, +-- trunCation = False, +-- recDesired = True, +-- recAvailable = True, +-- rcode = NoErr, +-- authenData = False +-- }, +-- }, +-- question = [Question { qname = \"www.example.com.\", +-- qtype = A}], +-- answer = [ResourceRecord {rrname = \"www.example.com.\", +-- rrtype = A, +-- rrttl = 800, +-- rdlen = 4, +-- rdata = 93.184.216.119}], +-- authority = [], +-- additional = []}) +-- @ +-- +-- AXFR requests cannot be performed with this interface. +-- +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupRaw resolver "mew.org" AXFR +-- Left InvalidAXFRLookup +-- +lookupRaw :: Resolver -- ^ Resolver obtained via 'withResolver' + -> Domain -- ^ Query domain + -> TYPE -- ^ Query RRtype + -> IO (Either DNSError DNSMessage) +lookupRaw rslv dom typ = lookupRawCtl rslv dom typ mempty + +-- | Similar to 'lookupRaw', but the default values of the RD, AD, CD and DO +-- flag bits, as well as various EDNS features, can be adjusted via the +-- 'QueryControls' parameter. +-- +lookupRawCtl :: Resolver -- ^ Resolver obtained via 'withResolver' + -> Domain -- ^ Query domain + -> TYPE -- ^ Query RRtype + -> QueryControls -- ^ Query flag and EDNS overrides + -> IO (Either DNSError DNSMessage) +lookupRawCtl rslv dom typ ctls = resolve rslv dom typ ctls receive + +-- | Similar to 'lookupRawCtl', but the recv action can be replaced with +-- something other than `Network.DNS.IO.receive`. +-- For example, in an environment where frequent retrieval of the current time +-- is a performance issue, you can pass the time from outside instead of +-- having `Network.DNS.IO.receive` retrieve the current time. +lookupRawCtlRecv :: Resolver -- ^ Resolver obtained via 'withResolver' + -> Domain -- ^ Query domain + -> TYPE -- ^ Query RRtype + -> QueryControls -- ^ Query flag and EDNS overrides + -> (Socket -> IO DNSMessage) -- ^ Action to receive message from socket + -> IO (Either DNSError DNSMessage) +lookupRawCtlRecv = resolve + +---------------------------------------------------------------- + +-- | Messages with a non-error RCODE are passed to the supplied function +-- for processing. Other messages are translated to 'DNSError' instances. +-- +-- Note that 'NameError' is not a lookup error. The lookup is successful, +-- bearing the sad news that the requested domain does not exist. 'NameError' +-- responses may return a meaningful AD bit, may contain useful data in the +-- authority section, and even initial CNAME records that lead to the +-- ultimately non-existent domain. Applications that wish to process the +-- content of 'NameError' (NXDomain) messages will need to implement their +-- own RCODE handling. +-- +fromDNSMessage :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a +fromDNSMessage ans conv = case errcode ans of + NoErr -> Right $ conv ans + FormatErr -> Left FormatError + ServFail -> Left ServerFailure + NameErr -> Left NameError + NotImpl -> Left NotImplemented + Refused -> Left OperationRefused + BadVers -> Left BadOptRecord + BadRCODE -> Left $ DecodeError "Malformed EDNS message" + _ -> Left UnknownDNSError + where + errcode = rcode . flags . header diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs --- a/Network/DNS/Resolver.hs +++ b/Network/DNS/Resolver.hs @@ -1,139 +1,52 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} --- | DNS Resolver and generic (lower-level) lookup functions. +-- | Resolver related data types. module Network.DNS.Resolver ( - -- * Documentation - -- ** Configuration for resolver - FileOrNumericHost(..), ResolvConf(..), defaultResolvConf - -- ** Intermediate data type for resolver - , ResolvSeed, makeResolvSeed - -- ** Type and function for resolver - , Resolver(..), withResolver, withResolvers - -- ** Looking up functions - , lookup - , lookupAuth - -- ** Raw looking up function - , lookupRaw - , lookupRawAD - , fromDNSMessage - , fromDNSFormat + -- * Configuration for resolver + ResolvConf + , defaultResolvConf + -- ** Accessors + , resolvInfo + , resolvTimeout + , resolvRetry + , resolvConcurrent + , resolvCache + , resolvQueryControls + -- ** Specifying DNS servers + , FileOrNumericHost(..) + -- ** Configuring cache + , CacheConf + , defaultCacheConf + , maximumTTL + , pruningDelay + -- * Intermediate data type for resolver + , ResolvSeed + , makeResolvSeed + -- * Type and function for resolver + , Resolver + , withResolver + , withResolvers ) where -#if !defined(mingw32_HOST_OS) -#define POSIX -#else -#define WIN -#endif - -#if __GLASGOW_HASKELL__ < 709 -#define GHC708 -#endif - -import Control.Exception (bracket) -import Data.Char (isSpace) -import Data.List (isPrefixOf) -import Data.Maybe (fromMaybe) -import Network.BSD (getProtocolNumber) -import Network.DNS.Decode -import Network.DNS.Encode -import Network.DNS.Internal -import qualified Data.ByteString.Char8 as BS -import Network.Socket (HostName, Socket, SocketType(Stream, Datagram)) -import Network.Socket (AddrInfoFlag(..), AddrInfo(..), SockAddr(..)) -import Network.Socket (Family(AF_INET, AF_INET6), PortNumber(..)) -import Network.Socket (close, socket, connect, getPeerName, getAddrInfo) -import Network.Socket (defaultHints, defaultProtocol) -import Prelude hiding (lookup) -import System.Random (getStdRandom, randomR) -import System.Timeout (timeout) -#ifdef GHC708 -import Control.Applicative ((<$>), (<*>), pure) -#endif - -#if defined(WIN) && defined(GHC708) -import Network.Socket (send) -import qualified Data.ByteString.Lazy.Char8 as LB -import Control.Monad (when) -#else -import Network.Socket.ByteString.Lazy (sendAll) -#endif - ----------------------------------------------------------------- - - --- | Union type for 'FilePath' and 'HostName'. Specify 'FilePath' to --- \"resolv.conf\" or numeric IP address in 'String' form. --- --- /Warning/: Only numeric IP addresses are valid @RCHostName@s. --- --- Example (using Google's public DNS cache): --- --- >>> let cache = RCHostName "8.8.8.8" --- -data FileOrNumericHost = RCFilePath FilePath -- ^ A path for \"resolv.conf\" - | RCHostName HostName -- ^ A numeric IP address - | RCHostPort HostName PortNumber -- ^ A numeric IP address and port number - --- | Type for resolver configuration. The easiest way to construct a --- @ResolvConf@ object is to modify the 'defaultResolvConf'. -data ResolvConf = ResolvConf { - resolvInfo :: FileOrNumericHost - -- | Timeout in micro seconds. - , resolvTimeout :: Int - -- | The number of retries including the first try. - , resolvRetry :: Int - -- | This field was obsoleted. - , resolvBufsize :: Integer -} - - --- | Return a default 'ResolvConf': --- --- * 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\". --- --- * 'resolvTimeout' is 3,000,000 micro seconds. --- --- * 'resolvRetry' is 3. --- --- * 'resolvBufsize' is 512. (obsoleted) --- --- Example (use Google's public DNS cache instead of resolv.conf): --- --- >>> let cache = RCHostName "8.8.8.8" --- >>> let rc = defaultResolvConf { resolvInfo = cache } --- -defaultResolvConf :: ResolvConf -defaultResolvConf = ResolvConf { - resolvInfo = RCFilePath "/etc/resolv.conf" - , resolvTimeout = 3 * 1000 * 1000 - , resolvRetry = 3 - , resolvBufsize = 512 -} - ----------------------------------------------------------------- - --- | Abstract data type of DNS Resolver seed. --- When implementing a DNS cache, this should be re-used. -data ResolvSeed = ResolvSeed { - addrInfo :: AddrInfo - , rsTimeout :: Int - , rsRetry :: Int - , rsBufsize :: Integer -} +import Control.Exception as E +import qualified Crypto.Random as C +import qualified Data.ByteString as BS +import Data.IORef (IORef) +import qualified Data.IORef as I +import qualified Data.List.NonEmpty as NE +import Network.Socket (AddrInfoFlag(..), AddrInfo(..), PortNumber, HostName, SocketType(Datagram), getAddrInfo, defaultHints) +import Prelude --- | Abstract data type of DNS Resolver --- When implementing a DNS cache, this MUST NOT be re-used. -data Resolver = Resolver { - genId :: IO Int - , dnsSock :: Socket - , dnsTimeout :: Int - , dnsRetry :: Int - , dnsBufsize :: Integer -} +import Network.DNS.Imports +import Network.DNS.Memo +import Network.DNS.Resolver.Internal +import Network.DNS.Transport +import Network.DNS.Types.Internal +import Network.DNS.Types.Resolver ---------------------------------------------------------------- - -- | Make a 'ResolvSeed' from a 'ResolvConf'. -- -- Examples: @@ -141,328 +54,55 @@ -- >>> rs <- makeResolvSeed defaultResolvConf -- makeResolvSeed :: ResolvConf -> IO ResolvSeed -makeResolvSeed conf = ResolvSeed <$> addr - <*> pure (resolvTimeout conf) - <*> pure (resolvRetry conf) - <*> pure (resolvBufsize conf) +makeResolvSeed conf = ResolvSeed conf <$> findAddresses where - addr = case resolvInfo conf of - RCHostName numhost -> makeAddrInfo numhost Nothing - RCHostPort numhost mport -> makeAddrInfo numhost $ Just mport - RCFilePath file -> toAddr <$> readFile file >>= \i -> makeAddrInfo i Nothing - toAddr cs = let l:_ = filter ("nameserver" `isPrefixOf`) $ lines cs - in extract l - extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11 + findAddresses :: IO (NonEmpty AddrInfo) + findAddresses = case resolvInfo conf of + RCHostName numhost -> (:| []) <$> makeAddrInfo numhost Nothing + RCHostPort numhost mport -> (:| []) <$> makeAddrInfo numhost (Just mport) + RCHostNames nss -> mkAddrs nss + RCFilePath file -> getDefaultDnsServers file >>= mkAddrs + mkAddrs [] = E.throwIO BadConfiguration + mkAddrs (l:ls) = (:|) <$> makeAddrInfo l Nothing <*> forM ls (`makeAddrInfo` Nothing) makeAddrInfo :: HostName -> Maybe PortNumber -> IO AddrInfo makeAddrInfo addr mport = do - proto <- getProtocolNumber "udp" let hints = defaultHints { - addrFlags = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_PASSIVE] + addrFlags = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE] , addrSocketType = Datagram - , addrProtocol = proto } - a:_ <- getAddrInfo (Just hints) (Just addr) (Just "domain") - let connectPort = case addrAddress a of - SockAddrInet pn ha -> SockAddrInet (fromMaybe pn mport) ha - SockAddrInet6 pn fi ha sid -> SockAddrInet6 (fromMaybe pn mport) fi ha sid - unixAddr -> unixAddr - return $ a { addrAddress = connectPort } + -- 53 is the standard port number for domain name servers as assigned by IANA + serv = maybe "53" show mport + head <$> getAddrInfo (Just hints) (Just addr) (Just serv) ---------------------------------------------------------------- - -- | Giving a thread-safe 'Resolver' to the function of the second --- argument. A socket for UDP is opened inside and is surely closed. --- Multiple 'withResolver's can be used concurrently. --- Multiple lookups must be done sequentially with a given --- 'Resolver'. If multiple 'Resolver's are necessary for --- concurrent purpose, use 'withResolvers'. +-- argument. withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a -withResolver seed func = bracket (openSocket seed) close $ \sock -> do - connectSocket sock seed - func $ makeResolver seed sock +withResolver seed f = makeResolver seed >>= f +{-# DEPRECATED withResolvers "Use withResolver with resolvConcurrent set to True" #-} -- | Giving thread-safe 'Resolver's to the function of the second --- argument. Sockets for UDP are opened inside and are surely closed. --- For each 'Resolver', multiple lookups must be done sequentially. --- 'Resolver's can be used concurrently. +-- argument. For each 'Resolver', multiple lookups must be done +-- sequentially. 'Resolver's can be used concurrently. withResolvers :: [ResolvSeed] -> ([Resolver] -> IO a) -> IO a -withResolvers seeds func = bracket openSockets closeSockets $ \socks -> do - mapM_ (uncurry connectSocket) $ zip socks seeds - let resolvs = zipWith makeResolver seeds socks - func resolvs - where - openSockets = mapM openSocket seeds - closeSockets = mapM close - -openSocket :: ResolvSeed -> IO Socket -openSocket seed = socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) - where - ai = addrInfo seed - -connectSocket :: Socket -> ResolvSeed -> IO () -connectSocket sock seed = connect sock (addrAddress ai) - where - ai = addrInfo seed - -makeResolver :: ResolvSeed -> Socket -> Resolver -makeResolver seed sock = Resolver { - genId = getRandom - , dnsSock = sock - , dnsTimeout = rsTimeout seed - , dnsRetry = rsRetry seed - , dnsBufsize = rsBufsize seed - } - -getRandom :: IO Int -getRandom = getStdRandom (randomR (0,65535)) - ----------------------------------------------------------------- - --- | Looking up resource records of a domain. The first parameter is one of --- the field accessors of the 'DNSMessage' type -- this allows you to --- choose which section (answer, authority, or additional) you would like --- to inspect for the result. - -lookupSection :: (DNSMessage -> [ResourceRecord]) - -> Resolver - -> Domain - -> TYPE - -> IO (Either DNSError [RData]) -lookupSection section rlv dom typ = do - eans <- lookupRaw rlv dom typ - case eans of - Left err -> return $ Left err - Right ans -> return $ fromDNSMessage ans toRData - where - {- CNAME hack - dom' = if "." `isSuffixOf` dom then dom else dom ++ "." - correct r = rrname r == dom' && rrtype r == typ - -} - correct r = rrtype r == typ - toRData = map rdata . filter correct . section - --- | Extract necessary information from 'DNSMessage' -fromDNSMessage :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a -fromDNSMessage ans conv = case errcode ans of - NoErr -> Right $ conv ans - FormatErr -> Left FormatError - ServFail -> Left ServerFailure - NameErr -> Left NameError - NotImpl -> Left NotImplemented - Refused -> Left OperationRefused - BadOpt -> Left BadOptRecord - where - errcode = rcode . flags . header - --- | For backward compatibility. -fromDNSFormat :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a -fromDNSFormat = fromDNSMessage - --- | Look up resource records for a domain, collecting the results --- from the ANSWER section of the response. --- --- We repeat an example from "Network.DNS.Lookup": --- --- >>> let hostname = Data.ByteString.Char8.pack "www.example.com" --- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookup resolver hostname A --- Right [93.184.216.34] --- -lookup :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData]) -lookup = lookupSection answer - --- | Look up resource records for a domain, collecting the results --- from the AUTHORITY section of the response. -lookupAuth :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData]) -lookupAuth = lookupSection authority - - --- | Look up a name and return the entire DNS Response. If the --- initial UDP query elicits a truncated answer, the query is --- retried over TCP. The TCP retry may extend the total time --- taken by one more timeout beyond timeout * tries. --- --- Sample output is included below, however it is /not/ tested --- the sequence number is unpredictable (it has to be!). --- --- The example code: --- --- @ --- let hostname = Data.ByteString.Char8.pack \"www.example.com\" --- rs <- makeResolvSeed defaultResolvConf --- withResolver rs $ \resolver -> lookupRaw resolver hostname A --- @ --- --- And the (formatted) expected output: --- --- @ --- Right (DNSMessage --- { header = DNSHeader --- { identifier = 1, --- flags = DNSFlags --- { qOrR = QR_Response, --- opcode = OP_STD, --- authAnswer = False, --- trunCation = False, --- recDesired = True, --- recAvailable = True, --- rcode = NoErr, --- authenData = False --- }, --- }, --- question = [Question { qname = \"www.example.com.\", --- qtype = A}], --- answer = [ResourceRecord {rrname = \"www.example.com.\", --- rrtype = A, --- rrttl = 800, --- rdlen = 4, --- rdata = 93.184.216.119}], --- authority = [], --- additional = []}) --- @ --- -lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage) -lookupRaw = lookupRawInternal receive False - --- | Same as lookupRaw, but the query sets the AD bit, which solicits the --- the authentication status in the server reply. In most applications --- (other than diagnostic tools) that want authenticated data It is --- unwise to trust the AD bit in the responses of non-local servers, this --- interface should in most cases only be used with a loopback resolver. --- -lookupRawAD :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage) -lookupRawAD = lookupRawInternal receive True - --- Lookup loop, we try UDP until we get a response. If the response --- is truncated, we try TCP once, with no further UDP retries. --- EDNS0 support would significantly reduce the need for TCP retries. --- --- For now, we optimize for low latency high-availability caches --- (e.g. running on a loopback interface), where TCP is cheap --- enough. We could attempt to complete the TCP lookup within the --- original time budget of the truncated UDP query, by wrapping both --- within a a single 'timeout' thereby staying within the original --- time budget, but it seems saner to give TCP a full opportunity to --- return results. TCP latency after a truncated UDP reply will be --- atypical. --- --- Future improvements might also include support for TCP on the --- initial query, and of course support for multiple nameservers. - -lookupRawInternal :: - (Socket -> IO DNSMessage) - -> Bool - -> Resolver - -> Domain - -> TYPE - -> IO (Either DNSError DNSMessage) -lookupRawInternal _ _ _ dom _ - | isIllegal dom = return $ Left IllegalDomain -lookupRawInternal rcv ad rlv dom typ = do - seqno <- genId rlv - let query = (if ad then composeQueryAD else composeQuery) seqno [q] - checkSeqno = check seqno - loop query checkSeqno 0 False - where - loop query checkSeqno cnt mismatch - | cnt == retry = do - let ret | mismatch = SequenceNumberMismatch - | otherwise = RetryLimitExceeded - return $ Left ret - | otherwise = do - sendAll sock query - response <- timeout tm (rcv sock) - case response of - Nothing -> loop query checkSeqno (cnt + 1) False - Just res -> do - let valid = checkSeqno res - case valid of - False -> loop query checkSeqno (cnt + 1) False - True | not $ trunCation $ flags $ header res - -> return $ Right res - _ -> tcpRetry query sock tm - sock = dnsSock rlv - tm = dnsTimeout rlv - retry = dnsRetry rlv - q = makeQuestion dom typ - check seqno res = identifier (header res) == seqno - --- Create a TCP socket `just like` our UDP socket and retry the same --- query over TCP. Since TCP is a reliable transport, and we just --- got a (truncated) reply from the server over UDP (so it has the --- answer, but it is just too large for UDP), we expect to succeed --- quickly on the first try. There will be no further retries. - -tcpRetry :: - Query - -> Socket - -> Int - -> IO (Either DNSError DNSMessage) -tcpRetry query sock tm = do - peer <- getPeerName sock - bracket (tcpOpen peer) - (maybe (return ()) close) - (tcpLookup query peer tm) - --- Create a TCP socket with the given socket address (taken from a --- corresponding UDP socket). This might throw an I/O Exception --- if we run out of file descriptors. Should this use tryIOError, --- and return "Nothing" also in that case? If so, perhaps similar --- code is needed in openSocket, but that has to wait until we --- refactor `withResolver` to not do "early" socket allocation, and --- instead allocate a fresh UDP socket for each `lookupRawInternal` --- invocation. It would be bad to fail an entire `withResolver` --- action, if the socket shortage is transient, and the user intends --- to make many DNS queries with the same resolver handle. - -tcpOpen :: SockAddr -> IO (Maybe Socket) -tcpOpen peer = do - case (peer) of - SockAddrInet _ _ -> - socket AF_INET Stream defaultProtocol >>= return . Just - SockAddrInet6 _ _ _ _ -> - socket AF_INET6 Stream defaultProtocol >>= return . Just - _ -> return Nothing -- Only IPv4 and IPv6 are possible - --- Perform a DNS query over TCP, if we were successful in creating --- the TCP socket. The socket creation can only fail if we run out --- of file descriptors, we're not making connections here. Failure --- is reported as "server" failure, though it is really our stub --- resolver that's failing. This is likely good enough. - -tcpLookup :: - Query - -> SockAddr - -> Int - -> Maybe Socket - -> IO (Either DNSError DNSMessage) -tcpLookup _ _ _ Nothing = return $ Left ServerFailure -tcpLookup query peer tm (Just vc) = do - response <- timeout tm $ do - connect vc $ peer - sendAll vc $ encodeVC query - receiveVC vc - case response of - Nothing -> return $ Left TimeoutExpired - Just res -> return $ Right res +withResolvers seeds f = mapM makeResolver seeds >>= f -#if defined(WIN) && defined(GHC708) --- Windows does not support sendAll in Network.ByteString for older GHCs. -sendAll :: Socket -> BS.ByteString -> IO () -sendAll sock bs = do - sent <- send sock (LB.unpack bs) - when (sent < fromIntegral (LB.length bs)) $ sendAll sock (LB.drop (fromIntegral sent) bs) -#endif +makeResolver :: ResolvSeed -> IO Resolver +makeResolver seed = do + let n = NE.length $ nameservers seed + refs <- replicateM n (C.drgNew >>= I.newIORef) + let gens = NE.fromList $ map getRandom refs + case resolvCache $ resolvconf seed of + Just cacheconf -> do + c <- newCache $ pruningDelay cacheconf + return $ Resolver seed gens $ Just c + Nothing -> return $ Resolver seed gens Nothing -isIllegal :: Domain -> Bool -isIllegal "" = True -isIllegal dom - | '.' `BS.notElem` dom = True - | ':' `BS.elem` dom = True - | '/' `BS.elem` dom = True - | BS.length dom > 253 = True - | any (\x -> BS.length x > 63) - (BS.split '.' dom) = True -isIllegal _ = False +getRandom :: IORef C.ChaChaDRG -> IO Word16 +getRandom ref = I.atomicModifyIORef' ref $ \gen -> + let (bs, gen') = C.randomBytesGenerate 2 gen + [u,l] = map fromIntegral $ BS.unpack bs + !seqno = u * 256 + l + in (gen', seqno) diff --git a/Network/DNS/StateBinary.hs b/Network/DNS/StateBinary.hs deleted file mode 100644 --- a/Network/DNS/StateBinary.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} -module Network.DNS.StateBinary where - -import Control.Monad.State (State, StateT) -import qualified Control.Monad.State as ST -import Control.Monad.Trans.Resource (ResourceT) -import qualified Data.Attoparsec.ByteString as A -import qualified Data.Attoparsec.ByteString.Lazy as AL -import qualified Data.Attoparsec.Types as T -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as BL -import Data.Conduit (Sink) -import Data.Conduit.Attoparsec (sinkParser) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IM -import Data.Map (Map) -import qualified Data.Map as M -import Data.Word (Word8, Word16, Word32) -import Network.DNS.Types - -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative ((<$>), (<*)) -import Data.Monoid (Monoid, mconcat, mappend, mempty) -#endif - ----------------------------------------------------------------- - -type SPut = State WState Builder - -data WState = WState { - wsDomain :: Map Domain Int - , wsPosition :: Int -} - -initialWState :: WState -initialWState = WState M.empty 0 - -instance Monoid SPut where - mempty = return mempty - mappend a b = mconcat <$> sequence [a, b] - -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 - -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 - } - ----------------------------------------------------------------- - -getPosition :: SGet Int -getPosition = psPosition <$> ST.get - -addPosition :: Int -> SGet () -addPosition n = do - PState dom pos <- ST.get - ST.put $ PState dom (pos + n) - -push :: Int -> Domain -> SGet () -push n d = do - PState dom pos <- ST.get - ST.put $ PState (IM.insert n d dom) pos - -pop :: Int -> SGet (Maybe Domain) -pop n = IM.lookup n . psDomain <$> ST.get - ----------------------------------------------------------------- - -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 - ----------------------------------------------------------------- - -getNBytes :: Int -> SGet [Int] -getNBytes len = toInts <$> getNByteString len - where - toInts = map fromIntegral . BS.unpack - -getNByteString :: Int -> SGet ByteString -getNByteString n = ST.lift (A.take n) <* addPosition n - ----------------------------------------------------------------- - -initialState :: PState -initialState = PState IM.empty 0 - -sinkSGet :: SGet a -> Sink ByteString (ResourceT IO) (a, PState) -sinkSGet parser = sinkParser (ST.runStateT parser initialState) - -runSGet :: SGet a -> BL.ByteString -> Either String (a, PState) -runSGet parser bs = AL.eitherResult $ AL.parse (ST.runStateT parser initialState) bs - -runSGetWithLeftovers :: SGet a -> BL.ByteString -> Either String ((a, PState), BL.ByteString) -runSGetWithLeftovers parser bs = toResult $ AL.parse (ST.runStateT parser initialState) bs - where - toResult :: AL.Result r -> Either String (r, BL.ByteString) - toResult (AL.Done i r) = Right (r, i) - toResult (AL.Fail _ _ err) = Left err - -runSPut :: SPut -> BL.ByteString -runSPut = BB.toLazyByteString . flip ST.evalState initialWState diff --git a/Network/DNS/Transport.hs b/Network/DNS/Transport.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/Transport.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Network.DNS.Transport ( + Resolver(..) + , resolve + ) where + +import Control.Concurrent.Async (async, waitAnyCancel) +import Control.Exception as E +import qualified Data.ByteString.Char8 as BS +import qualified Data.List.NonEmpty as NE +import Network.Socket (AddrInfo(..), SockAddr(..), Family(AF_INET, AF_INET6), Socket, SocketType(Stream), close, socket, connect, defaultProtocol) +import System.IO.Error (annotateIOError) +import System.Timeout (timeout) + +import Network.DNS.IO +import Network.DNS.Imports +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 + +---------------------------------------------------------------- + +data TCPFallback = TCPFallback deriving (Show, Typeable) +instance Exception TCPFallback + +type Rslv0 = QueryControls -> (Socket -> IO DNSMessage) + -> IO (Either DNSError DNSMessage) + +type Rslv1 = Question + -> Int -- Timeout + -> Int -- Retry + -> Rslv0 + +type TcpRslv = AddrInfo + -> Question + -> Int -- Timeout + -> QueryControls + -> IO DNSMessage + +type UdpRslv = Int -- Retry + -> (Socket -> IO DNSMessage) + -> TcpRslv + +-- In lookup loop, we try UDP until we get a response. If the response +-- is truncated, we try TCP once, with no further UDP retries. +-- +-- For now, we optimize for low latency high-availability caches +-- (e.g. running on a loopback interface), where TCP is cheap +-- enough. We could attempt to complete the TCP lookup within the +-- original time budget of the truncated UDP query, by wrapping both +-- within a a single 'timeout' thereby staying within the original +-- time budget, but it seems saner to give TCP a full opportunity to +-- return results. TCP latency after a truncated UDP reply will be +-- atypical. +-- +-- Future improvements might also include support for TCP on the +-- initial query. +-- +-- This function merges the query flag overrides from the resolver +-- configuration with any additional overrides from the caller. +-- +resolve :: Resolver -> Domain -> TYPE -> Rslv0 +resolve rlv dom typ qctls rcv + | isIllegal dom = return $ Left IllegalDomain + | typ == AXFR = return $ Left InvalidAXFRLookup + | onlyOne = resolveOne (head nss) (head gens) q tm retry ctls rcv + | concurrent = resolveConcurrent nss gens q tm retry ctls rcv + | otherwise = resolveSequential nss gens q tm retry ctls rcv + where + q = case BS.last dom of + '.' -> Question dom typ + _ -> Question (dom <> ".") typ + + gens = NE.toList $ genIds rlv + + seed = resolvseed rlv + nss = NE.toList $ nameservers seed + onlyOne = length nss == 1 + ctls = qctls <> resolvQueryControls (resolvconf $ resolvseed rlv) + + conf = resolvconf seed + concurrent = resolvConcurrent conf + tm = resolvTimeout conf + retry = resolvRetry conf + + +resolveSequential :: [AddrInfo] -> [IO Identifier] -> Rslv1 +resolveSequential nss gs q tm retry ctls rcv = loop nss gs + where + loop [ai] [gen] = resolveOne ai gen q tm retry ctls rcv + loop (ai:ais) (gen:gens) = do + eres <- resolveOne ai gen q tm retry ctls rcv + case eres of + Left _ -> loop ais gens + res -> return res + loop _ _ = error "resolveSequential:loop" + +resolveConcurrent :: [AddrInfo] -> [IO Identifier] -> Rslv1 +resolveConcurrent nss gens q tm retry ctls rcv = do + asyncs <- mapM mkAsync $ zip nss gens + snd <$> waitAnyCancel asyncs + where + mkAsync (ai,gen) = async $ resolveOne ai gen q tm retry ctls rcv + +resolveOne :: AddrInfo -> IO Identifier -> Rslv1 +resolveOne ai gen q tm retry ctls rcv = + E.try $ udpTcpLookup gen retry rcv ai q tm ctls + +---------------------------------------------------------------- + +-- UDP attempts must use the same ID and accept delayed answers +-- but we use a fresh ID for each TCP lookup. +-- +udpTcpLookup :: IO Identifier -> UdpRslv +udpTcpLookup gen retry rcv ai q tm ctls = do + ident <- gen + udpLookup ident retry rcv ai q tm ctls `E.catch` + \TCPFallback -> tcpLookup gen ai q tm ctls + +---------------------------------------------------------------- + +ioErrorToDNSError :: AddrInfo -> String -> IOError -> IO DNSMessage +ioErrorToDNSError ai protoName ioe = throwIO $ NetworkFailure aioe + where + loc = protoName ++ "@" ++ show (addrAddress ai) + aioe = annotateIOError ioe loc Nothing Nothing + +---------------------------------------------------------------- + +udpOpen :: AddrInfo -> IO Socket +udpOpen ai = do + sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) + connect sock (addrAddress ai) + return sock + +-- This throws DNSError or TCPFallback. +udpLookup :: Identifier -> UdpRslv +udpLookup ident retry rcv ai q tm ctls = do + let qry = encodeQuestion ident q ctls + E.handle (ioErrorToDNSError ai "udp") $ + bracket (udpOpen ai) close (loop qry ctls 0 RetryLimitExceeded) + where + loop qry lctls cnt err sock + | cnt == retry = E.throwIO err + | otherwise = do + mres <- timeout tm (send sock qry >> getAns sock) + case mres of + Nothing -> loop qry lctls (cnt + 1) RetryLimitExceeded sock + Just res -> do + let fl = flags $ header res + tc = trunCation fl + rc = rcode fl + eh = ednsHeader res + cs = ednsEnabled FlagClear <> lctls + if tc then E.throwIO TCPFallback + else if rc == FormatErr && eh == NoEDNS && cs /= lctls + then let qry' = encodeQuestion ident q cs + in loop qry' cs cnt RetryLimitExceeded sock + else return res + + -- | Closed UDP ports are occasionally re-used for a new query, with + -- the nameserver returning an unexpected answer to the wrong socket. + -- Such answers should be simply dropped, with the client continuing + -- to wait for the right answer, without resending the question. + -- Note, this eliminates sequence mismatch as a UDP error condition, + -- instead we'll time out if no matching answer arrives. + -- + getAns sock = do + resp <- rcv sock + if checkResp q ident resp + then return resp + else getAns sock + +---------------------------------------------------------------- + +-- Create a TCP socket with the given socket address. +tcpOpen :: SockAddr -> IO Socket +tcpOpen peer = case peer of + SockAddrInet{} -> socket AF_INET Stream defaultProtocol + SockAddrInet6{} -> socket AF_INET6 Stream defaultProtocol + _ -> E.throwIO ServerFailure + +-- Perform a DNS query over TCP, if we were successful in creating +-- the TCP socket. +-- This throws DNSError only. +tcpLookup :: IO Identifier -> TcpRslv +tcpLookup gen ai q tm ctls = + E.handle (ioErrorToDNSError ai "tcp") $ do + res <- bracket (tcpOpen addr) close (perform ctls) + let rc = rcode $ flags $ header res + eh = ednsHeader res + cs = ednsEnabled FlagClear <> ctls + -- If we first tried with EDNS, retry without on FormatErr. + if rc == FormatErr && eh == NoEDNS && cs /= ctls + then bracket (tcpOpen addr) close (perform cs) + else return res + where + addr = addrAddress ai + perform cs vc = do + ident <- gen + let qry = encodeQuestion ident q cs + mres <- timeout tm $ do + connect vc addr + sendVC vc qry + receiveVC vc + case mres of + Nothing -> E.throwIO TimeoutExpired + Just res -> maybe (return res) E.throwIO (checkRespM q ident res) + +---------------------------------------------------------------- + +badLength :: Domain -> Bool +badLength dom + | BS.null dom = True + | BS.last dom == '.' = BS.length dom > 254 + | otherwise = BS.length dom > 253 + +isIllegal :: Domain -> Bool +isIllegal dom + | badLength dom = True + | '.' `BS.notElem` dom = True + | ':' `BS.elem` dom = True + | '/' `BS.elem` dom = True + | any (\x -> BS.length x > 63) + (BS.split '.' dom) = True + | otherwise = False diff --git a/Network/DNS/Types.hs b/Network/DNS/Types.hs --- a/Network/DNS/Types.hs +++ b/Network/DNS/Types.hs @@ -2,29 +2,133 @@ -- For more information, see . module Network.DNS.Types ( - -- * Domain - Domain -- * Resource Records - , ResourceRecord (..) - , RData (..), OData (..) - -- ** Resource Record Type - , TYPE (..), intToType, typeToInt - , OPTTYPE (..), intToOptType, optTypeToInt - -- * DNS Error - , DNSError (..) + 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 (..) - , DNSFormat - -- * DNS Header + -- ** 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 (..) - -- * DNS Flags + , Identifier + -- *** DNS flags , DNSFlags (..) - -- * DNS Body , QorR (..) + , defaultDNSFlags + -- *** OPCODE and RCODE , OPCODE (..) - , RCODE (..) + , 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 (..) - , responseA, responseAAAA - ) where + -- * DNS Error + , DNSError (..) + -- * Other types + , Mailbox + ) where -import Network.DNS.Internal +import Network.DNS.Types.Internal diff --git a/Network/DNS/Utils.hs b/Network/DNS/Utils.hs --- a/Network/DNS/Utils.hs +++ b/Network/DNS/Utils.hs @@ -4,17 +4,15 @@ normalize , normalizeCase , normalizeRoot + , splitDomain + , splitMailbox ) where -import qualified Data.ByteString.Char8 as BS ( - append - , last - , map - , null - , pack ) -import Data.Char ( toLower ) +import qualified Data.ByteString.Char8 as BS +import Data.Char (toLower) -import Network.DNS.Types ( Domain ) +import Network.DNS.Types.Internal (DNSError, Domain, Mailbox) +import Network.DNS.StateBinary (parseLabel) -- | Perform both 'normalizeCase' and 'normalizeRoot' on the given @@ -37,7 +35,7 @@ -- -- Ensure that we don't crash on the empty 'Domain': -- --- >>> import qualified Data.ByteString.Char8 as BS ( empty ) +-- >>> import qualified Data.ByteString.Char8 as BS -- >>> normalize BS.empty -- "." -- @@ -70,7 +68,7 @@ -- -- Ensure that we don't crash on the empty 'Domain': -- --- >>> import qualified Data.ByteString.Char8 as BS ( empty ) +-- >>> import qualified Data.ByteString.Char8 as BS -- >>> normalizeCase BS.empty -- "" -- @@ -124,7 +122,7 @@ -- -- Ensure that we don't crash on the empty 'Domain': -- --- >>> import qualified Data.ByteString.Char8 as BS ( empty ) +-- >>> import qualified Data.ByteString.Char8 as BS -- >>> normalizeRoot BS.empty -- "." -- @@ -135,3 +133,45 @@ | otherwise = d `BS.append` trailing_dot where trailing_dot = BS.pack "." + +-- | Split a domain name in A-label form into its initial label and the rest of +-- the domain. Returns an error if the initial label is malformed. When no +-- more labels remain, the initial label will satisfy 'BS.null'. +-- +-- This also decodes any escaped characters in the initial label, which may +-- therefore contain whitespace, binary data, or unescaped internal dots. To +-- reconstruct the original domain, the initial label may sometimes require +-- correct escaping of special characters. +-- +-- ==== __Examples__ +-- +-- >>> import Data.ByteString.Char8 as BS +-- >>> splitDomain $ BS.pack "abc\\.def.xyz" +-- Right ("abc.def","xyz") +-- +-- >>> splitDomain $ BS.pack ".abc.def.xyz" +-- Left (DecodeError "invalid domain: .abc.def.xyz") +-- +splitDomain :: Domain -> Either DNSError (BS.ByteString, Domain) +splitDomain = parseLabel 0x2e + +-- | Split a 'Mailbox' in A-label form into its initial label 'BS.ByteString' +-- (the /localpart/ of the email address) and the remaining 'Domain' (the +-- /domainpart/ of the email address, with a possible trailing @'.'@). Returns +-- an error if the initial label is malformed. When no more labels remain, the +-- initial label will satisfy 'BS.null'. The remaining labels can be obtained +-- by applying 'splitDomain' the returned domain part. +-- +-- This also decodes any escaped characters in the initial label, which may +-- therefore contain whitespace, binary data, or unescaped internal dots. To +-- reconstruct the original mailbox, the initial label may sometimes require +-- correct escaping of special characters. +-- +-- ==== __Example__ +-- +-- >>> import Data.ByteString.Char8 as BS +-- >>> splitMailbox $ BS.pack "Joe.Admin@example.com." +-- Right ("Joe.Admin","example.com.") +-- +splitMailbox :: Mailbox -> Either DNSError (BS.ByteString, Domain) +splitMailbox = parseLabel 0x40 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,4 @@ import Distribution.Simple + +main :: IO () main = defaultMain 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/cbits/dns.c b/cbits/dns.c new file mode 100644 --- /dev/null +++ b/cbits/dns.c @@ -0,0 +1,77 @@ +#include +#include +#include +#include +#include + +#define MALLOC(x) HeapAlloc(GetProcessHeap(), 0, (x)) +#define FREE(x) HeapFree(GetProcessHeap(), 0, (x)) + +// Fills `dnsAddresses` with the DNS addresses found, up to `bufferLen`. +// Returns NO_ERROR (0x0) in case the operation succeeds, otherwise a non-zero +// error code. See: https://msdn.microsoft.com/en-us/library/windows/desktop/ms681382(v=vs.85).aspx +DWORD getWindowsDefDnsServers(char* dnsAddresses, size_t bufferLen) { + FIXED_INFO *pFixedInfo; + ULONG ulOutBufLen; + DWORD dwRetVal; + + if (bufferLen <= 0) return ERROR_NOT_ENOUGH_MEMORY; + + pFixedInfo = (FIXED_INFO *) MALLOC(sizeof (FIXED_INFO)); + if (pFixedInfo == NULL) + return ERROR_NOT_ENOUGH_MEMORY; + ulOutBufLen = sizeof (FIXED_INFO); + + // Make an initial call to GetAdaptersInfo to get the necessary size into the + // ulOutBufLen variable + if (GetNetworkParams(pFixedInfo, &ulOutBufLen) == ERROR_BUFFER_OVERFLOW) { + FREE(pFixedInfo); + pFixedInfo = (FIXED_INFO *) MALLOC(ulOutBufLen); + if (pFixedInfo == NULL) + return ERROR_NOT_ENOUGH_MEMORY; + } + + dwRetVal = GetNetworkParams(pFixedInfo, &ulOutBufLen); + + if (dwRetVal == NO_ERROR) { + int offset = 0; + int spaceAvailable = bufferLen; + IP_ADDR_STRING* head = &pFixedInfo->DnsServerList; + int count = 0; + + while (head != NULL) { + int ipLen = strlen(head->IpAddress.String); + int copySize = ipLen + 1; + + spaceAvailable -= copySize; + if (spaceAvailable >= 0) { + // Write the separator. + // The string is already terminated due to the call to + // strcpy_s, which copies the null terminator. + if (count != 0) dnsAddresses[offset - 1] = ','; + // Copy the IP address, including the null terminator. + strcpy_s(dnsAddresses + offset, copySize, head->IpAddress.String); + if (spaceAvailable == 0) break; + } else + break; + + offset += copySize; + count++; + head = head->Next; + } + + } + + if (pFixedInfo) FREE(pFixedInfo); + return dwRetVal; +} + +/* + +// Test with 'gcc -o dnsServer -Wall -Werror -pedantic -liphlpapi -Iinclude dns.c' on a +// Windows machine. + +int main(){ + printf(getWindowsDefDnsServers()->dnsAddresses); + return 0; +}*/ diff --git a/dns.cabal b/dns.cabal --- a/dns.cabal +++ b/dns.cabal @@ -1,108 +1,138 @@ -Name: dns -Version: 2.0.13 -Author: Kazu Yamamoto -Maintainer: Kazu Yamamoto -License: BSD3 -License-File: LICENSE -Synopsis: DNS library in Haskell -Description: - A thread-safe DNS library for both clients and servers written - in pure Haskell. -Category: Network -Cabal-Version: >= 1.10 -Build-Type: Simple -Extra-Source-Files: Changelog +cabal-version: 2.0 +name: dns +version: 4.2.0 +license: BSD3 +license-file: LICENSE +maintainer: Kazu Yamamoto +author: Kazu Yamamoto +tested-with: + ghc ==8.0.2 ghc ==8.2.2 ghc ==8.4.4 ghc ==8.6.5 ghc ==8.8.1 -Library - Default-Language: Haskell2010 - GHC-Options: -Wall - Exposed-Modules: Network.DNS - Network.DNS.Lookup - Network.DNS.Resolver - Network.DNS.Utils - Network.DNS.Types - Network.DNS.Encode - Network.DNS.Decode - Other-Modules: Network.DNS.Internal - Network.DNS.StateBinary - if impl(ghc >= 7) - Build-Depends: base >= 4 && < 5 - , attoparsec - , binary - , bytestring - , conduit >= 1.1 - , conduit-extra >= 1.1 - , containers - , iproute >= 1.3.2 - , mtl - , network >= 2.3 - , random - , resourcet - , safe == 0.3.* - else - Build-Depends: base >= 4 && < 5 - , attoparsec - , binary - , bytestring - , conduit >= 1.1 - , conduit-extra >= 1.1 - , containers - , iproute >= 1.2.4 - , mtl - , network - , network-bytestring - , random - , resourcet - , safe == 0.3.* +synopsis: DNS library in Haskell +description: + A thread-safe DNS library for both clients and servers written + in pure Haskell. -Test-Suite network - Type: exitcode-stdio-1.0 - Default-Language: Haskell2010 - Hs-Source-Dirs: test2 - Ghc-Options: -Wall - Main-Is: Spec.hs - Other-Modules: LookupSpec - Build-Depends: dns - , base - , bytestring - , bytestring-builder - , hspec +category: Network +build-type: Simple +extra-source-files: + Changelog.md + cabal.project + cbits/dns.c -Test-Suite spec - Type: exitcode-stdio-1.0 - Default-Language: Haskell2010 - Hs-Source-Dirs: test, . - Ghc-Options: -Wall - Main-Is: Spec.hs - Other-Modules: EncodeSpec - DecodeSpec - Build-Depends: base - , attoparsec - , binary - , bytestring - , bytestring-builder - , conduit >= 1.1 - , conduit-extra >= 1.1 - , containers - , dns - , hspec - , iproute >= 1.2.4 - , mtl - , network >= 2.3 - , random - , resourcet - , safe == 0.3.* - , word8 +source-repository head + type: git + location: https://github.com/kazu-yamamoto/dns.git -Test-Suite doctest - Type: exitcode-stdio-1.0 - Default-Language: Haskell2010 - Hs-Source-Dirs: test2 - Ghc-Options: -Wall - Main-Is: doctests.hs - Build-Depends: base - , doctest +library + exposed-modules: + Network.DNS + Network.DNS.Lookup + Network.DNS.LookupRaw + Network.DNS.Resolver + Network.DNS.Utils + Network.DNS.Types + Network.DNS.Decode + Network.DNS.Encode + Network.DNS.IO -Source-Repository head - Type: git - Location: git://github.com/kazu-yamamoto/dns.git + other-modules: Network.DNS.Transport + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + dns-internal, + base >=4 && <5, + array, + async, + attoparsec, + auto-update, + base16-bytestring, + base64-bytestring, + bytestring, + containers, + crypton, + hourglass, + iproute >=1.3.2, + mtl, + network >=2.3, + psqueues + +library dns-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 + + hs-source-dirs: internal + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base, + array, + async, + attoparsec, + auto-update, + base16-bytestring, + base64-bytestring, + bytestring, + case-insensitive, + containers, + crypton, + hourglass, + iproute, + mtl, + network, + psqueues + + if os(windows) + c-sources: cbits/dns.c + extra-libraries: iphlpapi + +test-suite network-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover + hs-source-dirs: test2 + other-modules: + LookupSpec + IOSpec + + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + dns, + dns-internal, + base, + hspec, + network + +test-suite spec-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover + hs-source-dirs: test + other-modules: + EncodeSpec + DecodeSpec + RoundTripSpec + + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + dns, + dns-internal, + QuickCheck >=2.9, + base, + bytestring, + case-insensitive, + hspec, + iproute >=1.3.2, + word8 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 (e.g. the SOA record /rname/ 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,508 @@ +{-# LANGUAGE BangPatterns, LambdaCase, 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.CaseInsensitive as CI +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 RP _ = RD_RP <$> getMailbox + <*> getDomain +-- +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 CAA len = do + dend <- rdataEnd len + flags <- get8 + tag <- getInt8 >>= getNByteString + tpos <- getPosition + RD_CAA flags (CI.mk tag) <$> getNByteString (dend - tpos) +-- +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 + -- Reprocess the same ByteString starting at the pointer + -- target (offset). + getPtr pos offset = do + msg <- getInput + let parser = skipNBytes offset >> getDomain' sep1 offset + case runSGet parser msg of + Left (DecodeError err) -> failSGet err + Left err -> fail $ show err + Right o -> do + -- Cache only the presentation form decoding of domain names, + -- mailboxes (e.g. SOA rname) are less frequently reused, and + -- have a different presentation form, so must not share the + -- same cache. + when (sep1 == dot) $ + push pos (fst o) + return (fst o) + + 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" + if sep1 /= dot + then getPtr pos offset + else pop offset >>= \case + Nothing -> getPtr pos offset + Just 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,361 @@ +{-# 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 Control.Exception as E +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.CaseInsensitive as CI +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_RP mbox dname -> putMailbox mbox <> putDomain dname + 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 + RD_CAA f t v -> putCAA f t v + 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 + ] + putCAA flags tag value = mconcat + [ put8 flags + , putByteStringWithLength (CI.original tag) + , putByteString value + ] + +-- | 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 -> do + -- Pointers are limited to 14-bits! + when (cur <= 0x3fff) $ wsPush dom cur + mconcat [ putPartialDomain hd + , putDomain' '.' tl + ] + where + -- Try with the preferred separator if present, else fall back to '.'. + (hd, tl) = loop (c2w sep) + where + loop w = case parseLabel w dom of + Right p | w /= 0x2e && BS.null (snd p) -> loop 0x2e + | otherwise -> p + Left e -> E.throw e + + 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@ and @RP@ records. +-- +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,102 @@ +{-# LANGUAGE RecordWildCards #-} + +module Network.DNS.Memo where + +import qualified Control.Reaper as R +import qualified Data.ByteString as B +import qualified Data.CaseInsensitive as CI +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 (RD_RP mbox dname) = RD_RP (B.copy mbox) (B.copy dname) +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 (RD_CAA f t v) = RD_CAA f (CI.mk (B.copy (CI.original t))) (B.copy v) +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,441 @@ +{-# 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. +-- +parseLabel :: Word8 -> ByteString -> Either DNSError (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 = Right r + | otherwise = bottom + bottom = Left $ 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,1407 @@ +{-# 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.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +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 /rname/ of @SOA@ records, +-- and is also employed in the @mbox-dname@ field of @RP@ 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 + +---------------------------------------------------------------- + +-- | 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 +-- | Responsible Person +pattern RP :: TYPE +pattern RP = TYPE 17 +-- | 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 + +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 RP = "RP" + 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 + +---------------------------------------------------------------- + +-- | 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 + +---------------------------------------------------------------- + +-- 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_RP Mailbox Domain -- ^ Responsible Person (RFC1183) + | 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_CAA Word8 (CI ByteString) ByteString + -- ^ CAA (RFC 6844) + --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_RP mbox dname -> showRP mbox dname + 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 + RD_CAA f t v -> showCAA f t v + UnknownRData bytes -> showOpaque bytes + where + showSalt "" = "-" + showSalt salt = _b16encode salt + showDomain = BS.unpack + showSOA mname rname serial refresh retry expire minttl = + showDomain mname ++ " " ++ showDomain rname ++ " " ++ + 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 + showRP mbox dname = showDomain mbox ++ " " ++ showDomain dname + 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 + showCAA flags tag value = + show flags ++ " " ++ BS.unpack (CI.original tag) ++ " " ++ show value + -- | 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 + +---------------------------------------------------------------- + +-- | 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 + +---------------------------------------------------------------- + +-- | 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 @@ -1,65 +1,115 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} +{-# LANGUAGE OverloadedStrings #-} module DecodeSpec where import Data.ByteString.Internal (ByteString(..), unsafeCreate) -#if !MIN_VERSION_bytestring(0,10,0) -import qualified Data.ByteString as BS -#endif -import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BC import Data.Word8 import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (plusPtr) import Foreign.Storable (peek, poke, peekByteOff) -import Network.DNS.Decode -import Network.DNS.Encode import Test.Hspec +import Network.DNS +import Network.DNS.Imports + ---------------------------------------------------------------- -test_doublePointer :: BL.ByteString +test_doublePointer :: ByteString test_doublePointer = "f7eb8500000100010007000404736563330561706e696303636f6d0000010001c00c0001000100001c200004ca0c1c8cc0110002000100001c20000f036e73310561706e6963036e657400c0300002000100001c200006036e7333c040c0300002000100001c200006036e7334c040c0300002000100001c20001004736563310561706e696303636f6d00c0300002000100001c20001704736563310761757468646e730472697065036e657400c0300002000100001c20001004736563320561706e696303636f6d00c0300002000100001c2000070473656333c0bfc07b0001000100001c200004ca0c1d3bc07b001c000100001c20001020010dc02001000a4608000000000059c0ba0001000100001c200004ca0c1d3cc0d6001c000100001c20001020010dc0000100004777000000000140" +-- DNSMessage {header = DNSHeader {identifier = 63467, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = True, trunCation = False, recDesired = True, recAvailable = False, rcode = NoErr, authenData = False}}, question = [Question {qname = "sec3.apnic.com.", qtype = A}], answer = [ResourceRecord {rrname = "sec3.apnic.com.", rrtype = A, rrttl = 7200, rdata = 202.12.28.140}], authority = [ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = ns1.apnic.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = ns3.apnic.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = ns4.apnic.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec1.apnic.com.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec1.authdns.ripe.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec2.apnic.com.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec3.apnic.com.}], additional = [ResourceRecord {rrname = "sec1.apnic.com.", rrtype = A, rrttl = 7200, rdata = 202.12.29.59},ResourceRecord {rrname = "sec1.apnic.com.", rrtype = AAAA, rrttl = 7200, rdata = 2001:dc0:2001:a:4608::59},ResourceRecord {rrname = "sec2.apnic.com.", rrtype = A, rrttl = 7200, rdata = 202.12.29.60},ResourceRecord {rrname = "sec3.apnic.com.", rrtype = AAAA, rrttl = 7200, rdata = 2001:dc0:1:0:4777::140}]}) -test_txt :: BL.ByteString -test_txt = "463181800001000100000000076e69636f6c6173046b766462076e647072696d6102696f0000100001c00c0010000100000e10000c6e69636f6c61732e6b766462" +test_txt :: ByteString +test_txt = "463181800001000100000000076e69636f6c6173046b766462076e647072696d6102696f0000100001c00c0010000100000e10000d0c6e69636f6c61732e6b766462" +-- DNSMessage {header = DNSHeader {identifier = 17969, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = False, trunCation = False, recDesired = True, recAvailable = True, rcode = NoErr, authenData = False}} +-- , question = [Question {qname = "nicolas.kvdb.ndprima.io.", qtype = TXT}] +-- , answer = [ResourceRecord {rrname = "nicolas.kvdb.ndprima.io.", rrtype = TXT, rrttl = 3600, rdata = nicolas.kvdb}] +-- , authority = [] +-- , additional = []}) -test_dname :: BL.ByteString +test_dname :: ByteString test_dname = "b3c0818000010005000200010377777706376b616e616c02636f02696c0000010001c0100027000100000003000c0769737261656c3702727500c00c0005000100000003000603777777c02ec046000500010000255b0002c02ec02e000100010000003d000451daf938c02e000100010000003d0004c33ce84ac02e000200010005412b000c036e7332026137036f726700c02e000200010005412b0006036e7331c08a0000291000000000000000" +-- DNSMessage {header = DNSHeader {identifier = 46016, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = False, trunCation = False, recDesired = True, recAvailable = True, rcode = NoErr, authenData = False}}, question = [Question {qname = "www.7kanal.co.il.", qtype = A}], answer = [ResourceRecord {rrname = "7kanal.co.il.", rrtype = DNAME, rrttl = 3, rdata = israel7.ru.},ResourceRecord {rrname = "www.7kanal.co.il.", rrtype = CNAME, rrttl = 3, rdata = www.israel7.ru.},ResourceRecord {rrname = "www.israel7.ru.", rrtype = CNAME, rrttl = 9563, rdata = israel7.ru.},ResourceRecord {rrname = "israel7.ru.", rrtype = A, rrttl = 61, rdata = 81.218.249.56},ResourceRecord {rrname = "israel7.ru.", rrtype = A, rrttl = 61, rdata = 195.60.232.74}], authority = [ResourceRecord {rrname = "israel7.ru.", rrtype = NS, rrttl = 344363, rdata = ns2.a7.org.},ResourceRecord {rrname = "israel7.ru.", rrtype = NS, rrttl = 344363, rdata = ns1.a7.org.}], additional = [OptRecord {orudpsize = 4096, ordnssecok = False, orversion = 0, rdata = []}]}) +test_mx :: ByteString +test_mx = "f03681800001000100000001036d6577036f726700000f0001c00c000f000100000df10009000a046d61696cc00c0000291000000000000000" +-- DNSMessage {header = DNSHeader {identifier = 61494, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = False, trunCation = False, recDesired = True, recAvailable = True, rcode = NoErr, authenData = False}} +-- , question = [Question {qname = "mew.org.", qtype = MX}] +-- , answer = [ResourceRecord {rrname = "mew.org.", rrtype = MX, rrttl = 3569, rdata = 10 mail.mew.org.}] +-- , authority = [] +-- , additional = [OptRecord {orudpsize = 4096, ordnssecok = False, orversion = 0, rdata = []}]}) + +-- Message with question domain == SOA rname, testing correct decoding of +-- of the rname to presentation form when it encoded in compressed form +-- as a pointer to the question domain. +test_soa_in :: DNSMessage +test_soa_in = + let soard = RD_SOA "ns1.example.com." "hostmaster.example.com." 0 0 0 0 0 + soarr = ResourceRecord "example.com." SOA 1 3600 soard + in defaultResponse { question = [Question "hostmaster.example.com." A] + , authority = [soarr] } + +-- Expected decoded presentation form of the 'test_soa' message. +test_soa_out :: DNSMessage +test_soa_out = + let soard = RD_SOA "ns1.example.com." "hostmaster@example.com." 0 0 0 0 0 + soarr = ResourceRecord "example.com." SOA 1 3600 soard + in defaultResponse { question = [Question "hostmaster.example.com." A] + , authority = [soarr] } + +-- Expected compressed encoding of the 'test_soa' message +test_soa_bytes :: ByteString +test_soa_bytes = "0000858000010000000100000a686f73746d6173746572076578616d706c6503636f6d0000010001c0170006000100000e10001c036e7331c017c00c0000000000000000000000000000000000000000" + ---------------------------------------------------------------- spec :: Spec spec = do describe "decode" $ do - it "decodes double pointers correctly" $ do - let Right x1 = decode $ fromHexString test_doublePointer - Right x2 = decode (encode x1) - Right x3 = decode (encode x2) - x3 `shouldBe` x2 - it "decodes dname" $ do - let Right x1 = decode $ fromHexString test_dname - Right x2 = decode (encode x1) - Right x3 = decode (encode x2) - print x1 - x3 `shouldBe` x2 - it "decodes txt" $ do - let Right x1 = decode $ fromHexString test_txt - Right x2 = decode (encode x1) - Right x3 = decode (encode x2) - print x1 - x3 `shouldBe` x2 + it "decodes double pointers correctly" $ + tripleDecodeTest test_doublePointer + it "decodes dname" $ + tripleDecodeTest test_dname + it "decodes txt" $ + tripleDecodeTest test_txt + it "decodes mx" $ + tripleDecodeTest test_mx + it "detect excess" $ + case decode (encode defaultQuery <> "\0") of + Left (DecodeError {}) -> True + _ -> error "Excess input not detected" + it "detect truncation" $ + case decode (BC.init $ encode defaultQuery) of + Left (DecodeError {}) -> True + _ -> error "Excess input not detected" + it "soa mailbox presentation form" $ + case encode test_soa_in of + enc | enc /= fromHexString test_soa_bytes + -> error "Unexpected test_soa encoding" + | otherwise -> case decode enc of + Left err -> error $ "Error decoding test_soa: " ++ show err + Right m | m /= test_soa_out + -> error $ "Wrong decode of test_soa: " ++ show m + | otherwise -> True ----------------------------------------------------------------- +tripleDecodeTest :: ByteString -> IO () +tripleDecodeTest hexbs = + ecase (decode $ fromHexString hexbs) fail' $ \ x1 -> + ecase (decode $ encode x1) fail' $ \ x2 -> + ecase (decode $ encode x2) fail' $ \ x3 -> + x3 `shouldBe` x2 + where + fail' (DecodeError err) = fail err + fail' _ = error "fail'" -fromHexString :: BL.ByteString -> BL.ByteString -#if MIN_VERSION_bytestring(0,10,0) -fromHexString = BL.fromStrict . fromHexString' . BL.toStrict -#else -fromHexString = BL.pack . BS.unpack . fromHexString' . BS.pack . BL.unpack -#endif +ecase :: Either a b -> (a -> c) -> (b -> c) -> c +ecase (Left a) f _ = f a +ecase (Right b) _ g = g b -fromHexString' :: ByteString -> ByteString -fromHexString' (PS fptr off len) = unsafeCreate size $ \dst -> +---------------------------------------------------------------- + +fromHexString :: ByteString -> ByteString +fromHexString (PS fptr off len) = unsafeCreate size $ \dst -> withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0 where size = len `div` 2 diff --git a/test/EncodeSpec.hs b/test/EncodeSpec.hs --- a/test/EncodeSpec.hs +++ b/test/EncodeSpec.hs @@ -3,10 +3,10 @@ module EncodeSpec where import Data.IP -import Network.DNS -import Network.DNS.Internal (defaultQuery, makeQuestion) import Test.Hspec +import Network.DNS + spec :: Spec spec = do describe "encode" $ do @@ -44,15 +44,15 @@ header = defaultHeader { identifier = 1000 } - , question = [makeQuestion "www.mew.org." A] + , question = [Question "www.mew.org." A] } testQueryAAAA :: DNSMessage testQueryAAAA = defaultQuery { header = defaultHeader { - identifier = 1000 + identifier = 1001 } - , question = [makeQuestion "www.mew.org." AAAA] + , question = [Question "www.mew.org." AAAA] } testResponseA :: DNSMessage @@ -68,100 +68,35 @@ , recAvailable = True , rcode = NoErr , authenData = False + , chkDisable = False } } + , ednsHeader = NoEDNS , question = [Question { qname = "492056364.qzone.qq.com." , qtype = A } ] - , answer = [ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [119, 147, 15, 122] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [119, 147, 79, 106] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [183, 60, 55, 43] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [183, 60, 55, 107] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [113, 108, 7, 172] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [113, 108, 7, 174] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [113, 108, 7, 175] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [119, 147, 15, 100] - } - ] - , authority = [ ResourceRecord { - rrname = "qzone.qq.com." - , rrtype = NS - , rrttl = 45919 - , rdata = RD_NS "ns-tel2.qq.com." - } - , ResourceRecord { - rrname = "qzone.qq.com." - , rrtype = NS - , rrttl = 45919 - , rdata = RD_NS "ns-tel1.qq.com." - } - ] - , additional = [ ResourceRecord { - rrname = "ns-tel1.qq.com." - , rrtype = A - , rrttl = 46520 - , rdata = RD_A $ toIPv4 [121, 14, 73, 115] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [222, 73, 76, 226] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [183, 60, 3, 202] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [218, 30, 72, 180] - } - ] + , answer = + [ ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [119, 147, 15, 122]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [119, 147, 79, 106]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [183, 60, 55, 43]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [183, 60, 55, 107]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [113, 108, 7, 172]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [113, 108, 7, 174]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [113, 108, 7, 175]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [119, 147, 15, 100]) + ] + , authority = + [ ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel2.qq.com.") + , ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel1.qq.com.") + ] + , additional = + [ ResourceRecord "ns-tel1.qq.com." A classIN 46520 (RD_A $ toIPv4 [121, 14, 73, 115]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [222, 73, 76, 226]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [183, 60, 3, 202]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [218, 30, 72, 180]) + ] } testResponseTXT :: DNSMessage @@ -177,56 +112,26 @@ , recAvailable = True , rcode = NoErr , authenData = False + , chkDisable = False } } + , ednsHeader = EDNSheader defaultEDNS , question = [Question { qname = "492056364.qzone.qq.com." , qtype = TXT } ] - , answer = [ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = TXT - , rrttl = 0 - , rdata = RD_TXT "simple txt line" - } - ] - , authority = [ ResourceRecord { - rrname = "qzone.qq.com." - , rrtype = NS - , rrttl = 45919 - , rdata = RD_NS "ns-tel2.qq.com." - } - , ResourceRecord { - rrname = "qzone.qq.com." - , rrtype = NS - , rrttl = 45919 - , rdata = RD_NS "ns-tel1.qq.com." - } - ] - , additional = [ ResourceRecord { - rrname = "ns-tel1.qq.com." - , rrtype = A - , rrttl = 46520 - , rdata = RD_A $ toIPv4 [121, 14, 73, 115] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [222, 73, 76, 226] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [183, 60, 3, 202] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [218, 30, 72, 180] - } - ] + , answer = + [ ResourceRecord "492056364.qzone.qq.com." TXT classIN 0 (RD_TXT "simple txt line") + ] + , authority = + [ ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel2.qq.com.") + , ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel1.qq.com.") + ] + , additional = + [ ResourceRecord "ns-tel1.qq.com." A classIN 46520 (RD_A $ toIPv4 [121, 14, 73, 115]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [222, 73, 76, 226]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [183, 60, 3, 202]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [218, 30, 72, 180]) + ] } diff --git a/test/RoundTripSpec.hs b/test/RoundTripSpec.hs new file mode 100644 --- /dev/null +++ b/test/RoundTripSpec.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE OverloadedStrings, TransformListComp #-} + +module RoundTripSpec where + +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 qualified Data.CaseInsensitive as CI +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck (Gen, arbitrary, elements, forAll, frequency, listOf, oneof) +import GHC.Exts (the, groupWith) + +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 + prop "IPv4" . forAll genIPv4 $ \ ip4 -> do + let str = show ip4 + read str `shouldBe` ip4 + show (read str :: IPv4) `shouldBe` str + + prop "IPv6" . forAll genIPv6 $ \ ip6 -> do + let str = show ip6 + read str `shouldBe` ip6 + show (read str :: IPv6) `shouldBe` str + + prop "TYPE" . forAll genTYPE $ \ t -> + toTYPE (fromTYPE t) `shouldBe` t + + prop "Domain" . forAll genDomain $ \ dom -> do + let bs = encodeDomain dom + decodeDomain bs `shouldBe` Right dom + fmap encodeDomain (decodeDomain bs) `shouldBe` Right bs + + prop "Mailbox" . forAll genMailbox $ \ dom -> do + let bs = encodeMailbox dom + decodeMailbox bs `shouldBe` Right dom + fmap encodeMailbox (decodeMailbox bs) `shouldBe` Right bs + + prop "DNSFlags" . forAll (genDNSFlags 0x0f) $ \ flgs -> do + let bs = encodeDNSFlags flgs + decodeDNSFlags bs `shouldBe` Right flgs + fmap encodeDNSFlags (decodeDNSFlags bs) `shouldBe` Right bs + + prop "ResourceRecord" . forAll genResourceRecord $ \ rr -> do + let bs = encodeResourceRecord rr + decodeResourceRecord bs `shouldBe` Right rr + fmap encodeResourceRecord (decodeResourceRecord bs) `shouldBe` Right bs + + prop "DNSHeader" . forAll (genDNSHeader 0x0f) $ \ hdr -> + decodeDNSHeader (encodeDNSHeader hdr) `shouldBe` Right hdr + + prop "DNSMessage" . forAll genDNSMessage $ \ msg -> + decode (encode msg) `shouldBe` Right msg + + prop "EDNS" . forAll genEDNSHeader $ \(edns, hdr) -> do + let eh = EDNSheader edns + Right m = decode. encode $ DNSMessage hdr eh [] [] [] [] + ednsHeader m `shouldBe` eh + +---------------------------------------------------------------- + +genDNSMessage :: Gen DNSMessage +genDNSMessage = + DNSMessage <$> genDNSHeader 0x0f <*> makeEDNS <*> listOf genQuestion + <*> listOf genResourceRecord <*> listOf genResourceRecord + <*> listOf genResourceRecord + where + makeEDNS :: Gen EDNSheader + makeEDNS = genBool >>= \t -> + if t then EDNSheader <$> genEDNS + else pure NoEDNS + + +genQuestion :: Gen Question +genQuestion = Question <$> genDomain <*> genTYPE + +genTYPE :: Gen TYPE +genTYPE = frequency + [ (20, elements + [ A, AAAA, NS, TXT, MX, CNAME, SOA, PTR, SRV, DNAME, OPT, DS, RRSIG + , NSEC, DNSKEY, NSEC3, NSEC3PARAM, TLSA, CDS, CDNSKEY, CSYNC + ]) + , (1, toTYPE <$> genWord16) + ] + +genResourceRecord :: Gen ResourceRecord +genResourceRecord = frequency + [ (8, genRR) + ] + where + genRR = do + dom <- genDomain + t <- elements [A, AAAA, NS, TXT, MX, CNAME, SOA, PTR, SRV, DNAME, DS, + TLSA, NSEC, NSEC3] + ResourceRecord dom t classIN <$> genWord32 <*> mkRData dom t + +mkRData :: Domain -> TYPE -> Gen RData +mkRData dom typ = + case typ of + A -> RD_A <$> genIPv4 + AAAA -> RD_AAAA <$> genIPv6 + NS -> pure $ RD_NS dom + TXT -> RD_TXT <$> genTextString + MX -> RD_MX <$> genWord16 <*> genDomain + CNAME -> pure $ RD_CNAME dom + SOA -> RD_SOA dom <$> genMailbox <*> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 + PTR -> RD_PTR <$> genDomain + SRV -> RD_SRV <$> genWord16 <*> genWord16 <*> genWord16 <*> genDomain + DNAME -> RD_DNAME <$> genDomain + DS -> RD_DS <$> genWord16 <*> genWord8 <*> genWord8 <*> genByteString + NSEC -> RD_NSEC <$> genDomain <*> genNsecTypes + NSEC3 -> genNSEC3 + TLSA -> RD_TLSA <$> genWord8 <*> genWord8 <*> genWord8 <*> genByteString + CAA -> RD_CAA <$> genWord8 <*> (CI.mk <$> genByteString) <*> genByteString + + _ -> pure . RD_TXT $ "Unhandled type " <> BS.pack (show typ) + where + genNSEC3 = do + (alg, hlen) <- elements [(1,32),(2,64)] + flgs <- elements [0,1] + iter <- elements [0..100] + salt <- elements ["", "AB"] + hash <- B.pack <$> replicateM hlen genWord8 + RD_NSEC3 alg flgs iter salt hash <$> genNsecTypes + genTextString = do + len <- elements [0, 1, 63, 255, 256, 511, 512, 1023, 1024] + B.pack <$> replicateM len genWord8 + genNsecTypes = do + ntypes <- elements [0..15] + types <- sequence $ replicate ntypes $ toTYPE <$> elements [1..1024] + return $ [ the t | + t <- types, + then group by (fromTYPE t) + using groupWith ] + +genIPv4 :: Gen IPv4 +genIPv4 = toIPv4 <$> replicateM 4 (fromIntegral <$> genWord8) + +genIPv6 :: Gen IPv6 +genIPv6 = toIPv6 <$> replicateM 8 (fromIntegral <$> genWord16) + +genByteString :: Gen BS.ByteString +genByteString = elements + [ "", "a", "a.b", "abc", "a.b.c", "a\\.b.c", "\\001.a.b", "\\$.a.b" ] + +genMboxString :: Gen BS.ByteString +genMboxString = elements + [ "", "a", "a@b", "abc", "a@b.c", "first.last@example.org" ] + +genDomain :: Gen Domain +genDomain = do + bs <- genByteString + pure $ bs <> "." + +genMailbox :: Gen Mailbox +genMailbox = do + bs <- genMboxString + pure $ bs <> "." + +genDNSHeader :: Word16 -> Gen DNSHeader +genDNSHeader maxrc = DNSHeader <$> genWord16 <*> genDNSFlags maxrc + +genDNSFlags :: Word16 -> Gen DNSFlags +genDNSFlags maxrc = + DNSFlags <$> genQorR <*> genOPCODE <*> genBool <*> genBool + <*> genBool <*> genBool <*> genRCODE maxrc <*> genBool <*> genBool + +genWord16 :: Gen Word16 +genWord16 = arbitrary + +genWord32 :: Gen Word32 +genWord32 = arbitrary + +genWord8 :: Gen Word8 +genWord8 = arbitrary + +genBool :: Gen Bool +genBool = elements [True, False] + +genQorR :: Gen QorR +genQorR = elements [minBound .. maxBound] + +genOPCODE :: Gen OPCODE +genOPCODE = elements [OP_STD, OP_INV, OP_SSR, OP_NOTIFY, OP_UPDATE] + +genRCODE :: Word16 -> Gen RCODE +genRCODE maxrc = elements $ map toRCODE [0..maxrc] + +genEDNS :: Gen EDNS +genEDNS = do + vers <- genWord8 + ok <- genBool + od <- genOData + us <- elements [minUdpSize..maxUdpSize] + return $ defaultEDNS { + ednsVersion = vers + , ednsUdpSize = us + , ednsDnssecOk = ok + , ednsOptions = [od] + } + +genOData :: Gen OData +genOData = oneof + [ genOD_Unknown + , genOD_ECS + ] + where + -- | Choose from the range reserved for local use + -- https://tools.ietf.org/html/rfc6891#section-9 + genOD_Unknown = UnknownOData <$> elements [65001, 65534] <*> genByteString + + -- | Only valid ECS prefixes round-trip, make sure the prefix is + -- is consistent with the mask. + genOD_ECS = do + usev4 <- genBool + if usev4 + then genFuzzed genIPv4 IPv4 Data.IP.fromIPv4 1 32 + else genFuzzed genIPv6 IPv6 Data.IP.fromIPv6b 2 128 + where + genFuzzed :: Addr a + => Gen a + -> (a -> IP) + -> (a -> [Int]) + -> Word16 + -> Word8 + -> Gen OData + genFuzzed gen toIP toBytes fam alen = do + ip <- gen + bits1 <- elements [1 .. alen] + bits2 <- elements [0 .. alen] + fuzzSrcBits <- genBool + fuzzScpBits <- genBool + srcBits <- if not fuzzSrcBits + then pure bits1 + else flip mod alen. (+) bits1 <$> elements [1..alen-1] + scpBits <- if not fuzzScpBits + then pure bits2 + else elements [alen+1 .. 0xFF] + let addr = Data.IP.addr. makeAddrRange ip $ fromIntegral bits1 + bytes = map fromIntegral $ toBytes addr + len = (fromIntegral bits1 + 7) `div` 8 + less = take (len - 1) bytes + more = less ++ [0xFF] + if srcBits == bits1 + then if scpBits == bits2 + then pure $ OD_ClientSubnet bits1 scpBits $ toIP addr + else pure $ OD_ECSgeneric fam bits1 scpBits $ B.pack bytes + else if srcBits < bits1 + then pure $ OD_ECSgeneric fam srcBits scpBits $ B.pack more + else pure $ OD_ECSgeneric fam srcBits scpBits $ B.pack less + +genExtRCODE :: Gen RCODE +genExtRCODE = elements $ map toRCODE [0..4095] + +genEDNSHeader :: Gen (EDNS, DNSHeader) +genEDNSHeader = do + edns <- genEDNS + hdr <- genDNSHeader 0xF00 + return (edns, hdr) diff --git a/test2/IOSpec.hs b/test2/IOSpec.hs new file mode 100644 --- /dev/null +++ b/test2/IOSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IOSpec where + +import Network.Socket hiding (send) +import Test.Hspec + +import Network.DNS.IO as DNS +import Network.DNS.Imports +import Network.DNS.Types as DNS + +spec :: Spec +spec = describe "send/receive" $ do + + it "resolves well with UDP" $ do + sock <- connectedSocket Datagram + -- Google's resolvers support the AD and CD bits + let qry = encodeQuestion 1 (Question "www.mew.org" A) $ + adFlag FlagSet <> ednsEnabled FlagClear + send sock qry + ans <- receive sock + identifier (header ans) `shouldBe` 1 + + it "resolves well with TCP" $ do + sock <- connectedSocket Stream + let qry = encodeQuestion 1 (Question "www.mew.org" A) $ + adFlag FlagClear <> cdFlag FlagSet <> doFlag FlagSet + sendVC sock qry + ans <- receiveVC sock + identifier (header ans) `shouldBe` 1 + +connectedSocket :: SocketType -> IO Socket +connectedSocket typ = do + let hints = defaultHints { addrFamily = AF_INET, addrSocketType = typ, addrFlags = [AI_NUMERICHOST]} + addr:_ <- getAddrInfo (Just hints) (Just "8.8.8.8") (Just "domain") + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + connect sock $ addrAddress addr + return sock diff --git a/test2/LookupSpec.hs b/test2/LookupSpec.hs --- a/test2/LookupSpec.hs +++ b/test2/LookupSpec.hs @@ -2,17 +2,58 @@ module LookupSpec where -import Network.DNS as DNS import Test.Hspec +import Network.DNS as DNS + spec :: Spec -spec = do +spec = describe "lookup" $ do - describe "lookupAAAA" $ do - it "gets IPv6 addresses" $ do - rs <- makeResolvSeed defaultResolvConf - withResolver rs $ \resolver -> do - DNS.lookupAAAA resolver "mew.org" - `shouldReturn` - Right [] + it "lookupA" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupA resolver "mew.org" + -- mew.org has one or more IPv6 addresses + fmap null addrs `shouldBe` Right False + it "lookupAAAA" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + -- google.com has one or more IPv6 addresses + addrs <- DNS.lookupAAAA resolver "google.com" + fmap null addrs `shouldBe` Right False + + it "lookupAAAA with emty result" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupAAAA resolver "ipv4.tlund.se" + -- mew.org does not have any IPv6 addresses + fmap null addrs `shouldBe` Right True + + it "lookupMX" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupMX resolver "mew.org" + -- mew.org has one or more MX records. + fmap null addrs `shouldBe` Right False + + it "lookupTXT" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupTXT resolver "mew.org" + -- mew.org has one or more TXT records. + fmap null addrs `shouldBe` Right False + + it "lookupSOA" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupTXT resolver "mew.org" + -- mew.org has a SOA record. + fmap null addrs `shouldBe` Right False + + it "lookupNS" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupNS resolver "mew.org" + -- mew.org has one or more NS records. + fmap null addrs `shouldBe` Right False diff --git a/test2/doctests.hs b/test2/doctests.hs deleted file mode 100644 --- a/test2/doctests.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Main where - -import Test.DocTest - -main :: IO () -main = doctest [ - "-XOverloadedStrings" - {- - Both 'iproute' and 'network-data' provide - ‘Data.IP’ package: - Ambiguous interface for ‘Data.IP’: - it was found in multiple packages: network-data-0.5.3 iproute-1.7.0 - We ignore network-data to make tests pass. - -} - , "-ignore-package=network-data" - , "Network/DNS.hs" - ]