diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/hookup.cabal b/hookup.cabal --- a/hookup.cabal +++ b/hookup.cabal @@ -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 diff --git a/src/Hookup.hs b/src/Hookup.hs --- a/src/Hookup.hs +++ b/src/Hookup.hs @@ -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 diff --git a/src/Hookup/Socks5.hs b/src/Hookup/Socks5.hs new file mode 100644 --- /dev/null +++ b/src/Hookup/Socks5.hs @@ -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 +-} +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