diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for hookup +## 0.8 + +* Add support for plaintext socks5 authentication + ## 0.7 * Add ability to specify TLS 1.3 cipher suites diff --git a/hookup.cabal b/hookup.cabal --- a/hookup.cabal +++ b/hookup.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hookup -version: 0.7 +version: 0.8 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) @@ -11,10 +11,10 @@ copyright: 2016-2020 Eric Mertens category: Network build-type: Simple -extra-source-files: ChangeLog.md +extra-doc-files: ChangeLog.md homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues -tested-with: GHC==8.10.1 +tested-with: GHC==9.4.7 source-repository head type: git @@ -37,11 +37,11 @@ cbits/pem_password_cb.c build-depends: - base >=4.11 && <4.17, + base >=4.11 && <4.20, async ^>=2.2, stm ^>=2.5, network >=3.0 && <3.2, - bytestring >=0.10 && <0.12, + bytestring >=0.10 && <0.13, attoparsec ^>=0.14, HsOpenSSL >=0.11.2.3 && <0.12, HsOpenSSL-x509-system >=0.1 && <0.2, diff --git a/src/Hookup.hs b/src/Hookup.hs --- a/src/Hookup.hs +++ b/src/Hookup.hs @@ -1,4 +1,4 @@ -{-# Language BlockArguments #-} +{-# Language BlockArguments, LambdaCase #-} {-| Module : Hookup Description : Network connections generalized over TLS and SOCKS @@ -42,12 +42,12 @@ -- * Configuration ConnectionParams(..), SocksParams(..), + SocksAuthentication(..), TlsParams(..), TlsVerify(..), PEM.PemPasswordSupply(..), defaultTlsParams, - -- * Errors ConnectionFailure(..), CommandReply(..) @@ -63,16 +63,14 @@ , getPeerPubkeyFingerprintSha512 ) where -import Control.Concurrent.Async -import Control.Concurrent.STM import Control.Concurrent import Control.Exception -import Control.Monad +import Control.Monad (when, unless) import System.IO.Error (isDoesNotExistError, ioeGetErrorString) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 -import Data.Foldable +import Data.Foldable (for_, traverse_) import Data.List (intercalate, partition) import Data.Maybe (fromMaybe, mapMaybe) import Foreign.C.String (withCStringLen) @@ -83,7 +81,7 @@ import OpenSSL.Session (SSL, SSLContext) import qualified OpenSSL as SSL import qualified OpenSSL.Session as SSL -import OpenSSL.X509.SystemStore +import OpenSSL.X509.SystemStore (contextLoadSystemCerts) import OpenSSL.X509 (X509) import qualified OpenSSL.X509 as X509 import qualified OpenSSL.PEM as PEM @@ -114,13 +112,21 @@ , cpTls :: Maybe TlsParams -- ^ Optional TLS parameters , cpBind :: Maybe HostName -- ^ Source address to bind } + deriving Show -- | SOCKS connection parameters data SocksParams = SocksParams { spHost :: HostName -- ^ SOCKS server host , spPort :: PortNumber -- ^ SOCKS server port + , spAuth :: SocksAuthentication -- ^ SOCKS authentication method } + deriving Show +data SocksAuthentication + = NoSocksAuthentication -- ^ no credentials + | UsernamePasswordSocksAuthentication ByteString ByteString -- ^ RFC 1929 username and password + deriving Show + -- | TLS connection parameters. These parameters are passed to -- OpenSSL when making a secure connection. data TlsParams = TlsParams @@ -132,6 +138,7 @@ , tpCipherSuiteTls13 :: Maybe String -- ^ OpenSSL cipher suites for TLS 1.3 , tpVerify :: TlsVerify -- ^ Hostname to use when checking certificate validity } + deriving Show data TlsVerify = VerifyDefault -- ^ Use the connection hostname to verify @@ -152,7 +159,11 @@ -- | Socks command rejected by server by given reply code | SocksError CommandReply -- | Socks authentication method was not accepted - | SocksAuthenticationError + | SocksAuthenticationMethodRejected + -- | Socks authentication method was not accepted + | SocksAuthenticationCredentialsRejected + -- | Username or password were too long + | SocksBadAuthenticationCredentials -- | Socks server sent an invalid message or no message. | SocksProtocolError -- | Domain name was too long for SOCKS protocol @@ -168,8 +179,12 @@ intercalate ", " (map displayException xs) displayException (HostnameResolutionFailure h s) = "hostname resolution failed (" ++ h ++ "): " ++ s - displayException SocksAuthenticationError = + displayException SocksAuthenticationMethodRejected = "SOCKS authentication method rejected" + displayException SocksAuthenticationCredentialsRejected = + "SOCKS authentication credentials rejected" + displayException SocksBadAuthenticationCredentials = + "SOCKS authentication credentials too long" displayException SocksProtocolError = "SOCKS server protocol error" displayException SocksBadDomainName = @@ -218,10 +233,11 @@ case cpSocks params of Nothing -> openSocket' (cpHost params) (cpPort params) (cpBind params) Just sp -> - do sock <- openSocket' (spHost sp) (spPort sp) (cpBind params) - (sock <$ socksConnect sock (cpHost params) (cpPort params)) - `onException` Socket.close sock - + bracketOnError + (openSocket' (spHost sp) (spPort sp) (cpBind params)) + Socket.close + \sock -> + sock <$ socksConnect sock (cpHost params) (cpPort params) (spAuth sp) netParse :: Show a => Socket -> Parser a -> IO a netParse sock parser = @@ -233,41 +249,51 @@ parser B.empty case result of - Parser.Done i x | B.null i -> return x + Parser.Done i x | B.null i -> pure 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) +socksConnect :: Socket -> HostName -> PortNumber -> SocksAuthentication -> IO () +socksConnect sock host port auth = + do case auth of + NoSocksAuthentication -> + do SocketB.sendAll sock $ + buildClientHello ClientHello + { cHelloMethods = [AuthNoAuthenticationRequired] } + hello <- netParse sock parseServerHello + unless (sHelloMethod hello == AuthNoAuthenticationRequired) + (throwIO SocksAuthenticationMethodRejected) - SocketB.sendAll sock $ - buildRequest Request - { reqCommand = Connect - , reqAddress = Address (DomainName dnBytes) port - } + UsernamePasswordSocksAuthentication u p -> + do unless (B.length u < 256 && B.length p < 256) + (throwIO SocksBadAuthenticationCredentials) - validateResponse =<< netParse sock parseResponse + SocketB.sendAll sock $ + buildClientHello ClientHello + { cHelloMethods = [AuthUsernamePassword] } + hello <- netParse sock parseServerHello + unless (sHelloMethod hello == AuthUsernamePassword) + (throwIO SocksAuthenticationMethodRejected) + SocketB.sendAll sock $ + buildPlainAuthentication PlainAuthentication + { plainUsername = u, plainPassword = p } + status <- netParse sock parsePlainAuthenticationReply + unless (0 == plainStatus status) + (throwIO SocksAuthenticationCredentialsRejected) -validateHello :: ServerHello -> IO () -validateHello hello = - unless (sHelloMethod hello == AuthNoAuthenticationRequired) - (throwIO SocksAuthenticationError) + let dnBytes = B8.pack host + unless (B.length dnBytes < 256) + (throwIO SocksBadDomainName) -validateResponse :: Response -> IO () -validateResponse response = - unless (rspReply response == Succeeded ) - (throwIO (SocksError (rspReply response))) + SocketB.sendAll sock $ + buildRequest Request + { reqCommand = Connect + , reqAddress = Address (DomainName dnBytes) port + } + response <- netParse sock parseResponse + unless (rspReply response == Succeeded ) + (throwIO (SocksError (rspReply response))) openSocket' :: HostName {- ^ destination -} -> @@ -295,7 +321,7 @@ resolve mbPort host = do res <- try (Socket.getAddrInfo (Just hints) (Just host) (show<$>mbPort)) case res of - Right ais -> return ais + Right ais -> pure ais Left ioe | isDoesNotExistError ioe -> throwIO (HostnameResolutionFailure host (ioeGetErrorString ioe)) @@ -334,7 +360,7 @@ connectToAddrInfo :: Maybe SockAddr -> AddrInfo -> IO Socket connectToAddrInfo mbSrc info = let addr = Socket.addrAddress info in - bracketOnError (socket' info) Socket.close $ \s -> + bracketOnError (socket' info) Socket.close \s -> do traverse_ (bind' s) mbSrc Socket.connect s addr pure s @@ -365,7 +391,6 @@ data NetworkHandle = SSL (Maybe X509) SSL | Socket Socket - openNetworkHandle :: ConnectionParams {- ^ parameters -} -> IO Socket {- ^ socket creation action -} -> @@ -377,7 +402,6 @@ do (clientCert, ssl) <- startTls tls (cpHost params) mkSocket pure (SSL clientCert ssl) - closeNetworkHandle :: NetworkHandle -> IO () closeNetworkHandle (Socket s) = Socket.close s closeNetworkHandle (SSL _ s) = @@ -392,7 +416,6 @@ networkRecv (Socket s) = SocketB.recv s networkRecv (SSL _ s) = SSL.read s - ------------------------------------------------------------------------ -- Sockets with a receive buffer ------------------------------------------------------------------------ @@ -416,8 +439,8 @@ ConnectionParams {- ^ parameters -} -> IO Connection {- ^ open connection -} connect params = - do h <- openNetworkHandle params (openSocket params) - Connection <$> newMVar B.empty <*> newMVar h + do h <- openNetworkHandle params (openSocket params) + Connection <$> newMVar B.empty <*> newMVar h -- | Create a new 'Connection' using an already connected socket. -- This will attempt to start TLS if configured but will ignore @@ -430,14 +453,14 @@ Socket {- ^ connected socket -} -> IO Connection {- ^ open connection -} connectWithSocket params sock = - do h <- openNetworkHandle params (return sock) - Connection <$> newMVar B.empty <*> newMVar h + do h <- openNetworkHandle params (pure sock) + Connection <$> newMVar B.empty <*> newMVar h -- | Close network connection. close :: Connection {- ^ open connection -} -> IO () -close (Connection _ m) = withMVar m $ \h -> closeNetworkHandle h +close (Connection _ m) = withMVar m \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 @@ -449,12 +472,13 @@ Int {- ^ maximum underlying recv size -} -> IO ByteString {- ^ next chunk from stream -} recv (Connection bufVar hVar) n = - modifyMVar bufVar $ \bufChunk -> - do if B.null bufChunk - then do h <- readMVar hVar - bs <- networkRecv h n - return (B.empty, bs) - else return (B.empty, bufChunk) + modifyMVar bufVar \bufChunk -> + if B.null bufChunk then + do h <- readMVar hVar + bs <- networkRecv h n + pure (B.empty, bs) + else + pure (B.empty, bufChunk) -- | Receive a line from the network connection. Both -- @"\\r\\n"@ and @"\\n"@ are recognized. @@ -472,28 +496,27 @@ Int {- ^ maximum line length -} -> IO (Maybe ByteString) {- ^ next line or end-of-stream -} recvLine (Connection bufVar hVar) n = - modifyMVar bufVar $ \bs -> - do h <- readMVar hVar - go h (B.length bs) bs [] + modifyMVar bufVar \bs -> + do h <- readMVar hVar + go h (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 h bsn bs bss = case B8.elemIndex '\n' bs of - Just i -> return (B.tail b, -- tail drops newline - Just (cleanEnd (B.concat (reverse (a:bss))))) + Just i -> pure (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 -- connection closed - then if bsn == 0 then return (B.empty, Nothing) + then if bsn == 0 then pure (B.empty, Nothing) else throwIO LineTruncated else go h (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 @@ -503,8 +526,7 @@ ByteString {- ^ new head of buffer -} -> IO () putBuf (Connection bufVar _) bs = - modifyMVar_ bufVar (\old -> return $! B.append bs old) - + modifyMVar_ bufVar (\old -> pure $! B.append bs old) -- | Remove the trailing @'\\r'@ if one is found. cleanEnd :: ByteString -> ByteString @@ -512,7 +534,6 @@ | B.null bs || B8.last bs /= '\r' = bs | otherwise = B.init bs - -- | Send bytes on the network connection. This ensures the whole chunk is -- transmitted, which might take multiple underlying sends. -- @@ -525,24 +546,22 @@ do h <- readMVar hVar networkSend h bs - upgradeTls :: TlsParams {- ^ connection params -} -> String {- ^ hostname -} -> Connection -> IO () upgradeTls tp hostname (Connection bufVar hVar) = - modifyMVar_ bufVar $ \buf -> - modifyMVar hVar $ \h -> + modifyMVar_ bufVar \buf -> + modifyMVar hVar \h -> case h of - SSL{} -> return (h, buf) + SSL{} -> pure (h, buf) Socket s -> do (cert, ssl) <- startTls tp hostname (pure s) - return (SSL cert ssl, B.empty) + pure (SSL cert ssl, B.empty) ------------------------------------------------------------------------ - -- | 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 @@ -554,43 +573,44 @@ IO Socket {- ^ socket creation action -} -> IO (Maybe X509, SSL) {- ^ (client certificate, connected TLS) -} startTls tp hostname mkSocket = SSL.withOpenSSL $ - do ctx <- SSL.context - - -- configure context - SSL.contextSetCiphers ctx (tpCipherSuite tp) - traverse_ (contextSetTls13Ciphers ctx) (tpCipherSuiteTls13 tp) - case tpVerify tp of - VerifyDefault -> - do installVerification ctx hostname - SSL.contextSetVerificationMode ctx verifyPeer - VerifyHostname h -> - do installVerification ctx h - SSL.contextSetVerificationMode ctx verifyPeer - VerifyNone -> pure () - SSL.contextAddOption ctx SSL.SSL_OP_ALL - SSL.contextRemoveOption ctx SSL.SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS + do ctx <- SSL.context + -- configure context + SSL.contextSetCiphers ctx (tpCipherSuite tp) + traverse_ (contextSetTls13Ciphers ctx) (tpCipherSuiteTls13 tp) + + case tpVerify tp of + VerifyNone -> pure () + VerifyDefault -> + do installVerification ctx hostname + SSL.contextSetVerificationMode ctx verifyPeer + VerifyHostname h -> + do installVerification ctx h + SSL.contextSetVerificationMode ctx verifyPeer + + SSL.contextAddOption ctx SSL.SSL_OP_ALL + SSL.contextRemoveOption ctx SSL.SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS - -- configure certificates - setupCaCertificates ctx (tpServerCertificate tp) - clientCert <- traverse (setupCertificate ctx) (tpClientCertificate tp) + -- configure certificates + setupCaCertificates ctx (tpServerCertificate tp) + clientCert <- traverse (setupCertificate ctx) (tpClientCertificate tp) - for_ (tpClientPrivateKey tp) $ \path -> - withDefaultPassword ctx (tpClientPrivateKeyPassword tp) $ - SSL.contextSetPrivateKeyFile ctx path + for_ (tpClientPrivateKey tp) \path -> + withDefaultPassword ctx (tpClientPrivateKeyPassword tp) $ + SSL.contextSetPrivateKeyFile ctx path - -- add socket to context - -- 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 + -- add socket to context + -- 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 SNI - isip <- isIpAddress hostname - unless isip (SSL.setTlsextHostName ssl hostname) + -- configure hostname used for SNI + isip <- isIpAddress hostname + unless isip (SSL.setTlsextHostName ssl hostname) - SSL.connect ssl + SSL.connect ssl - return (clientCert, ssl) + pure (clientCert, ssl) isIpAddress :: HostName -> IO Bool isIpAddress host = @@ -607,7 +627,6 @@ Nothing -> contextLoadSystemCerts ctx Just path -> withDefaultPassword ctx Nothing (SSL.contextSetCAFile ctx path) - setupCertificate :: SSLContext -> FilePath -> IO X509 setupCertificate ctx path = do x509 <- PEM.readX509 =<< readFile path -- EX @@ -624,18 +643,17 @@ -- | Get peer certificate if one exists. getPeerCertificate :: Connection -> IO (Maybe X509.X509) getPeerCertificate (Connection _ hVar) = - withMVar hVar $ \h -> - case h of - Socket{} -> return Nothing + withMVar hVar \case + Socket{} -> pure Nothing SSL _ ssl -> SSL.getPeerCertificate ssl -- | Get peer certificate if one exists. getClientCertificate :: Connection -> IO (Maybe X509.X509) getClientCertificate (Connection _ hVar) = - do h <- readMVar hVar - return $ case h of - Socket{} -> Nothing - SSL c _ -> c + do h <- readMVar hVar + pure case h of + Socket{} -> Nothing + SSL c _ -> c getPeerCertFingerprintSha1 :: Connection -> IO (Maybe ByteString) getPeerCertFingerprintSha1 = getPeerCertFingerprint "sha1" @@ -650,13 +668,13 @@ getPeerCertFingerprint name h = do mb <- getPeerCertificate h case mb of - Nothing -> return Nothing + Nothing -> pure Nothing Just x509 -> - do der <- X509.writeDerX509 x509 - mbdigest <- Digest.getDigestByName name - case mbdigest of - Nothing -> return Nothing - Just digest -> return $! Just $! Digest.digestLBS digest der + do der <- X509.writeDerX509 x509 + mbdigest <- Digest.getDigestByName name + pure $! case mbdigest of + Nothing -> Nothing + Just digest -> Just $! Digest.digestLBS digest der getPeerPubkeyFingerprintSha1 :: Connection -> IO (Maybe ByteString) getPeerPubkeyFingerprintSha1 = getPeerPubkeyFingerprint "sha1" @@ -667,15 +685,14 @@ getPeerPubkeyFingerprintSha512 :: Connection -> IO (Maybe ByteString) getPeerPubkeyFingerprintSha512 = getPeerPubkeyFingerprint "sha512" - getPeerPubkeyFingerprint :: String -> Connection -> IO (Maybe ByteString) getPeerPubkeyFingerprint name h = - do mb <- getPeerCertificate h - case mb of - Nothing -> return Nothing - Just x509 -> - do der <- getPubKeyDer x509 - mbdigest <- Digest.getDigestByName name - case mbdigest of - Nothing -> return Nothing - Just digest -> return $! Just $! Digest.digestBS digest der + do mb <- getPeerCertificate h + case mb of + Nothing -> pure Nothing + Just x509 -> + do der <- getPubKeyDer x509 + mbdigest <- Digest.getDigestByName name + pure $! case mbdigest of + Nothing -> Nothing + Just digest -> Just $! Digest.digestBS digest der diff --git a/src/Hookup/Concurrent.hs b/src/Hookup/Concurrent.hs --- a/src/Hookup/Concurrent.hs +++ b/src/Hookup/Concurrent.hs @@ -1,4 +1,4 @@ -{-# Language BlockArguments, ScopedTypeVariables #-} +{-# Language BlockArguments, ScopedTypeVariables, LambdaCase #-} {-| Module : Hookup.Concurrent Description : Concurrently run actions until one succeeds or all fail @@ -13,7 +13,7 @@ import Control.Concurrent.Async (Async, AsyncCancelled(..), async, asyncThreadId, cancel, waitCatch, waitCatchSTM) import Control.Concurrent.STM (STM, atomically, check, orElse, readTVar, registerDelay, retry) import Control.Exception (SomeException, finally, mask_, onException) -import Control.Monad (join) +import Control.Monad (join, void) import Data.Foldable (for_) concurrentAttempts :: @@ -22,13 +22,13 @@ [IO a] {- ^ ordered list of attempts -} -> IO (Either [SomeException] a) concurrentAttempts delay release actions = - let st = St { threads = [], - errors = [], - work = actions, - delay = delay, - clean = release, - readySTM = retry } - in mask_ (loop st) + mask_ (loop St{ + threads = [], + errors = [], + work = actions, + delay = delay, + clean = release, + readySTM = retry }) data St a = St { threads :: [Async a] @@ -43,46 +43,49 @@ -- | Main event loop for concurrent attempt system loop :: forall a. St a -> Answer a -loop st = if null (threads st) then nothingRunning st else waitForEvent st +loop st + | null (threads st) = nothingRunning st + | otherwise = waitForEvent st -- | No threads are active, either start a new thread or return the complete error list nothingRunning :: St a -> Answer a nothingRunning st = case work st of - [] -> pure (Left (errors st)) + [] -> pure (Left (errors st)) x:xs -> start x st{work = xs} -- | Start a new thread for the given attempt start :: IO a -> St a -> Answer a -start x st = - do thread <- async x +start io st = + do thread <- async io ready <- if null (work st) then pure retry else startTimer (delay st) - loop st { threads = thread : threads st, readySTM = ready } + loop st{ threads = thread : threads st, readySTM = ready } -- Nothing to do but wait for a thread to finish or the timer to fire waitForEvent :: St a -> Answer a -waitForEvent st = join (atomically (finish st [] (threads st)) - `onException` cleanup (clean st) (threads st)) +waitForEvent st = + join (atomically (finish st [] (threads st)) + `onException` cleanup (clean st) (threads st)) -- Search for an event out of the active threads and timer finish :: St a -> [Async a] -> [Async a] -> STM (Answer a) -finish st threads' [] = fresh st -finish st threads' (t:ts) = finish1 st (threads' ++ ts) t - `orElse` finish st (t:threads') ts +finish st threads' = \case + [] -> fresh st + t:ts -> finish1 st (threads' ++ ts) t `orElse` finish st (t:threads') ts -- Handle a thread completion event finish1 :: St a -> [Async a] -> Async a -> STM (Answer a) finish1 st threads' t = - do res <- waitCatchSTM t - pure case res of - Right s -> Right s <$ cleanup (clean st) threads' - Left e -> loop st { errors = e : errors st, threads = threads'} + do res <- waitCatchSTM t + pure case res of + Right s -> Right s <$ cleanup (clean st) threads' + Left e -> loop st{ errors = e : errors st, threads = threads' } -- Handle a new thread timer event fresh :: St a -> STM (Answer a) fresh st = case work st of - [] -> retry + [] -> retry x:xs -> start x st{work = xs} <$ readySTM st -- | Create an STM action that only succeeds after at least 'n' microseconds have passed. @@ -94,6 +97,8 @@ -- non-blocking cancelation of the remaining threads cleanup :: (a -> IO ()) -> [Async a] -> IO () cleanup release xs = - () <$ forkIO do for_ xs \x -> throwTo (asyncThreadId x) AsyncCancelled - for_ xs \x -> do res <- waitCatch x - for_ res release + void $ forkIO + do for_ xs \x -> throwTo (asyncThreadId x) AsyncCancelled + for_ xs \x -> + do res <- waitCatch x + for_ res release diff --git a/src/Hookup/Socks5.hs b/src/Hookup/Socks5.hs --- a/src/Hookup/Socks5.hs +++ b/src/Hookup/Socks5.hs @@ -42,6 +42,16 @@ , AuthUsernamePassword , AuthNoAcceptableMethods ) + -- * Plaintext authentication request message + , PlainAuthentication(..) + , buildPlainAuthentication + , parsePlainAuthentication + + -- * Plaintext authentication reply message + , PlainAuthenticationReply(..) + , buildPlainAuthenticationReply + , parsePlainAuthenticationReply + -- * Commands , Command ( Connect @@ -132,7 +142,21 @@ | DomainName ByteString -- ^ Domain name (maximum length 255) deriving Show +-- RFC 1929 Username/Password +-- | Plaintext username and password request +data PlainAuthentication = PlainAuthentication + { plainUsername :: ByteString -- ^ username + , plainPassword :: ByteString -- ^ password + } + deriving Show + +-- | Plaintext username and password response +newtype PlainAuthenticationReply = PlainAuthenticationReply + { plainStatus :: Word8 -- ^ @0@ for success, failure otherwise + } + deriving Show + -- | Initial SOCKS sent by client with proposed list of authentication methods. newtype ClientHello = ClientHello { cHelloMethods :: [AuthMethod] -- ^ proposed methods (maximum length 255) @@ -213,7 +237,7 @@ parseHostAddress :: Parser HostAddress parseHostAddress = do [a1,a2,a3,a4] <- replicateM 4 Parser.anyWord8 - return $! tupleToHostAddress (a1,a2,a3,a4) + pure $! tupleToHostAddress (a1,a2,a3,a4) ------------------------------------------------------------------------ @@ -226,7 +250,7 @@ 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) + pure $! tupleToHostAddress6 (a1,a2,a3,a4,a5,a6,a7,a8) ------------------------------------------------------------------------ @@ -364,9 +388,47 @@ ------------------------------------------------------------------------ +buildPlainAuthentication :: PlainAuthentication -> ByteString +buildPlainAuthentication msg = + runBuilder $ + Builder.word8 1 <> -- subnegotiation version + buildBS (plainUsername msg) <> + buildBS (plainPassword msg) + where + buildBS x = + Builder.word8 (fromIntegral (B.length x)) <> + Builder.byteString x + +parsePlainAuthentication :: Parser PlainAuthentication +parsePlainAuthentication = + PlainAuthentication + <$ Parser.word8 1 -- subnegotiation version + <*> parseBS + <*> parseBS + where + parseBS = + do len <- Parser.anyWord8 + Parser.take (fromIntegral len) + +------------------------------------------------------------------------ + +buildPlainAuthenticationReply :: PlainAuthenticationReply -> ByteString +buildPlainAuthenticationReply msg = + runBuilder $ + Builder.word8 1 <> -- subnegotiation version + Builder.word8 (plainStatus msg) + +parsePlainAuthenticationReply :: Parser PlainAuthenticationReply +parsePlainAuthenticationReply = + PlainAuthenticationReply + <$ Parser.word8 1 -- subnegotiation version + <*> Parser.anyWord8 + +------------------------------------------------------------------------ + -- | Match a 16-bit, big-endian word. parseWord16BE :: Parser Word16 parseWord16BE = do hi <- Parser.anyWord8 lo <- Parser.anyWord8 - return $! fromIntegral hi * 0x100 + fromIntegral lo + pure $! fromIntegral hi * 0x100 + fromIntegral lo