hookup 0.2 → 0.2.2

raw patch · 4 files changed

+621/−62 lines, 4 filesdep +attoparsecdep −socksdep ~basedep ~networkPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec

Dependencies removed: socks

Dependency ranges changed: base, network

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• hookup.cabal +6/−5
• src/Hookup.hs +251/−57
• src/Hookup/Socks5.hs +360/−0

@@ -1,5 +1,9 @@ # Revision history for hookup +## 0.2.1 -- 2018-07++* Added `connectWithSocket`, `recv`, `putBuf`, `defaultTlsParams`+ ## 0.2 -- 2017-11-22  * Allow connection parameters to specify address family with `cpFamily` field

@@ -1,5 +1,5 @@ name:                hookup-version:             0.2+version:             0.2.2 synopsis:            Abstraction over creating network connections with SOCKS5 and TLS description:         This package provides an abstraction for communicating with line-oriented                      network services while abstracting over the use of SOCKS5 and TLS (via OpenSSL)@@ -23,12 +23,13 @@  library   exposed-modules:     Hookup-  other-modules:       Hookup.OpenSSL+  other-modules:       Hookup.OpenSSL,+                       Hookup.Socks5   extra-libraries:     ssl-  build-depends:       base                  >=4.9  && <4.11,-                       socks                 >=0.5  && <0.6,-                       network               >=2.6  && <2.7,+  build-depends:       base                  >=4.9  && <4.12,+                       network               >=2.6  && <2.8,                        bytestring            >=0.10 && <0.11,+                       attoparsec            >=0.13 && <0.14,                        HsOpenSSL             >=0.11.2.3 && <0.12,                        HsOpenSSL-x509-system >=0.1  && <0.2   hs-source-dirs:      src

