resolve (empty) → 0.1.0.0
raw patch · 22 files changed
+1389/−0 lines, 22 filesdep +attoparsecdep +attoparsec-binarydep +basesetup-changed
Dependencies added: attoparsec, attoparsec-binary, base, bv, bytestring, hashable, hashmap, hslogger, iproute, network, parsec, stm, stm-containers, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- resolve.cabal +60/−0
- src/Resolve/DNS/Channel.hs +152/−0
- src/Resolve/DNS/Decode.hs +189/−0
- src/Resolve/DNS/Encode.hs +156/−0
- src/Resolve/DNS/Helper/DNS.hs +35/−0
- src/Resolve/DNS/Helper/LiveTCP.hs +23/−0
- src/Resolve/DNS/Helper/TCP.hs +19/−0
- src/Resolve/DNS/Helper/UDP.hs +19/−0
- src/Resolve/DNS/LiveTCP.hs +97/−0
- src/Resolve/DNS/Server/TCP.hs +46/−0
- src/Resolve/DNS/Server/Types.hs +24/−0
- src/Resolve/DNS/Server/UDP.hs +70/−0
- src/Resolve/DNS/TCP.hs +117/−0
- src/Resolve/DNS/Truncation.hs +40/−0
- src/Resolve/DNS/Types.hs +165/−0
- src/Resolve/DNS/UDP.hs +55/−0
- src/Resolve/Log.hs +17/−0
- src/Resolve/Retry.hs +23/−0
- src/Resolve/Timeout.hs +25/−0
- src/Resolve/Types.hs +25/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Zesen Qian (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Zesen Qian nor the names of other+ 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ resolve.cabal view
@@ -0,0 +1,60 @@+name: resolve+version: 0.1.0.0+synopsis: A name resolusion library+description: Please see README.org+homepage: https://github.com/riaqn/resolve#readme+license: BSD3+license-file: LICENSE+author: Zesen Qian+maintainer: haskell@riaqn.org+copyright: GPL3+category: Network+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Resolve.Types+ , Resolve.Timeout+ , Resolve.Retry+ , Resolve.Log+ , Resolve.DNS.TCP+ , Resolve.DNS.UDP+ , Resolve.DNS.Truncation+ , Resolve.DNS.LiveTCP+ , Resolve.DNS.Channel+ , Resolve.DNS.Decode+ , Resolve.DNS.Encode+ , Resolve.DNS.Types+ , Resolve.DNS.Helper.TCP+ , Resolve.DNS.Helper.UDP+ , Resolve.DNS.Helper.LiveTCP+ , Resolve.DNS.Helper.DNS+ , Resolve.DNS.Server.UDP+ , Resolve.DNS.Server.TCP+ , Resolve.DNS.Server.Types+ build-depends: base >= 4.7 && < 5+ , bytestring+ , attoparsec+ , attoparsec-binary+ , transformers+ , bv+ , hashmap+ , hashable+ , network+ , stm+ , stm-containers+ , parsec+ , hslogger+ , iproute+ default-language: Haskell2010+ default-extensions: BinaryLiterals+ , MultiParamTypeClasses+ , FunctionalDependencies+ , FlexibleInstances+ , GADTs+ +source-repository head+ type: git+ location: https://github.com/riaqn/resolve
+ src/Resolve/DNS/Channel.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE Unsafe #-}+module Resolve.DNS.Channel where++import qualified Resolve.Types as T+import Resolve.DNS.Types+import qualified Resolve.DNS.Encode as E+import qualified Resolve.DNS.Decode as D++import Data.Word+import Data.Hashable+import Data.Either+import Data.Maybe++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL++import Control.Monad.STM+import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Reader+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TMVar+++import Data.Typeable++import System.Log.Logger+++import qualified STMContainers.Map as M++nameM = "Resolve.DNS.Channel"++type Send = ByteString -> IO ()+type Recv = IO ByteString++data EncodeError = EncodeError String + deriving (Typeable, Show)++data Dead = Dead+ deriving (Typeable, Show)++instance Exception EncodeError where+ toException = dnsExceptionToException+ fromException = dnsExceptionFromException++instance Exception Dead where+ toException = dnsExceptionToException+ fromException = dnsExceptionFromException++data Config = Config { send :: Send+ , recv :: Recv+ , nick :: String+ }+ +data Resolver = Resolver { tid :: ThreadId+ , book :: M.Map Word16 (TMVar Message)+ , config :: Config+ , dead :: TVar Bool+ }++new :: Config -> IO (T.Resolver Message Message)+new c = do+ b <- M.newIO+ si <- newTVarIO False++ bracketOnError+ (forkIOWithUnmask $ \unmask -> unmask $ finally (forever $ runExceptT $ do -- EitherT String IO ()+ let nameF = nameM ++ ".recv"+ bs <- lift $ recv c+ m <- ExceptT $ return $ D.decodeMessage bs+ lift $ debugM nameF $ (nick c) ++ " -> recvd " ++ (show m)+ let ident' = (ident $ header $ m)+ r <- lift $ atomically $ lookupAndDelete b ident'+ case r of+ Nothing -> throwE "ID not in book"+ Just mvar -> lift $ atomically $ tryPutTMVar mvar m ) + (do+ debugM nameM $ (nick c) ++ " died"+ atomically $ writeTVar si True))+ killThread+ (\t -> do + let chan = Resolver { tid = t+ , book = b+ , config = c+ , dead = si+ }+ debugM nameM $ (nick c) ++ " created"+ return $ T.Resolver { T.delete = delete chan+ , T.resolve = resolve chan+ }+ )+ +delete r = killThread (tid r)++resolve r a = do+ let nameF = nameM ++ ".resolve"+ mvar <- newEmptyTMVarIO+ bracketOnError+ (atomically $ allocate (book r) (ident $ header $ a) mvar)+ (\ident_ -> atomically $ lookupAndDelete (book r) ident_)+ (\ident_ -> do + let a_ = a { header = (header a) { ident = ident_ }}+++ bs <- case E.encode E.message a_ of+ Left s -> throw $ EncodeError s+ Right b -> return $ BSL.toStrict b+++ forkIO $ catch+ (do+ debugM nameF $ (nick $ config $ r) ++ " <- sending " ++ (show a_)+ (send $ config $ r) bs+ debugM nameF $ (nick $ config $ r) ++ " <- sent ")+ (\e -> debugM nameF $ "exception when sending: " ++ show (e :: SomeException))+ + x <- atomically $ do+ a <- readTVar $ dead r+ if a then tryTakeTMVar mvar+ else + Just <$> takeTMVar mvar+ case x of+ Nothing -> throwIO Dead+ Just x -> return x+ )+ +allocate :: (Eq i, Hashable i, Num i) => M.Map i a -> i -> a -> STM i+allocate b i a = let loop i = do+ m <- do+ r <- M.lookup i b+ case r of+ Nothing -> do+ M.insert a i b+ return True+ Just _ -> return False+ if m then return i+ else loop (i + 1)+ in loop i++lookupAndDelete :: (Eq i, Hashable i) => M.Map i a -> i -> STM (Maybe a)+lookupAndDelete b i = do+ mvar <- M.lookup i b+ case mvar of+ Nothing -> return Nothing+ Just mvar -> do+ M.delete i b+ return $ Just mvar
+ src/Resolve/DNS/Decode.hs view
@@ -0,0 +1,189 @@+module Resolve.DNS.Decode where++import Prelude hiding (take)+import Resolve.DNS.Types hiding (name, header, question, qname, qclass, qtype)+import qualified Resolve.DNS.Types as T ++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Attoparsec.ByteString (Parser, parse) +import Data.Attoparsec.Binary +import Data.Attoparsec.ByteString+import Data.Word+import Data.Bits+import Data.Tuple+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad+import qualified Data.HashMap as HM+import Data.BitVector hiding (not)++import Data.IP++toCLASS :: Word16 -> CLASS+toCLASS c = case c of+ 1 -> IN+ 3 -> CH + 4 -> HS + i -> OTHER i ++toQCLASS :: Word16 -> QCLASS+toQCLASS c = case toCLASS c of+ OTHER i -> case i of+ 5 -> ANY+ _ -> CLASS $ OTHER i+ j -> CLASS $ j++toQTYPE :: Word16 -> QTYPE +toQTYPE t = case t of+ 1 -> Q_A + 2 -> Q_NS + 5 -> Q_CNAME + 6 -> Q_SOA+ 12 -> Q_PTR + 15 -> Q_MX + 16 -> Q_TXT + i -> Q_OTHER i ++toOPCODE :: BitVector -> OPCODE +toOPCODE c = case c of+ 0 -> STD + 1 -> INV + 2 -> SSR + +toRCODE :: BitVector -> RCODE +toRCODE c = case c of+ 0 -> NoErr+ 1 -> FormatErr+ 2 -> ServFail+ 3 -> NameErr+ 4 -> NotImpl+ 5 -> Refused+ i -> Other $ fromIntegral i++toQR :: Bool -> QR+toQR c = case c of+ False -> Query + True -> Response+++type SGet = ReaderT ByteString Parser++decodeMessage :: ByteString -> Either String Message+decodeMessage bs = parseOnly (runReaderT message bs) bs++message :: SGet T.Message+message = do+ (h, qd, an, ns, ar) <- lift header+ if tc h then+ return $ T.Message h [] [] [] []+ else+ T.Message h+ <$> count (fromIntegral qd) question+ <*> count (fromIntegral an) rr+ <*> count (fromIntegral ns) rr+ <*> count (fromIntegral ar) rr+ ++toBool :: (Eq a, Num a) => a -> Bool+toBool = (/= 0)++isEnd :: Word8 -> Bool+isEnd c = (c == 0) || (testBit c 7) && (testBit c 8)++extractNAME :: ByteString -> Int -> Either String T.NAME+extractNAME m i = parseOnly (runReaderT name m) (BS.drop i m)+ +name :: SGet T.NAME+name = do+ m <- ask+ c <- lift anyWord8+ if all (testBit c) [6,7] then do+ c' <- lift anyWord8+ let pos = ((fromIntegral (c .&. 0b111111) :: Word16) `shift` 8) .|. (fromIntegral c')+ case extractNAME m (fromIntegral pos) of+ Left e -> error e+ Right r -> return r+ + else if not (any (testBit c) [6,7]) then do+ l <- lift $ take (fromIntegral c)+ if c == 0 then return $ NAME [l]+ else do + (T.NAME tail) <- name+ return $ NAME $ l : tail+ else+ error $ "NAME format not recognized"+++charString :: SGet ByteString+charString = do+ n <- lift anyWord8+ lift $ take (fromIntegral n)++rr :: SGet T.RR+rr = do+ n <- name+ (c, t, ttl, rdata) <- lift $ do + t <- anyWord16be+ c_ <- anyWord16be+ let c = toCLASS c_ + ttl <- anyWord32be+ rdlength <- anyWord16be+ rdata <- take (fromIntegral rdlength)+ return (c, t, ttl, rdata)+ let p = case (t, c) of+ (5, _) -> RR_COM c <$> CNAME <$> name+ (15, _) -> RR_COM c <$> (MX <$> (lift anyWord16be) <*> name)+ (2, _) -> RR_COM c <$> NS <$> name+ (12, _) -> RR_COM c <$> PTR <$> name+ (6, _) -> RR_COM c <$> (SOA <$> name <*> name <*> lift anyWord32be+ <*> lift anyWord32be <*> lift anyWord32be <*> lift anyWord32be <*> lift anyWord32be)+ (16, _) -> RR_COM c <$> TXT <$> many1 charString+ (1, IN) -> RR_A <$> (lift $ do+ ip <- count 4 anyWord8+ flag <- atEnd+ when (not flag) $ error "IPv4 is not 4B?"+ return $ toIPv4 $ map fromIntegral ip)+ _ -> RR_OTHER c t <$> lift takeByteString+ bs <- ask+ case parseOnly (runReaderT p bs) rdata of+ Left e -> error $ e ++ show (c, t, ttl, rdata)+ Right r -> return $ RR n ttl r++qname = Resolve.DNS.Decode.name++qtype :: Parser T.QTYPE+qtype = do+ n <- anyWord16be+ return $ toQTYPE n ++qclass :: Parser T.QCLASS+qclass = do+ n <- anyWord16be+ return $ toQCLASS n + +question :: SGet T.Question+question = Question <$> qname+ <*> lift qtype+ <*> lift qclass++header :: Parser (T.Header, Word16, Word16, Word16, Word16)+header = do + i <- anyWord16be+ f_ <- anyWord16be+ qd <- anyWord16be+ an <- anyWord16be+ ns <- anyWord16be+ ar <- anyWord16be+ let f = bitVec 16 f_+ return $ (T.Header { T.ident = i+ , T.qr = toQR $ f @. 15+ , T.opcode = toOPCODE $ f @@ (14, 11)+ , T.aa = f @. 10+ , T.tc = f @. 9+ , T.rd = f @. 8+ , T.ra = f @. 7+ , T.zero = fromIntegral $ f @@ (6, 4)+ , T.rcode = toRCODE $ f @@ (3, 0)+ }+ , qd, an, ns, ar)
+ src/Resolve/DNS/Encode.hs view
@@ -0,0 +1,156 @@+module Resolve.DNS.Encode where++import Control.Monad.Trans.State+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder)+import Data.ByteString.Builder +import Resolve.DNS.Types hiding (header, name, qtype, question, qclass)+import qualified Resolve.DNS.Types as T +import Data.Monoid+import Data.Word+import Data.BitVector+import qualified Data.HashMap as HM+import Data.Maybe+import Data.Hashable+import Data.IP++instance Hashable QCLASS where+ hashWithSalt i a = i `xor` (fromIntegral $ fromQCLASS a)+ +instance Hashable QTYPE where+ hashWithSalt i a = i `xor` (fromIntegral $ fromQTYPE a)++fromCLASS :: CLASS -> Word16+fromCLASS c = case c of+ IN -> 1+ CH -> 3+ HS -> 4+ OTHER i -> i ++fromQCLASS :: QCLASS -> Word16+fromQCLASS c = case c of+ CLASS c' -> fromCLASS c'+ ANY -> 5++fromQTYPE :: QTYPE -> Word16 +fromQTYPE t = case t of+ Q_A -> 1+ Q_NS -> 2+ Q_CNAME -> 5+ Q_SOA -> 6+ Q_PTR -> 12+ Q_MX -> 15+ Q_TXT -> 16+ Q_OTHER i -> i++fromOPCODE :: OPCODE -> BitVector +fromOPCODE c = bitVec 4 $ case c of+ STD -> 0+ INV -> 1+ SSR -> 2+ +fromRCODE :: RCODE -> BitVector +fromRCODE c = bitVec 4 $ case c of+ NoErr -> 0+ FormatErr -> 1+ ServFail -> 2+ NameErr -> 3+ NotImpl -> 4+ Refused -> 5+ Other i -> i++fromQR :: QR -> Bool+fromQR c = case c of+ Query -> False+ Response -> True++type SPut a = a -> Either String Builder+type Put a = a -> Builder++encode :: SPut a -> a -> Either String BSL.ByteString+encode e a = case e a of+ Left e -> Left e+ Right b -> Right $ toLazyByteString b++message :: SPut Message+message m = fmap mconcat $ sequence [ Right $ header ( T.header m+ , fromIntegral $ length $ T.question m+ , fromIntegral $ length $ answer m+ , fromIntegral $ length $ authority m+ , fromIntegral $ length $ additional m)+ , fmap mconcat (mapM question $ T.question m)+ , fmap mconcat (mapM rr $ answer m)+ , fmap mconcat (mapM rr $ authority m)+ , fmap mconcat (mapM rr $ additional m)]+ +header :: Put (Header, Word16, Word16, Word16, Word16)+header (h, qd, an, ns, ar) =+ (word16BE (ident h)) <>+ (word16BE $ fromIntegral ((fromBool $ fromQR $ qr h) #+ (fromOPCODE $ opcode h) #+ (fromBool $ aa h) #+ (fromBool $ tc h) #+ (fromBool $ rd h) #+ (fromBool $ ra h) #+ (bitVec 3 $ zero h) #+ (fromRCODE $ rcode h))) <>+ word16BE qd <>+ word16BE an <>+ word16BE ns <>+ word16BE ar++label :: SPut LABEL+label l = if len < (fromIntegral (maxBound :: Word8)) then+ Right $ (word8 (fromIntegral len)) <> (byteString l)+ else+ Left "Too long the LABEL"+ where len = BS.length l++name :: SPut NAME+name (NAME n) = mconcat <$> mapM label n++qtype :: Put QTYPE+qtype t = word16BE $ fromQTYPE t++qclass :: Put QCLASS+qclass c = word16BE $ fromQCLASS c++question :: SPut Question+question q = mconcat <$> sequence [ name (qname q)+ , Right $ qtype (T.qtype q)+ , Right $ qclass (T.qclass q)]++rr :: SPut RR+rr rr = do+ b <- d+ let bs = toLazyByteString b+ let len = BSL.length bs+ if len < (fromIntegral (maxBound :: Word16)) then Right ()+ else Left "too large the RDATA"+ + mconcat <$> sequence [ name $ T.name rr+ , Right $ word16BE t+ , Right $ word16BE $ fromCLASS $ c+ , Right $ word32BE $ ttl rr+ , Right $ word16BE (fromIntegral len)+ , Right $ lazyByteString bs]+ where (c, t, d) = case rdata rr of+ RR_COM c com -> case com of + CNAME n -> (c, 5, name n)+ NS n -> (c, 2, name n)+ SOA mname rname serial refresh retry expire minimum ->+ (c, 6, mconcat <$> sequence [ name mname+ , name rname+ , Right $ word32BE serial+ , Right $ word32BE refresh+ , Right $ word32BE retry+ , Right $ word32BE expire+ , Right $ word32BE minimum+ ])+ PTR n -> (c, 12, name n)+ MX ref n -> (c, 15, mappend <$> (Right $ word16BE ref) <*> (name n))+ TXT d -> (c, 16, Right $ mconcat $ map byteString d)+ RR_A ip -> (IN, 1, Right $ mconcat $ map (word8 . fromIntegral) (fromIPv4 ip))+ RR_OTHER c t d -> (c, t, Right $ byteString d)
+ src/Resolve/DNS/Helper/DNS.hs view
@@ -0,0 +1,35 @@+module Resolve.DNS.Helper.DNS where++import Network.Socket++import Resolve.Types+import Resolve.DNS.Types+import qualified Resolve.DNS.Channel as C++import qualified Resolve.DNS.Helper.UDP as UDP+import qualified Resolve.DNS.Helper.LiveTCP as TCP++import qualified Resolve.DNS.Truncation as T++import Control.Exception+++data Config = Config { host :: HostName+ , port :: ServiceName+ }++new :: Config -> IO (Resolver Message Message)+new c = do+ bracketOnError+ (do+ u <- UDP.new $ UDP.Config {UDP.host = host c, UDP.port = port c}+ t <- TCP.new $ TCP.Config {TCP.host = host c, TCP.port = port c}+ return $ Resolver { resolve = T.truncation $ T.Config {T.udp = resolve u, T.tcp = resolve t}+ , delete = do+ delete u+ delete t+ }+ )+ (\r -> delete r)+ return+
+ src/Resolve/DNS/Helper/LiveTCP.hs view
@@ -0,0 +1,23 @@+module Resolve.DNS.Helper.LiveTCP where++import qualified Resolve.DNS.LiveTCP as TCP+import Resolve.Types+import Resolve.DNS.Types+import System.Log.Logger++import Network.Socket++data Config = Config { host :: HostName+ , port :: ServiceName+ }++lname = "Resolve.DNS.Helper.LiveTCP" ++new :: Config -> IO (Resolver Message Message)+new c = do+ let hints = defaultHints { addrSocketType = Stream}+ addr:_ <- getAddrInfo (Just hints) (Just $ host c) (Just $ port c)+ TCP.new $ TCP.Config { TCP.family = addrFamily addr+ , TCP.protocol = addrProtocol addr+ , TCP.server = addrAddress addr+ }
+ src/Resolve/DNS/Helper/TCP.hs view
@@ -0,0 +1,19 @@+module Resolve.DNS.Helper.TCP where++import qualified Resolve.DNS.TCP as TCP+import Resolve.Types+import Resolve.DNS.Types++import Network.Socket++data Config = Config { host :: HostName+ , port :: ServiceName+ }++new :: Config -> IO (Resolver Message Message)+new c = do+ let hints = defaultHints { addrSocketType = Stream}+ addr:_ <- getAddrInfo (Just hints) (Just $ host c) (Just $ port c)+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ connect sock $ addrAddress addr+ TCP.new $ TCP.Config { TCP.socket = sock}
+ src/Resolve/DNS/Helper/UDP.hs view
@@ -0,0 +1,19 @@+module Resolve.DNS.Helper.UDP where++import qualified Resolve.DNS.UDP as UDP+import Resolve.Types+import Resolve.DNS.Types++import Network.Socket++data Config = Config { host :: HostName+ , port :: ServiceName+ }++new :: Config -> IO (Resolver Message Message)+new c = do+ let hints = defaultHints { addrSocketType = Datagram}+ addr:_ <- getAddrInfo (Just hints) (Just $ host c) (Just $ port c)+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ UDP.new $ UDP.Config { UDP.socket = sock+ , UDP.server = addrAddress addr}
+ src/Resolve/DNS/LiveTCP.hs view
@@ -0,0 +1,97 @@+module Resolve.DNS.LiveTCP where++import qualified Resolve.DNS.TCP as TCP+import Resolve.Types+import qualified Resolve.DNS.Channel as C+import Resolve.DNS.Types++import Control.Monad+import Control.Monad.STM+import Control.Monad.Trans.Except+import Control.Concurrent.STM.TMVar+import Control.Concurrent++import Data.Maybe+import Data.Unique++import Control.Exception+++import Network.Socket hiding (Closed)++import System.Log.Logger++nameM = "Resolve.DNS.LiveTCP"++data Config = Config { family :: Family+ , protocol :: ProtocolNumber+ , server :: SockAddr + }+ deriving (Show)++data Record = Record { resolver :: Resolver Message Message+ , unique :: Unique+ , sock :: Socket+ }+ +new :: Config -> IO (Resolver Message Message)+new c = do+ res <- newEmptyTMVarIO+ l <- newEmptyTMVarIO -- whoever holds the lock will reconnect++ let del r = do+ delete (resolver r)+ close (sock r)+ x <- atomically $ do+ x <- tryReadTMVar res+ case x of+ Nothing -> return False+ Just r' -> if ((unique r) == (unique r')) then (void $ takeTMVar res) >> return True+ else return False+ when x $ debugM nameM $ (show c) ++ " connection closed, deleted"++ let loop a = do+ let nameF = nameM ++ ".resolve"+ bracket+ (atomically $ do+ x <- tryReadTMVar res+ when (isNothing x) $ putTMVar l ()+ return x)+ (\x -> atomically $ when (isNothing x) $ takeTMVar l)+ (\x -> case x of+ Just r -> do+ b <- try (resolve (resolver r) a)+ case b of+ Left C.Dead -> do+ del r+ loop a+ Right b' -> return b'+ Nothing -> do+ debugM nameF $ (show c) ++ " trying to reconnect"+ bracketOnError+ (socket (family c) (Stream) (protocol c))+ (\s -> close s)+ (\s -> do + connect s (server c)+ debugM nameF $ (show c ) ++ " reconnected"+ bracketOnError + (TCP.new $ TCP.Config { TCP.socket = s})+ delete+ (\r -> do+ u <- newUnique+ atomically $ do + putTMVar res $ Record { resolver = r+ , unique = u+ , sock = s}+ )+ )+ loop a)+ + return $ Resolver { resolve = loop+ , delete = do+ x <- atomically $ tryReadTMVar res+ case x of+ Nothing -> return ()+ Just r -> del r+ }+
+ src/Resolve/DNS/Server/TCP.hs view
@@ -0,0 +1,46 @@+module Resolve.DNS.Server.TCP where++import Resolve.Types++import Resolve.DNS.Types+import Resolve.DNS.Server.Types+import Data.ByteString+import qualified Data.ByteString.Lazy as BSL+import Data.Typeable++import qualified Resolve.DNS.Decode as D+import qualified Resolve.DNS.Encode as E++import Control.Monad.Trans.Reader+import Control.Monad.Trans.Except+import Control.Exception++++data DecodeError = DecodeError String+ deriving (Typeable, Show)++instance Exception DecodeError where+ toException = serverExceptionToException+ fromException = serverExceptionFromException++data EncodeError = EncodeError String+ deriving (Typeable, Show)++instance Exception EncodeError where+ toException = serverExceptionToException+ fromException = serverExceptionFromException++encodeMessage :: Message -> BSL.ByteString+encodeMessage m = case E.encode E.message m of+ Left e -> throw $ EncodeError e+ Right b -> b++resolve :: Resolve Message Message -> Resolve BSL.ByteString BSL.ByteString+resolve r a = do+ a' <- case D.decodeMessage (BSL.toStrict a) of+ Left e -> throw $ DecodeError e+ Right a' -> return a'+ b' <- r a'++ return $ encodeMessage b'
+ src/Resolve/DNS/Server/Types.hs view
@@ -0,0 +1,24 @@+module Resolve.DNS.Server.Types where++import Resolve.DNS.Types++import Data.Typeable+import Control.Exception++data ServerException where+ ServerException :: Exception e => e -> ServerException+ deriving (Typeable)++instance Show ServerException where+ show (ServerException e) = show e++instance Exception ServerException where+ toException = dnsExceptionToException+ fromException = dnsExceptionFromException++serverExceptionToException :: Exception e => e -> SomeException+serverExceptionToException = toException . ServerException++serverExceptionFromException x = do+ ServerException a <- fromException x+ cast a
+ src/Resolve/DNS/Server/UDP.hs view
@@ -0,0 +1,70 @@+module Resolve.DNS.Server.UDP where++import Resolve.Types++import Resolve.DNS.Types+import Resolve.DNS.Server.Types+import Data.ByteString+import qualified Data.ByteString.Lazy as BSL+import Data.Typeable++import qualified Resolve.DNS.Decode as D+import qualified Resolve.DNS.Encode as E++import Control.Monad.Trans.Reader+import Control.Monad.Trans.Except+import Control.Exception+++++data DecodeError = DecodeError String+ deriving (Typeable, Show)++instance Exception DecodeError where+ toException = serverExceptionToException+ fromException = serverExceptionFromException++data EncodeError = EncodeError String+ deriving (Typeable, Show)++instance Exception EncodeError where+ toException = serverExceptionToException+ fromException = serverExceptionFromException++data ResponseTooLong = ResponseTooLong+ deriving (Typeable, Show)++instance Exception ResponseTooLong where+ toException = serverExceptionToException+ fromException = serverExceptionFromException++maxLength = 512++encodeMessage :: Message -> BSL.ByteString+encodeMessage m = case E.encode E.message m of+ Left e -> throw $ EncodeError e+ Right b -> b++resolve :: Resolve Message Message -> Resolve ByteString ByteString+resolve r a = do+ a' <- case D.decodeMessage a of+ Left e -> throw $ DecodeError e+ Right a' -> return a'+ b' <- r a'++ let b = encodeMessage b'++ BSL.toStrict <$> if (BSL.null $ BSL.drop maxLength b) then+ return $ b+ else do+ let b_tc = encodeMessage $ b' { header = (header b') { tc = True }+ , question = question b'+ , answer = []+ , authority = []+ , additional = []+ }+ if (BSL.null $ BSL.drop maxLength b_tc) then+ return $ b_tc+ else+ throw ResponseTooLong
+ src/Resolve/DNS/TCP.hs view
@@ -0,0 +1,117 @@+module Resolve.DNS.TCP where++import Resolve.Types+import Resolve.DNS.Types+import qualified Resolve.DNS.Channel as C++import Data.Typeable+import Data.ByteString.Builder+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+++import Network.Socket hiding (recv, send, socket, Closed)+import Network.Socket.ByteString++import Data.Bits++import Control.Monad+import Control.Monad.Trans.Except+import Control.Monad.Trans.Class+import Control.Concurrent+import Control.Exception+import Control.Concurrent.STM.TMVar+import Control.Concurrent.STM.TVar+import Control.Monad.STM++import System.Log.Logger++nameM = "Resolve.DNS.TCP"++data Config = Config { socket :: Socket+ }++data Closed = Closed+ deriving (Show, Typeable)++instance Exception Closed where+ toException = dnsExceptionToException+ fromException = dnsExceptionFromException++new :: Config -> IO (Resolver Message Message)+new c = do+ qi <- newEmptyTMVarIO+ qo <- newEmptyTMVarIO+ si <- newTVarIO True+ so <- newTVarIO True+ + bracketOnError+ (do+ chan <- C.new C.Config { C.send = \a -> do+ v <- atomically $ do+ v <- readTVar so+ when v $ putTMVar qo a+ return v+ when (not v) $ throw Closed+ , C.recv = do+ v <- atomically $ do+ v <- readTVar si+ if v then do + x <- takeTMVar qi+ return $ Just x+ else tryTakeTMVar qi+ case v of+ Nothing -> throw Closed+ Just x -> return x+ , C.nick = "TCP<" ++ (show $ socket c) ++ ">"+ }++ to <- forkIOWithUnmask $ \unmask -> unmask $ finally+ (forever $ do+ let nameF = nameM ++ ".send"+ let sendAll bs = if BS.null bs then+ return ()+ else do+ n <- send (socket c) bs+ sendAll (BS.drop n bs)+ bs <- atomically $ takeTMVar qo+ sendAll $ BSL.toStrict $ toLazyByteString $ word16BE $ fromIntegral $ BS.length bs+ sendAll $ bs)+ (do+ debugM nameM "send died"+ atomically $ writeTVar so False)++ + ti <- forkIOWithUnmask $ \unmask -> unmask $ finally+ (forever $ runExceptT $ do -- EitherT String IO ()+ let nameF = nameM ++ ".recv"+ let recvAll' n = if n == 0 then return mempty+ else do -- IO ()+ bs <- recv (socket c) n++ when (BS.null bs) $ do+ throwTo to ThreadKilled+ throw ThreadKilled+ mappend (byteString bs) <$> (recvAll' $ n - (BS.length bs))+ recvAll n = do+ BSL.toStrict <$> toLazyByteString <$> recvAll' n+ n <- lift $ recvAll 2+ let n' = ((fromIntegral $ BS.index n 0) `shift` 8) .|. (fromIntegral $ BS.index n 1)+ d <- lift $ recvAll $ n'+ lift $ atomically $ putTMVar qi $ d)+ (do+ debugM nameM "recv died"+ atomically $ writeTVar si False)+ + return (resolve chan, do+ delete chan+ killThread ti+ killThread to+ )+ )+ (\(_, d) -> d)+ (\(r, d) -> return $ Resolver { resolve = r+ , delete = d+ }+ )
+ src/Resolve/DNS/Truncation.hs view
@@ -0,0 +1,40 @@+module Resolve.DNS.Truncation where++import Resolve.Types+import Resolve.DNS.Types+import qualified Resolve.DNS.Channel as C+import qualified Resolve.DNS.UDP as UDP+import qualified Resolve.DNS.LiveTCP as TCP++import Control.Monad.Trans.Except+import Control.Monad.Trans.Class+import Control.Exception++import System.Log.Logger++nameM = "Resolve.DNS.Truncation"+++data Config = Config { udp :: Resolve Message Message+ , tcp :: Resolve Message Message+ }++truncation :: Config -> Resolve Message Message+truncation c a = do+ let nameF = nameM+ b <- try (udp c a)+ res <- case b of+ Left UDP.QueryTooLong -> do + debugM nameF "query too long"+ return Nothing+ Right b -> if tc $ header $ b then do+ debugM nameF "response truncated"+ return Nothing+ else + return $ Just b+ case res of+ Nothing -> do+ debugM nameF "using TCP"+ tcp c a+ Just b -> return b+
+ src/Resolve/DNS/Types.hs view
@@ -0,0 +1,165 @@+module Resolve.DNS.Types where++import Data.Word+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import qualified Data.HashMap as HM+import Data.Tuple (swap)+import Data.Maybe+import Data.Bits+import Data.BitVector+import Data.List+import Data.IP+import Data.Typeable+++import Resolve.Types++import Control.Exception++data DNSException where+ DNSException :: Exception e => e -> DNSException+ deriving (Typeable)++instance Show DNSException where+ show (DNSException e) = show e++instance Exception DNSException where+ toException = resolveExceptionToException+ fromException = resolveExceptionFromException++dnsExceptionToException :: Exception e => e -> SomeException+dnsExceptionToException = toException . DNSException++dnsExceptionFromException x = do+ DNSException a <- fromException x+ cast a++type LABEL = ByteString+newtype NAME = NAME [LABEL] deriving (Eq, Ord)++qclass_word = map (\(a, b) -> (CLASS a, b)) class_word+ ++ [(ANY, 5)]+ :: [(QCLASS, Word16)]++class_word = [ (IN, 1)+ , (CH, 3)+ , (HS, 4)+ ] :: [(CLASS, Word16)]++qtype_word = [ (Q_A, 1 :: Word16)+ , (Q_NS, 2)+ , (Q_CNAME, 5)+ , (Q_SOA, 6)+ , (Q_PTR, 12)+ , (Q_MX, 15)+ , (Q_TXT, 16)+ ]++opcode_word = map (\(a, b) -> (a, bitVec 4 b))+ [ (STD, bitVec 4 0)+ , (INV, bitVec 4 1)+ , (SSR, bitVec 4 2)+ ]++rcode_word = map (\(a, b) -> (a, bitVec 4 b))+ [ (NoErr, 0)+ , (FormatErr, 1)+ , (ServFail, 2)+ , (NameErr, 3)+ , (NotImpl, 4)+ , (Refused, 5)+ ]++qr_word = [ (Query, False)+ , (Response, True)]+ +data Message = Message {+ header :: Header+ , question :: [Question]+ , answer :: [RR]+ , authority :: [RR]+ , additional :: [RR]+ } deriving (Eq, Show)++data Header = Header { ident :: Word16+ , qr :: QR+ , opcode :: OPCODE+ , aa :: Bool+ , tc :: Bool+ , rd :: Bool+ , ra :: Bool+ , zero :: Word8 -- should be Word3+ , rcode :: RCODE+ } deriving (Eq, Show)++data QR = Query | Response deriving (Eq, Show)++toBool :: QR -> Bool+toBool Query = False+toBool Response = True++data OPCODE+ = STD+ | INV+ | SSR+ deriving (Eq, Show, Bounded)++data RCODE+ = NoErr+ | FormatErr+ | ServFail+ | NameErr+ | NotImpl+ | Refused+ | Other Word8 -- actually should be Word4+ deriving (Eq, Ord, Show)++data CLASS = IN+ | CH+ | HS+ | OTHER Word16+ deriving (Eq, Show, Ord)++data QCLASS = CLASS CLASS+ | ANY+ deriving (Eq, Show, Ord)++data QTYPE = Q_A+ | Q_NS+ | Q_CNAME+ | Q_SOA+ | Q_PTR+ | Q_MX+ | Q_TXT+ | Q_AXFR+ | Q_ALL+ | Q_OTHER Word16+ deriving (Eq, Show, Ord)++data Question = Question { qname :: NAME+ , qtype :: QTYPE+ , qclass :: QCLASS+ } deriving (Eq, Show)++data RR = RR { name :: NAME+ , ttl :: Word32+ , rdata :: RDATA+ }+ deriving (Eq, Show)++data RDATA_COM = CNAME NAME+ | MX Word16 NAME+ | NS NAME+ | PTR NAME+ | SOA NAME NAME Word32 Word32 Word32 Word32 Word32+ | TXT [ByteString]+ deriving (Eq, Ord, Show)++data RDATA = RR_COM CLASS RDATA_COM+ | RR_A IPv4+ | RR_OTHER CLASS Word16 ByteString+ deriving (Eq, Ord, Show)++instance Show NAME where+ show (NAME xs) = intercalate "." (map BS.unpack xs)
+ src/Resolve/DNS/UDP.hs view
@@ -0,0 +1,55 @@+module Resolve.DNS.UDP where++import qualified Resolve.DNS.Channel as C+import Resolve.Types++import Resolve.DNS.Types+import Network.Socket hiding (send, sendTo, recv, recvFrom, socket)+import Network.Socket.ByteString+import qualified Data.ByteString as BS++import Data.Typeable++import Control.Exception+import Control.Monad++import System.Log.Logger++nameM = "Resolve.DNS.UDP"+++data Config = Config { socket :: Socket+ , server :: SockAddr+ }++data QueryTooLong = QueryTooLong+ deriving (Typeable, Show)++instance Exception QueryTooLong where+ toException = dnsExceptionToException+ fromException = dnsExceptionFromException++maxLength = 512++new :: Config -> IO (Resolver Message Message)+new c = do+ chan <- C.new C.Config { C.send = \a -> do+ let nameF = nameM ++ ".send"+ if BS.length a > maxLength then+ throw QueryTooLong+ else do+ void $ sendTo (socket c) a (server c)++ + , C.recv = let loop = do+ let nameF = nameM ++ ".recv"+ (bs, sa) <- (recvFrom (socket c) maxLength)+ if sa /= (server c) then loop+ else return bs+ in+ loop+ , C.nick = "UDP<" ++ (show $ socket $ c) ++ ">" ++ (show $ server $ c)+ }+ return $ Resolver { resolve = resolve chan+ , delete = delete chan+ }
+ src/Resolve/Log.hs view
@@ -0,0 +1,17 @@+module Resolve.Log where++import Resolve.Types+import Control.Exception++log :: (Show a, Show b) => (String -> IO()) -> (String -> IO()) -> Resolve a b -> Resolve a b+log error info r a = do+ catch + (do+ b <- r a+ info $ show a ++ "->" ++ show b+ return b+ )+ (\e -> do+ error $ show a ++ "->" ++ show (e :: SomeException)+ throw e+ )
+ src/Resolve/Retry.hs view
@@ -0,0 +1,23 @@+module Resolve.Retry where++import Resolve.Types++import Data.Typeable+import Control.Exception++data RetryOut = RetryOut+ deriving (Show, Typeable)++instance Exception RetryOut++retry :: Int -> Resolve a b -> Resolve a b+retry n r a =+ let loop n = if n == 0 then throw RetryOut+ else do+ m <- try (r a)+ case m of+ Left e -> do+ let x = e :: SomeException+ loop (n - 1)+ Right b -> return b+ in loop n
+ src/Resolve/Timeout.hs view
@@ -0,0 +1,25 @@+module Resolve.Timeout where++import Resolve.Types+import Control.Concurrent+import Control.Exception++import Data.Typeable++import Data.Unique++data Timeout = Timeout+ deriving (Show)++instance Exception Timeout where+ toException = resolveExceptionToException+ fromException = resolveExceptionFromException++timeout :: Int -> Resolve a b -> Resolve a b+timeout n r a = do + pid <- myThreadId+ bracket+ (forkIOWithUnmask $ \unmask ->+ unmask $ threadDelay n >> throwTo pid Timeout)+ (uninterruptibleMask_ . killThread)+ (\_ -> r a)
+ src/Resolve/Types.hs view
@@ -0,0 +1,25 @@+module Resolve.Types where++import Data.Typeable+import Control.Exception++type Resolve a b = a -> IO b+data Resolver a b = Resolver { resolve :: Resolve a b+ , delete :: IO ()+ }++data ResolveException where+ ResolveException :: Exception e => e -> ResolveException+ deriving (Typeable)++instance Show ResolveException where+ show (ResolveException e) = show e++instance Exception ResolveException++resolveExceptionToException :: Exception e => e -> SomeException+resolveExceptionToException = toException . ResolveException++resolveExceptionFromException x = do+ ResolveException a <- fromException x+ cast a