hookup 0.7 → 0.8

raw patch · 5 files changed

+249/−161 lines, 5 filesdep ~basedep ~bytestringdep ~networkPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, bytestring, network

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• hookup.cabal +5/−5
• src/Hookup.hs +143/−126
• src/Hookup/Concurrent.hs +32/−27
• src/Hookup/Socks5.hs +65/−3

@@ -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

@@ -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,

@@ -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

@@ -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

@@ -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