diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Network/DNS/Client.hs b/Network/DNS/Client.hs deleted file mode 100644 --- a/Network/DNS/Client.hs +++ /dev/null @@ -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 } diff --git a/Network/DNS/Common.hs b/Network/DNS/Common.hs deleted file mode 100644 --- a/Network/DNS/Common.hs +++ /dev/null @@ -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 diff --git a/Network/DNS/ResolveConfParse.hs b/Network/DNS/ResolveConfParse.hs deleted file mode 100644 --- a/Network/DNS/ResolveConfParse.hs +++ /dev/null @@ -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 diff --git a/Network/DNS/Types.hs b/Network/DNS/Types.hs deleted file mode 100644 --- a/Network/DNS/Types.hs +++ /dev/null @@ -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 - diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/examples/Resolver.hs b/examples/Resolver.hs new file mode 100644 --- /dev/null +++ b/examples/Resolver.hs @@ -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) + diff --git a/network-dns.cabal b/network-dns.cabal --- a/network-dns.cabal +++ b/network-dns.cabal @@ -1,23 +1,47 @@ -name: network-dns -version: 0.1.2 -license: BSD3 -license-file: LICENSE -author: Adam Langley -maintainer: Adam Langley -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 +Maintainer: Mikhail Vorozhtsov +Copyright: 2013 Mikhail Vorozhtsov +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 diff --git a/src/Network/DNS.hs b/src/Network/DNS.hs new file mode 100644 --- /dev/null +++ b/src/Network/DNS.hs @@ -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 +