dns-3.0.4/0000755000000000000000000000000013300453471010470 5ustar0000000000000000dns-3.0.4/Setup.hs0000644000000000000000000000005613300453471012125 0ustar0000000000000000import Distribution.Simple main = defaultMain dns-3.0.4/LICENSE0000644000000000000000000000276513300453471011507 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-3.0.4/Changelog.md0000644000000000000000000000667313300453471012715 0ustar0000000000000000# 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-3.0.4/dns.cabal0000644000000000000000000000632113300453471012242 0ustar0000000000000000Name: dns Version: 3.0.4 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: DNS library in Haskell Description: A thread-safe DNS library for both clients and servers written in pure Haskell. Category: Network Cabal-Version: >= 1.10 Build-Type: Simple Extra-Source-Files: Changelog.md cbits/dns.c 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.Encode Network.DNS.Decode Network.DNS.IO Other-Modules: Network.DNS.Decode.Internal Network.DNS.Imports Network.DNS.Memo Network.DNS.StateBinary Network.DNS.Transport Network.DNS.Types.Internal if impl(ghc < 8) Build-Depends: semigroups Build-Depends: base >= 4 && < 5 , async , auto-update , attoparsec , base64-bytestring , binary , bytestring , containers , cryptonite , iproute >= 1.3.2 , mtl , network >= 2.3 , psqueues , safe == 0.3.* , time if os(windows) Build-Depends: split C-Sources: cbits/dns.c Extra-Libraries: iphlpapi Test-Suite network Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: test2 Ghc-Options: -Wall Main-Is: Spec.hs Other-Modules: LookupSpec IOSpec Build-Depends: dns , base , bytestring , hspec , network Test-Suite spec Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: test Ghc-Options: -Wall Main-Is: Spec.hs Other-Modules: EncodeSpec DecodeSpec RoundTripSpec Build-Depends: dns , QuickCheck >= 2.9 , base , bytestring , hspec , iproute >= 1.2.4 , word8 Test-Suite doctest Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: test2 Ghc-Options: -Wall Main-Is: doctests.hs Build-Depends: base , doctest Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/dns.git dns-3.0.4/cbits/0000755000000000000000000000000013300453471011574 5ustar0000000000000000dns-3.0.4/cbits/dns.c0000644000000000000000000000437713300453471012537 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-3.0.4/test/0000755000000000000000000000000013300453471011447 5ustar0000000000000000dns-3.0.4/test/RoundTripSpec.hs0000644000000000000000000001361313300453471014550 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module RoundTripSpec where import Control.Monad (replicateM) import Data.IP (IP (..), IPv4, IPv6, toIPv4, toIPv6) import qualified Data.ByteString.Char8 as BS import Network.DNS.Decode import Network.DNS.Encode import Network.DNS.Types import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck (Gen, arbitrary, elements, forAll, frequency, listOf, oneof) import Data.Word (Word8, Word16, Word32) import Data.Monoid ((<>)) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif 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 $ \ 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 $ \ hdr -> decodeDNSHeader (encodeDNSHeader hdr) `shouldBe` Right hdr prop "DNSMessage" . forAll genDNSMessage $ \ msg -> decode (encode msg) `shouldBe` Right msg prop "EDNS0" . forAll genEDNS0Header $ \(edns0,hdr) -> do let rr0 = fromEDNS0 edns0 msg0 = DNSMessage hdr [] [] [] [rr0] Right msg1 = decode $ encode msg0 medns1 = toEDNS0 (flags $ header msg0) (head $ additional msg1) medns1 `shouldBe` Just edns0 ---------------------------------------------------------------- genDNSMessage :: Gen DNSMessage genDNSMessage = DNSMessage <$> genDNSHeader <*> listOf genQuestion <*> listOf genResourceRecord <*> listOf genResourceRecord <*> listOf genResourceRecord genQuestion :: Gen Question genQuestion = do typ <- genTYPE dom <- genDomain pure $ Question dom typ 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] 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 <$> genByteString 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 TLSA -> RD_TLSA <$> genWord8 <*> genWord8 <*> genWord8 <*> genByteString _ -> pure . RD_TXT $ "Unhandled type " <> BS.pack (show typ) 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" ] genMboxString :: Gen BS.ByteString genMboxString = elements [ "", "a", "a@b", "abc", "a@b.c" ] genDomain :: Gen Domain genDomain = do bs <- genByteString pure $ bs <> "." genMailbox :: Gen Mailbox genMailbox = do bs <- genMboxString pure $ bs <> "." genDNSHeader :: Gen DNSHeader genDNSHeader = DNSHeader <$> genWord16 <*> genDNSFlags genDNSFlags :: Gen DNSFlags genDNSFlags = DNSFlags <$> genQorR <*> genOPCODE <*> genBool <*> genBool <*> genBool <*> genBool <*> genRCODE <*> 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 [minBound .. maxBound] genRCODE :: Gen RCODE genRCODE = elements $ map toRCODE [0..15] genEDNS0 :: Gen EDNS0 genEDNS0 = do erc <- genExtRCODE ok <- genBool od <- genOData return $ defaultEDNS0 { extRCODE = erc , dnssecOk = ok , options = [od] } genOData :: Gen OData genOData = oneof [ genOD_Unknown , OD_ClientSubnet <$> genWord8 <*> genWord8 <*> oneof [ IPv4 <$> genIPv4, IPv6 <$> genIPv6 ] ] where genOD_Unknown = do bs <- genByteString let opc = toOptCode $ fromIntegral $ BS.length bs pure $ UnknownOData opc bs genExtRCODE :: Gen RCODE genExtRCODE = elements $ map toRCODE [0..4095] genEDNS0Header :: Gen (EDNS0, DNSHeader) genEDNS0Header = do edns <- genEDNS0 hdr <- genDNSHeader let flg = flags hdr return (edns, hdr { flags = flg { rcode = extRCODE edns } }) dns-3.0.4/test/EncodeSpec.hs0000644000000000000000000001062313300453471014015 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module EncodeSpec where import Data.IP import Network.DNS import Network.DNS.Types (defaultQuery, Question(..)) import Test.Hspec 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 } } , 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 } } , 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-3.0.4/test/Spec.hs0000644000000000000000000000005413300453471012674 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} dns-3.0.4/test/DecodeSpec.hs0000644000000000000000000001546713300453471014016 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module DecodeSpec where import Data.ByteString.Internal (ByteString(..), unsafeCreate) #if !MIN_VERSION_bytestring(0,10,0) import qualified Data.ByteString as BS #endif import Data.Word8 import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (plusPtr) import Foreign.Storable (peek, poke, peekByteOff) import Network.DNS import Test.Hspec ---------------------------------------------------------------- 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 = "463181800001000100000000076e69636f6c6173046b766462076e647072696d6102696f0000100001c00c0010000100000e10000c6e69636f6c61732e6b766462" -- 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 = icolas.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 = []}]}) ---------------------------------------------------------------- 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 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-3.0.4/Network/0000755000000000000000000000000013300453471012121 5ustar0000000000000000dns-3.0.4/Network/DNS.hs0000644000000000000000000000320513300453471013101 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. -- EDNS0 and TCP fallback are supported. -- -- Examples: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupA resolver "www.mew.org" -- Right [210.130.207.72] 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 'lookup', 'lookupAuth', or 'lookupRaw' 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-3.0.4/Network/DNS/0000755000000000000000000000000013300453471012545 5ustar0000000000000000dns-3.0.4/Network/DNS/Resolver.hs0000644000000000000000000001122013300453471014676 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} -- | Resolver related data types. module Network.DNS.Resolver ( -- * Configuration for resolver ResolvConf , defaultResolvConf -- ** Accessors , resolvInfo , resolvTimeout , resolvRetry , resolvEDNS , resolvConcurrent , resolvCache -- ** Specifying DNS servers , FileOrNumericHost(..) -- ** Configuring cache , CacheConf , defaultCacheConf , maximumTTL , pruningDelay -- * Intermediate data type for resolver , ResolvSeed , makeResolvSeed -- * Type and function for resolver , Resolver , withResolver , withResolvers ) where #if !defined(mingw32_HOST_OS) #define POSIX #else #define WIN #endif #if __GLASGOW_HASKELL__ < 709 #define GHC708 #endif import Control.Exception 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 hiding (lookup) #if defined(WIN) import qualified Data.List.Split as Split import Foreign.C.String import Foreign.Marshal.Alloc (allocaBytes) #else import Data.Char (isSpace) #endif import Network.DNS.Imports import Network.DNS.Memo import Network.DNS.Transport import Network.DNS.Types import Network.DNS.Types.Internal ---------------------------------------------------------------- -- | 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) getDefaultDnsServers :: FilePath -> IO [String] #if defined(WIN) foreign import ccall "getWindowsDefDnsServers" getWindowsDefDnsServers :: CString -> Int -> IO Word32 getDefaultDnsServers _ = do allocaBytes 128 $ \cString -> do res <- getWindowsDefDnsServers cString 128 case res of 0 -> do addresses <- peekCString cString return $ filter (not . null) . Split.splitOn "," $ addresses _ -> do -- TODO: Do proper error handling here. return mempty #else getDefaultDnsServers file = toAddresses <$> readFile file where toAddresses :: String -> [String] toAddresses cs = map extract (filter ("nameserver" `isPrefixOf`) (lines cs)) extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11 #endif makeAddrInfo :: HostName -> Maybe PortNumber -> IO AddrInfo makeAddrInfo addr mport = do let flgs = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_PASSIVE] hints = defaultHints { addrFlags = if isJust mport then AI_NUMERICSERV : flgs else flgs , addrSocketType = Datagram } serv = maybe "domain" 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-3.0.4/Network/DNS/Utils.hs0000644000000000000000000001013713300453471014203 0ustar0000000000000000-- | Miscellaneous utility functions for processing DNS data. -- module Network.DNS.Utils ( normalize , normalizeCase , normalizeRoot ) where import qualified Data.ByteString.Char8 as BS ( append , last , map , null , pack ) import Data.Char (toLower) import Network.DNS.Types (Domain) -- | 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 ( empty ) -- >>> 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 ( empty ) -- >>> 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 ( empty ) -- >>> 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 "." dns-3.0.4/Network/DNS/Decode.hs0000644000000000000000000000325313300453471014267 0ustar0000000000000000-- | Decoders for DNS. module Network.DNS.Decode ( -- * Decoder decode , decodeMany -- ** Decoder for Each Part , decodeResourceRecord , decodeDNSHeader , decodeDNSFlags , decodeDomain , decodeMailbox ) where import Network.DNS.Decode.Internal import Network.DNS.Imports import Network.DNS.StateBinary import Network.DNS.Types ---------------------------------------------------------------- -- | Decoding DNS query or response. decode :: ByteString -> Either DNSError DNSMessage decode bs = fst <$> runSGet getResponse bs -- | Parse many length-encoded DNS records, for example, from TCP traffic. decodeMany :: ByteString -> Either DNSError ([DNSMessage], ByteString) decodeMany bs = do ((bss, _), leftovers) <- runSGetWithLeftovers lengthEncoded bs msgs <- mapM decode bss return (msgs, leftovers) where -- Read a list of length-encoded lazy bytestrings lengthEncoded :: SGet [ByteString] lengthEncoded = many $ do len <- getInt16 getNByteString len -- | Decoding DNS flags. decodeDNSFlags :: ByteString -> Either DNSError DNSFlags decodeDNSFlags bs = fst <$> runSGet getDNSFlags bs -- | Decoding DNS header. decodeDNSHeader :: ByteString -> Either DNSError DNSHeader decodeDNSHeader bs = fst <$> runSGet getHeader bs -- | Decoding domain. decodeDomain :: ByteString -> Either DNSError Domain decodeDomain bs = fst <$> runSGet getDomain bs -- | Decoding mailbox. decodeMailbox :: ByteString -> Either DNSError Mailbox decodeMailbox bs = fst <$> runSGet getMailbox bs -- | Decoding resource record. decodeResourceRecord :: ByteString -> Either DNSError ResourceRecord decodeResourceRecord bs = fst <$> runSGet getResourceRecord bs dns-3.0.4/Network/DNS/Transport.hs0000644000000000000000000001746613300453471015113 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 import Network.DNS.Types.Internal -- | 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 resp = (identifier (header resp) == seqno) && (q == (question resp)) ---------------------------------------------------------------- data TCPFallback = TCPFallback deriving (Show, Typeable) instance Exception TCPFallback type Rslv0 = Bool -> (Socket -> IO DNSMessage) -> IO (Either DNSError DNSMessage) type Rslv1 = [Question] -> [ResourceRecord] -> Int -- Timeout -> Int -- Retry -> Rslv0 type TcpRslv = Identifier -> AddrInfo -> [Question] -> Int -- Timeout -> Bool -> IO DNSMessage type UdpRslv = [ResourceRecord] -> 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. resolve :: Domain -> TYPE -> Resolver -> Rslv0 resolve dom typ rlv ad rcv | isIllegal dom = return $ Left IllegalDomain | onlyOne = resolveOne (head nss) (head gens) q edns tm retry ad rcv | concurrent = resolveConcurrent nss gens q edns tm retry ad rcv | otherwise = resolveSequential nss gens q edns tm retry ad 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 conf = resolvconf seed concurrent = resolvConcurrent conf tm = resolvTimeout conf retry = resolvRetry conf edns = resolvEDNS conf resolveSequential :: [AddrInfo] -> [IO Identifier] -> Rslv1 resolveSequential nss gs q edns tm retry ad rcv = loop nss gs where loop [ai] [gen] = resolveOne ai gen q edns tm retry ad rcv loop (ai:ais) (gen:gens) = do eres <- resolveOne ai gen q edns tm retry ad rcv case eres of Left _ -> loop ais gens res -> return res loop _ _ = error "resolveSequential:loop" resolveConcurrent :: [AddrInfo] -> [IO Identifier] -> Rslv1 resolveConcurrent nss gens q edns tm retry ad rcv = do asyncs <- mapM mkAsync $ zip nss gens snd <$> waitAnyCancel asyncs where mkAsync (ai,gen) = async $ resolveOne ai gen q edns tm retry ad rcv resolveOne :: AddrInfo -> IO Identifier -> Rslv1 resolveOne ai gen q edns tm retry ad rcv = do ident <- gen E.try $ udpTcpLookup edns retry rcv ident ai q tm ad ---------------------------------------------------------------- udpTcpLookup :: UdpRslv udpTcpLookup edns retry rcv ident ai q tm ad = udpLookup edns retry rcv ident ai q tm ad `E.catch` \TCPFallback -> tcpLookup ident ai q tm ad ---------------------------------------------------------------- ioErrorToDNSError :: AddrInfo -> String -> IOError -> IO DNSMessage ioErrorToDNSError ai tag ioe = throwIO $ NetworkFailure aioe where aioe = annotateIOError ioe (show ai) Nothing $ Just tag ---------------------------------------------------------------- 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 :: UdpRslv udpLookup edns retry rcv ident ai q tm ad = do let qry = encodeQuestions ident q edns ad ednsRetry = not $ null edns E.handle (ioErrorToDNSError ai "UDP") $ bracket (udpOpen ai) close (loop qry ednsRetry 0 RetryLimitExceeded) where loop qry ednsRetry cnt err sock | cnt == retry = E.throwIO err | otherwise = do mres <- timeout tm (send sock qry >> getAns sock) case mres of Nothing -> loop qry ednsRetry (cnt + 1) RetryLimitExceeded sock Just res -> do let flgs = flags$ header res truncated = trunCation flgs rc = rcode flgs if truncated then E.throwIO TCPFallback else if ednsRetry && rc == FormatErr then let nonednsQuery = encodeQuestions ident q [] ad in loop nonednsQuery False 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 mres <- rcv sock if checkResp q ident mres then return mres 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 :: TcpRslv tcpLookup ident ai q tm ad = E.handle (ioErrorToDNSError ai "TCP") $ bracket (tcpOpen addr) close perform where addr = addrAddress ai perform vc = do let qry = encodeQuestions ident q [] ad mres <- timeout tm $ do connect vc addr sendVC vc qry receiveVC vc case mres of Nothing -> E.throwIO TimeoutExpired Just res | checkResp q ident res -> return res | otherwise -> E.throwIO SequenceNumberMismatch ---------------------------------------------------------------- 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-3.0.4/Network/DNS/Encode.hs0000644000000000000000000001607313300453471014305 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} -- | Encoders for DNS. module Network.DNS.Encode ( -- * Encoder encode -- ** Encoder for Each Part , encodeResourceRecord , encodeDNSHeader , encodeDNSFlags , encodeDomain , encodeMailbox ) where import Control.Monad.State (State, modify, execState, gets) import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.IP (IP(..), fromIPv4, fromIPv6b) import Network.DNS.Imports import Network.DNS.StateBinary import Network.DNS.Types ---------------------------------------------------------------- -- | Encoding DNS query or response. encode :: DNSMessage -> ByteString encode = runSPut . putDNSMessage -- | Encoding DNS flags. encodeDNSFlags :: DNSFlags -> ByteString encodeDNSFlags = runSPut . putDNSFlags -- | Encoding DNS header. encodeDNSHeader :: DNSHeader -> ByteString encodeDNSHeader = runSPut . putHeader -- | Encoding domain. encodeDomain :: Domain -> ByteString encodeDomain = runSPut . putDomain -- | Encoding mailbox. encodeMailbox :: Mailbox -> ByteString encodeMailbox = runSPut . putMailbox -- | Encoding resource record. encodeResourceRecord :: ResourceRecord -> ByteString encodeResourceRecord rr = runSPut $ putResourceRecord rr ---------------------------------------------------------------- putDNSMessage :: DNSMessage -> SPut putDNSMessage msg = putHeader hdr <> 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 ] hdr = header msg qs = question msg an = answer msg au = authority msg ad = additional msg putHeader :: DNSHeader -> SPut putHeader hdr = putIdentifier (identifier hdr) <> putDNSFlags (flags hdr) where putIdentifier = put16 putDNSFlags :: DNSFlags -> SPut putDNSFlags DNSFlags{..} = put16 word where word16 :: Enum a => a -> Word16 word16 = toEnum . fromEnum set :: Word16 -> State Word16 () set byte = modify (.|. byte) st :: State Word16 () st = sequence_ [ set (fromIntegral $ fromRCODEforHeader rcode) , when authenData $ set (bit 5) , when recAvailable $ set (bit 7) , when recDesired $ set (bit 8) , when trunCation $ set (bit 9) , when authAnswer $ set (bit 10) , set (word16 opcode `shiftL` 11) , when (qOrR==QR_Response) $ set (bit 15) ] word = execState st 0 -- 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 ip -> mconcat $ map putInt8 (fromIPv4 ip) RD_AAAA ip -> mconcat $ map putInt8 (fromIPv6b ip) RD_NS dom -> putDomain dom RD_CNAME dom -> putDomain dom RD_DNAME dom -> putDomain dom RD_PTR dom -> putDomain dom RD_MX prf dom -> mconcat [put16 prf, putDomain dom] RD_TXT txt -> putByteStringWithLength txt RD_OPT opts -> mconcat $ fmap putOData opts RD_SOA mn mr serial refresh retry expire min' -> mconcat [ putDomain mn , putMailbox mr , put32 serial , put32 refresh , put32 retry , put32 expire , put32 min' ] RD_SRV prio weight port dom -> mconcat [ put16 prio , put16 weight , put16 port , putDomain dom ] RD_TLSA u s m d -> mconcat [ put8 u , put8 s , put8 m , putByteString d ] RD_DS t a dt dv -> mconcat [ put16 t , put8 a , put8 dt , putByteString dv ] RD_NULL -> pure mempty (RD_DNSKEY f p a k) -> mconcat [ put16 f , put8 p , put8 a , putByteString k ] (RD_NSEC3PARAM h f i s) -> mconcat [ put8 h , put8 f , put16 i , putByteStringWithLength s ] UnknownRData bytes -> putByteString bytes putOData :: OData -> SPut putOData (OD_ClientSubnet srcNet scpNet ip) = let dropZeroes = dropWhileEnd (==0) (fam,raw) = case ip of IPv4 ip4 -> (1,dropZeroes $ fromIPv4 ip4) IPv6 ip6 -> (2,dropZeroes $ fromIPv6b ip6) dataLen = 2 + 2 + length raw in mconcat [ put16 $ fromOptCode ClientSubnet , putInt16 dataLen , putInt16 fam , put8 srcNet , put8 scpNet , mconcat $ fmap putInt8 raw ] putOData (UnknownOData code bs) = mconcat [ put16 $ fromOptCode code , putInt16 $ BS.length bs , putByteString bs ] -- In the case of the TXT record, we need to put the string length -- fixme : What happens with the length > 256 ? putByteStringWithLength :: BS.ByteString -> SPut putByteStringWithLength bs = putInt8 (fromIntegral $ BS.length bs) -- put the length of the given string <> putByteString bs ---------------------------------------------------------------- rootDomain :: Domain rootDomain = BS.pack "." putDomain :: Domain -> SPut putDomain = putDomain' '.' putMailbox :: Mailbox -> SPut putMailbox = putDomain' '@' putDomain' :: Char -> ByteString -> SPut putDomain' sep dom | BS.null dom || dom == rootDomain = put8 0 | otherwise = do mpos <- wsPop dom cur <- gets wsPosition case mpos of Just pos -> putPointer pos Nothing -> wsPush dom cur >> mconcat [ putPartialDomain hd , putDomain' '.' tl ] where (hd, tl') = case sep of '.' -> BS.break (== '.') dom _ | sep `BS.elem` dom -> BS.break (== sep) dom | otherwise -> BS.break (== '.') dom tl = if BS.null tl' then tl' else BS.drop 1 tl' putPointer :: Int -> SPut putPointer pos = putInt16 (pos .|. 0xc000) putPartialDomain :: Domain -> SPut putPartialDomain = putByteStringWithLength dns-3.0.4/Network/DNS/LookupRaw.hs0000644000000000000000000002242013300453471015024 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Network.DNS.LookupRaw ( -- * Looking up functions lookup , lookupAuth -- * Raw looking up function , lookupRaw , lookupRawAD , fromDNSMessage , fromDNSFormat ) where import Data.Time (getCurrentTime, addUTCTime) import Prelude hiding (lookup) import Network.DNS.IO import Network.DNS.Imports hiding (lookup) import Network.DNS.Memo import Network.DNS.Transport import Network.DNS.Types import Network.DNS.Types.Internal -- $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 manual the manual 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 manual the manual 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 tim <- addUTCTime life <$> getCurrentTime insertCache k tim v c where 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 CacheConf{..} c k v ttl = when (ttl /= 0) $ do tim <- addUTCTime life <$> getCurrentTime insertCache k tim v c where 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 EDNS0 if specifiecd). -- If it appear that the target DNS server does not support EDNS0, -- it falls back to traditional queries. -- -- * If the response is truncated, a new TCP socket bound to a new -- locla port is created. Then exactly one TCP query is retried. -- -- -- If multiple DNS server 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 = []}) -- @ -- lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage) lookupRaw rslv dom typ = resolve dom typ rslv False receive -- | Same as 'lookupRaw' but the query sets the AD bit, which solicits the -- the authentication status in the server reply. In most applications -- (other than diagnostic tools) that want authenticated data It is -- unwise to trust the AD bit in the responses of non-local servers, this -- interface should in most cases only be used with a loopback resolver. -- lookupRawAD :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage) lookupRawAD rslv dom typ = resolve dom typ rslv True receive ---------------------------------------------------------------- -- | Extract necessary information from 'DNSMessage' fromDNSMessage :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a fromDNSMessage ans conv = case errcode ans of NoErr -> Right $ conv ans FormatErr -> Left FormatError ServFail -> Left ServerFailure NameErr -> Left NameError NotImpl -> Left NotImplemented Refused -> Left OperationRefused BadOpt -> Left BadOptRecord _ -> Left UnknownDNSError where errcode = rcode . flags . header {-# DEPRECATED fromDNSFormat "Use fromDNSMessage instead" #-} -- | For backward compatibility. fromDNSFormat :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a fromDNSFormat = fromDNSMessage dns-3.0.4/Network/DNS/Imports.hs0000644000000000000000000000106513300453471014540 0ustar0000000000000000module Network.DNS.Imports ( ByteString , NonEmpty(..) , module Control.Applicative , module Control.Monad , module Data.Bits , module Data.List , module Data.Maybe , module Data.Monoid , module Data.Ord , module Data.Typeable , module Data.Word , module Numeric ) where import Control.Applicative import Control.Monad import Data.Bits import Data.ByteString (ByteString) import Data.List import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe import Data.Monoid import Data.Ord import Data.Typeable import Data.Word import Numeric dns-3.0.4/Network/DNS/Types.hs0000644000000000000000000006412713300453471014217 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} -- | Data types for DNS Query and Response. -- For more information, see . module Network.DNS.Types ( -- * Resource Records ResourceRecord (..) -- ** 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 , ANY ) , fromTYPE , toTYPE -- ** Resource Data , RData (..) -- * DNS Message , DNSMessage (..) , defaultQuery , defaultResponse , DNSFormat -- ** DNS Header , DNSHeader (..) , Identifier , QorR (..) , DNSFlags (..) , OPCODE (..) , RCODE ( NoErr , FormatErr , ServFail , NameErr , NotImpl , Refused , YXDomain , YXRRSet , NXRRSet , NotAuth , NotZone , BadOpt ) , fromRCODE , toRCODE , fromRCODEforHeader , toRCODEforHeader -- ** DNS Body , Question (..) -- * DNS Error , DNSError (..) -- * EDNS0 , EDNS0 , defaultEDNS0 , maxUdpSize , minUdpSize -- ** Accessors , udpSize , extRCODE , dnssecOk , options -- ** Converters , fromEDNS0 , toEDNS0 -- * EDNS0 option data , OData (..) , OptCode ( ClientSubnet ) , fromOptCode , toOptCode -- * Other types , Mailbox ) where import Control.Exception (Exception, IOException) import qualified Data.ByteString.Base64 as B64 (encode) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Builder as L import qualified Data.ByteString.Lazy as L import Data.IP (IP, IPv4, IPv6) import Network.DNS.Imports ---------------------------------------------------------------- -- | Type for domain. type Domain = ByteString -- | Type for a mailbox encoded on the wire as a DNS name, but the first label -- is conceptually the user name, and sometimes has contains internal periods -- that are not label separators. Therefore, in mailboxes \@ is used as the -- separator between the first and second labels. type Mailbox = ByteString ---------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 802 -- | Types for resource records. newtype TYPE = TYPE { -- | From type to number. fromTYPE :: Word16 } deriving (Eq, Ord) -- https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-4 -- | IPv4 address pattern A :: TYPE pattern A = TYPE 1 -- | An authoritative name serve pattern NS :: TYPE pattern NS = TYPE 2 -- | The canonical name for an alias pattern CNAME :: TYPE pattern CNAME = TYPE 5 -- | Marks the start of a zone of authority pattern SOA :: TYPE pattern SOA = TYPE 6 -- | A null RR (EXPERIMENTAL) pattern NULL :: TYPE pattern NULL = TYPE 10 -- | A domain name pointer pattern PTR :: TYPE pattern PTR = TYPE 12 -- | Mail exchange pattern MX :: TYPE pattern MX = TYPE 15 -- | Text strings pattern TXT :: TYPE pattern TXT = TYPE 16 -- | IPv6 Address pattern AAAA :: TYPE pattern AAAA = TYPE 28 -- | Server Selection (RFC2782) pattern SRV :: TYPE pattern SRV = TYPE 33 -- | DNAME (RFC6672) pattern DNAME :: TYPE pattern DNAME = TYPE 39 -- RFC 6672 -- | OPT (RFC6891) pattern OPT :: TYPE pattern OPT = TYPE 41 -- RFC 6891 -- | Delegation Signer (RFC4034) pattern DS :: TYPE pattern DS = TYPE 43 -- RFC 4034 -- | RRSIG (RFC4034) pattern RRSIG :: TYPE pattern RRSIG = TYPE 46 -- RFC 4034 -- | NSEC (RFC4034) pattern NSEC :: TYPE pattern NSEC = TYPE 47 -- RFC 4034 -- | DNSKEY (RFC4034) pattern DNSKEY :: TYPE pattern DNSKEY = TYPE 48 -- RFC 4034 -- | NSEC3 (RFC5155) pattern NSEC3 :: TYPE pattern NSEC3 = TYPE 50 -- RFC 5155 -- | NSEC3PARAM (RFC5155) pattern NSEC3PARAM :: TYPE pattern NSEC3PARAM = TYPE 51 -- RFC 5155 -- | TLSA (RFC6698) pattern TLSA :: TYPE pattern TLSA = TYPE 52 -- RFC 6698 -- | Child DS (RFC7344) pattern CDS :: TYPE pattern CDS = TYPE 59 -- RFC 7344 -- | DNSKEY(s) the Child wants reflected in DS (RFC7344) pattern CDNSKEY :: TYPE pattern CDNSKEY = TYPE 60 -- RFC 7344 -- | Child-To-Parent Synchronization (RFC7477) pattern CSYNC :: TYPE pattern CSYNC = TYPE 62 -- RFC 7477 -- | A request for all records the server/cache has available pattern ANY :: TYPE pattern ANY = TYPE 255 instance Show TYPE where show A = "A" show NS = "NS" show CNAME = "CNAME" show SOA = "SOA" show NULL = "NULL" show PTR = "PTR" show MX = "MX" show TXT = "TXT" show AAAA = "AAAA" show SRV = "SRV" show DNAME = "DNAME" show OPT = "OPT" show DS = "DS" show RRSIG = "RRSIG" show NSEC = "NSEC" show DNSKEY = "DNSKEY" show NSEC3 = "NSEC3" show NSEC3PARAM = "NSEC3PARAM" show TLSA = "TLSA" show CDS = "CDS" show CDNSKEY = "CDNSKEY" show CSYNC = "CSYNC" show ANY = "ANY" show x = "TYPE " ++ (show $ fromTYPE x) -- | From number to type. toTYPE :: Word16 -> TYPE toTYPE = TYPE #else -- | Types for resource records. data TYPE = A -- ^ IPv4 address | NS -- ^ An authoritative name serve | CNAME -- ^ The canonical name for an alias | SOA -- ^ Marks the start of a zone of authority | NULL -- ^ A null RR (EXPERIMENTAL) | PTR -- ^ A domain name pointer | MX -- ^ Mail exchange | TXT -- ^ Text strings | AAAA -- ^ IPv6 Address | SRV -- ^ Server Selection (RFC2782) | DNAME -- ^ DNAME (RFC6672) | OPT -- ^ OPT (RFC6891) | DS -- ^ Delegation Signer (RFC4034) | RRSIG -- ^ RRSIG (RFC4034) | NSEC -- ^ NSEC (RFC4034) | DNSKEY -- ^ DNSKEY (RFC4034) | NSEC3 -- ^ NSEC3 (RFC5155) | NSEC3PARAM -- ^ NSEC3PARAM (RFC5155) | TLSA -- ^ TLSA (RFC6698) | CDS -- ^ Child DS (RFC7344) | CDNSKEY -- ^ DNSKEY(s) the Child wants reflected in DS (RFC7344) | CSYNC -- ^ Child-To-Parent Synchronization (RFC7477) | ANY -- ^ A request for all records the server/cache -- has available | UnknownTYPE Word16 -- ^ Unknown type deriving (Eq, Ord, Show, Read) -- | From type to number. fromTYPE :: TYPE -> Word16 fromTYPE A = 1 fromTYPE NS = 2 fromTYPE CNAME = 5 fromTYPE SOA = 6 fromTYPE NULL = 10 fromTYPE PTR = 12 fromTYPE MX = 15 fromTYPE TXT = 16 fromTYPE AAAA = 28 fromTYPE SRV = 33 fromTYPE DNAME = 39 fromTYPE OPT = 41 fromTYPE DS = 43 fromTYPE RRSIG = 46 fromTYPE NSEC = 47 fromTYPE DNSKEY = 48 fromTYPE NSEC3 = 50 fromTYPE NSEC3PARAM = 51 fromTYPE TLSA = 52 fromTYPE CDS = 59 fromTYPE CDNSKEY = 60 fromTYPE CSYNC = 62 fromTYPE ANY = 255 fromTYPE (UnknownTYPE x) = x -- | From number to type. toTYPE :: Word16 -> TYPE toTYPE 1 = A toTYPE 2 = NS toTYPE 5 = CNAME toTYPE 6 = SOA toTYPE 10 = NULL toTYPE 12 = PTR toTYPE 15 = MX toTYPE 16 = TXT toTYPE 28 = AAAA toTYPE 33 = SRV toTYPE 39 = DNAME toTYPE 41 = OPT toTYPE 43 = DS toTYPE 46 = RRSIG toTYPE 47 = NSEC toTYPE 48 = DNSKEY toTYPE 50 = NSEC3 toTYPE 51 = NSEC3PARAM toTYPE 52 = TLSA toTYPE 59 = CDS toTYPE 60 = CDNSKEY toTYPE 62 = CSYNC toTYPE 255 = ANY toTYPE x = UnknownTYPE x #endif ---------------------------------------------------------------- -- | An enumeration of all possible DNS errors that can occur. data DNSError = -- | The sequence number of the answer doesn't match our query. This -- could indicate foul play. SequenceNumberMismatch -- | The number of retries for the request was exceeded. | RetryLimitExceeded -- | 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 detected a malformed OPT RR. | BadOptRecord -- | Configuration is wrong. | BadConfiguration -- | Network failure. | NetworkFailure IOException -- | Error is unknown | DecodeError String | UnknownDNSError deriving (Eq, Show, Typeable) instance Exception DNSError -- | Raw data format for DNS Query and Response. data DNSMessage = DNSMessage { header :: DNSHeader -- ^ Header , question :: [Question] -- ^ The question for the name server , answer :: [ResourceRecord] -- ^ RRs answering the question , authority :: [ResourceRecord] -- ^ RRs pointing toward an authority , additional :: [ResourceRecord] -- ^ RRs holding additional information } deriving (Eq, Show) {-# DEPRECATED DNSFormat "Use DNSMessage instead" #-} -- | For backward compatibility. type DNSFormat = DNSMessage -- | 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 -- ^ An identifier. , flags :: DNSFlags -- ^ The second 16bit word. } 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 -- ^ Authoritative Answer - 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 -- ^ TrunCation - specifies that this message was truncated -- due to length greater than that permitted on the -- transmission channel. , recDesired :: Bool -- ^ Recursion Desired - 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 -- ^ Recursion Available - this be is set or cleared in a -- response, and denotes whether recursive query support is -- available in the name server. , rcode :: RCODE -- ^ Response code. , authenData :: Bool -- ^ Authentic Data (RFC4035). } deriving (Eq, Show) ---------------------------------------------------------------- -- | 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. | OP_SSR -- ^ A server status request. deriving (Eq, Show, Enum, Bounded) ---------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 802 -- | Response code including EDNS0's 12bit ones. newtype RCODE = RCODE { -- | From rcode to number. 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 (RFC 6891) or TSIG Signature Failure (RFC2845). pattern BadOpt :: RCODE pattern BadOpt = RCODE 16 -- | 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 BadOpt = "BADVERS" show x = "RCODE " ++ (show $ fromRCODE x) -- | From number to rcode. toRCODE :: Word16 -> RCODE toRCODE = RCODE -- | From rcode to number for header (4bits only). fromRCODEforHeader :: RCODE -> Word16 fromRCODEforHeader (RCODE w) = w .&. 0x0f -- | From number in header to rcode (4bits only). toRCODEforHeader :: Word16 -> RCODE toRCODEforHeader w = RCODE (w .&. 0x0f) #else -- | Response code. data RCODE = NoErr -- ^ No error condition. | FormatErr -- ^ Format error - The name server was -- unable to interpret the query. | ServFail -- ^ Server failure - The name server was -- unable to process this query due to a -- problem with the name server. | NameErr -- ^ Name Error - Meaningful only for -- responses from an authoritative name -- server, this code signifies that the -- domain name referenced in the query does -- not exist. | NotImpl -- ^ Not Implemented - The name server does -- not support the requested kind of query. | Refused -- ^ Refused - The name server refuses to -- perform the specified operation for -- policy reasons. For example, a name -- server may not wish to provide the -- information to the particular requester, -- or a name server may not wish to perform -- a particular operation (e.g., zone -- transfer) for particular data. | YXDomain -- ^ Dynamic update response, a pre-requisite -- domain that should not exist, does exist. | YXRRSet -- ^ Dynamic update response, a pre-requisite -- RRSet that should not exist, does exist. | NXRRSet -- ^ Dynamic update response, a pre-requisite -- RRSet that should exist, does not exist. | NotAuth -- ^ Dynamic update response, the server is not -- authoritative for the zone named in the Zone Section. | NotZone -- ^ Dynamic update response, a name used in the -- Prerequisite or Update Section is not within the zone -- denoted by the Zone Section. | BadOpt -- ^ Bad OPT Version (RFC 6891) or TSIG Signature -- Failure (RFC2845). | UnknownRCODE Word16 deriving (Eq, Ord, Show) -- | From rcode to number. fromRCODE :: RCODE -> Word16 fromRCODE NoErr = 0 fromRCODE FormatErr = 1 fromRCODE ServFail = 2 fromRCODE NameErr = 3 fromRCODE NotImpl = 4 fromRCODE Refused = 5 fromRCODE YXDomain = 6 fromRCODE YXRRSet = 7 fromRCODE NXRRSet = 8 fromRCODE NotAuth = 9 fromRCODE NotZone = 10 fromRCODE BadOpt = 16 fromRCODE (UnknownRCODE x) = x -- | From number to rcode. toRCODE :: Word16 -> RCODE toRCODE 0 = NoErr toRCODE 1 = FormatErr toRCODE 2 = ServFail toRCODE 3 = NameErr toRCODE 4 = NotImpl toRCODE 5 = Refused toRCODE 6 = YXDomain toRCODE 7 = YXRRSet toRCODE 8 = NXRRSet toRCODE 9 = NotAuth toRCODE 10 = NotZone toRCODE 16 = BadOpt toRCODE x = UnknownRCODE x -- | From rcode to number for header (4bits only). fromRCODEforHeader :: RCODE -> Word16 fromRCODEforHeader rc = fromRCODE rc .&. 0x0f -- | From number in header to rcode (4bits only). toRCODEforHeader :: Word16 -> RCODE toRCODEforHeader w = toRCODE (w .&. 0x0f) #endif ---------------------------------------------------------------- -- XXX: The Question really should also include the CLASS -- -- | Raw data format for DNS questions. data Question = Question { qname :: Domain -- ^ A domain name , qtype :: TYPE -- ^ The type of the query } deriving (Eq, Show) ---------------------------------------------------------------- -- | Resource record class. type CLASS = Word16 -- | Resource record class for the Internet. classIN :: CLASS classIN = 1 -- | Time to live in second. type TTL = Word32 -- | Raw data format for resource records. data ResourceRecord = ResourceRecord { rrname :: Domain -- ^ Name , rrtype :: TYPE -- ^ Resource record type , rrclass :: CLASS -- ^ Resource record class , rrttl :: TTL -- ^ Time to live , rdata :: RData -- ^ Resource data } deriving (Eq,Show) -- | 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 -- ^ A null RR (EXPERIMENTAL). -- Anything can be in a NULL record, -- for now we just drop this data. | RD_PTR Domain -- ^ A domain name pointer | RD_MX Word16 Domain -- ^ Mail exchange | RD_TXT ByteString -- ^ Text strings | RD_AAAA IPv6 -- ^ IPv6 Address | RD_SRV Word16 Word16 Word16 Domain -- ^ Server Selection (RFC2782) | RD_DNAME Domain -- ^ DNAME (RFC6672) | RD_OPT [OData] -- ^ OPT (RFC6891) | RD_DS Word16 Word8 Word8 ByteString -- ^ Delegation Signer (RFC4034) --RD_RRSIG --RD_NSEC | RD_DNSKEY Word16 Word8 Word8 ByteString -- ^ DNSKEY (RFC4034) --RD_NSEC3 | RD_NSEC3PARAM Word8 Word8 Word16 ByteString | RD_TLSA Word8 Word8 Word8 ByteString -- ^ TLSA (RFC6698) --RD_CDS --RD_CDNSKEY --RD_CSYNC | UnknownRData ByteString -- ^ Unknown resource data deriving (Eq, Ord) instance Show RData where show (RD_NS dom) = BS.unpack dom show (RD_MX prf dom) = show prf ++ " " ++ BS.unpack dom show (RD_CNAME dom) = BS.unpack dom show (RD_DNAME dom) = BS.unpack dom show (RD_A a) = show a show (RD_AAAA aaaa) = show aaaa show (RD_TXT txt) = BS.unpack txt show (RD_SOA mn mr serial refresh retry expire mi) = BS.unpack mn ++ " " ++ BS.unpack mr ++ " " ++ show serial ++ " " ++ show refresh ++ " " ++ show retry ++ " " ++ show expire ++ " " ++ show mi show (RD_PTR dom) = BS.unpack dom show (RD_SRV pri wei prt dom) = show pri ++ " " ++ show wei ++ " " ++ show prt ++ BS.unpack dom show (RD_OPT od) = show od show (UnknownRData is) = show is show (RD_TLSA use sel mtype dgst) = show use ++ " " ++ show sel ++ " " ++ show mtype ++ " " ++ hexencode dgst show (RD_DS t a dt dv) = show t ++ " " ++ show a ++ " " ++ show dt ++ " " ++ hexencode dv show RD_NULL = "NULL" show (RD_DNSKEY f p a k) = show f ++ " " ++ show p ++ " " ++ show a ++ " " ++ b64encode k show (RD_NSEC3PARAM h f i s) = show h ++ " " ++ show f ++ " " ++ show i ++ " " ++ showSalt s where showSalt "" = "-" showSalt salt = hexencode salt hexencode :: ByteString -> String hexencode = BS.unpack . L.toStrict . L.toLazyByteString . L.byteStringHex b64encode :: ByteString -> String b64encode = BS.unpack . B64.encode ---------------------------------------------------------------- -- | Default query. defaultQuery :: DNSMessage defaultQuery = DNSMessage { header = DNSHeader { identifier = 0 , flags = DNSFlags { qOrR = QR_Query , opcode = OP_STD , authAnswer = False , trunCation = False , recDesired = True , recAvailable = False , rcode = NoErr , authenData = False } } , question = [] , answer = [] , authority = [] , additional = [] } -- | Default response. defaultResponse :: DNSMessage defaultResponse = let hd = header defaultQuery flg = flags hd in defaultQuery { header = hd { flags = flg { qOrR = QR_Response , authAnswer = True , recAvailable = True , authenData = False } } } ---------------------------------------------------------------- -- EDNS0 (RFC 6891) ---------------------------------------------------------------- -- | EDNS0 infromation defined in RFC 6891. data EDNS0 = EDNS0 { -- | UDP payload size. udpSize :: Word16 -- | Extended RCODE. , extRCODE :: RCODE -- | Is DNSSEC OK? , dnssecOk :: Bool -- | EDNS0 option data. , options :: [OData] } deriving (Eq, Show) #if __GLASGOW_HASKELL__ >= 802 -- | Default information for EDNS0. -- -- >>> defaultEDNS0 -- EDNS0 {udpSize = 4096, extRCODE = NoError, dnssecOk = False, options = []} #else -- | Default information for EDNS0. -- -- >>> defaultEDNS0 -- EDNS0 {udpSize = 4096, extRCODE = NoErr, dnssecOk = False, options = []} #endif defaultEDNS0 :: EDNS0 defaultEDNS0 = EDNS0 4096 NoErr False [] -- | Maximum UDP size. If 'udpSize' of 'EDNS0' is larger than this, -- 'fromEDNS0' uses this value instead. -- -- >>> maxUdpSize -- 16384 maxUdpSize :: Word16 maxUdpSize = 16384 -- | Minimum UDP size. If 'udpSize' of 'EDNS0' is smaller than this, -- 'fromEDNS0' uses this value instead. -- -- >>> minUdpSize -- 512 minUdpSize :: Word16 minUdpSize = 512 -- | Generating a resource record for the additional section based on EDNS0. -- 'DNSFlags' is not generated. -- Just set the same 'RCODE' to 'DNSFlags'. fromEDNS0 :: EDNS0 -> ResourceRecord fromEDNS0 edns = ResourceRecord name' type' class' ttl' rdata' where name' = "." type' = OPT class' = maxUdpSize `min` (minUdpSize `max` udpSize edns) ttl0' = fromIntegral (fromRCODE (extRCODE edns) .&. 0x0ff0) `shiftL` 20 ttl' | dnssecOk edns = ttl0' `setBit` 15 | otherwise = ttl0' rdata' = RD_OPT $ options edns -- | Generating EDNS0 information from the OPT RR. toEDNS0 :: DNSFlags -> ResourceRecord -> Maybe EDNS0 toEDNS0 flgs (ResourceRecord "." OPT udpsiz ttl' (RD_OPT opts)) = Just $ EDNS0 udpsiz (toRCODE erc) secok opts where lp = fromRCODEforHeader $ rcode flgs up = shiftR (ttl' .&. 0xff000000) 20 erc = fromIntegral up .|. lp secok = ttl' `testBit` 15 toEDNS0 _ _ = Nothing ---------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 802 -- | EDNS0 Option Code (RFC 6891). newtype OptCode = OptCode { -- | From option code to number. fromOptCode :: Word16 } deriving (Eq,Ord) -- | Client subnet (RFC7871) pattern ClientSubnet :: OptCode pattern ClientSubnet = OptCode 8 instance Show OptCode where show ClientSubnet = "ClientSubnet" show x = "OptCode " ++ (show $ fromOptCode x) -- | From number to option code. toOptCode :: Word16 -> OptCode toOptCode = OptCode #else -- | Option Code (RFC 6891). data OptCode = ClientSubnet -- ^ Client subnet (RFC7871) | UnknownOptCode Word16 -- ^ Unknown option code deriving (Eq, Ord, Show) -- | From option code to number. fromOptCode :: OptCode -> Word16 fromOptCode ClientSubnet = 8 fromOptCode (UnknownOptCode x) = x -- | From number to option code. toOptCode :: Word16 -> OptCode toOptCode 8 = ClientSubnet toOptCode x = UnknownOptCode x #endif ---------------------------------------------------------------- -- | Optional resource data. data OData = OD_ClientSubnet Word8 Word8 IP -- ^ Client subnet (RFC7871) | UnknownOData OptCode ByteString -- ^ Unknown optional type deriving (Eq,Show,Ord) dns-3.0.4/Network/DNS/StateBinary.hs0000644000000000000000000001253613300453471015335 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} module Network.DNS.StateBinary ( PState(..) , initialState , SPut , runSPut , put8 , put16 , put32 , putInt8 , putInt16 , putInt32 , putByteString , SGet , runSGet , runSGetWithLeftovers , get8 , get16 , get32 , getInt8 , getInt16 , getInt32 , getNByteString , getPosition , getInput , wsPop , wsPush , wsPosition , addPositionW , push , pop , getNBytes ) where import Control.Monad.State (State, StateT) import qualified Control.Monad.State 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.Lazy.Char8 as LBS import Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.Map (Map) import qualified Data.Map as M import Data.Semigroup as Sem import Network.DNS.Imports import Network.DNS.Types ---------------------------------------------------------------- type SPut = State WState Builder data WState = WState { wsDomain :: Map Domain Int , wsPosition :: Int } initialWState :: WState initialWState = WState M.empty 0 instance Sem.Semigroup SPut where p1 <> p2 = (Sem.<>) <$> p1 <*> p2 instance Monoid SPut where mempty = return mempty #if !(MIN_VERSION_base(4,11,0)) mappend = (Sem.<>) #endif put8 :: Word8 -> SPut put8 = fixedSized 1 BB.word8 put16 :: Word16 -> SPut put16 = fixedSized 2 BB.word16BE put32 :: Word32 -> SPut put32 = fixedSized 4 BB.word32BE putInt8 :: Int -> SPut putInt8 = fixedSized 1 (BB.int8 . fromIntegral) putInt16 :: Int -> SPut putInt16 = fixedSized 2 (BB.int16BE . fromIntegral) putInt32 :: Int -> SPut putInt32 = fixedSized 4 (BB.int32BE . fromIntegral) putByteString :: ByteString -> SPut putByteString = writeSized BS.length BB.byteString 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 } ---------------------------------------------------------------- getPosition :: SGet Int getPosition = psPosition <$> ST.get getInput :: SGet ByteString getInput = psInput <$> ST.get addPosition :: Int -> SGet () addPosition n = do PState dom pos inp <- ST.get ST.put $ PState dom (pos + n) inp push :: Int -> Domain -> SGet () push n d = do PState dom pos inp <- ST.get ST.put $ PState (IM.insert n d dom) pos inp pop :: Int -> SGet (Maybe Domain) pop n = IM.lookup n . psDomain <$> ST.get ---------------------------------------------------------------- get8 :: SGet Word8 get8 = ST.lift A.anyWord8 <* addPosition 1 get16 :: SGet Word16 get16 = ST.lift getWord16be <* addPosition 2 where word8' = fromIntegral <$> A.anyWord8 getWord16be = do a <- word8' b <- word8' return $ a * 0x100 + b get32 :: SGet Word32 get32 = ST.lift getWord32be <* addPosition 4 where word8' = fromIntegral <$> A.anyWord8 getWord32be = do a <- word8' b <- word8' c <- word8' d <- word8' return $ a * 0x1000000 + b * 0x10000 + c * 0x100 + d getInt8 :: SGet Int getInt8 = fromIntegral <$> get8 getInt16 :: SGet Int getInt16 = fromIntegral <$> get16 getInt32 :: SGet Int getInt32 = fromIntegral <$> get32 ---------------------------------------------------------------- getNBytes :: Int -> SGet [Int] getNBytes len = toInts <$> getNByteString len where toInts = map fromIntegral . BS.unpack getNByteString :: Int -> SGet ByteString getNByteString n = ST.lift (A.take n) <* addPosition n ---------------------------------------------------------------- initialState :: ByteString -> PState initialState inp = PState IM.empty 0 inp runSGet :: SGet a -> ByteString -> Either DNSError (a, PState) runSGet parser inp = toResult $ A.parse (ST.runStateT parser $ initialState inp) inp where toResult :: A.Result r -> Either DNSError r toResult (A.Done _ r) = Right r toResult (A.Fail _ _ msg) = Left $ DecodeError msg toResult (A.Partial _) = Left $ DecodeError "incomplete input" runSGetWithLeftovers :: SGet a -> ByteString -> Either DNSError ((a, PState), ByteString) runSGetWithLeftovers parser inp = toResult $ A.parse (ST.runStateT parser $ initialState 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 _ _ err) = Left $ DecodeError err runSPut :: SPut -> ByteString runSPut = LBS.toStrict . BB.toLazyByteString . flip ST.evalState initialWState dns-3.0.4/Network/DNS/IO.hs0000644000000000000000000001245613300453471013420 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.DNS.IO ( -- * Receiving from socket receive , receiveVC -- * Sending to socket , send , sendVC -- ** Creating Query , encodeQuestions , composeQuery , composeQueryAD -- ** Creating Response , responseA , responseAAAA ) where #if !defined(mingw32_HOST_OS) #define POSIX #else #define WIN #endif #if __GLASGOW_HASKELL__ < 709 #define GHC708 #endif 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 Data.Char (ord) import Data.IP (IPv4, IPv6) import Network.Socket (Socket) import System.IO.Error #if defined(WIN) && defined(GHC708) import Network.Socket (send, recv) import qualified Data.ByteString.Char8 as BS #else import Network.Socket.ByteString (sendAll, recv) #endif import Network.DNS.Decode (decode) import Network.DNS.Encode (encode) import Network.DNS.Imports import Network.DNS.Types ---------------------------------------------------------------- -- | Receiving DNS data from 'Socket' and parse it. receive :: Socket -> IO DNSMessage receive sock = do let bufsiz = fromIntegral maxUdpSize bs <- recv sock bufsiz `E.catch` \e -> E.throwIO $ NetworkFailure e case decode bs of Left e -> E.throwIO e Right msg -> return msg -- | Receive and parse a single virtual-circuit (TCP) query or response. -- It is up to the caller to implement any desired timeout. receiveVC :: Socket -> IO DNSMessage receiveVC sock = do len <- toLen <$> recvDNS sock 2 bs <- recvDNS sock len case decode bs of Left e -> E.throwIO e Right msg -> return msg where toLen bs = case map ord $ BS.unpack bs of [hi, lo] -> 256 * hi + 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 ---------------------------------------------------------------- -- | Sending composed query or response to 'Socket'. send :: Socket -> ByteString -> IO () send sock legacyQuery = sendAll sock legacyQuery -- | Sending composed query or response to a single virtual-circuit (TCP). sendVC :: Socket -> ByteString -> IO () sendVC vc legacyQuery = sendAll vc $ encodeVC legacyQuery -- | Encoding for virtual circuit. encodeVC :: ByteString -> ByteString encodeVC legacyQuery = let len = LBS.toStrict . BB.toLazyByteString $ BB.int16BE $ fromIntegral $ BS.length legacyQuery in len <> legacyQuery #if defined(WIN) && defined(GHC708) -- Windows does not support sendAll in Network.ByteString for older GHCs. sendAll :: Socket -> BS.ByteString -> IO () sendAll sock bs = do sent <- send sock (BS.unpack bs) when (sent < fromIntegral (BS.length bs)) $ sendAll sock (BS.drop (fromIntegral sent) bs) #endif ---------------------------------------------------------------- -- | Creating query. encodeQuestions :: Identifier -> [Question] -> [ResourceRecord] -- ^ Additional RRs for EDNS. -> Bool -- ^ Authentication -> ByteString encodeQuestions idt qs adds auth = encode qry where hdr = header defaultQuery flg = flags hdr qry = defaultQuery { header = hdr { identifier = idt, flags = flg { authenData = auth } } , question = qs , additional = adds } {-# DEPRECATED composeQuery "Use encodeQuestions instead" #-} -- | Composing query without EDNS0. composeQuery :: Identifier -> [Question] -> ByteString composeQuery idt qs = encodeQuestions idt qs [] False {-# DEPRECATED composeQueryAD "Use encodeQuestions instead" #-} -- | Composing query with authentic data flag set without EDNS0. composeQueryAD :: Identifier -> [Question] -> ByteString composeQueryAD idt qs = encodeQuestions idt qs [] True ---------------------------------------------------------------- -- | Composing a response from IPv4 addresses responseA :: Identifier -> Question -> [IPv4] -> DNSMessage responseA ident q ips = let hd = header defaultResponse dom = qname q an = ResourceRecord dom A classIN 300 . RD_A <$> ips in defaultResponse { header = hd { identifier=ident } , question = [q] , answer = an } -- | Composing a response from IPv6 addresses responseAAAA :: Identifier -> Question -> [IPv6] -> DNSMessage responseAAAA ident q ips = let hd = header defaultResponse dom = qname q an = ResourceRecord dom AAAA classIN 300 . RD_AAAA <$> ips in defaultResponse { header = hd { identifier=ident } , question = [q] , answer = an } dns-3.0.4/Network/DNS/Lookup.hs0000644000000000000000000004007213300453471014355 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 manual -- 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 ---------------------------------------------------------------- -- | Look up all \'A\' records for the given hostname. -- -- A straightforward example: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupA resolver "www.mew.org" -- Right [210.130.207.72] -- -- This function will also follow a CNAME and resolve its target if -- one exists for the queries hostname: -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupA resolver "www.kame.net" -- Right [203.178.141.194] -- 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:dff:fff1:216:3eff:fe4b:651c] -- 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 no MX (to prevent a deluge of spam from -- examples posted on the internet). But remember, \"no results\" is -- still a successful result. -- -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> withResolver rs $ \resolver -> lookupMX resolver "example.com" -- Right [] -- -- 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. -- 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 [133.138.10.39,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 -- >>> withResolver rs $ \resolver -> lookupSOA resolver "mew.org" -- Right [("ns1.mew.org.","kazu@mew.org.",201406240,3600,300,3600000,3600)] -- 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 "164.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.164" -- 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-3.0.4/Network/DNS/Memo.hs0000644000000000000000000000504413300453471014001 0ustar0000000000000000module Network.DNS.Memo where import qualified Control.Reaper as R import qualified Data.ByteString as B import Data.OrdPSQ (OrdPSQ) import qualified Data.OrdPSQ as PSQ import Data.Time (UTCTime, getCurrentTime) import Network.DNS.Imports import Network.DNS.Types data Section = Answer | Authority deriving (Eq, Ord, Show) type Key = (ByteString ,TYPE) type Prio = UTCTime 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 <- getCurrentTime 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 = RD_NULL copy (RD_MX prf dom) = RD_MX prf $ B.copy dom copy (RD_TXT txt) = RD_TXT $ B.copy txt copy r@(RD_AAAA _) = r copy (RD_SRV a b c dom) = RD_SRV a b c $ B.copy dom copy (RD_DNAME dom) = RD_DNAME $ B.copy dom copy (RD_OPT od) = RD_OPT $ map copyOData od copy (RD_DS t a dt dv) = RD_DS t a dt $ B.copy dv copy (RD_DNSKEY f p a k) = RD_DNSKEY f p a $ B.copy k copy (RD_TLSA a b c dgst) = RD_TLSA a b c $ B.copy dgst copy (RD_NSEC3PARAM a b c salt) = RD_NSEC3PARAM a b c $ B.copy salt copy (UnknownRData is) = UnknownRData $ B.copy is copyOData :: OData -> OData copyOData o@(OD_ClientSubnet _ _ _) = o copyOData (UnknownOData c b) = UnknownOData c $ B.copy b dns-3.0.4/Network/DNS/Types/0000755000000000000000000000000013300453471013651 5ustar0000000000000000dns-3.0.4/Network/DNS/Types/Internal.hs0000644000000000000000000001063613300453471015767 0ustar0000000000000000module Network.DNS.Types.Internal where import Network.Socket (AddrInfo(..), PortNumber, HostName) import Network.DNS.Imports import Network.DNS.Memo import Network.DNS.Types ---------------------------------------------------------------- -- | The type to specify a cache server. data FileOrNumericHost = RCFilePath FilePath -- ^ A path for \"resolv.conf\" -- where one or more IP addresses -- of DNS servers should be found -- on Unix. -- Default DNS servers are -- automatically detected -- on Windows regardless of -- the value of the file name. | RCHostName HostName -- ^ A numeric IP address. /Warning/: host names are invalid. | RCHostNames [HostName] -- ^ Numeric IP addresses. /Warning/: host names are invalid. | RCHostPort HostName PortNumber -- ^ A numeric IP address and port number. /Warning/: host names are invalid. deriving Show ---------------------------------------------------------------- -- | Cache configuration for responses. data CacheConf = CacheConf { -- | If RR's TTL is higher than this value, this value is used instead. maximumTTL :: TTL -- | Cache pruning interval in seconds. , pruningDelay :: Int } deriving Show -- | Default cache configuration. -- -- >>> defaultCacheConf -- CacheConf {maximumTTL = 300, pruningDelay = 10} defaultCacheConf :: CacheConf defaultCacheConf = CacheConf 300 10 ---------------------------------------------------------------- -- | Type for resolver configuration. -- Use 'defaultResolvConf' to create a new value. -- -- An example to use Google's public DNS cache instead of resolv.conf: -- -- >>> let conf = defaultResolvConf { resolvInfo = RCHostName "8.8.8.8" } -- -- An example to use multiple Google's public DNS cache concurrently: -- -- >>> let conf = defaultResolvConf { resolvInfo = RCHostNames ["8.8.8.8","8.8.4.4"], resolvConcurrent = True } -- -- An example to disable EDNS0: -- -- >>> let conf = defaultResolvConf { resolvEDNS = [] } -- -- An example to enable EDNS0 with a 1,280-bytes buffer: -- -- >>> let conf = defaultResolvConf { resolvEDNS = [fromEDNS0 defaultEDNS0 { udpSize = 1280 }] } -- -- An example to enable cache: -- -- >>> let conf = defaultResolvConf { resolvCache = Just defaultCacheConf } data ResolvConf = ResolvConf { -- | Server information. resolvInfo :: FileOrNumericHost -- | Timeout in micro seconds. , resolvTimeout :: Int -- | The number of retries including the first try. , resolvRetry :: Int -- | Additional resource records to specify EDNS. , resolvEDNS :: [ResourceRecord] -- | Concurrent queries if multiple DNS servers are specified. , resolvConcurrent :: Bool -- | Cache configuration. , resolvCache :: Maybe CacheConf } deriving Show -- | Return a default 'ResolvConf': -- -- * 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\". -- * 'resolvTimeout' is 3,000,000 micro seconds. -- * 'resolvRetry' is 3. -- * 'resolvEDNS' is EDNS0 with a 4,096-bytes buffer. -- * 'resolvConcurrent' is False. -- * 'resolvCache' is Nothing. defaultResolvConf :: ResolvConf defaultResolvConf = ResolvConf { resolvInfo = RCFilePath "/etc/resolv.conf" , resolvTimeout = 3 * 1000 * 1000 , resolvRetry = 3 , resolvEDNS = [fromEDNS0 defaultEDNS0] , resolvConcurrent = False , resolvCache = Nothing } ---------------------------------------------------------------- -- | 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-3.0.4/Network/DNS/Decode/0000755000000000000000000000000013300453471013730 5ustar0000000000000000dns-3.0.4/Network/DNS/Decode/Internal.hs0000644000000000000000000002134413300453471016044 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.DNS.Decode.Internal ( getResponse , getDNSFlags , getHeader , getResourceRecord , getResourceRecords , getDomain , getMailbox ) where import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BS import Data.IP (IP(..), toIPv4, toIPv6b) import qualified Safe import Network.DNS.Imports import Network.DNS.StateBinary import Network.DNS.Types ---------------------------------------------------------------- getResponse :: SGet DNSMessage getResponse = do hd <- getHeader qdCount <- getInt16 anCount <- getInt16 nsCount <- getInt16 arCount <- getInt16 DNSMessage hd <$> getQueries qdCount <*> getResourceRecords anCount <*> getResourceRecords nsCount <*> getResourceRecords arCount ---------------------------------------------------------------- getDNSFlags :: SGet DNSFlags getDNSFlags = do word <- get16 maybe (fail $ "Unsupported flags: 0x" ++ showHex word "") pure (toFlags word) where toFlags :: Word16 -> Maybe DNSFlags toFlags flgs = do oc <- getOpcode flgs let rc = getRcode flgs return $ DNSFlags (getQorR flgs) oc (getAuthAnswer flgs) (getTrunCation flgs) (getRecDesired flgs) (getRecAvailable flgs) rc (getAuthenData flgs) getQorR w = if testBit w 15 then QR_Response else QR_Query getOpcode w = Safe.toEnumMay (fromIntegral (shiftR w 11 .&. 0x0f)) getAuthAnswer w = testBit w 10 getTrunCation w = testBit w 9 getRecDesired w = testBit w 8 getRecAvailable w = testBit w 7 getRcode w = toRCODEforHeader $ fromIntegral w getAuthenData w = testBit w 5 ---------------------------------------------------------------- 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 getOptCode :: SGet OptCode getOptCode = toOptCode <$> 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 getResourceRecords :: Int -> SGet [ResourceRecord] getResourceRecords n = replicateM n getResourceRecord getResourceRecord :: SGet ResourceRecord getResourceRecord = do dom <- getDomain typ <- getTYPE cls <- decodeCLASS ttl <- decodeTTL len <- decodeRLen dat <- getRData typ len return $ ResourceRecord dom typ cls ttl dat where decodeCLASS = get16 decodeTTL = get32 decodeRLen = getInt16 getRData :: TYPE -> Int -> SGet RData getRData NS _ = RD_NS <$> getDomain getRData MX _ = RD_MX <$> decodePreference <*> getDomain where decodePreference = get16 getRData CNAME _ = RD_CNAME <$> getDomain getRData DNAME _ = RD_DNAME <$> getDomain getRData TXT len = (RD_TXT . ignoreLength) <$> getNByteString len where ignoreLength = BS.drop 1 getRData A len | len == 4 = (RD_A . toIPv4) <$> getNBytes len | otherwise = fail "IPv4 addresses must be 4 bytes long" getRData AAAA len | len == 16 = (RD_AAAA . toIPv6b) <$> getNBytes len | otherwise = fail "IPv6 addresses must be 16 bytes long" getRData SOA _ = RD_SOA <$> getDomain <*> getMailbox <*> decodeSerial <*> decodeRefesh <*> decodeRetry <*> decodeExpire <*> decodeMinimum where decodeSerial = get32 decodeRefesh = get32 decodeRetry = get32 decodeExpire = get32 decodeMinimum = get32 getRData PTR _ = RD_PTR <$> getDomain getRData SRV _ = RD_SRV <$> decodePriority <*> decodeWeight <*> decodePort <*> getDomain where decodePriority = get16 decodeWeight = get16 decodePort = get16 getRData OPT ol = RD_OPT <$> decode' ol where decode' :: Int -> SGet [OData] decode' l | l < 0 = fail $ "decodeOPTData: length inconsistency (" ++ show l ++ ")" | l == 0 = pure [] | otherwise = do optCode <- getOptCode optLen <- getInt16 dat <- getOData optCode optLen (dat:) <$> decode' (l - optLen - 4) -- 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 NULL len = const RD_NULL <$> getNByteString len -- getRData DNSKEY len = RD_DNSKEY <$> decodeKeyFlags <*> decodeKeyProto <*> decodeKeyAlg <*> decodeKeyBytes where decodeKeyFlags = get16 decodeKeyProto = get8 decodeKeyAlg = get8 decodeKeyBytes = getNByteString (len - 4) -- getRData NSEC3PARAM len = RD_NSEC3PARAM <$> decodeHashAlg <*> decodeFlags <*> decodeIterations <*> decodeSalt where decodeHashAlg = get8 decodeFlags = get8 decodeIterations = get16 decodeSalt = do let n = len - 5 slen <- get8 guard $ fromIntegral slen == n if (n == 0) then return B.empty else getNByteString n -- getRData _ len = UnknownRData <$> getNByteString len getOData :: OptCode -> Int -> SGet OData getOData ClientSubnet len = do fam <- getInt16 srcMask <- get8 scpMask <- get8 rawip <- fmap fromIntegral . B.unpack <$> getNByteString (len - 4) -- 4 = 2 + 1 + 1 ip <- case fam of 1 -> pure . IPv4 . toIPv4 $ take 4 (rawip ++ repeat 0) 2 -> pure . IPv6 . toIPv6b $ take 16 (rawip ++ repeat 0) _ -> fail "Unsupported address family" pure $ OD_ClientSubnet srcMask scpMask ip getOData opc len = UnknownOData opc <$> getNByteString len ---------------------------------------------------------------- getDomain :: SGet Domain getDomain = do lim <- B.length <$> getInput getDomain' '.' lim 0 getMailbox :: SGet Mailbox getMailbox = do lim <- B.length <$> getInput getDomain' '@' lim 0 -- | Get a domain name, using sep1 as the separate between the 1st and 2nd -- label. Subsequent labels (and always the trailing label) are terminated -- with a ".". getDomain' :: Char -> Int -> Int -> SGet ByteString getDomain' sep1 lim loopcnt -- 127 is the logical limitation of pointers. | loopcnt >= 127 = fail "pointer recursion limit exceeded" | otherwise = do pos <- getPosition c <- getInt8 let n = getValue c getdomain pos c n where getdomain pos c n | c == 0 = return "." -- Perhaps the root domain? | isPointer c = do d <- getInt8 let offset = n * 256 + d when (offset >= lim) $ fail "pointer is too large" mo <- pop offset case mo of Nothing -> do target <- B.drop offset <$> getInput case runSGet (getDomain' sep1 lim (loopcnt + 1)) target of Left (DecodeError err) -> fail err Left err -> fail $ show err Right o -> push pos (fst o) >> return (fst o) Just o -> push pos o >> return o -- As for now, extended labels have no use. -- This may change some time in the future. | isExtLabel c = return "" | otherwise = do hs <- getNByteString n ds <- getDomain' '.' lim (loopcnt + 1) let dom = case ds of -- avoid trailing ".." "." -> hs `BS.append` "." _ -> hs `BS.append` BS.singleton sep1 `BS.append` 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 ignoreClass :: SGet () ignoreClass = () <$ get16 dns-3.0.4/test2/0000755000000000000000000000000013300453471011531 5ustar0000000000000000dns-3.0.4/test2/doctests.hs0000644000000000000000000000063013300453471013714 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = doctest [ "-XOverloadedStrings" {- Both 'iproute' and 'network-data' provide ‘Data.IP’ package: Ambiguous interface for ‘Data.IP’: it was found in multiple packages: network-data-0.5.3 iproute-1.7.0 We ignore network-data to make tests pass. -} , "-ignore-package=network-data" , "Network/DNS.hs" ] dns-3.0.4/test2/LookupSpec.hs0000644000000000000000000000401313300453471014147 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module LookupSpec where import Network.DNS as DNS import Test.Hspec 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 "mew.org" -- 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-3.0.4/test2/Spec.hs0000644000000000000000000000005413300453471012756 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} dns-3.0.4/test2/IOSpec.hs0000644000000000000000000000235413300453471013213 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module IOSpec where import Network.DNS.IO as DNS import Network.DNS.Types as DNS import Network.Socket hiding (send) import Test.Hspec spec :: Spec spec = describe "send/receive" $ do it "resolves well with UDP" $ do let hints = defaultHints { addrFamily = AF_INET, addrSocketType = Datagram, 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 let qry = encodeQuestions 1 [Question "www.mew.org" A] [] False send sock qry ans <- receive sock identifier (header ans) `shouldBe` 1 it "resolves well with TCP" $ do let hints = defaultHints { addrFamily = AF_INET, addrSocketType = Stream, 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 let qry = encodeQuestions 1 [Question "www.mew.org" A] [] False sendVC sock qry ans <- receiveVC sock identifier (header ans) `shouldBe` 1