@@ -7,24 +7,47 @@  This module provides a uniform interface to network connections with optional support for TLS and SOCKS.++This library is careful to support both IPv4 and IPv6. It will attempt to+all of the addresses that a domain name resolves to until one the first+successful connection.++Use 'connect' and 'close' to establish and close network connections.++Use 'recv', 'recvLine', and 'send' to receive and transmit data on an+open network connection.++TLS and SOCKS parameters can be provided. When both are provided a connection+will first be established to the SOCKS server and then the TLS connection will+be established through that proxy server. This is most useful when connecting+through a dynamic port forward of an SSH client via the @-D@ flag.+ -} module Hookup   (+  -- * Connections+  Connection,+  connect,+  connectWithSocket,+  close,++  -- * Reading and writing data+  recv,+  recvLine,+  send,+  putBuf,+   -- * Configuration   ConnectionParams(..),   SocksParams(..),   TlsParams(..),   defaultFamily,+  defaultTlsParams, -  -- * Connections-  Connection,-  connect,-  recvLine,-  send,-  close,    -- * Errors   ConnectionFailure(..),+  CommandReply(..)   ) where  import           Control.Concurrent@@ -32,34 +55,49 @@ import           Control.Monad import           Data.ByteString (ByteString) import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8 import           Data.Foldable import           Data.List (intercalate)-import           Network (PortID(..)) import           Network.Socket (Socket, AddrInfo, PortNumber, HostName, Family) import qualified Network.Socket as Socket import qualified Network.Socket.ByteString as SocketB-import           Network.Socks5 import           OpenSSL.Session (SSL, SSLContext) import qualified OpenSSL as SSL import qualified OpenSSL.Session as SSL import qualified OpenSSL.X509 as SSL import           OpenSSL.X509.SystemStore import qualified OpenSSL.PEM as PEM+import           Data.Attoparsec.ByteString (Parser)+import qualified Data.Attoparsec.ByteString as Parser  import           Hookup.OpenSSL (installVerification)+import           Hookup.Socks5   -- | Parameters for 'connect'.+--+-- Common defaults for fields: 'defaultFamily', 'defaultTlsParams'+--+-- The address family can be specified in order to force only+-- IPv4 or IPv6 to be used. The default behavior is to support both.+-- It can be useful to specify exactly one of these in the case that+-- the other is misconfigured and a hostname is resolving to both.+--+-- When a 'SocksParams' is provided the connection will be established+-- using a SOCKS (version 5) proxy.+--+-- When a 'TlsParams' is provided the connection negotiate TLS at connect+-- time in order to protect the stream. data ConnectionParams = ConnectionParams   { cpFamily :: Family           -- ^ IP Protocol family (default 'AF_UNSPEC')   , cpHost  :: HostName          -- ^ Destination host   , cpPort  :: PortNumber        -- ^ Destination TCP port-  , cpSocks :: Maybe SocksParams -- ^ Optional SOCKS5 parameters+  , cpSocks :: Maybe SocksParams -- ^ Optional SOCKS parameters   , cpTls   :: Maybe TlsParams   -- ^ Optional TLS parameters   }  --- | SOCKS5 connection parameters+-- | SOCKS connection parameters data SocksParams = SocksParams   { spHost :: HostName   -- ^ SOCKS server host   , spPort :: PortNumber -- ^ SOCKS server port@@ -72,11 +110,10 @@   { tpClientCertificate  :: Maybe FilePath -- ^ Path to client certificate   , tpClientPrivateKey   :: Maybe FilePath -- ^ Path to client private key   , tpServerCertificate  :: Maybe FilePath -- ^ Path to CA certificate bundle-  , tpCipherSuite        :: String -- ^ OpenSSL cipher suite name (e.g. "HIGH")-  , tpInsecure           :: Bool -- ^ Disables certificate checking+  , tpCipherSuite        :: String -- ^ OpenSSL cipher suite name (e.g. @\"HIGH\"@)+  , tpInsecure           :: Bool -- ^ Disables certificate checking when 'True'   } - -- | Type for errors that can be thrown by this package. data ConnectionFailure   -- | Failure during 'getAddrInfo' resolving remote host@@ -87,6 +124,14 @@   | LineTooLong   -- | Incomplete line during 'recvLine'   | LineTruncated+  -- | Socks command rejected by server by given reply code+  | SocksError CommandReply+  -- | Socks authentication method was not accepted+  | SocksAuthenticationError+  -- | Socks server sent an invalid message or no message.+  | SocksProtocolError+  -- | Domain name was too long for SOCKS protocol+  | SocksBadDomainName   deriving Show  -- | 'displayException' implemented for prettier messages@@ -94,15 +139,45 @@   displayException LineTruncated = "connection closed while reading line"   displayException LineTooLong   = "line length exceeded maximum"   displayException (ConnectionFailure xs) =-    "connection attempts failed due to: " +++    "connection attempt failed due to: " ++       intercalate ", " (map displayException xs)   displayException (HostnameResolutionFailure x) =     "hostname resolution failed: " ++ displayException x+  displayException SocksAuthenticationError =+    "SOCKS authentication method rejected"+  displayException SocksProtocolError =+    "SOCKS server protocol error"+  displayException SocksBadDomainName =+    "SOCKS domain name length limit exceeded"+  displayException (SocksError reply) =+    "SOCKS command rejected: " +++    case reply of+      Succeeded         -> "succeeded"+      GeneralFailure    -> "general SOCKS server failure"+      NotAllowed        -> "connection not allowed by ruleset"+      NetUnreachable    -> "network unreachable"+      HostUnreachable   -> "host unreachable"+      ConnectionRefused -> "connection refused"+      TTLExpired        -> "TTL expired"+      CmdNotSupported   -> "command not supported"+      AddrNotSupported  -> "address type not supported"+      CommandReply n    -> "unknown reply " ++ show n  -- | Default 'Family' value is unspecified and allows both INET and INET6. defaultFamily :: Socket.Family defaultFamily = Socket.AF_UNSPEC +-- | Default values for TLS that use no client certificates, use+-- system CA root, @\"HIGH\"@ cipher suite, and which validate hostnames.+defaultTlsParams :: TlsParams+defaultTlsParams = TlsParams+  { tpClientCertificate  = Nothing+  , tpClientPrivateKey   = Nothing+  , tpServerCertificate  = Nothing -- use system provided CAs+  , tpCipherSuite        = "HIGH"+  , tpInsecure           = False+  }+ ------------------------------------------------------------------------ -- Opening sockets ------------------------------------------------------------------------@@ -113,16 +188,58 @@ openSocket params =   case cpSocks params of     Nothing -> openSocket' (cpFamily params) (cpHost params) (cpPort params)-    Just sp -> openSocks sp (cpHost params) (cpPort params)+    Just sp ->+      do sock <- openSocket' (cpFamily params) (spHost sp) (spPort sp)+         (sock <$ socksConnect sock (cpHost params) (cpPort params))+           `onException` Socket.close sock  -openSocks :: SocksParams -> HostName -> PortNumber -> IO Socket-openSocks sp h p =-  do socksConnectTo'-       (spHost sp) (PortNumber (spPort sp))-       h           (PortNumber p)+netParse :: Show a => Socket -> Parser a -> IO a+netParse sock parser =+  do -- receiving 1 byte at a time is not efficient, but these messages+     -- are very short and we don't want to read any more from the socket+     -- than is necessary+     result <- Parser.parseWith+                 (SocketB.recv sock 1)+                 parser+                 B.empty+     case result of+       Parser.Done i x | B.null i -> return x+       _ -> throwIO SocksProtocolError  +socksConnect :: Socket -> HostName -> PortNumber -> IO ()+socksConnect sock host port =+  do SocketB.sendAll sock $+       buildClientHello ClientHello+         { cHelloMethods = [AuthNoAuthenticationRequired] }++     validateHello =<< netParse sock parseServerHello++     let dnBytes = B8.pack host+     unless (B.length dnBytes < 256)+       (throwIO SocksBadDomainName)++     SocketB.sendAll sock $+       buildRequest Request+         { reqCommand  = Connect+         , reqAddress  = Address (DomainName dnBytes) port+         }++     validateResponse =<< netParse sock parseResponse+++validateHello :: ServerHello -> IO ()+validateHello hello =+  unless (sHelloMethod hello == AuthNoAuthenticationRequired)+    (throwIO SocksAuthenticationError)++validateResponse :: Response -> IO ()+validateResponse response =+  unless (rspReply response == Succeeded )+    (throwIO (SocksError (rspReply response)))++ openSocket' :: Family -> HostName -> PortNumber -> IO Socket openSocket' family h p =   do let hints = Socket.defaultHints@@ -137,16 +254,28 @@        Left  ioe -> throwIO (HostnameResolutionFailure ioe)  -attemptConnections :: [IOError] -> [Socket.AddrInfo] -> IO Socket+-- | Try establishing a connection to the services indicated by+-- a given list of 'AddrInfo' values. Either return a socket that+-- has successfully connected to one of the candidate 'AddrInfo's+-- or throw a 'ConnectionFailure' exception will all of the+-- encountered errors.+attemptConnections ::+  [IOError]         {- ^ accumulated errors  -} ->+  [Socket.AddrInfo] {- ^ candidate AddrInfos -} ->+  IO Socket         {- ^ connected socket    -} attemptConnections exs [] = throwIO (ConnectionFailure exs) attemptConnections exs (ai:ais) =-  do s <- socket' ai-     res <- try (Socket.connect s (Socket.addrAddress ai))+  do res <- try (connectToAddrInfo ai)      case res of-       Left ex -> do Socket.close s-                     attemptConnections (ex:exs) ais-       Right{} -> return s+       Left ex -> attemptConnections (ex:exs) ais+       Right s -> return s +-- | Create a socket and connect to the service identified+-- by the given 'AddrInfo' and return the connected socket.+connectToAddrInfo :: AddrInfo -> IO Socket+connectToAddrInfo info+  = bracketOnError (socket' info) Socket.close+  $ \s -> s <$ Socket.connect s (Socket.addrAddress info)  -- | Open a 'Socket' using the parameters from an 'AddrInfo' socket' :: AddrInfo -> IO Socket@@ -164,12 +293,14 @@ data NetworkHandle = SSL SSL | Socket Socket  -openNetworkHandle :: ConnectionParams -> IO NetworkHandle-openNetworkHandle params =-  do s <- openSocket params-     case cpTls params of-       Nothing -> return (Socket s)-       Just tp -> SSL <$> startTls (cpHost params) tp s+openNetworkHandle ::+  ConnectionParams {- ^ parameters             -} ->+  IO Socket        {- ^ socket creation action -} ->+  IO NetworkHandle {- ^ open network handle    -}+openNetworkHandle params mkSocket =+  case cpTls params of+    Nothing  -> Socket <$> mkSocket+    Just tls -> SSL <$> startTls tls (cpHost params) mkSocket   closeNetworkHandle :: NetworkHandle -> IO ()@@ -199,18 +330,53 @@ -- | Open network connection to TCP service specified by -- the given parameters. --+-- The resulting connection MUST be closed with 'close' to avoid leaking+-- resources.+-- -- Throws 'IOError', 'SocksError', 'SSL.ProtocolError', 'ConnectionFailure'-connect :: ConnectionParams -> IO Connection+connect ::+  ConnectionParams {- ^ parameters      -} ->+  IO Connection    {- ^ open connection -} connect params =-  do h <- openNetworkHandle params+  do h <- openNetworkHandle params (openSocket params)      b <- newMVar B.empty      return (Connection b h) +-- | Create a new 'Connection' using an already connected socket.+-- This will attempt to start TLS if configured but will ignore+-- any SOCKS server settings as it is assumed that the socket+-- is already actively connected to the intended service.+--+-- Throws 'SSL.ProtocolError'+connectWithSocket ::+  ConnectionParams {- ^ parameters       -} ->+  Socket           {- ^ connected socket -} ->+  IO Connection    {- ^ open connection  -}+connectWithSocket params sock =+  do h <- openNetworkHandle params (return sock)+     b <- newMVar B.empty+     return (Connection b h)  -- | Close network connection.-close :: Connection -> IO ()+close ::+  Connection {- ^ open connection -} ->+  IO () close (Connection _ h) = closeNetworkHandle h +-- | Receive the next chunk from the stream. This operation will first+-- return the buffer if it contains a non-empty chunk. Otherwise it will+-- request up to the requested number of bytes from the stream.+--+-- Throws: 'IOError', 'SSL.ConnectionAbruptlyTerminated', 'SSL.ProtocolError'+recv ::+  Connection    {- ^ open connection              -} ->+  Int           {- ^ maximum underlying recv size -} ->+  IO ByteString {- ^ next chunk from stream       -}+recv (Connection buf h) n =+  do bufChunk <- swapMVar buf B.empty+     if B.null bufChunk+       then networkRecv h n+       else return bufChunk  -- | Receive a line from the network connection. Both -- @"\\r\\n"@ and @"\\n"@ are recognized.@@ -222,38 +388,60 @@ -- can happen if the peer transmits some data and closes its end -- without transmitting a line terminator. ----- Throws: 'ConnectionAbruptlyTerminated', 'ConnectionFailure', 'IOError'-recvLine :: Connection -> Int -> IO (Maybe ByteString)+-- Throws: 'SSL.ConnectionAbruptlyTerminated', 'SSL.ProtocolError', 'ConnectionFailure', 'IOError'+recvLine ::+  Connection            {- ^ open connection            -} ->+  Int                   {- ^ maximum line length        -} ->+  IO (Maybe ByteString) {- ^ next line or end-of-stream -} recvLine (Connection buf h) n =   modifyMVar buf $ \bs ->     go (B.length bs) bs []   where+    -- bsn: cached length of concatenation of (bs:bss)+    -- bs : most recent chunk+    -- bss: other chunks ordered from most to least recent     go bsn bs bss =-      case B.elemIndex 10 bs of-        Just i -> return (B.tail b,+      case B8.elemIndex '\n' bs of+        Just i -> return (B.tail b, -- tail drops newline                           Just (cleanEnd (B.concat (reverse (a:bss)))))           where             (a,b) = B.splitAt i bs         Nothing ->           do when (bsn >= n) (throwIO LineTooLong)              more <- networkRecv h n-             if B.null more-               then if B.null bs then return (B.empty, Nothing)-                                 else throwIO LineTruncated+             if B.null more -- connection closed+               then if bsn == 0 then return (B.empty, Nothing)+                                else throwIO LineTruncated                else go (bsn + B.length more) more (bs:bss)  +-- | Push a 'ByteString' onto the buffer so that it will be the first+-- bytes to be read on the next receive operation. This could perhaps+-- be useful for putting the unused portion of a 'recv' back into the+-- buffer for future 'recvLine' or 'recv' operations.+putBuf ::+  Connection {- ^ connection         -} ->+  ByteString {- ^ new head of buffer -} ->+  IO ()+putBuf (Connection buf h) bs =+  modifyMVar_ buf (\old -> return $! B.append bs old)++ -- | Remove the trailing @'\\r'@ if one is found. cleanEnd :: ByteString -> ByteString cleanEnd bs-  | B.null bs || B.last bs /= 13 = bs-  | otherwise                    = B.init bs+  | B.null bs || B8.last bs /= '\r' = bs+  | otherwise                       = B.init bs  --- | Send bytes on the network connection.+-- | Send bytes on the network connection. This ensures the whole chunk is+-- transmitted, which might take multiple underlying sends. ----- Throws: 'IOError', 'ProtocolError'-send :: Connection -> ByteString -> IO ()+-- Throws: 'IOError', 'SSL.ProtocolError'+send ::+  Connection {- ^ open connection -} ->+  ByteString {- ^ chunk           -} ->+  IO () send (Connection _ h) = networkSend h  @@ -263,18 +451,19 @@ -- | Initiate a TLS session on the given socket destined for -- the given hostname. When successful an active TLS connection -- is returned with certificate verification successful when--- requested.+-- requested. This function requires that the TLSParams component+-- of 'ConnectionParams' is set. startTls ::-  HostName  {- ^ server hostname  -} ->-  TlsParams {- ^ parameters       -} ->-  Socket    {- ^ connected socket -} ->-  IO SSL    {- ^ connected TLS    -}-startTls host tp s = SSL.withOpenSSL $+  TlsParams {- ^ connection params      -} ->+  String    {- ^ hostname               -} ->+  IO Socket {- ^ socket creation action -} ->+  IO SSL    {- ^ connected TLS          -}+startTls tp hostname mkSocket = SSL.withOpenSSL $   do ctx <- SSL.context       -- configure context      SSL.contextSetCiphers          ctx (tpCipherSuite tp)-     installVerification            ctx host+     installVerification            ctx hostname      SSL.contextSetVerificationMode ctx (verificationMode (tpInsecure tp))      SSL.contextAddOption           ctx SSL.SSL_OP_ALL      SSL.contextRemoveOption        ctx SSL.SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS@@ -285,8 +474,13 @@      traverse_ (setupPrivateKey  ctx) (tpClientPrivateKey  tp)       -- add socket to context-     ssl <- SSL.connection ctx s-     SSL.setTlsextHostName ssl host+     -- creation of the socket is delayed until this point to avoid+     -- leaking the file descriptor in the cases of exceptions above.+     ssl <- SSL.connection ctx =<< mkSocket++     -- configure hostname used for certificate validation+     SSL.setTlsextHostName ssl hostname+      SSL.connect ssl       return ssl@@ -309,7 +503,7 @@ setupPrivateKey :: SSLContext -> FilePath -> IO () setupPrivateKey ctx path =   do str <- readFile path -- EX-     key <- PEM.readPrivateKey str PEM.PwNone -- add password support+     key <- PEM.readPrivateKey str PEM.PwNone -- TODO: add password support      SSL.contextSetPrivateKey ctx key  

@@ -0,0 +1,360 @@+{-# Language PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -Wno-missing-pattern-synonym-signatures #-}+{-|+Module      : Hookup.Socks5+Description : SOCKS5 network protocol implementation+Copyright   : (c) Eric Mertens, 2018+License     : ISC+Maintainer  : emertens@gmail.com++This module provides types, parsers, and builders for the messages+used in the SOCKS5 protocol. See <https://tools.ietf.org/html/rfc1928>+-}+module Hookup.Socks5++  ( -- * Client hello message+    ClientHello(..)+  , buildClientHello+  , parseClientHello++  -- * Server hello message+  , ServerHello(..)+  , buildServerHello+  , parseServerHello++  -- * Command request message+  , Request(..)+  , buildRequest+  , parseRequest++  -- * Command response message+  , Response(..)+  , buildResponse+  , parseResponse++  -- * Network address types+  , Address(..)+  , Host(..)++  -- * Authentication methods+  , AuthMethod+      ( AuthNoAuthenticationRequired+      , AuthGssApi+      , AuthUsernamePassword+      , AuthNoAcceptableMethods )++  -- * Commands+  , Command+      ( Connect+      , Bind+      , UdpAssociate )++  -- * Command reply codes+  , CommandReply+      ( CommandReply+      , Succeeded+      , GeneralFailure+      , NotAllowed+      , NetUnreachable+      , HostUnreachable+      , ConnectionRefused+      , TTLExpired+      , CmdNotSupported+      , AddrNotSupported )++  )+  where++import           Control.Monad              (replicateM)+import           Data.Attoparsec.ByteString (Parser)+import           Data.ByteString            (ByteString)+import           Data.ByteString.Builder    (Builder)+import           Data.Word                  (Word8, Word16)+import           Network.Socket             (HostAddress, HostAddress6, PortNumber,+                                             hostAddressToTuple, hostAddress6ToTuple,+                                             tupleToHostAddress, tupleToHostAddress6)+import qualified Data.Attoparsec.ByteString as Parser+import qualified Data.ByteString            as B+import qualified Data.ByteString.Builder    as Builder+import qualified Data.ByteString.Lazy       as L++-- | SOCKS authentication methods+newtype AuthMethod                      = AuthMethod Word8 deriving (Eq, Show)+pattern AuthNoAuthenticationRequired    = AuthMethod 0x00+pattern AuthGssApi                      = AuthMethod 0x01+pattern AuthUsernamePassword            = AuthMethod 0x02+pattern AuthNoAcceptableMethods         = AuthMethod 0xFF++-- | SOCKS client commands+newtype Command                         = Command Word8 deriving (Eq, Show)+pattern Connect                         = Command 1+pattern Bind                            = Command 2+pattern UdpAssociate                    = Command 3++-- | Tags used in the protocol messages for encoded 'Host' values+newtype HostTag                         = HostTag Word8 deriving (Eq, Show)+pattern IPv4Tag                         = HostTag 1+pattern DomainNameTag                   = HostTag 3+pattern IPv6Tag                         = HostTag 4++-- | SOCKS command reply codes+newtype CommandReply                    = CommandReply Word8 deriving (Eq, Show)+pattern Succeeded                       = CommandReply 0+pattern GeneralFailure                  = CommandReply 1+pattern NotAllowed                      = CommandReply 2+pattern NetUnreachable                  = CommandReply 3+pattern HostUnreachable                 = CommandReply 4+pattern ConnectionRefused               = CommandReply 5+pattern TTLExpired                      = CommandReply 6+pattern CmdNotSupported                 = CommandReply 7+pattern AddrNotSupported                = CommandReply 8++-- | Network host and port number+data Address = Address Host PortNumber+  deriving Show++-- | Network host identified by address or domain name.+data Host+  = IPv4 HostAddress      -- ^ IPv4 host address+  | IPv6 HostAddress6     -- ^ IPv6 host address+  | DomainName ByteString -- ^ Domain name (maximum length 255)+  deriving Show+++-- | Initial SOCKS sent by client with proposed list of authentication methods.+data ClientHello = ClientHello+  { cHelloMethods :: [AuthMethod] -- ^ proposed methods (maximum length 255)+  }+  deriving Show++-- | Initial SOCKS sent by server with chosen authentication method.+data ServerHello = ServerHello+  { sHelloMethod  :: AuthMethod+  }+  deriving Show++-- | Client message used to request a network operation from the SOCKS server.+data Request = Request+  { reqCommand :: Command+  , reqAddress :: Address+  }+  deriving Show++-- | Server message used to indicate result of client's request.+data Response = Response+  { rspReply   :: CommandReply+  , rspAddress :: Address+  }+  deriving Show++-- | Transform a 'Builder' into a strict 'ByteString'+runBuilder :: Builder -> ByteString+runBuilder = L.toStrict . Builder.toLazyByteString++------------------------------------------------------------------------++buildCommand :: Command -> Builder+buildCommand (Command c) = Builder.word8 c++parseCommand :: Parser Command+parseCommand = Command <$> Parser.anyWord8++------------------------------------------------------------------------++buildHost :: Host -> Builder+buildHost (IPv4 hostAddr) = buildHostTag IPv4Tag       <> buildHostAddress  hostAddr+buildHost (IPv6 hostAddr) = buildHostTag IPv6Tag       <> buildHostAddress6 hostAddr+buildHost (DomainName dn) = buildHostTag DomainNameTag <> buildDomainName dn++parseHost :: Parser Host+parseHost =+  do tag <- parseHostTag+     case tag of+       IPv4Tag       -> IPv4       <$> parseHostAddress+       IPv6Tag       -> IPv6       <$> parseHostAddress6+       DomainNameTag -> DomainName <$> parseDomainName+       _             -> fail "bad address tag"++------------------------------------------------------------------------++buildAddress :: Address -> Builder+buildAddress (Address host port) = buildHost host <> buildPort port++parseAddress :: Parser Address+parseAddress = Address <$> parseHost <*> parsePort++------------------------------------------------------------------------++buildHostTag :: HostTag -> Builder+buildHostTag (HostTag tag) = Builder.word8 tag++parseHostTag :: Parser HostTag+parseHostTag = HostTag <$> Parser.anyWord8++------------------------------------------------------------------------++buildHostAddress :: HostAddress -> Builder+buildHostAddress hostAddr =+  case hostAddressToTuple hostAddr of+    (a1,a2,a3,a4) -> foldMap Builder.word8 [a1,a2,a3,a4]++parseHostAddress :: Parser HostAddress+parseHostAddress =+  do [a1,a2,a3,a4] <- replicateM 4 Parser.anyWord8+     return $! tupleToHostAddress (a1,a2,a3,a4)++------------------------------------------------------------------------++buildHostAddress6 :: HostAddress6 -> Builder+buildHostAddress6 hostAddr =+  case hostAddress6ToTuple hostAddr of+    (a1,a2,a3,a4,a5,a6,a7,a8) ->+      foldMap Builder.word16BE [a1,a2,a3,a4,a5,a6,a7,a8]++parseHostAddress6 :: Parser HostAddress6+parseHostAddress6 =+  do [a1,a2,a3,a4,a5,a6,a7,a8] <- replicateM 8 parseWord16BE+     return $! tupleToHostAddress6 (a1,a2,a3,a4,a5,a6,a7,a8)++------------------------------------------------------------------------++buildDomainName :: ByteString -> Builder+buildDomainName bs+  | B.length bs < 256 = Builder.word8 (fromIntegral (B.length bs)) <>+                        Builder.byteString bs+  | otherwise = error "SOCKS5 domain name too long"++parseDomainName :: Parser ByteString+parseDomainName =+  do len <- Parser.anyWord8+     Parser.take (fromIntegral len)++------------------------------------------------------------------------++buildPort :: PortNumber -> Builder+buildPort port = Builder.word16BE (fromIntegral port)++parsePort :: Parser PortNumber+parsePort = fromIntegral <$> parseWord16BE++------------------------------------------------------------------------++buildVersion :: Builder+buildVersion = Builder.word8 5++parseVersion :: Parser ()+parseVersion = () <$ Parser.word8 5++------------------------------------------------------------------------++buildAuthMethod :: AuthMethod -> Builder+buildAuthMethod (AuthMethod x) = Builder.word8 x++parseAuthMethod :: Parser AuthMethod+parseAuthMethod = AuthMethod <$> Parser.anyWord8++------------------------------------------------------------------------++buildReply :: CommandReply -> Builder+buildReply (CommandReply x) = Builder.word8 x++parseReply :: Parser CommandReply+parseReply = CommandReply <$> Parser.anyWord8++------------------------------------------------------------------------++buildReserved :: Builder+buildReserved = Builder.word8 0++parseReserved :: Parser ()+parseReserved = () <$ Parser.anyWord8++------------------------------------------------------------------------++-- | Build a list of buildable things prefixing the length of the list+-- as a single byte. The list must not be longer than 255 elements.+buildListOf :: (a -> Builder) -> [a] -> Builder+buildListOf builder xs+  | length xs < 256 = Builder.word8 (fromIntegral (length xs)) <>+                      foldMap builder xs+  | otherwise       = error "buildListOf: list too long"++-- | Parse a list of parsable things where the length of the list+-- is encoded as a single byte before the items to be parsed.+parseListOf :: Parser a -> Parser [a]+parseListOf parser =+  do n <- Parser.anyWord8+     replicateM (fromIntegral n) parser++------------------------------------------------------------------------++buildClientHello :: ClientHello -> ByteString+buildClientHello msg =+  runBuilder $+  buildVersion <>+  buildListOf buildAuthMethod (cHelloMethods msg)++parseClientHello :: Parser ClientHello+parseClientHello =+  ClientHello+    <$  parseVersion+    <*> parseListOf parseAuthMethod++------------------------------------------------------------------------++buildServerHello :: ServerHello -> ByteString+buildServerHello msg =+  runBuilder $+  buildVersion <>+  buildAuthMethod (sHelloMethod msg)++parseServerHello :: Parser ServerHello+parseServerHello =+  ServerHello+    <$  parseVersion+    <*> parseAuthMethod++------------------------------------------------------------------------++buildRequest :: Request -> ByteString+buildRequest req =+  runBuilder $+  buildVersion                    <>+  buildCommand  (reqCommand  req) <>+  buildReserved                   <>+  buildAddress  (reqAddress  req)++parseRequest :: Parser Request+parseRequest =+  Request+    <$  parseVersion+    <*> parseCommand+    <*  parseReserved+    <*> parseAddress++------------------------------------------------------------------------++buildResponse :: Response -> ByteString+buildResponse msg =+  runBuilder $+  buildVersion                  <>+  buildReply   (rspReply   msg) <>+  buildReserved                 <>+  buildAddress (rspAddress msg)++parseResponse :: Parser Response+parseResponse =+  Response+    <$  parseVersion+    <*> parseReply+    <*  parseReserved+    <*> parseAddress++------------------------------------------------------------------------++-- | Match a 16-bit, big-endian word.+parseWord16BE :: Parser Word16+parseWord16BE =+  do hi <- Parser.anyWord8+     lo <- Parser.anyWord8+     return $! fromIntegral hi * 0x100 + fromIntegral lo