network-dns 0.1.2 → 1.0
raw patch · 10 files changed
+934/−962 lines, 10 filesdep +cerealdep +data-textualdep +hashabledep −arraydep −binary-strictdep −control-timeoutdep ~basedep ~binarydep ~bytestringsetup-changednew-uploader
Dependencies added: cereal, data-textual, hashable, network-ip, parsers, semigroups, tagged, text-latin1, text-printer
Dependencies removed: array, binary-strict, control-timeout, network, network-bytestring, parsec, random, stm, time, unix
Dependency ranges changed: base, binary, bytestring, containers
Files
- LICENSE +22/−25
- Network/DNS/Client.hs +0/−450
- Network/DNS/Common.hs +0/−257
- Network/DNS/ResolveConfParse.hs +0/−119
- Network/DNS/Types.hs +0/−85
- Setup.hs +2/−0
- Setup.lhs +0/−3
- examples/Resolver.hs +45/−0
- network-dns.cabal +47/−23
- src/Network/DNS.hs +818/−0
LICENSE view
@@ -1,30 +1,27 @@-Copyright (c) Adam Langley-+Copyright (c) 2013, Mikhail Vorozhtsov All rights reserved. -Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.+Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: -2. 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.+- 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 names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. -3. Neither the name of the author nor the names of his 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. -THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
− Network/DNS/Client.hs
@@ -1,450 +0,0 @@--- | A DNS resolver. This code acts like the resolver library from libc, except--- that it can work asynchronously, and can return much more information.------ At the moment, the interface is very much undecided but currently looks--- like this:------ > import qualified Network.DNS.Client as DNS--- >--- > DNS.resolve DNS.A "somedomain.com"--- > Right [(2008-02-01 00:27:14.861098 UTC, DNS.RRA [2466498203])]------ The first element of the tuple is the time when the information expires.--- The second depends on the record type requested (A, in this case) and--- A records contain IP address, so that's a HostAddress in there.------ This module parses @/etc/resolv.conf@ for it's configuration. It needs a--- recursive server to do the hard work. If you're lacking a recursive--- server, you can setup dnscache (from djbdns) locally and point at that.--module Network.DNS.Client- ( module Network.DNS.Types- , resolve- , resolveAsync- , DNSError(..)- ) where--import Data.Word-import Data.List (nub)-import Data.Maybe (fromMaybe)-import Data.Time-import Control.Monad (when)-import Control.Timeout-import Control.Concurrent (forkIO)-import System.IO.Unsafe (unsafePerformIO)-import System.Random (mkStdGen, random, Random, randomR)-import Control.Concurrent.STM--import qualified Data.Binary.Get as G--import qualified Data.Map as Map--import Network.Socket hiding (sendTo, recvFrom)-import Network.Socket.ByteString--import qualified Data.Binary.Put as P-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL--import Network.DNS.Common-import Network.DNS.ResolveConfParse-import Network.DNS.Types--queryHeader :: Word16 -> Header-queryHeader id = Header id False QUERY False False True False NoError 1 0 0 0---- | This is the type of errors from the library. Either it's one of the first--- two errors (which are generated from within this code), or it's an error--- directly from the DNS server.-data DNSError = Timeout -- ^ the DNS server didn't answer- | AnswerNotIncluded- -- ^ this is returned when the DNS server returned a valid- -- answer, but the answer didn't include the information we- -- were looking for. Firstly, this isn't a recursive- -- resolver, so if you point it at a non-recursive server- -- you'll get this for nearly every query as the server will- -- just be telling us the location of the roots.- --- -- This can also occur when you ask for a resource which- -- doesn't exist - like a AAAA record from www.google.com- | DNSError ResponseCode -- ^ errors from the DNS server- deriving (Show, Eq)--data InflightRequest =- InflightRequest { infRequest :: B.ByteString -- ^ the question section- , infCallback :: (Either DNSError ([String], ([Entry], [Entry], [Entry])) -> IO ())- , infCurrent :: [String] -- ^ the current name being queried- , infSearch :: [[String]] -- ^ alternative names to try- , infAttempts :: Int -- ^ number of times transmitted- , infTimeout :: TimeoutTag -- ^ the timeout- , infType :: DNSType -- ^ the type of the query- -- | In the case that we need to always send this request to- -- a specific nameserver (e.g. it's a probe packet), this- -- is set to a non-Nothing value.- , infSpecificNameserver :: Maybe Nameserver- }--data Nameserver = Nameserver { nsAddress :: Word32 -- ^ ip address- , nsUp :: TVar Bool -- ^ do we believe that this server is up?- , nsInflight :: TVar (Map.Map Word16 InflightRequest)- , nsTimeouts :: TVar Int -- ^ how many requests have timed out in a row- }--data ResolverConfig = ResolverConfig- { rcNameservers :: [Nameserver]- -- | This is a list of lists of labels. If a requested domain name is short- -- enougth (see ndots) it's tried with these suffixes first- , rcSearchPath :: [[String]]- -- | If a name has this many dots, we try an initial absolute query- , rcNdots :: Int- -- | Number of attempts per request- , rcAttempts :: Int- -- | Number of seconds to wait for the nameserver- , rcTimeout :: Int- -- | This is the next nameserver to try- , rcRobin :: TVar Int- -- | This is an infinite list of random seeds- , rcSeeds :: TVar [Int]- }---- | This is the max number of requests which can be outstanding against--- any one server at a time. Since, to generate ids, we roll until we find--- a good id setting this > 60000 is dangerous. If it hit 2**16 we would--- livelock-maxInflightPerServer :: Int-maxInflightPerServer = 2048---- | This is a socket that is bound, locally, to a port and all outgoing--- packets are written to it. It's also the socket that we listen on.-globalSocket :: Socket-globalSocket = unsafePerformIO $ do- s <- socket AF_INET Datagram 0- bindSocket s $ SockAddrInet (PortNum 0) iNADDR_ANY- return s---- | Lookup a reply from the network-lookupReply :: ResolverConfig- -> Word16 -- ^ The id of the reply- -> Word32 -- ^ The IP address of the source- -> IO (Maybe (InflightRequest, Nameserver))-lookupReply config id addr = do- case filter (\x -> nsAddress x == addr) $ rcNameservers config of- [] -> return Nothing- (ns:_) -> do- minf <- atomically (do- inflight <- readTVar $ nsInflight ns- let (minf, inflight') = Map.updateLookupWithKey (const $ const Nothing) id inflight- writeTVar (nsInflight ns) inflight'- -- cancel the timeout if we found an inflight- case minf of- Just inf -> cancelTimeout $ infTimeout inf- _ -> return False- return minf)- return $ minf >>= (\inf -> return (inf, ns))---- | This function never returns an it's expected that it runs in it's own--- thread, forever reading from the network.-readerThread :: Socket -> IO ()-readerThread socket = do- (bytes, SockAddrInet _ addr) <- recvFrom socket 1500- case parsePacket bytes of- Left _ -> readerThread socket- Right (Packet header _ ans nses additional) -> do- if (headIsResponse header == False) || (headIsTruncated header)- then readerThread socket- else do config <- getResolveConfig- minfns <- lookupReply config (headId header) addr- case minfns of- Nothing -> readerThread socket- Just (inf, ns) -> do- case headResponseCode header of- ServerError -> handleTransientError config inf $ DNSError ServerError- NoError -> handleReply config inf ns (ans, nses, additional)- x -> handleFailure config inf $ DNSError x-- readerThread socket---- | There can only ever really be a single config in action at any one time,--- because there is only a single @readerThread@. One could imaging having a--- socket bound to get packets only from a single nameserver, and that would--- work so long as the sets of nameservers didn't overlap. However, I don't--- think that's a common requirement, so I don't support it.-globalConfig :: TVar (Maybe ResolverConfig)-globalConfig = unsafePerformIO $ newTVarIO Nothing---- | Build a ResolverConfig by parsing @/etc/resolv.conf@-resolverConfigFromResolvConf :: IO ResolverConfig-resolverConfigFromResolvConf = do- Right resolvconf <- parseResolveConf "/etc/resolv.conf"- robin <- atomically $ newTVar 0- let toNameserver ip = do- up <- atomically $ newTVar True- inflight <- atomically $ newTVar Map.empty- timeouts <- atomically $ newTVar 0- return $ Nameserver ip up inflight timeouts-- -- For the list of seeds we have a lazy IO on /dev/urandom going through a- -- Get monad, which parses 4 byte lumps as Ints- urandom <- BL.readFile "/dev/urandom"- let urandomParser :: G.Get [Int]- urandomParser = do- v <- G.getWord32be- rest <- urandomParser- return $ fromIntegral v : rest- seeds = G.runGet urandomParser urandom-- tseeds <- atomically $ newTVar seeds-- ns <- mapM toNameserver $ nub $ resolveNameservers resolvconf- return $ ResolverConfig ns- (resolveSearch resolvconf)- (fromMaybe 1 (resolveNdots resolvconf))- (fromMaybe 2 (resolveAttempts resolvconf))- (fromMaybe 5 (resolveTimeout resolvconf))- robin- tseeds---- | Pick a nameserver from a config. We try to round robin the nameservers,--- avoiding the down nameservers. If all nameservers are down, we just pick--- one anyway.-selectNameserver :: ResolverConfig -> STM Nameserver-selectNameserver config = do- robin <- readTVar $ rcRobin config- writeTVar (rcRobin config) $ (robin + 1) `mod` (length (rcNameservers config))- let servers = (drop robin $ rcNameservers config) ++- (take robin $ rcNameservers config)- servers' <- mapM (\x -> readTVar (nsUp x) >>= \up -> return (up, x)) servers- case filter fst servers' of- [] -> return $ head servers -- all down, just pick one- x:_ -> return $ snd x--instance Random Word16 where- random g = (fromIntegral result, g') where- result :: Int- (result, g') = randomR (0, 65535) g- randomR (lo, hi) g = (fromIntegral result, g') where- result :: Int- (result, g') = randomR (fromIntegral lo, fromIntegral hi) g--submit4 :: ResolverConfig- -> InflightRequest- -> (IO () -> STM TimeoutTag)- -> STM (Word16, Word32)-submit4 config inf mtag = do- -- We cannot reuse a id number if we already have an inflight request to the- -- same nameserver with the same id. Thus, once we have picked a nameserver- -- we need to generate a stream of numbers until we find one which isn't- -- currently in use. So we generate a strong random seed and use it with the- -- standard Haskell PRNG to generate the stream of ids in the STM monad- ns <- case infSpecificNameserver inf of- Nothing -> selectNameserver config- Just ns -> return ns- inflight <- readTVar $ nsInflight ns- when (Map.size inflight > maxInflightPerServer) retry- seeds <- readTVar (rcSeeds config)- let seed = head seeds- writeTVar (rcSeeds config) $ tail seeds- let prng = mkStdGen seed- f prng = r where- r = if Map.member candidate inflight- then f prng'- else candidate- (candidate, prng') = random prng- id = f prng- addr = nsAddress ns- tag <- mtag $ handleTimeout config id addr- let inf' = inf { infTimeout = tag, infAttempts = infAttempts inf + 1 }- writeTVar (nsInflight ns) $ Map.insert id inf' inflight- return (id, addr)---- | This is the maximum number of timeouts, in a row, that can happen from a--- single nameserver before we consider that server to be down. When we mark--- a server as down we start sending probes to it. Once it responds to one of--- those probes with anything save a Timeout, we'll mark it good again.-maxTimeoutsPerServer :: Int-maxTimeoutsPerServer = 5---- | This is the callback from a probe request. If it came back with a--- reasonable reply we mark the nameserver as up-probeCallback :: Nameserver- -> Either DNSError ([String], ([Entry], [Entry], [Entry])) -> IO ()-probeCallback ns result =- case result of- Left Timeout -> (addTimeout 60 $ probeNameserver ns) >> return ()- _ -> atomically (writeTVar (nsUp ns) True)---- | This is a timeout callback. The timeout is called when we mark a--- nameserver as down. This timeout is to start a probe. If the probe returns--- any kind of DNS packet, we call the nameserver up again.-probeNameserver :: Nameserver -> IO ()-probeNameserver ns = do- config <- getResolveConfig- let labels = ["www", "google", "com"]- Just name = serialiseDNSName labels- req = B.concat $ BL.toChunks $ P.runPut $ serialiseQuestion name A- inf = InflightRequest req (probeCallback ns) labels [labels] 1 undefined A $ Just ns- transmit config inf--handleTimeout :: ResolverConfig -- ^ the config when the request started- -> Word16 -- ^ the id of the request which has timed out- -> Word32 -- ^ the IP address of the nameserver- -> IO ()-handleTimeout config id addr = do- -- There has to be a nameserver with the correct IP address because- -- we chose it from this same config- minfns <- lookupReply config id addr- case minfns of- Nothing -> return () -- we raced the network and lost- Just (inf, ns) -> do- -- First, deal with the nameserver. If it's been handling a lot of failures- -- recently we might want to consider it down- timeouts <- atomically $ do- timeouts <- readTVar $ nsTimeouts ns- writeTVar (nsTimeouts ns) $ timeouts + 1- return timeouts- when (timeouts > maxTimeoutsPerServer) $ do- mtimeout <- addTimeoutAtomic 60- atomically $ do- upflag <- readTVar $ nsUp ns- when (upflag == True) $ do- writeTVar (nsUp ns) False- mtimeout $ probeNameserver ns- return ()-- handleTransientError config inf Timeout--handleReply :: ResolverConfig -> InflightRequest -> Nameserver -> ([Entry], [Entry], [Entry]) -> IO ()-handleReply _ inf ns answers = do- -- we got a good reply from a nameserver, mark as up and good- atomically $ do- writeTVar (nsTimeouts ns) 0- writeTVar (nsUp ns) True-- (infCallback inf) $ Right (infCurrent inf, answers)--transmit :: ResolverConfig -> InflightRequest -> IO ()-transmit config inf = do- mtag <- addTimeoutAtomic $ fromIntegral $ rcTimeout config- (id, addr) <- atomically $ submit4 config inf mtag- let header = B.concat $ BL.toChunks $ P.runPut $ serialiseHeader $ queryHeader id- query = header `B.append` infRequest inf- sendTo globalSocket query $ SockAddrInet 53 addr- -- FIXME: check return value?- return ()---- | Increment the attempts, pop the next name from the search list and--- transmit the given inflight-sendInflight :: ResolverConfig -> InflightRequest -> IO ()-sendInflight config inf =- if null $ infSearch inf- then (infCallback inf) $ Left $ DNSError NXDomain- else do let inf' = inf { infSearch = tail $ infSearch inf, infAttempts = 1 }- target = head $ infSearch inf- case serialiseDNSName target of- Nothing -> sendInflight config inf'- Just name -> do- transmit config $ inf' { infRequest = B.concat $ BL.toChunks $ P.runPut $ serialiseQuestion name $ infType inf- , infCurrent = target }---- | This is for when we get a timeout or ServerError - there might not--- be anything wrong with the query so we retry it.-handleTransientError :: ResolverConfig -> InflightRequest -> DNSError -> IO ()-handleTransientError config inf result = do- if infAttempts inf > rcAttempts config- then handleFailure config inf result- else transmit config $ inf { infAttempts = 1 + infAttempts inf }---- | This is for when we have a harder error - either multiple timeouts or--- NXDomain etc from the server. The timeout must have been canceled by here-handleFailure :: ResolverConfig -> InflightRequest -> DNSError -> IO ()-handleFailure config inf result = do- if not $ null $ infSearch inf- then sendInflight config inf- else (infCallback inf) $ Left result--type DNSDB = Map.Map ([String], DNSType) [(UTCTime, RR)]--answersToDB :: UTCTime -> ([Entry], [Entry], [Entry]) -> DNSDB-answersToDB currentTime (ans, nses, additional) =- Map.unionsWith (++) $ map toMap [ans, nses, additional] where- toMap :: [Entry] -> Map.Map ([String], DNSType) [(UTCTime, RR)]- toMap = Map.fromListWith (++) . map (\(host, secs, rr) -> ((host, rrToType rr), [(t secs, rr)]))- t :: Word32 -> UTCTime- t = (flip addUTCTime) currentTime . fromIntegral--dbGet :: [String] -> DNSType -> DNSDB -> [(UTCTime, RR)]-dbGet host ty db = find host (0 :: Int) where- -- this limits the CNAME depth- find _ 16 = []- find host n =- case Map.lookup (host, ty) db of- Just x -> x- Nothing -> case Map.lookup (host, CNAME) db of- Nothing -> []- Just ((_, RRCNAME host'):_) -> find host' (n + 1)---- | This has to turn the information from the server into something--- useful for the caller. At the moment this is pretty stupid, just--- grab A records from the answer section-parseQuery :: DNSType- -> (Either DNSError [(UTCTime, RR)] -> IO ())- -> Either DNSError ([String], ([Entry], [Entry], [Entry]))- -> IO ()-parseQuery ty cb e =- case e of- Left x -> cb $ Left x- Right (host, answers) -> do- currentTime <- getCurrentTime- let db = answersToDB currentTime answers- case dbGet host ty db of- [] -> cb $ Left AnswerNotIncluded- x -> cb $ Right x--getResolveConfig :: IO ResolverConfig-getResolveConfig = do- config <- atomically $ readTVar globalConfig- case config of- Nothing -> do- config <- resolverConfigFromResolvConf- (set, config') <- atomically $ do- mconfig <- readTVar globalConfig- case mconfig of- Nothing -> do- writeTVar globalConfig $ Just config- return (True, config)- Just config'' -> return (False, config'')- when set (forkIO (readerThread globalSocket) >> return ())- return config'-- Just config' -> return config'---- | Lookup some information from DNS-resolve :: DNSType -- ^ the type of DNS information requested- -> String -- ^ the domain to query- -> IO (Either DNSError [(UTCTime, RR)]) -- ^ The RR values here will- -- always be of the correct- -- type for the requested- -- DNSType-resolve ty hostname = do- var <- atomically $ newEmptyTMVar- resolveAsync ty hostname (atomically . putTMVar var)- atomically $ takeTMVar var---- | This is the same as resolve, below, put you get the answer asynchronously.--- Blocking the thread which makes the callback in this case is bad - it'll--- block the DNS network reading thread.-resolveAsync :: DNSType- -> String- -> (Either DNSError [(UTCTime, RR)] -> IO ())- -> IO ()-resolveAsync ty host cb = do- config <- getResolveConfig- let labels = splitDNSName host- wrappedCb = parseQuery ty cb- inf = InflightRequest undefined wrappedCb labels [] 1 undefined ty Nothing- -- get the list of names that we'll try to resolve, in order.- -- if we are searching, that could be a list of length > 1- let names = if last host /= '.' && length labels - 1 < rcNdots config && length (rcSearchPath config) > 0- then (map ((++) labels) $ rcSearchPath config) ++ [labels]- else [labels]- sendInflight config $ inf { infSearch = names }
− Network/DNS/Common.hs
@@ -1,257 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-}--module Network.DNS.Common where--import Control.Monad (when)--import Data.Word-import Data.Bits-import Data.List (intersperse)--import qualified Data.ByteString as B-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.Binary.Put as P-import qualified Data.Binary.Strict.Get as G-import qualified Data.Binary.Strict.BitGet as BG--import Network.DNS.Types--foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32---- | Types of DNS queries. RFC 1035, 4.1.1.-data QueryType = QUERY | IQUERY | SERVERSTATUS deriving (Show, Eq, Enum, Bounded)---- | Parse an enum from a Word8 in a monad and fail if the value is out of range.--- It's assumed that the enum is defined at every value between the min and max--- bound-parseEnum :: forall m a. (Enum a, Bounded a, Monad m) => Word8 -> m a-parseEnum x' = r where- r = if x < low || x > high- then fail "Enum out of bounds"- else return $ toEnum x- low = fromEnum (minBound :: a)- high = fromEnum (maxBound :: a)- x = fromIntegral x'---- | A DNS protocol header. RFC 1035, 4.1.1.-data Header = Header { headId :: Word16- , headIsResponse :: Bool- , headOpCode :: QueryType- , headIsAuthoritative :: Bool- , headIsTruncated :: Bool- , headRecursionDesired :: Bool- , headRecursionAvailible :: Bool- , headResponseCode :: ResponseCode- , headQuestionCount :: Int- , headAnswerCount :: Int- , headNSCount :: Int- , headAdditionalCount :: Int }- deriving (Show, Eq)--parseHeader :: G.Get Header-parseHeader = do- id <- G.getWord16be- flags <- G.getByteString 2- qdcount <- G.getWord16be >>= return . fromIntegral- ancount <- G.getWord16be >>= return . fromIntegral- nscount <- G.getWord16be >>= return . fromIntegral- arcount <- G.getWord16be >>= return . fromIntegral-- let r = BG.runBitGet flags (do- isquery <- BG.getBit- opcode <- BG.getAsWord8 4 >>= parseEnum- aa <- BG.getBit- tc <- BG.getBit- rd <- BG.getBit- ra <- BG.getBit-- BG.getAsWord8 3- rcode <- BG.getAsWord8 4 >>= parseEnum-- return $ Header id isquery opcode aa tc rd ra rcode qdcount ancount nscount arcount)-- case r of- Left error -> fail error- Right x -> return x--serialiseHeader :: Header -> P.Put-serialiseHeader header = do- P.putWord16be $ headId header-- let flags1 = (v (headIsResponse header) `shiftL` 7) .|.- (fromEnum (headOpCode header) `shiftL` 3) .|.- (v (headIsAuthoritative header) `shiftL` 2) .|.- (v (headIsTruncated header) `shiftL` 1) .|.- (v (headRecursionDesired header))- flags2 = (v (headRecursionAvailible header) `shiftL` 7) .|.- (fromEnum (headResponseCode header))- v True = 1- v False = 0-- P.putWord8 $ fromIntegral flags1- P.putWord8 $ fromIntegral flags2- P.putWord16be $ fromIntegral $ headQuestionCount header- P.putWord16be $ fromIntegral $ headAnswerCount header- P.putWord16be $ fromIntegral $ headNSCount header- P.putWord16be $ fromIntegral $ headAdditionalCount header---- | Break a DNS name (e.g. www.google.com) into a list of labels-splitDNSName :: String -> [String]-splitDNSName = filter (not . null) . split '.' where- split c xs = head : tail where- (head, rest) = span (/= c) xs- tail = case rest of- [] -> []- (_:xs) -> split c xs---- | Convert a split name into the length-prefixed DNS wire format.--- FIXME: should work with the IDNA system. Returns Nothing if the--- name couldn't be serialised.--- FIXME: catch invalid charactors and > 255 parts-serialiseDNSName :: [String] -> Maybe B.ByteString-serialiseDNSName x- | length x > 255 = fail ""- | otherwise = mapM f x >>= return . (flip B.snoc) 0 . B.concat where- f x- | length x > 63 = fail ""- | otherwise = return $ B.cons lengthByte s where- lengthByte = fromIntegral $ length x- s = B.pack $ map c2w x---- | Convert a list of labels to a normal string by interspersing periods-fromDNSName :: [String] -> String-fromDNSName = concat . intersperse "."--parseDNSName :: B.ByteString -> G.Get [String]-parseDNSName packet = do- let getLabel 16 = fail "Pointer loop in DNS name"- getLabel depth = do- b <- G.getWord8- -- if it's a pointer we need to decode it- if b .&. 0xc0 == 0xc0- then do b2 <- G.getWord8- let offset = ((fromIntegral $ b .&. 0x3f) `shiftL` 8) .|. fromIntegral b2- if offset >= B.length packet- then fail "Invalid DNS label pointer"- else case G.runGet (getLabel (depth + 1)) $ B.drop offset packet of- (Left error, _) -> fail error- (Right l, _) -> return l- else if b == 0- then return []- else do l <- G.getByteString $ fromIntegral b- rest <- getLabel depth- return $ (map w2c $ B.unpack l) : rest- getLabel (0 :: Int)--serialiseQuestion :: B.ByteString -- ^ the encoded name (see @serialiseDNSName@)- -> DNSType -- ^ the type of the question- -> P.Put-serialiseQuestion s ty = do- P.putByteString s- P.putWord16be $ fromIntegral $ fromEnum ty- P.putWord16be 1--parseQuestion :: B.ByteString -> G.Get (String, DNSType)-parseQuestion packet = do- name <- parseDNSName packet- ty <- parseDNSType- G.getWord16be-- return (fromDNSName name, ty)--parseDNSType :: G.Get DNSType-parseDNSType = do- ty <- G.getWord16be >>= return . toEnum . fromIntegral- case ty of- UnknownDNSType -> fail "Unknown DNS type in question"- _ -> return ty--deserialiseQuestion :: B.ByteString -> G.Get ([String], DNSType)-deserialiseQuestion packet = do- name <- parseDNSName packet- ty <- parseDNSType- G.getWord16be-- return (name, ty)--parseGenericRR :: B.ByteString -> G.Get ([String], DNSType, Word32, B.ByteString)-parseGenericRR packet = do- name <- parseDNSName packet- ty <- parseDNSType- clas <- G.getWord16be- when (clas /= 1) $ fail "Bad class in RR"- ttl <- G.getWord32be- rlen <- G.getWord16be- bytes <- G.getByteString $ fromIntegral rlen-- return (name, ty, ttl, bytes)--type Entry = ([String], Word32, RR)--parseRR :: B.ByteString -> G.Get Entry-parseRR packet = do- (name, ty, ttl, bytes) <- parseGenericRR packet- let parseMany :: G.Get a -> G.Get [a]- parseMany parser = do- emptyp <- G.isEmpty- if emptyp- then return []- else do v <- parser- rest <- parseMany parser- return $ v : rest- parseIP = G.getWord32be >>= return . htonl- parseA = parseMany parseIP- parseAAAA = parseMany $ do- a <- parseIP- b <- parseIP- c <- parseIP- d <- parseIP- return (a, b, c, d)-- parseName = parseDNSName packet- parseMX = parseMany $ do- pref <- G.getWord16be- name <- parseDNSName packet- return (fromIntegral pref, name)-- parseSOA = do- name <- parseDNSName packet- rname <- parseDNSName packet- serial <- G.getWord32be- refresh <- G.getWord32be- retry <- G.getWord32be- expire <- G.getWord32be- minimum <- G.getWord32be-- return $ RRSOA name rname serial refresh retry expire minimum-- parseTXT = do- length <- G.getWord8- G.getByteString (fromIntegral length) >>= return-- let parse = case ty of- A -> parseA >>= return . RRA- NS -> parseName >>= return . RRNS- CNAME -> parseName >>= return . RRCNAME- SOA -> parseSOA- PTR -> parseName >>= return . RRPTR- MX -> parseMX >>= return . RRMX- TXT -> parseTXT >>= return . RRTXT- AAAA -> parseAAAA >>= return . RRAAAA- let (err, _) = G.runGet parse bytes- case err of- Left error -> fail error- Right rr -> return (name, ttl, rr)--data Packet = Packet Header [(String, DNSType)] [Entry] [Entry] [Entry]- deriving (Show)--parsePacket :: B.ByteString -> Either String Packet-parsePacket input = fst $ G.runGet (do- header <- parseHeader- a <- sequence $ replicate (headQuestionCount header) $ parseQuestion input- b <- sequence $ replicate (headAnswerCount header) $ parseRR input- c <- sequence $ replicate (headNSCount header) $ parseRR input- d <- sequence $ replicate (headAdditionalCount header) $ parseRR input-- return $ Packet header a b c d) input
− Network/DNS/ResolveConfParse.hs
@@ -1,119 +0,0 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-module Network.DNS.ResolveConfParse- ( ResolveConf(..)- , parseResolveConf- ) where--import Data.Word-import Data.Bits-import Text.ParserCombinators.Parsec-import System.Posix.Unistd (getSystemID, nodeName)--import Network.DNS.Common---- | This is the result of parsing a resolv.conf like file. The search path is--- either taken from a "search" line in the config, a "domain" line in the--- config or from the domainname of the current host. If it's taken from the--- config, the last line takes precedent. It's in a form like:------ > [["london", "myorg", "org"], ["myorg", "org"]]------ The maybe members are set to the found values if they are there. Otherwise--- they are Nothing.-data ResolveConf =- ResolveConf { resolveNameservers :: [Word32] -- ^ a list of IPs in big-endian format- , resolveSearch :: [[String]] -- ^ the search path- , resolveNdots :: Maybe Int- , resolveTimeout :: Maybe Int- , resolveAttempts :: Maybe Int- } deriving (Show)--comment = do- char '#'- skipMany (noneOf "\n")- return '\n'--ws = many (char ' ' <|> char '\t' <|> char '\n' <|> try comment)-sep = many (char ' ' <|> char '\t')--octet = do- s <- many1 $ oneOf "0123456789"- let n = (read s) :: Word32- if n > 255- then fail "Octet of IP address out of range"- else return n--int = do- s <- many1 $ oneOf "0123456789"- return ((read s) :: Int)--nonws = many1 (noneOf " \t\n")--nameserverLine = do- string "nameserver"- sep- a <- octet- char '.'- b <- octet- char '.'- c <- octet- char '.'- d <- octet-- let ip = htonl $ (a `shiftL` 24) .|. (b `shiftL` 16) .|. (c `shiftL` 8) .|. d-- getState >>= (\st -> setState $ st { resolveNameservers = ip : resolveNameservers st })--domainLine = do- string "domain"- sep- domain <- many1 (noneOf "\n")-- getState >>= (\st -> setState $ st { resolveSearch = [splitDNSName domain] })--searchLine = do- string "search"- sep- domains <- sepBy1 nonws sep-- getState >>= (\st -> setState $ st { resolveSearch = map splitDNSName domains })--optionsLine = do- string "options"- sep- let optionChunk = try ndots <|> try attempts <|> try timeout <|> (nonws >> return ())- ndots = string "ndots:" >> int >>= (\n -> getState >>= (\st -> setState $ st { resolveNdots = Just n }))- attempts = string "attempts:" >> int >>= (\n -> getState >>= (\st -> setState $ st { resolveAttempts = Just n }))- timeout = string "timeout:" >> int >>= (\n -> getState >>= (\st -> setState $ st { resolveTimeout = Just n }))- sepBy optionChunk sep- return ()--parseLine = do- try nameserverLine <|> try domainLine <|> try optionsLine <|> try searchLine <|> (nonws >> return ())--parseResolveConf' defaultSearch = do- ws- sepEndBy parseLine ws- ws- eof- st <- getState- -- if resolv.conf didn't include a search path or domain line we use the- -- default state from the domainname of the host- let st' = if null $ resolveSearch st- then st { resolveSearch = defaultSearch }- else st- st'' = if null $ resolveNameservers st- then st' { resolveNameservers = [htonl 0x7f000001] }- else st'- return st''---- | Parse a resolv.conf like file.-parseResolveConf filename = do- -- we need to get the default search path from the domain name- node <- getSystemID >>= return . splitDNSName . nodeName- let defaultSearch =- if length node < 2- then []- else [tail node]- input <- readFile filename- return $ runParser (parseResolveConf' defaultSearch) (ResolveConf [] [] Nothing Nothing Nothing) filename input
− Network/DNS/Types.hs
@@ -1,85 +0,0 @@--- | Contains DNS types which users of the DNS library may need to use. Private--- types are mostly kept in Network.DNS.Common--module Network.DNS.Types- ( DNSType(..)- , ResponseCode(..)- , RR(..)- , rrToType- ) where--import qualified Data.ByteString as B-import Network.Socket (HostAddress, HostAddress6)-import Data.Word (Word32)---- | Types of DNS resources. RFC 1035, 3.2.2.-data DNSType = A | NS | CNAME | SOA | PTR | MX | TXT | AAAA- | UnknownDNSType -- ^ This is for internal error handling- -- and should never be used or seen outside- -- Network.DNS- deriving (Show, Eq, Ord)--instance Enum DNSType where- fromEnum A = 1- fromEnum NS = 2- fromEnum CNAME = 5- fromEnum SOA = 6- fromEnum PTR = 12- fromEnum MX = 15- fromEnum TXT = 16- fromEnum AAAA = 28- fromEnum UnknownDNSType = error "fromEnum of UnknownDNSType"-- toEnum 1 = A- toEnum 2 = NS- toEnum 5 = CNAME- toEnum 6 = SOA- toEnum 12 = PTR- toEnum 15 = MX- toEnum 16 = TXT- toEnum 28 = AAAA- toEnum _ = UnknownDNSType---- | Error codes. RFC 1035, 4.1.1.-data ResponseCode = NoError- -- | 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- | ServerError- -- | Meaningful only for responses from an authoritative name server, this code signifies that the domain name referenced in the query does not exist- | NXDomain- -- | 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.- | AccessDenied- deriving (Show, Eq, Enum, Bounded)---- | Resource record types. There store the actual data in the DNS database.--- There's one for each DNSType-data RR = RRCNAME [String]- | RRMX [(Int, [String])] -- ^ a list of preferences and hostnames- | RRNS [String]- | RRPTR [String]- | RRSOA { soaName :: [String]- , soaRname :: [String]- , soaSerial :: Word32- , soaRefresh :: Word32- , soaRetry :: Word32- , soaExpire :: Word32- , soaMinTTL :: Word32 }- | RRTXT B.ByteString- | RRA [HostAddress]- | RRAAAA [HostAddress6]- deriving (Show)---- | Given an RR, this tells you the resource type of it-rrToType :: RR -> DNSType-rrToType (RRCNAME _) = CNAME-rrToType (RRMX _) = MX-rrToType (RRNS _) = NS-rrToType (RRPTR _) = PTR-rrToType (RRSOA { }) = SOA-rrToType (RRTXT _) = TXT-rrToType (RRA _) = A-rrToType (RRAAAA _) = AAAA-
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
+ examples/Resolver.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE UnicodeSyntax #-}++import Data.Foldable (forM_)+import Data.Maybe (listToMaybe)+import Data.List (isPrefixOf)+import Data.Char (isDigit)+import Data.Serialize+import Data.Textual (fromString)+import Network.DNS+import Control.Monad (join, void)+import System.Environment (getArgs)+import System.IO+import System.Posix.Socket+import System.Posix.Socket.Inet++main ∷ IO ()+main = do+ mName ← fmap (join . fmap fromString . listToMaybe) getArgs+ forM_ mName $ \name → do+ putStrLn $ "Resolving " ++ show name+ mAddr ← + fmap (join+ . fmap (fromString . dropWhile (not . isDigit))+ . listToMaybe+ . filter ("nameserver " `isPrefixOf`)+ . lines) $+ openFile "/etc/resolv.conf" ReadMode >>= hGetContents+ forM_ mAddr $ \addr → do+ putStrLn $ "Resolver address: " ++ show addr+ sk ← socket AF_INET datagramSockType defaultSockProto+ let req = DnsReq { dnsReqId = 123+ , dnsReqTruncd = False+ , dnsReqRec = True+ , dnsReqQuestion = DnsQuestion+ { dnsQName = name+ , dnsQType = StdDnsType AddrDnsType } }+ reqBs = encode req+ putStrLn $ "Raw request: " ++ show reqBs+ void $ sendTo sk reqBs (InetAddr addr 53)+ (_, respBs) ← recvFrom sk 1024+ putStrLn $ "Raw response: " ++ show respBs+ case decode respBs of+ Left err → putStrLn $ "Parsing failed: " ++ err+ Right resp → putStrLn $ "Parsed response: " ++ show (resp ∷ DnsResp)+
network-dns.cabal view
@@ -1,23 +1,47 @@-name: network-dns-version: 0.1.2-license: BSD3-license-file: LICENSE-author: Adam Langley <agl@imperialviolet.org>-maintainer: Adam Langley <agl@imperialviolet.org>-homepage: http://darcs.imperialviolet.org/network-dns-description: A pure Haskell, asyncronous DNS client library-synopsis: A pure Haskell, asyncronous DNS client library-category: Network-build-depends: base, containers, array, bytestring>=0.9, binary-strict>=0.2.4,- control-timeout>=0.1.2, network>=2.1, network-bytestring,- binary>=0.4.1, unix>=2.3, parsec>=2.1, stm>=2.1, random>=1.0,- time>=1.1-stability: provisional-tested-with: GHC == 6.8.2-exposed-modules: Network.DNS.Client- , Network.DNS.Types-other-modules: Network.DNS.ResolveConfParse- , Network.DNS.Common-extensions: ForeignFunctionInterface-ghc-options: -Wall -fno-warn-name-shadowing -fwarn-tabs-build-type: Simple+Name: network-dns+Version: 1.0+Category: Network+Stability: experimental+Synopsis: Domain Name System data structures+Description:+ This package provides Domain Name System data structures and+ (de)serialization routines.++Homepage: https://github.com/mvv/network-dns+Bug-Reports: https://github.com/mvv/network-dns/issues++Author: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Maintainer: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Copyright: 2013 Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+License: BSD3+License-File: LICENSE++Extra-Source-Files: examples/Resolver.hs++Cabal-Version: >= 1.10.0+Build-Type: Simple++Source-Repository head+ Type: git+ Location: https://github.com/mvv/network-dns.git++Library+ Default-Language: Haskell2010+ Build-Depends:+ base >= 4.3 && < 5,+ tagged >= 0.2,+ hashable >= 1.1,+ semigroups >= 0.8,+ containers >= 0.4,+ binary >= 0.5,+ cereal >= 0.3,+ bytestring >= 0.10,+ text-latin1 >= 0.2,+ text-printer >= 0.3,+ data-textual >= 0.1,+ parsers >= 0.5,+ network-ip >= 0.2+ Hs-Source-Dirs: src+ GHC-Options: -Wall+ Exposed-Modules:+ Network.DNS
+ src/Network/DNS.hs view
@@ -0,0 +1,818 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module provides Domain Name System data structures and+-- (de)serialization routines.+module Network.DNS+ ( HostName+ , aHostName+ , hostName+ , hostNameLabels+ , arpaHostName+ , HostAddr(..)+ , Host4Addr+ , Host6Addr+ , aHostAddr+ , aHostAddrOf+ , aHost4Addr+ , aHost6Addr+ , aHostAddrIP+ , DnsId+ , DnsType(..)+ , dnsTypeCode+ , DnsData(..)+ , DnsRecord(..)+ , DnsQType(..)+ , dnsQTypeCode+ , DnsQuestion(..)+ , DnsReq(..)+ , DnsError(..)+ , DnsResp(..)+ ) where++import Data.Typeable+import Data.Proxy (Proxy(..))+import Data.Foldable (forM_)+import Data.Hashable+import Data.Word+import Data.Bits+import Data.Char (chr, ord)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL+import Data.Binary (Binary)+import qualified Data.Binary as B+import qualified Data.Binary.Put as B+import qualified Data.Binary.Get as B+import Data.Serialize (Serialize)+import qualified Data.Serialize as S+import Text.Parser.Combinators as P+import Text.Parser.Char as P+import Text.Printer ((<>))+import qualified Text.Printer as T+import Data.Textual (Printable, toAscii, toUtf8, Textual)+import qualified Data.Textual as T+import qualified Text.Ascii as A+import Text.Printf+import qualified Text.Read as TR+import Network.IP.Addr+import Control.Applicative ((<$>), Applicative(..), (<|>))+import Control.Monad (void, unless, ap, foldM)++-- | Host name.+newtype HostName = HN { -- | Host name as a 'ByteString'.+ hostName ∷ ByteString+ }+ deriving (Typeable, Eq, Ord, Hashable)++-- | 'HostName' proxy value.+aHostName ∷ Proxy HostName+aHostName = Proxy++instance Show HostName where+ showsPrec p (HN bs) = showParen (p > 10)+ $ showString "fromJust "+ . (showParen True $+ showString "fromString "+ . showsPrec 10 (BS8.unpack bs))++instance Read HostName where+ readPrec = TR.parens $ TR.prec 10 $ do+ TR.Ident "fromJust" ← TR.lexP+ TR.step $ TR.parens $ TR.prec 10 $ do+ TR.Ident "fromString" ← TR.lexP+ TR.String s ← TR.lexP+ Just n ← return $ T.fromString s+ return n++instance Printable HostName where+ print (HN bs) = T.ascii bs++{-# RULES "toAscii/HostName" toAscii = hostName #-}+{-# RULES "toUtf8/HostName" toUtf8 = hostName #-}++instance Textual HostName where+ textual = go [] (0 ∷ Int) False [] (0 ∷ Int) <?> "host name"+ where alphaNumOrDashOrDot c = A.isAlphaNum c || c == '-' || c == '.'+ go !ls !ncs _ _ 0 =+ optional (P.satisfy A.isAlpha) >>= \case+ Just c → if ncs == 255+ then P.unexpected "Host name is too long"+ else go ls (ncs + 1) False [A.ascii c] 1+ Nothing → P.unexpected "A letter expected"+ go !ls !ncs !dash !lcs !nlcs =+ optional (P.satisfy alphaNumOrDashOrDot) >>= \case+ Just '.' → if dash+ then P.unexpected "Label ends with a dash"+ else if ncs == 255+ then P.unexpected "Host name is too long"+ else go (reverse (A.ascii '.' : lcs) : ls)+ (ncs + 1) False [] 0+ Just c → if nlcs == 63+ then P.unexpected "Label is too long"+ else if ncs == 255+ then P.unexpected "Host name is too long"+ else go ls (ncs + 1) (c == '-')+ (A.ascii c : lcs) (nlcs + 1)+ Nothing → return $ HN $ BS.pack $ concat+ $ reverse $ reverse lcs : ls++instance Printable (InetAddr HostName) where+ print (InetAddr n p) = T.print n <> T.char7 ':' <> T.print p++instance Textual (InetAddr HostName) where+ textual = InetAddr <$> T.textual <*> (P.char ':' *> T.textual)++-- | List the 'HostName' labels:+-- +-- @+-- 'hostNameLabels' ('Data.Maybe.fromJust' ('Data.Textual.fromString' /"www.google.com"/)) = [/"www"/, /"google"/, /"com"/]+-- @+hostNameLabels ∷ HostName → [ByteString]+hostNameLabels = BS.split (A.ascii '.') . hostName++-- | Host name for reverse DNS lookups.+--+-- @+-- 'Text.Printer.toString' ('arpaHostName' ('IPv4' ('ip4FromOctets' /1/ /2/ /3/ /4/))) = /"4.3.2.1.in-addr.arpa"/+-- 'Text.Printer.toString' ('arpaHostName' ('IPv6' ('ip6FromWords' /1/ /2/ /3/ /4/ /5/ /6/ /7/ /8/))) = /"8.0.0.0.7.0.0.0.6.0.0.0.5.0.0.0.4.0.0.0.3.0.0.0.2.0.0.0.1.0.0.0.ip6.arpa"/+-- @+arpaHostName ∷ IP → HostName+arpaHostName (IPv4 a) =+ HN $ BS8.pack $ printf "%i.%i.%i.%i.in-addr.arpa" o4 o3 o2 o1+ where (o1, o2, o3, o4) = ip4ToOctets a+arpaHostName (IPv6 a) =+ HN $ BS8.pack $ digits (reverse $ ip6ToWordList a) ++ "ip6.arpa"+ where digits (w : ws) = [d4, '.', d3, '.', d2, '.', d1, '.'] ++ digits ws+ where d1 = toDigit $ w `shiftR` 12+ d2 = toDigit $ w `shiftR` 8 .&. 0xF + d3 = toDigit $ w `shiftR` 4 .&. 0xF + d4 = toDigit $ w .&. 0xF + toDigit n | n < 10 = chr $ ord '0' + fromIntegral n+ | otherwise = chr $ ord 'a' + fromIntegral n - 10+ digits [] = []++newtype StateT k v μ α =+ StateT { runStateT ∷ Map k v → Maybe Word16 → μ (Map k v, Maybe Word16, α) }++type CompT μ α = StateT [ByteString] Word16 μ α+type DecompT μ α = StateT Word16 HostName μ α++compress ∷ Monad μ ⇒ Word16 → CompT μ α → μ α+compress i m = do+ (_, _, x) ← runStateT m Map.empty $ Just i+ return x+{-# INLINE compress #-}++decompress ∷ Monad μ ⇒ Word16 → DecompT μ α → μ α+decompress i m = do+ (_, _, x) ← runStateT m Map.empty $ Just i+ return x+{-# INLINE decompress #-}++instance Monad μ ⇒ Functor (StateT k v μ) where+ fmap f m = StateT $ \ptrs offset → do+ (ptrs', offset', x) ← runStateT m ptrs offset+ return (ptrs', offset', f x)+ {-# INLINE fmap #-}++instance Monad μ ⇒ Applicative (StateT k v μ) where+ pure = return+ {-# INLINE pure #-}+ (<*>) = ap+ {-# INLINE (<*>) #-}++instance Monad μ ⇒ Monad (StateT k v μ) where+ return = lift . return+ {-# INLINE return #-}+ m >>= f = StateT $ \ptrs offset → do+ (ptrs', offset', x) ← runStateT m ptrs offset+ runStateT (f x) ptrs' offset'+ {-# INLINE (>>=) #-}+ fail msg = lift $ fail msg+ {-# INLINE fail #-}++lift ∷ Monad μ ⇒ μ α → StateT k v μ α+lift m = StateT $ \ptrs offset → do+ x ← m+ return (ptrs, offset, x)+{-# INLINE lift #-}++getOffset ∷ Monad μ ⇒ StateT k v μ (Maybe Word16)+getOffset = StateT $ \ptrs offset → return (ptrs, offset, offset)+{-# INLINE getOffset #-}++incOffset ∷ Monad μ ⇒ Word16 → StateT k v μ ()+incOffset n = StateT $ \ptrs offset → do+ let offset' = case offset of+ Just i | i' ← i + n, i' >= i && i' <= 0x3FFF → Just i'+ _ → Nothing+ return (ptrs, offset', ())+{-# INLINE incOffset #-}++getEntries ∷ Monad μ ⇒ StateT k v μ (Map k v)+getEntries = StateT $ \ptrs offset → return (ptrs, offset, ptrs)+{-# INLINE getEntries #-}++getEntry ∷ (Ord k, Monad μ) ⇒ k → StateT k v μ (Maybe v)+getEntry key = StateT $ \ptrs offset → do+ return (ptrs, offset, Map.lookup key ptrs)+{-# INLINE getEntry #-}++putEntry ∷ (Ord k, Monad μ) ⇒ k → v → StateT k v μ ()+putEntry key value = StateT $ \ptrs offset → do+ return (Map.insert key value ptrs, offset, ())+{-# INLINE putEntry #-}++evalComp ∷ Monad μ+ ⇒ (∀ α . μ α → (α, ByteString)) → CompT μ ()+ → CompT μ ByteString+evalComp run m = StateT $ \ptrs offset → do+ let ((ptrs', offset', _), bs) = run $ runStateT m ptrs offset+ return (ptrs', offset', bs)+{-# INLINE evalComp #-}++threadDecomp ∷ (∀ β . μ β → μ β) → DecompT μ α → DecompT μ α +threadDecomp f m = StateT $ \ptrs offset →+ f $ runStateT m ptrs offset+{-# INLINE threadDecomp #-}++class (Functor (GetM s), Monad (GetM s), Functor (PutM s), Monad (PutM s))+ ⇒ Serializer s where+ type GetM s ∷ ★ → ★+ type PutM s ∷ ★ → ★+ putWord8 ∷ s → Word8 → PutM s ()+ putWord16be ∷ s → Word16 → PutM s ()+ putWord32be ∷ s → Word32 → PutM s ()+ putIP4 ∷ s → IP4 → PutM s ()+ putIP6 ∷ s → IP6 → PutM s ()+ putByteString ∷ s → ByteString → PutM s ()+ runPutM ∷ s → PutM s α → (α, ByteString)+ getWord8 ∷ s → GetM s Word8+ getWord16be ∷ s → GetM s Word16+ getWord32be ∷ s → GetM s Word32+ getIP4 ∷ s → GetM s IP4+ getIP6 ∷ s → GetM s IP6+ getByteString ∷ s → Int → GetM s ByteString+ isolate ∷ s → Int → GetM s α → GetM s α++data BinarySerializer = BinarySerializer++instance Serializer BinarySerializer where+ type GetM BinarySerializer = B.Get+ type PutM BinarySerializer = B.PutM+ putWord8 _ = B.putWord8+ putWord16be _ = B.putWord16be+ putWord32be _ = B.putWord32be+ putIP4 _ = B.put+ putIP6 _ = B.put+ putByteString _ = B.putByteString+ runPutM _ p = (r, BSL.toStrict bs) where (r, bs) = B.runPutM p+ getWord8 _ = B.getWord8+ getWord16be _ = B.getWord16be+ getWord32be _ = B.getWord32be+ getIP4 _ = B.get+ getIP6 _ = B.get+ getByteString _ = B.getBytes+ isolate _ = undefined++data CerealSerializer = CerealSerializer++instance Serializer CerealSerializer where+ type GetM CerealSerializer = S.Get+ type PutM CerealSerializer = S.PutM+ putWord8 _ = S.putWord8+ putWord16be _ = S.putWord16be+ putWord32be _ = S.putWord32be+ putIP4 _ = S.put+ putIP6 _ = S.put+ putByteString _ = S.putByteString+ runPutM _ = S.runPutM+ getWord8 _ = S.getWord8+ getWord16be _ = S.getWord16be+ getWord32be _ = S.getWord32be+ getIP4 _ = S.get+ getIP6 _ = S.get+ getByteString _ = S.getBytes+ isolate _ = S.isolate++serializeHostName ∷ Serializer s ⇒ s → HostName → CompT (PutM s) ()+serializeHostName s = go . hostNameLabels+ where+ go [] = do+ lift $ putWord8 s 0+ incOffset 1+ go labels@(label : labels') = do+ entry ← getEntry labels+ case entry of+ Nothing → do+ let ll = BS.length label+ offset ← getOffset+ lift $ putWord8 s $ fromIntegral ll+ lift $ putByteString s label+ incOffset $ 1 + fromIntegral ll+ forM_ offset $ putEntry labels+ go labels'+ Just ptr → do+ lift $ putWord16be s $ 0xC000 .|. ptr+ incOffset 2++guard' ∷ Monad μ ⇒ String → Bool → μ ()+guard' msg test = unless test $ fail msg+{-# INLINE guard' #-}++deserializeHostName ∷ Serializer s ⇒ s → DecompT (GetM s) HostName+deserializeHostName s = go []+ where+ folder suffix (label, offset) = do+ forM_ offset $ \i → putEntry i (HN suffix')+ return suffix'+ where suffix' = BS.append label $ BS.cons (A.ascii '.') suffix+ go labels = do+ offset ← getOffset+ w ← lift $ getWord8 s+ incOffset 1+ if w .&. 0xC0 == 0xC0+ then do+ w' ← lift $ getWord8 s+ incOffset 1+ let ptr = fromIntegral (w .&. 0x3F) `shiftL` 8 .|. fromIntegral w'+ entry ← getEntry ptr+ case entry of+ Nothing → do+ entries ← getEntries+ fail $ "Invalid pointer " ++ show ptr ++ ": pointer map is " +++ show (Map.elems entries)+ Just (HN suffix1) → HN <$> foldM folder suffix1 labels+ else+ if w == 0+ then do+ guard' "Hostname with zero labels" $ not $ null labels+ let (lastLabel, lastOffset) : labels' = labels+ forM_ lastOffset $ \i → putEntry i (HN lastLabel)+ HN <$> foldM folder lastLabel labels'+ else do+ guard' "Label is too long" $ w <= 63+ label ← lift $ getByteString s $ fromIntegral w+ incOffset $ fromIntegral w+ go ((BS.map A.toLower8 label, offset) : labels)++-- | Host address. Either a host name or an IP address.+data HostAddr a = HostName {-# UNPACK #-} !HostName+ | HostAddr !a+ deriving (Typeable, Show, Read, Eq, Ord)++type Host4Addr = HostAddr IP4+type Host6Addr = HostAddr IP6++-- | 'HostAddr' proxy value.+aHostAddr ∷ Proxy HostAddr+aHostAddr = Proxy++-- | 'HostAddr' /a/ proxy value.+aHostAddrOf ∷ Proxy a → Proxy (HostAddr a)+aHostAddrOf _ = Proxy++-- | 'Host4Addr' proxy value.+aHost4Addr ∷ Proxy Host4Addr+aHost4Addr = Proxy++-- | 'Host6Addr' proxy value.+aHost6Addr ∷ Proxy Host6Addr+aHost6Addr = Proxy++-- | 'HostAddr' 'IP' proxy value.+aHostAddrIP ∷ Proxy (HostAddr IP)+aHostAddrIP = Proxy++instance Printable a ⇒ Printable (HostAddr a) where+ print (HostName name) = T.print name+ print (HostAddr addr) = T.print addr++instance Textual a ⇒ Textual (HostAddr a) where+ textual = P.try (HostName <$> T.textual)+ <|> (HostAddr <$> T.textual)++instance Printable (InetAddr a) ⇒ Printable (InetAddr (HostAddr a)) where+ print (InetAddr (HostName n) p) = T.print $ InetAddr n p+ print (InetAddr (HostAddr a) p) = T.print $ InetAddr a p++instance Textual (InetAddr a) ⇒ Textual (InetAddr (HostAddr a)) where+ textual = P.try (InetAddr <$> (HostName <$> T.textual)+ <*> (P.char ':' *> T.textual))+ <|> T.textual++-- | Message identifier.+type DnsId = Word16++-- | Resource Record type.+data DnsType α where+ -- IPv4 address record (/A/)+ AddrDnsType ∷ DnsType IP4 + -- IPv6 address record (/AAAA/)+ Addr6DnsType ∷ DnsType IP6+ -- Name server record (/NS/)+ NsDnsType ∷ DnsType HostName+ -- Canonical name record (/CNAME/)+ CNameDnsType ∷ DnsType HostName+ -- Pointer record (/PTR/)+ PtrDnsType ∷ DnsType HostName+ -- Mail exchange record (/MX/)+ MxDnsType ∷ DnsType (Word16, HostName)++deriving instance Typeable1 DnsType+deriving instance Eq (DnsType α)++instance Show (DnsType α) where+ showsPrec _ AddrDnsType = showString "AddrDnsType"+ showsPrec _ Addr6DnsType = showString "Addr6DnsType"+ showsPrec _ NsDnsType = showString "NsDnsType"+ showsPrec _ CNameDnsType = showString "CNameDnsType"+ showsPrec _ PtrDnsType = showString "PtrDnsType"+ showsPrec _ MxDnsType = showString "MxDnsType"++-- | Numeric representation of a Resource Record type.+dnsTypeCode ∷ DnsType α → Word16+dnsTypeCode AddrDnsType = 1+dnsTypeCode Addr6DnsType = 28+dnsTypeCode NsDnsType = 2+dnsTypeCode CNameDnsType = 5+dnsTypeCode PtrDnsType = 12+dnsTypeCode MxDnsType = 15++-- | Resource Record data.+data DnsData = ∀ α . DnsData { dnsType ∷ !(DnsType α) -- ^ The type+ , dnsData ∷ α -- ^ The data+ }+ deriving Typeable++instance Show DnsData where+ showsPrec p (DnsData {..}) = showParen (p > 10)+ $ showString "DnsData {dnsType = "+ . showsPrec (p + 1) dnsType+ . showString ", dnsData = "+ . case dnsType of+ AddrDnsType → showsPrec p' dnsData+ Addr6DnsType → showsPrec p' dnsData+ NsDnsType → showsPrec p' dnsData+ CNameDnsType → showsPrec p' dnsData+ PtrDnsType → showsPrec p' dnsData+ MxDnsType → showsPrec p' dnsData+ . showString "}"+ where p' = 10 ∷ Int++-- | Resource Record.+data DnsRecord = DnsRecord { -- | Record owner+ dnsRecOwner ∷ {-# UNPACK #-} !HostName+ , -- | Maximum caching time in secords+ dnsRecTtl ∷ {-# UNPACK #-} !Word32+ , -- | Record data+ dnsRecData ∷ !DnsData+ }+ deriving (Typeable, Show)++serializeDnsRecord ∷ Serializer s ⇒ s → DnsRecord → CompT (PutM s) ()+serializeDnsRecord s (DnsRecord {..}) | DnsData tp dt ← dnsRecData = do+ serializeHostName s dnsRecOwner+ lift $ putWord16be s $ dnsTypeCode tp+ lift $ putWord16be s 1+ lift $ putWord32be s dnsRecTtl+ incOffset 10+ d ← evalComp (runPutM s) $ case tp of+ AddrDnsType → lift (putIP4 s dt) >> incOffset 4+ Addr6DnsType → lift (putIP6 s dt) >> incOffset 16+ NsDnsType → serializeHostName s dt+ CNameDnsType → serializeHostName s dt+ PtrDnsType → serializeHostName s dt+ MxDnsType → do+ lift $ putWord16be s $ fst dt+ incOffset 2+ serializeHostName s $ snd dt+ lift $ putWord16be s $ fromIntegral $ BS.length d+ lift $ putByteString s d++deserializeDnsRecord ∷ Serializer s ⇒ s → DecompT (GetM s) DnsRecord+deserializeDnsRecord s = do+ owner ← deserializeHostName s+ code ← lift $ getWord16be s+ void $ lift $ getWord16be s+ ttl ← lift $ getWord32be s+ len ← lift $ fromIntegral <$> getWord16be s+ incOffset 10+ dd ← threadDecomp (isolate s len) $ case code of+ 1 → fmap (DnsData AddrDnsType) $ incOffset 4 >> lift (getIP4 s)+ 2 → DnsData NsDnsType <$> deserializeHostName s+ 5 → DnsData CNameDnsType <$> deserializeHostName s+ 12 → DnsData PtrDnsType <$> deserializeHostName s+ 28 → fmap (DnsData Addr6DnsType) $ incOffset 16 >> lift (getIP6 s)+ _ → fail "Unsupported type"+ return $ DnsRecord owner ttl dd++-- | DNS query type.+data DnsQType = ∀ α . StdDnsType (DnsType α) -- ^ Record type+ | AllDnsType -- ^ All record types+ deriving Typeable++instance Show DnsQType where+ showsPrec p (StdDnsType t) = showParen (p > 10)+ $ showString "StdDnsType "+ . showsPrec (p + 1) t+ showsPrec _ AllDnsType = showString "AllDnsType"++-- | Numeric representation of a DNS query type.+dnsQTypeCode ∷ DnsQType → Word16+dnsQTypeCode (StdDnsType t) = dnsTypeCode t+dnsQTypeCode AllDnsType = 255++instance Eq DnsQType where+ t1 == t2 = dnsQTypeCode t1 == dnsQTypeCode t2++instance Ord DnsQType where+ t1 `compare` t2 = dnsQTypeCode t1 `compare` dnsQTypeCode t2++putDnsQType ∷ Serializer s ⇒ s → DnsQType → PutM s ()+putDnsQType s = putWord16be s . dnsQTypeCode++getDnsQType ∷ Serializer s ⇒ s → GetM s DnsQType+getDnsQType s = getWord16be s >>= \case+ 1 → return $ StdDnsType AddrDnsType+ 2 → return $ StdDnsType NsDnsType+ 5 → return $ StdDnsType CNameDnsType+ 12 → return $ StdDnsType PtrDnsType+ 28 → return $ StdDnsType Addr6DnsType+ 255 → return AllDnsType+ _ → fail "Unsupported query type"++instance Binary DnsQType where+ put = putDnsQType BinarySerializer+ get = getDnsQType BinarySerializer++instance Serialize DnsQType where+ put = putDnsQType CerealSerializer+ get = getDnsQType CerealSerializer++-- | DNS question.+data DnsQuestion = DnsQuestion { -- | Ask about the specified host name+ dnsQName ∷ {-# UNPACK #-} !HostName+ , -- | Query type+ dnsQType ∷ !DnsQType+ }+ deriving (Typeable, Show, Eq, Ord)++serializeDnsQuestion ∷ Serializer s ⇒ s → DnsQuestion → CompT (PutM s) ()+serializeDnsQuestion s (DnsQuestion {..}) = do+ serializeHostName s dnsQName+ lift $ do+ putDnsQType s dnsQType+ putWord16be s 1+ incOffset 4++deserializeDnsQuestion ∷ Serializer s ⇒ s → DecompT (GetM s) DnsQuestion+deserializeDnsQuestion s = do+ q ← DnsQuestion <$> deserializeHostName s <*> lift (getDnsQType s)+ c ← lift $ getWord16be s+ guard' "Unsupported class in a question" $ c == 1+ incOffset 4+ return q++-- | Request message.+data DnsReq -- | Standard query+ = DnsReq { -- | Message identifier+ dnsReqId ∷ {-# UNPACK #-} !DnsId+ , -- | Truncation flag+ dnsReqTruncd ∷ !Bool+ , -- | Recursion flag+ dnsReqRec ∷ !Bool+ , -- | Question+ dnsReqQuestion ∷ {-# UNPACK #-} !DnsQuestion+ }+ -- | Inverse query+ | DnsInvReq { dnsReqId ∷ {-# UNPACK #-} !DnsId+ , -- | IP address+ dnsReqInv ∷ !IP+ }+ deriving (Typeable, Show)++anyHostName ∷ HostName+anyHostName = HN "any"++putDnsReq ∷ Serializer s ⇒ s → DnsReq → PutM s ()+putDnsReq s (DnsReq {..}) = do+ putWord16be s dnsReqId+ putWord8 s $ if dnsReqRec then 1 else 0+ .|. if dnsReqTruncd then 2 else 0+ putWord8 s 0+ putWord16be s 1+ putWord16be s 0+ putWord16be s 0+ putWord16be s 0+ compress 12 $ serializeDnsQuestion s dnsReqQuestion+putDnsReq s (DnsInvReq {..}) = do+ putWord16be s dnsReqId+ putWord8 s 8+ putWord8 s 0+ putWord16be s 0+ putWord16be s 1+ putWord16be s 0+ putWord16be s 0+ compress 12 $ serializeDnsRecord s $+ DnsRecord { dnsRecOwner = anyHostName+ , dnsRecTtl = 0+ , dnsRecData = case dnsReqInv of+ IPv4 a → DnsData AddrDnsType a+ IPv6 a → DnsData Addr6DnsType a }++getDnsReq ∷ Serializer s ⇒ s → GetM s DnsReq+getDnsReq s = do+ i ← getWord16be s+ w ← getWord8 s+ void $ getWord8 s+ guard' "Not a request" $ w .&. 128 == 0+ let rec = w .&. 1 /= 0+ truncd = w .&. 2 /= 0+ opcode = w `shiftR` 3 .&. 0xF+ case opcode of+ 0 → do+ getWord16be s >>= guard' "No questions in query" . (== 1)+ getWord16be s >>= guard' "Answers in query" . (== 0)+ getWord16be s >>= guard' "Authorities in query" . (== 0)+ getWord16be s >>= guard' "Extras in query" . (== 0)+ decompress 12 $ do+ q ← deserializeDnsQuestion s+ return $ DnsReq { dnsReqId = i+ , dnsReqTruncd = truncd+ , dnsReqRec = rec+ , dnsReqQuestion = q }+ 1 → do+ getWord16be s >>= guard' "Questions in inverse query" . (== 0)+ getWord16be s >>= guard' "No answers in inverse query" . (== 1)+ getWord16be s >>= guard' "Authorities in inverse query" . (== 0)+ getWord16be s >>= guard' "Extras in inverse query" . (== 0)+ DnsRecord {dnsRecData} ← decompress 12 $ deserializeDnsRecord s+ case dnsRecData of+ DnsData AddrDnsType a →+ return $ DnsInvReq { dnsReqId = i, dnsReqInv = IPv4 a }+ DnsData Addr6DnsType a →+ return $ DnsInvReq { dnsReqId = i, dnsReqInv = IPv6 a }+ _ → fail "Invalid answer RR in inverse query"+ _ → fail "Invalid opcode in request"++instance Binary DnsReq where+ put = putDnsReq BinarySerializer+ get = getDnsReq BinarySerializer++instance Serialize DnsReq where+ put = putDnsReq CerealSerializer+ get = getDnsReq CerealSerializer++-- | Errors returned in responses.+data DnsError = FormatDnsError+ | FailureDnsError+ | NoNameDnsError+ | NotImplDnsError+ | RefusedDnsError+ | NameExistsDnsError+ | RsExistsDnsError+ | NoRsDnsError+ | NotAuthDnsError+ | NotInZoneDnsError+ deriving (Typeable, Show, Read, Eq, Ord, Enum)++-- | Numerical representation of an error.+dnsErrorCode ∷ DnsError → Word8+dnsErrorCode FormatDnsError = 1+dnsErrorCode FailureDnsError = 2+dnsErrorCode NoNameDnsError = 3+dnsErrorCode NotImplDnsError = 4+dnsErrorCode RefusedDnsError = 5+dnsErrorCode NameExistsDnsError = 6+dnsErrorCode RsExistsDnsError = 7+dnsErrorCode NoRsDnsError = 8+dnsErrorCode NotAuthDnsError = 9+dnsErrorCode NotInZoneDnsError = 10++-- | Response message.+data DnsResp -- | Normal response.+ = DnsResp { -- | Request identifer+ dnsRespId ∷ {-# UNPACK #-} !DnsId+ , -- | Truncation flag+ dnsRespTruncd ∷ !Bool+ , -- | Authoritative answer flag+ dnsRespAuthd ∷ !Bool+ , -- | Recursive query support flag+ dnsRespRec ∷ !Bool+ , -- | Request question+ dnsRespQuestion ∷ {-# UNPACK #-} !DnsQuestion+ , -- | Answer records+ dnsRespAnswers ∷ [DnsRecord]+ , -- | Authority records+ dnsRespAuths ∷ [DnsRecord]+ , -- | Additional records+ dnsRespExtras ∷ [DnsRecord]+ }+ -- | Error response.+ | DnsErrResp { dnsRespId ∷ {-# UNPACK #-} !DnsId+ , -- | Error+ dnsRespError ∷ !DnsError+ }+ deriving (Typeable, Show)++putDnsResp ∷ Serializer s ⇒ s → DnsResp → PutM s ()+putDnsResp s (DnsResp {..}) = do+ putWord16be s dnsRespId+ putWord8 s $ 128+ .|. if dnsRespTruncd then 2 else 0+ .|. if dnsRespAuthd then 4 else 0+ putWord8 s $ if dnsRespRec then 128 else 0+ putWord16be s 1+ putWord16be s $ fromIntegral $ length dnsRespAnswers+ putWord16be s $ fromIntegral $ length dnsRespAuths+ putWord16be s $ fromIntegral $ length dnsRespExtras+ compress 12 $ do+ serializeDnsQuestion s dnsRespQuestion+ forM_ dnsRespAnswers (serializeDnsRecord s)+ forM_ dnsRespAuths (serializeDnsRecord s)+ forM_ dnsRespExtras (serializeDnsRecord s)+putDnsResp s (DnsErrResp {..}) = do+ putWord16be s dnsRespId+ putWord8 s 8+ putWord8 s $ dnsErrorCode dnsRespError+ putWord16be s 0+ putWord16be s 0+ putWord16be s 0+ putWord16be s 0++getDnsResp ∷ Serializer s ⇒ s → GetM s DnsResp+getDnsResp s = do+ i ← getWord16be s+ w ← getWord8 s+ guard' "Not a response" $ w .&. 128 /= 0+ w' ← getWord8 s+ let truncd = w .&. 2 /= 0+ authd = w .&. 4 /= 0+ rec = w' .&. 128 /= 0+ ec = w' .&. 0xF+ case ec of+ 0 → do+ getWord16be s >>= guard' "No question in a response" . (== 1)+ anc ← getWord16be s+ nsc ← getWord16be s+ arc ← getWord16be s+ decompress 12 $ do+ q ← deserializeDnsQuestion s+ ans ← mapM (const $ deserializeDnsRecord s) [1 .. anc] + nss ← mapM (const $ deserializeDnsRecord s) [1 .. nsc] + ars ← mapM (const $ deserializeDnsRecord s) [1 .. arc] + return $ DnsResp { dnsRespId = i+ , dnsRespTruncd = truncd+ , dnsRespAuthd = authd+ , dnsRespRec = rec+ , dnsRespQuestion = q+ , dnsRespAnswers = ans+ , dnsRespAuths = nss+ , dnsRespExtras = ars }+ _ → do+ void $ getWord16be s+ void $ getWord16be s+ void $ getWord16be s+ void $ getWord16be s+ DnsErrResp i <$> case ec of+ 1 → return FormatDnsError+ 2 → return FailureDnsError+ 3 → return NoNameDnsError+ 4 → return NotImplDnsError+ 5 → return RefusedDnsError+ 6 → return NameExistsDnsError+ 7 → return RsExistsDnsError+ 8 → return NoRsDnsError+ 9 → return NotAuthDnsError+ 10 → return NotInZoneDnsError+ _ → fail "Unknown error code in a response"++instance Binary DnsResp where+ put = putDnsResp BinarySerializer+ get = getDnsResp BinarySerializer++instance Serialize DnsResp where+ put = putDnsResp CerealSerializer+ get = getDnsResp CerealSerializer+