dns-4.1.1/0000755000000000000000000000000007346545000010472 5ustar0000000000000000dns-4.1.1/Changelog.md0000644000000000000000000003115507346545000012710 0ustar0000000000000000# ChangeLog ## 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 dns-4.1.1/LICENSE0000644000000000000000000000276507346545000011511 0ustar0000000000000000Copyright (c) 2009, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. dns-4.1.1/Network/0000755000000000000000000000000007346545000012123 5ustar0000000000000000dns-4.1.1/Network/DNS.hs0000644000000000000000000000323007346545000013101 0ustar0000000000000000-- | A thread-safe DNS library for both clients and servers written -- in pure Haskell. -- The Network.DNS module re-exports all other exposed modules for -- convenience. -- Applications will most likely use the high-level interface, while -- library/daemon authors may need to use the lower-level one. -- EDNS and TCP fallback are supported. -- -- Examples: -- -- >>> 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 -- | 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 -- | Resolver related data types. , module Network.DNS.Types -- | All of the types that the other modules use. , module Network.DNS.Utils -- | This module contains utility functions used -- for processing DNS data. -- * Middle level , module Network.DNS.LookupRaw -- | This provides the 'lookup', 'lookupAuth', 'lookupRaw' and -- 'lookupRawCtl' functions for any resource records. -- * Low level , module Network.DNS.Encode -- | Encoding a query or response. , 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.Types import Network.DNS.Utils dns-4.1.1/Network/DNS/0000755000000000000000000000000007346545000012547 5ustar0000000000000000dns-4.1.1/Network/DNS/Decode.hs0000644000000000000000000001141407346545000014267 0ustar0000000000000000-- | 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 ( -- * Decoding a single DNS message decodeAt , decode -- * Decoding multple length-encoded DNS messages, -- e.g., from TCP traffic. , decodeManyAt , decodeMany ) where import qualified Data.ByteString as B 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 -- | 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 -- | 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 -- | 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 decoder bss return (msgs, leftovers) where -- Read a list of length-encoded bytestrings lengthEncoded :: SGet [ByteString] lengthEncoded = many $ getInt16 >>= getNByteString dns-4.1.1/Network/DNS/Encode.hs0000644000000000000000000000274607346545000014311 0ustar0000000000000000-- | 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 ) where import Network.DNS.Imports import Network.DNS.StateBinary 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 = runSPut . putDNSMessage dns-4.1.1/Network/DNS/IO.hs0000644000000000000000000001673007346545000013421 0ustar0000000000000000{-# 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 dns-4.1.1/Network/DNS/Lookup.hs0000644000000000000000000004052107346545000014356 0ustar0000000000000000-- | Simple, high-level DNS lookup functions for clients. -- -- 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, -- will return a list of 'IPv4'. The 'lookupMX' function will -- 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 -- lookups. If you require consistent results, apply -- 'Data.List.sort' to the returned list. -- -- The errors that can occur are the same for all lookups. Namely: -- -- * Timeout -- -- * Wrong sequence number (foul play?) -- -- * Unexpected data in the response -- -- If an error occurs, you should be able to pattern match on the -- 'DNSError' constructor to determine which of these is the case. -- -- /Note/: A result of \"no records\" is not considered an -- error. If you perform, say, an \'AAAA\' lookup for a domain with -- no such records, the \"success\" result would be @Right []@. -- -- We perform a successful lookup of \"www.example.com\": -- -- >>> let hostname = Data.ByteString.Char8.pack "www.example.com" -- >>> -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupA resolver hostname -- Right [93.184.216.34] -- -- The only error that we can easily cause is a timeout. We do this -- 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 = 0, resolvRetry = 1 } -- >>> -- >>> rs <- makeResolvSeed badrc -- >>> withResolver rs $ \resolver -> lookupA resolver hostname -- Left RetryLimitExceeded -- -- As is the convention, successful results will always be wrapped -- in a 'Right' while errors will be wrapped in a 'Left'. -- -- 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. 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 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.Internal ---------------------------------------------------------------- -- | Look up all \'A\' records for the given hostname. -- -- A straightforward example: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> 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 queried hostname: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupA resolver "www.kame.net" -- Right [210.155.141.200] -- lookupA :: Resolver -> Domain -> IO (Either DNSError [IPv4]) lookupA rlv dom = do erds <- DNS.lookup rlv dom A 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 IPv4 unTag (RD_A x) = Right x unTag _ = Left UnexpectedRDATA -- | Look up all (IPv6) \'AAAA\' records for the given hostname. -- -- Examples: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> 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 erds <- DNS.lookup rlv dom AAAA 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 IPv6 unTag (RD_AAAA x) = Right x unTag _ = Left UnexpectedRDATA ---------------------------------------------------------------- -- | Look up all \'MX\' records for the given hostname. Two parts -- 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 an RFC7505 NULL MX (to prevent a deluge of spam from examples -- posted on the internet). -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupMX resolver "example.com" -- Right [(".",0)] -- -- -- The domain \"mew.org\" does however have a single MX: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \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. -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupMX resolver "mail.mew.org" -- Right [] -- lookupMX :: Resolver -> Domain -> IO (Either DNSError [(Domain,Int)]) lookupMX rlv dom = do erds <- DNS.lookup rlv dom MX 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,Int) unTag (RD_MX pr dm) = Right (dm, fromIntegral pr) unTag _ = Left UnexpectedRDATA -- | Look up all \'MX\' records for the given hostname, and then -- resolve their hostnames to IPv4 addresses by calling -- 'lookupA'. The priorities are not retained. -- -- Examples: -- -- >>> import Data.List (sort) -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> ips <- withResolver rs $ \resolver -> lookupAviaMX resolver "wide.ad.jp" -- >>> fmap sort ips -- 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. -- lookupAviaMX :: Resolver -> Domain -> IO (Either DNSError [IPv4]) lookupAviaMX rlv dom = lookupXviaMX rlv dom (lookupA rlv) -- | Look up all \'MX\' records for the given hostname, and then -- resolve their hostnames to IPv6 addresses by calling -- 'lookupAAAA'. The priorities are not retained. -- lookupAAAAviaMX :: Resolver -> Domain -> IO (Either DNSError [IPv6]) lookupAAAAviaMX rlv dom = lookupXviaMX rlv dom (lookupAAAA rlv) lookupXviaMX :: Resolver -> Domain -> (Domain -> IO (Either DNSError [a])) -> IO (Either DNSError [a]) lookupXviaMX rlv dom func = do edps <- lookupMX rlv dom case edps of -- We have to deconstruct and reconstruct the error so that the -- typechecker does not conclude that a ~ (Domain, Int). Left err -> return (Left err) Right dps -> do -- We'll get back a [Either DNSError a] here. responses <- mapM (func . fst) dps -- We can use 'sequence' to join all of the Eithers -- together. If any of them are (Left _), we'll get a Left -- overall. Otherwise, we'll get Right [a]. let overall = sequence responses -- Finally, we use (fmap concat) to concatenate the responses -- if there were no errors. return $ fmap concat overall ---------------------------------------------------------------- -- | This function performs the real work for both 'lookupNS' and -- 'lookupNSAuth'. The only difference between those two is which -- function, 'lookup' or 'lookupAuth', is used to perform the -- lookup. We take either of those as our first parameter. lookupNSImpl :: (Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])) -> Resolver -> Domain -> IO (Either DNSError [Domain]) lookupNSImpl lookup_function rlv dom = do erds <- lookup_function rlv dom NS 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 unTag (RD_NS dm) = Right dm unTag _ = Left UnexpectedRDATA -- | Look up all \'NS\' records for the given hostname. The results -- are taken from the ANSWER section of the response (as opposed to -- AUTHORITY). For details, see e.g. -- . -- -- There will typically be more than one name server for a -- domain. It is therefore extra important to sort the results if -- you prefer them to be at all deterministic. -- -- Examples: -- -- >>> import Data.List (sort) -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> ns <- withResolver rs $ \resolver -> lookupNS resolver "mew.org" -- >>> fmap sort ns -- Right ["ns1.mew.org.","ns2.mew.org."] -- lookupNS :: Resolver -> Domain -> IO (Either DNSError [Domain]) lookupNS = lookupNSImpl DNS.lookup -- | Look up all \'NS\' records for the given hostname. The results -- are taken from the AUTHORITY section of the response and not the -- usual ANSWER (use 'lookupNS' for that). For details, see e.g. -- . -- -- There will typically be more than one name server for a -- domain. It is therefore extra important to sort the results if -- you prefer them to be at all deterministic. -- -- For an example, we can look up the nameservers for -- \"example.com\" from one of the root servers, a.gtld-servers.net, -- the IP address of which was found beforehand: -- -- >>> import Data.List (sort) -- >>> 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 "example.com" -- >>> fmap sort ns -- Right ["a.iana-servers.net.","b.iana-servers.net."] -- lookupNSAuth :: Resolver -> Domain -> IO (Either DNSError [Domain]) lookupNSAuth = lookupNSImpl DNS.lookupAuth ---------------------------------------------------------------- -- | Look up all \'TXT\' records for the given hostname. The results -- are free-form 'ByteString's. -- -- Two common uses for \'TXT\' records are -- and -- . As an -- example, we find the SPF record for \"mew.org\": -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupTXT resolver "mew.org" -- Right ["v=spf1 +mx -all"] -- lookupTXT :: Resolver -> Domain -> IO (Either DNSError [ByteString]) lookupTXT rlv dom = do erds <- DNS.lookup rlv dom TXT 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 ByteString unTag (RD_TXT x) = Right x unTag _ = Left UnexpectedRDATA ---------------------------------------------------------------- -- | 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.\" -- -- We look up the PTR associated with the IP address -- 210.130.137.80, i.e., 80.137.130.210.in-addr.arpa: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> 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. -- lookupPTR :: Resolver -> Domain -> IO (Either DNSError [Domain]) lookupPTR rlv dom = do erds <- DNS.lookup rlv dom PTR 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 unTag (RD_PTR dm) = Right dm unTag _ = Left UnexpectedRDATA -- | Convenient wrapper around 'lookupPTR' to perform a reverse lookup -- on a single IP address. -- -- We repeat the example from 'lookupPTR', except now we pass the IP -- address directly: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupRDNS resolver "202.232.2.180" -- Right ["www.iij.ad.jp."] -- lookupRDNS :: Resolver -> Domain -> IO (Either DNSError [Domain]) lookupRDNS rlv ip = lookupPTR rlv dom where -- ByteString constants. dot = BS.pack "." suffix = BS.pack ".in-addr.arpa" octets = BS.split '.' ip reverse_ip = BS.intercalate dot (reverse octets) dom = reverse_ip `BS.append` suffix ---------------------------------------------------------------- -- | Look up all \'SRV\' records for the given hostname. SRV records -- consist (see ) of the -- following four fields: -- -- * Priority (lower is more-preferred) -- -- * Weight (relative frequency with which to use this record -- amongst all results with the same priority) -- -- * Port (the port on which the service is offered) -- -- * Target (the hostname on which the service is offered) -- -- The first three are integral, and the target is another DNS -- hostname. We therefore return a four-tuple -- @(Int,Int,Int,'Domain')@. -- -- Examples: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupSRV resolver "_xmpp-server._tcp.jabber.ietf.org" -- Right [(5,0,5269,"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 -- example only works when connected to the Internet. Perhaps the above -- example should be displayed in a format that is not recognized as a test -- by "doctest". lookupSRV :: Resolver -> Domain -> IO (Either DNSError [(Word16, Word16, Word16, Domain)]) lookupSRV rlv dom = do erds <- DNS.lookup rlv dom SRV 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 (Word16, Word16, Word16, Domain) unTag (RD_SRV pri wei prt dm) = Right (pri,wei,prt,dm) unTag _ = Left UnexpectedRDATA dns-4.1.1/Network/DNS/LookupRaw.hs0000644000000000000000000002577407346545000015045 0ustar0000000000000000{-# 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 dns-4.1.1/Network/DNS/Resolver.hs0000644000000000000000000000721007346545000014704 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} -- | Resolver related data types. module Network.DNS.Resolver ( -- * 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 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 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: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- makeResolvSeed :: ResolvConf -> IO ResolvSeed makeResolvSeed conf = ResolvSeed conf <$> findAddresses where 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 let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE] , addrSocketType = Datagram } -- 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. withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a 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. For each 'Resolver', multiple lookups must be done -- sequentially. 'Resolver's can be used concurrently. withResolvers :: [ResolvSeed] -> ([Resolver] -> IO a) -> IO a withResolvers seeds f = mapM makeResolver seeds >>= f 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 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) dns-4.1.1/Network/DNS/Transport.hs0000644000000000000000000002165607346545000015111 0ustar0000000000000000{-# 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 dns-4.1.1/Network/DNS/Types.hs0000644000000000000000000000364407346545000014216 0ustar0000000000000000-- | Data types for DNS Query and Response. -- For more information, see . module Network.DNS.Types ( -- * Resource Records ResourceRecord (..) , Answers , AuthorityRecords , AdditionalRecords -- ** Types , Domain , CLASS , classIN , TTL -- ** Resource Record Types , TYPE ( A , NS , CNAME , SOA , NULL , PTR , MX , TXT , AAAA , SRV , DNAME , OPT , DS , RRSIG , NSEC , DNSKEY , NSEC3 , NSEC3PARAM , TLSA , CDS , CDNSKEY , CSYNC , AXFR , ANY , CAA ) , fromTYPE , toTYPE -- ** Resource Data , RData (..) , RD_RRSIG(..) , dnsTime -- * DNS Message , DNSMessage (..) -- ** Query , makeQuery , makeEmptyQuery , defaultQuery -- ** Query Controls , QueryControls , rdFlag , adFlag , cdFlag , doFlag , ednsEnabled , ednsSetVersion , ednsSetUdpSize , ednsSetOptions -- *** Flag and OData control operations , FlagOp(..) , ODataOp(..) -- ** Response , defaultResponse , makeResponse -- ** DNS Header , DNSHeader (..) , Identifier -- *** DNS flags , DNSFlags (..) , QorR (..) , defaultDNSFlags -- *** OPCODE and RCODE , OPCODE (..) , fromOPCODE , toOPCODE , RCODE ( NoErr , FormatErr , ServFail , NameErr , NotImpl , Refused , YXDomain , YXRRSet , NXRRSet , NotAuth , NotZone , BadVers , BadKey , BadTime , BadMode , BadName , BadAlg , BadTrunc , BadCookie , BadRCODE ) , fromRCODE , toRCODE -- ** EDNS Pseudo-Header , EDNSheader(..) , ifEDNS , mapEDNS -- *** EDNS record , EDNS(..) , defaultEDNS , maxUdpSize , minUdpSize -- *** EDNS options , OData (..) , OptCode ( ClientSubnet , DAU , DHU , N3U , NSID ) , fromOptCode , toOptCode -- ** DNS Body , Question (..) -- * DNS Error , DNSError (..) -- * Other types , Mailbox ) where import Network.DNS.Types.Internal dns-4.1.1/Network/DNS/Utils.hs0000644000000000000000000001363007346545000014206 0ustar0000000000000000-- | Miscellaneous utility functions for processing DNS data. -- module Network.DNS.Utils ( normalize , normalizeCase , normalizeRoot , splitDomain , splitMailbox ) where import qualified Data.ByteString.Char8 as BS import Data.Char (toLower) import Network.DNS.Types.Internal (DNSError, Domain, Mailbox) import Network.DNS.StateBinary (parseLabel) -- | Perform both 'normalizeCase' and 'normalizeRoot' on the given -- 'Domain'. When comparing DNS names taken from user input, this is -- often necessary to avoid unexpected results. -- -- /Examples/: -- -- >>> let domain1 = BS.pack "ExAmPlE.COM" -- >>> let domain2 = BS.pack "example.com." -- >>> domain1 == domain2 -- False -- >>> normalize domain1 == normalize domain2 -- True -- -- The 'normalize' function should be idempotent: -- -- >>> normalize (normalize domain1) == normalize domain1 -- True -- -- Ensure that we don't crash on the empty 'Domain': -- -- >>> import qualified Data.ByteString.Char8 as BS -- >>> normalize BS.empty -- "." -- normalize :: Domain -> Domain normalize = normalizeCase . normalizeRoot -- | Normalize the case of the given DNS name for comparisons. -- -- According to RFC #1035, \"For all parts of the DNS that are part -- of the official protocol, all comparisons between character -- strings (e.g., labels, domain names, etc.) are done in a -- case-insensitive manner.\" This function chooses to lowercase -- its argument, but that should be treated as an implementation -- detail if at all possible. -- -- /Examples/: -- -- >>> let domain1 = BS.pack "ExAmPlE.COM" -- >>> let domain2 = BS.pack "exAMPle.com" -- >>> domain1 == domain2 -- False -- >>> normalizeCase domain1 == normalizeCase domain2 -- True -- -- The 'normalizeCase' function should be idempotent: -- -- >>> normalizeCase (normalizeCase domain2) == normalizeCase domain2 -- True -- -- Ensure that we don't crash on the empty 'Domain': -- -- >>> import qualified Data.ByteString.Char8 as BS -- >>> normalizeCase BS.empty -- "" -- normalizeCase :: Domain -> Domain normalizeCase = BS.map toLower -- | Normalize the given name by appending a trailing dot (the DNS -- root) if one does not already exist. -- -- Warning: this does not produce an equivalent DNS name! However, -- users are often unaware of the effect that the absence of the -- root will have. In user interface design, it may therefore be -- wise to act as if the user supplied the trailing dot during -- comparisons. -- -- Per RFC #1034, -- -- \"Since a complete domain name ends with the root label, this leads -- to a printed form which ends in a dot. We use this property to -- distinguish between: -- -- * a character string which represents a complete domain name -- (often called \'absolute\'). For example, \'poneria.ISI.EDU.\' -- -- * a character string that represents the starting labels of a -- domain name which is incomplete, and should be completed by -- local software using knowledge of the local domain (often -- called \'relative\'). For example, \'poneria\' used in the -- ISI.EDU domain. -- -- Relative names are either taken relative to a well known origin, -- or to a list of domains used as a search list. Relative names -- appear mostly at the user interface, where their interpretation -- varies from implementation to implementation, and in master -- files, where they are relative to a single origin domain name.\" -- -- /Examples/: -- -- >>> let domain1 = BS.pack "example.com" -- >>> let domain2 = BS.pack "example.com." -- >>> domain1 == domain2 -- False -- >>> normalizeRoot domain1 == normalizeRoot domain2 -- True -- -- The 'normalizeRoot' function should be idempotent: -- -- >>> normalizeRoot (normalizeRoot domain1) == normalizeRoot domain1 -- True -- -- Ensure that we don't crash on the empty 'Domain': -- -- >>> import qualified Data.ByteString.Char8 as BS -- >>> normalizeRoot BS.empty -- "." -- normalizeRoot :: Domain -> Domain normalizeRoot d | BS.null d = trailing_dot | BS.last d == '.' = d | 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 dns-4.1.1/Setup.hs0000644000000000000000000000007507346545000012130 0ustar0000000000000000import Distribution.Simple main :: IO () main = defaultMain dns-4.1.1/cabal.project0000644000000000000000000000010307346545000013116 0ustar0000000000000000packages: . optimization: True write-ghc-environment-files: always dns-4.1.1/cbits/0000755000000000000000000000000007346545000011576 5ustar0000000000000000dns-4.1.1/cbits/dns.c0000644000000000000000000000437707346545000012541 0ustar0000000000000000#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; }*/ dns-4.1.1/dns.cabal0000644000000000000000000001115607346545000012246 0ustar0000000000000000Name: dns Version: 4.1.1 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: 2.0 Build-Type: Simple Extra-Source-Files: Changelog.md cabal.project cbits/dns.c Tested-With: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.1 Library dns-internal Default-Language: Haskell2010 GHC-Options: -Wall Hs-Source-Dirs: internal Exposed-Modules: Network.DNS.Imports Network.DNS.Types.Internal Network.DNS.Types.Resolver Network.DNS.Resolver.Internal Network.DNS.Decode.Parsers Network.DNS.Decode.Internal Network.DNS.Encode.Builders Network.DNS.Encode.Internal Network.DNS.StateBinary Network.DNS.Memo Network.DNS.Base32Hex Build-Depends: base , array , async , attoparsec , auto-update , base16-bytestring , base64-bytestring , bytestring , case-insensitive , containers , cryptonite , hourglass , iproute , mtl , network , psqueues if os(windows) C-Sources: cbits/dns.c Extra-Libraries: iphlpapi Library Default-Language: Haskell2010 GHC-Options: -Wall 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 Other-Modules: Network.DNS.Transport Build-Depends: dns-internal , base >= 4 && < 5 , array , async , attoparsec , auto-update , base16-bytestring , base64-bytestring , bytestring , containers , cryptonite , hourglass , iproute >= 1.3.2 , mtl , network >= 2.3 , psqueues Test-Suite network-tests Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: test2 Ghc-Options: -Wall Main-Is: Spec.hs Other-Modules: LookupSpec IOSpec Build-Depends: dns , dns-internal , base , hspec , network Build-Tool-Depends: hspec-discover:hspec-discover Test-Suite spec-tests Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: test Ghc-Options: -Wall Main-Is: Spec.hs Other-Modules: EncodeSpec DecodeSpec RoundTripSpec Build-Depends: dns , dns-internal , QuickCheck >= 2.9 , base , bytestring , case-insensitive , hspec , iproute >= 1.3.2 , word8 Build-Tool-Depends: hspec-discover:hspec-discover Test-Suite doctests Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: test2 Ghc-Options: -Wall -threaded Main-Is: doctests.hs Other-Modules: Paths_dns Autogen-Modules: Paths_dns Build-Depends: base , doctest Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/dns.git dns-4.1.1/internal/Network/DNS/0000755000000000000000000000000007346545000014363 5ustar0000000000000000dns-4.1.1/internal/Network/DNS/Base32Hex.hs0000644000000000000000000000320107346545000016377 0ustar0000000000000000module 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 #-} dns-4.1.1/internal/Network/DNS/Decode/0000755000000000000000000000000007346545000015546 5ustar0000000000000000dns-4.1.1/internal/Network/DNS/Decode/Internal.hs0000644000000000000000000000476707346545000017674 0ustar0000000000000000{-# 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 dns-4.1.1/internal/Network/DNS/Decode/Parsers.hs0000644000000000000000000004332207346545000017525 0ustar0000000000000000{-# 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 dns-4.1.1/internal/Network/DNS/Encode/0000755000000000000000000000000007346545000015560 5ustar0000000000000000dns-4.1.1/internal/Network/DNS/Encode/Builders.hs0000644000000000000000000003114107346545000017665 0ustar0000000000000000{-# 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 dns-4.1.1/internal/Network/DNS/Encode/Internal.hs0000644000000000000000000000207607346545000017675 0ustar0000000000000000{-# 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 dns-4.1.1/internal/Network/DNS/Imports.hs0000644000000000000000000000120507346545000016352 0ustar0000000000000000module 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 dns-4.1.1/internal/Network/DNS/Memo.hs0000644000000000000000000000715207346545000015621 0ustar0000000000000000{-# 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 dns-4.1.1/internal/Network/DNS/Resolver/0000755000000000000000000000000007346545000016164 5ustar0000000000000000dns-4.1.1/internal/Network/DNS/Resolver/Internal.hs0000644000000000000000000000240707346545000020277 0ustar0000000000000000{-# 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 dns-4.1.1/internal/Network/DNS/StateBinary.hs0000644000000000000000000003401607346545000017150 0ustar0000000000000000{-# 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 dns-4.1.1/internal/Network/DNS/Types/0000755000000000000000000000000007346545000015467 5ustar0000000000000000dns-4.1.1/internal/Network/DNS/Types/Internal.hs0000644000000000000000000015225407346545000017610 0ustar0000000000000000{-# 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 dns-4.1.1/internal/Network/DNS/Types/Resolver.hs0000644000000000000000000001204407346545000017625 0ustar0000000000000000module 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 } dns-4.1.1/test/0000755000000000000000000000000007346545000011451 5ustar0000000000000000dns-4.1.1/test/DecodeSpec.hs0000644000000000000000000002144507346545000014011 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module DecodeSpec where import Data.ByteString.Internal (ByteString(..), unsafeCreate) 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 Test.Hspec import Network.DNS import Network.DNS.Imports ---------------------------------------------------------------- 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 :: 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 :: 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" $ 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'" 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 -> withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0 where size = len `div` 2 go from to bytes | bytes == size = return () | otherwise = do w1 <- peek from w2 <- peekByteOff from 1 let w = hex2w (w1,w2) poke to w go (from `plusPtr` 2) (to `plusPtr` 1) (bytes + 1) hex2w :: (Word8, Word8) -> Word8 hex2w (w1,w2) = h2w w1 * 16 + h2w w2 h2w :: Word8 -> Word8 h2w w | isDigit w = w - _0 | otherwise = w - _a + 10 dns-4.1.1/test/EncodeSpec.hs0000644000000000000000000001073207346545000014020 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module EncodeSpec where import Data.IP import Test.Hspec import Network.DNS spec :: Spec spec = do describe "encode" $ do it "encodes DNSMessage correctly" $ do check1 testQueryA check1 testQueryAAAA check1 testResponseA check1 testResponseTXT describe "decode" $ do it "decodes DNSMessage correctly" $ do check2 testQueryA check2 testQueryAAAA check2 testResponseA check2 testResponseTXT check1 :: DNSMessage -> Expectation check1 inp = out `shouldBe` Right inp where bs = encode inp out = decode bs check2 :: DNSMessage -> Expectation check2 inp = bs' `shouldBe` bs where bs = encode inp Right out = decode bs bs' = encode out defaultHeader :: DNSHeader defaultHeader = header defaultQuery testQueryA :: DNSMessage testQueryA = defaultQuery { header = defaultHeader { identifier = 1000 } , question = [Question "www.mew.org." A] } testQueryAAAA :: DNSMessage testQueryAAAA = defaultQuery { header = defaultHeader { identifier = 1001 } , question = [Question "www.mew.org." AAAA] } testResponseA :: DNSMessage testResponseA = DNSMessage { header = DNSHeader { identifier = 61046 , flags = DNSFlags { qOrR = QR_Response , opcode = OP_STD , authAnswer = False , trunCation = False , recDesired = True , recAvailable = True , rcode = NoErr , authenData = False , chkDisable = False } } , ednsHeader = NoEDNS , question = [Question { qname = "492056364.qzone.qq.com." , qtype = A } ] , 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 testResponseTXT = DNSMessage { header = DNSHeader { identifier = 48724 , flags = DNSFlags { qOrR = QR_Response , opcode = OP_STD , authAnswer = False , trunCation = False , recDesired = True , recAvailable = True , rcode = NoErr , authenData = False , chkDisable = False } } , ednsHeader = EDNSheader defaultEDNS , question = [Question { qname = "492056364.qzone.qq.com." , qtype = TXT } ] , 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]) ] } dns-4.1.1/test/RoundTripSpec.hs0000644000000000000000000002134207346545000014550 0ustar0000000000000000{-# 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) dns-4.1.1/test/Spec.hs0000644000000000000000000000005407346545000012676 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} dns-4.1.1/test2/0000755000000000000000000000000007346545000011533 5ustar0000000000000000dns-4.1.1/test2/IOSpec.hs0000644000000000000000000000241307346545000013211 0ustar0000000000000000{-# 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 dns-4.1.1/test2/LookupSpec.hs0000644000000000000000000000402207346545000014151 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module LookupSpec where import Test.Hspec import Network.DNS as DNS spec :: Spec spec = describe "lookup" $ do 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 dns-4.1.1/test2/Spec.hs0000644000000000000000000000005407346545000012760 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} dns-4.1.1/test2/doctests.hs0000644000000000000000000000143007346545000013715 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Run doctests only on non-Windows systems with GHC 8.4 or later. -- -- The Windows doctests now compile and run, but either succeed quickly or -- randomly hang (before AppVeyor kills them after an hour). So we disable -- these for now. This can be tested again at some point in the future. -- module Main where #if !defined(mingw32_HOST_OS) && MIN_TOOL_VERSION_ghc(8,4,0) import Test.DocTest import System.Environment -- | Expose precompiled library modules. modules :: [String] modules = [ "-XOverloadedStrings" , "-XCPP" , "-XLambdaCase" , "-XPatternSynonyms" , "-i","-i.","-iinternal" , "-threaded" , "-package=dns" , "Network/DNS.hs" ] main :: IO () main = getArgs >>= doctest . (++ modules) #else main :: IO () main = return () #endif