hookup 0.4 → 0.5

raw patch · 6 files changed

+294/−88 lines, 6 filesdep +asyncdep +stmdep ~networkPVP ok

version bump matches the API change (PVP)

Dependencies added: async, stm

Dependency ranges changed: network

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• cbits/pem_password_cb.c +49/−0
• hookup.cabal +25/−13
• src/Hookup.hs +69/−72
• src/Hookup/Concurrent.hs +99/−0
• src/Hookup/OpenSSL.hsc +46/−3

@@ -1,5 +1,11 @@ # Revision history for hookup +## 0.5++* Don't use `AI_ADDRCONFIG` flag+* Support all client-side certificates supported by OpenSSL (rather than just RSA/DSA)+* Add support for STARTTLS+ ## 0.4  * Added ability to specify TLS private key password

@@ -0,0 +1,49 @@+#include <stdlib.h>+#include <string.h>++struct CStringLen+{+    char const* ptr;+    int len;+};++void *+hookup_new_userdata(char const* ptr, int len)+{+    struct CStringLen *result = malloc(sizeof *result);++    // The null/error case is handled in hookup_pem_passwd_cb+    if (NULL != result) {+        result->ptr = ptr;+        result->len = len;+    }++    return result;+}++void+hookup_free_userdata(void *ud)+{+        free(ud);+}++int+hookup_pem_passwd_cb(char *buf, int size, int rwflag, void *userdata)+{+    struct CStringLen *password = userdata;++    // hookup_new_userdata failed, so we fail.+    if (NULL == password) { return -1; }++    // password requested when none was provided, so we fail.+    if (0 > password->len) { return -1; }++    // OpenSSL says to truncate the password if it's too long+    if (password->len < size) {+        size = password->len;+    }++    memcpy(buf, password->ptr, size);++    return size;+}

@@ -1,5 +1,6 @@+cabal-version:       2.2 name:                hookup-version:             0.4+version:             0.5 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)@@ -7,14 +8,13 @@ license-file:        LICENSE author:              Eric Mertens maintainer:          emertens@gmail.com-copyright:           2016 Eric Mertens+copyright:           2016-2020 Eric Mertens category:            Network build-type:          Simple extra-source-files:  ChangeLog.md homepage:            https://github.com/glguy/irc-core bug-reports:         https://github.com/glguy/irc-core/issues-tested-with:         GHC==8.0.2-cabal-version:       >=1.10+tested-with:         GHC==8.10.1  source-repository head   type: git@@ -22,14 +22,26 @@   branch: v2  library-  exposed-modules:     Hookup-  other-modules:       Hookup.OpenSSL,-                       Hookup.Socks5-  build-depends:       base                  >=4.11 && <4.15,-                       network               >=2.6  && <3.2,-                       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   default-language:    Haskell2010++  exposed-modules:+    Hookup+    Hookup.OpenSSL++  other-modules:+    Hookup.Socks5+    Hookup.Concurrent++  c-sources:+    cbits/pem_password_cb.c++  build-depends:+    base                  >=4.11 && <4.15,+    async                 ^>=2.2,+    stm                   ^>=2.5,+    network               >=3.0  && <3.2,+    bytestring            >=0.10 && <0.11,+    attoparsec            >=0.13 && <0.14,+    HsOpenSSL             >=0.11.2.3 && <0.12,+    HsOpenSSL-x509-system >=0.1  && <0.2,

@@ -1,3 +1,4 @@+{-# Language BlockArguments #-} {-| Module      : Hookup Description : Network connections generalized over TLS and SOCKS@@ -30,6 +31,7 @@   connect,   connectWithSocket,   close,+  upgradeTls,    -- * Reading and writing data   recv,@@ -60,6 +62,8 @@   , getPeerPubkeyFingerprintSha512   ) where +import           Control.Concurrent.Async+import           Control.Concurrent.STM import           Control.Concurrent import           Control.Exception import           Control.Monad@@ -69,6 +73,9 @@ import qualified Data.ByteString.Char8 as B8 import           Data.Foldable import           Data.List (intercalate, partition)+import           Data.Maybe (fromMaybe)+import           Foreign.C.String (withCStringLen)+import           Foreign.Ptr (nullPtr) import           Network.Socket (AddrInfo, HostName, PortNumber, SockAddr, Socket, Family) import qualified Network.Socket as Socket import qualified Network.Socket.ByteString as SocketB@@ -83,10 +90,10 @@ import           Data.Attoparsec.ByteString (Parser) import qualified Data.Attoparsec.ByteString as Parser -import           Hookup.OpenSSL (installVerification, getPubKeyDer)+import           Hookup.Concurrent (concurrentAttempts)+import           Hookup.OpenSSL import           Hookup.Socks5 - -- | Parameters for 'connect'. -- -- Common defaults for fields: 'defaultFamily', 'defaultTlsParams'@@ -113,13 +120,12 @@   , spPort :: PortNumber -- ^ SOCKS server port   } - -- | TLS connection parameters. These parameters are passed to -- OpenSSL when making a secure connection. data TlsParams = TlsParams   { tpClientCertificate  :: Maybe FilePath -- ^ Path to client certificate   , tpClientPrivateKey   :: Maybe FilePath -- ^ Path to client private key-  , tpClientPrivateKeyPassword :: PEM.PemPasswordSupply -- ^ Private key decryption password+  , tpClientPrivateKeyPassword :: Maybe ByteString -- ^ Private key decryption password   , tpServerCertificate  :: Maybe FilePath -- ^ Path to CA certificate bundle   , tpCipherSuite        :: String -- ^ OpenSSL cipher suite name (e.g. @\"HIGH\"@)   , tpInsecure           :: Bool -- ^ Disables certificate checking when 'True'@@ -180,7 +186,7 @@ defaultTlsParams = TlsParams   { tpClientCertificate  = Nothing   , tpClientPrivateKey   = Nothing-  , tpClientPrivateKeyPassword = PEM.PwNone+  , tpClientPrivateKeyPassword = Nothing   , tpServerCertificate  = Nothing -- use system provided CAs   , tpCipherSuite        = "HIGH"   , tpInsecure           = False@@ -259,12 +265,15 @@      let pairs = interleaveAddressFamilies (matchBindAddrs mbSrc dst)      when (null pairs)        (throwIO (HostnameResolutionFailure h "No source/destination address family match"))-     attempt pairs+     res <- concurrentAttempts connAttemptDelay Socket.close (uncurry connectToAddrInfo <$> pairs)+     case res of+       Left es -> throwIO (ConnectionFailure [ioe | e <- es, Just ioe <- [fromException e]])+       Right s -> pure s  hints :: AddrInfo hints = Socket.defaultHints   { Socket.addrSocketType = Socket.Stream-  , Socket.addrFlags      = [Socket.AI_ADDRCONFIG, Socket.AI_NUMERICSERV]+  , Socket.addrFlags      = [Socket.AI_NUMERICSERV]   }  resolve :: Maybe PortNumber -> HostName -> IO [AddrInfo]@@ -294,36 +303,6 @@ connAttemptDelay :: Int connAttemptDelay = 150 * 1000 -- 150ms -attempt ::-  [(Maybe SockAddr, AddrInfo)] {- ^ candidate AddrInfos -} ->-  IO Socket         {- ^ connected socket    -}-attempt xs =-  do comm <- newEmptyMVar--     let mkThread i (mbSrc, ai) =-           forkIOWithUnmask $ \unmask ->-           unmask $-           do threadDelay (connAttemptDelay * i)-              putMVar comm =<< try (connectToAddrInfo mbSrc ai)--     bracket (zipWithM mkThread [0..] xs)-             (traverse_ killThread)-             (\_ -> gather (length xs) [] comm)---- Either gather all of the errors possible and throw an exception or--- return the first successful socket.-gather ::-  Int {- ^ potential errors remaining -} ->-  [IOError] {- ^ errors gathered so far -} ->-  MVar (Either IOError Socket) ->-  IO Socket-gather 0 exs _ = throwIO (ConnectionFailure exs)-gather n exs comm =-  do res <- takeMVar comm-     case res of-       Right s -> pure s-       Left ex -> gather (n-1) (ex:exs) comm- -- | Alternate list of addresses between IPv6 and other (IPv4) addresses. interleaveAddressFamilies :: [(Maybe SockAddr, AddrInfo)] -> [(Maybe SockAddr, AddrInfo)] interleaveAddressFamilies xs = interleave sixes others@@ -404,7 +383,10 @@ -- | A connection to a network service along with its read buffer -- used for line-oriented protocols. The connection could be a plain -- network connection, SOCKS connected, or TLS.-data Connection = Connection (MVar ByteString) NetworkHandle+data Connection =+  Connection+  {-# UNPACK #-} !(MVar ByteString)+  {-# UNPACK #-} !(MVar NetworkHandle)  -- | Open network connection to TCP service specified by -- the given parameters.@@ -418,8 +400,7 @@   IO Connection    {- ^ open connection -} connect params =   do h <- openNetworkHandle params (openSocket params)-     b <- newMVar B.empty-     return (Connection b h)+     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@@ -433,14 +414,13 @@   IO Connection    {- ^ open connection  -} connectWithSocket params sock =   do h <- openNetworkHandle params (return sock)-     b <- newMVar B.empty-     return (Connection b h)+     Connection <$> newMVar B.empty <*> newMVar h  -- | Close network connection. close ::   Connection {- ^ open connection -} ->   IO ()-close (Connection _ 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@@ -451,11 +431,13 @@   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+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)  -- | Receive a line from the network connection. Both -- @"\\r\\n"@ and @"\\n"@ are recognized.@@ -472,14 +454,15 @@   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 []+recvLine (Connection bufVar hVar) n =+  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 bsn bs bss =+    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)))))@@ -491,7 +474,7 @@              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)+               else go h (bsn + B.length more) more (bs:bss)   -- | Push a 'ByteString' onto the buffer so that it will be the first@@ -502,8 +485,8 @@   Connection {- ^ connection         -} ->   ByteString {- ^ new head of buffer -} ->   IO ()-putBuf (Connection buf h) bs =-  modifyMVar_ buf (\old -> return $! B.append bs old)+putBuf (Connection bufVar _) bs =+  modifyMVar_ bufVar (\old -> return $! B.append bs old)   -- | Remove the trailing @'\\r'@ if one is found.@@ -521,9 +504,25 @@   Connection {- ^ open connection -} ->   ByteString {- ^ chunk           -} ->   IO ()-send (Connection _ h) = networkSend h+send (Connection _ hVar) bs =+  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 ->+  case h of+    SSL{} -> return (h, buf)+    Socket s ->+      do (cert, ssl) <- startTls tp hostname (pure s)+         return (SSL cert ssl, B.empty)+ ------------------------------------------------------------------------  @@ -547,11 +546,15 @@      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)-     traverse_ (setupPrivateKey ctx (tpClientPrivateKeyPassword tp)) (tpClientPrivateKey tp) +     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.@@ -564,12 +567,11 @@       return (clientCert, ssl) - setupCaCertificates :: SSLContext -> Maybe FilePath -> IO () setupCaCertificates ctx mbPath =   case mbPath of     Nothing   -> contextLoadSystemCerts ctx-    Just path -> SSL.contextSetCAFile ctx path+    Just path -> withDefaultPassword ctx Nothing (SSL.contextSetCAFile ctx path)   setupCertificate :: SSLContext -> FilePath -> IO X509@@ -579,13 +581,6 @@      pure x509  -setupPrivateKey :: SSLContext -> PEM.PemPasswordSupply -> FilePath -> IO ()-setupPrivateKey ctx password path =-  do str <- readFile path -- EX-     key <- PEM.readPrivateKey str password-     SSL.contextSetPrivateKey ctx key-- verificationMode :: Bool {- ^ insecure -} -> SSL.VerificationMode verificationMode insecure   | insecure  = SSL.VerifyNone@@ -597,17 +592,19 @@  -- | Get peer certificate if one exists. getPeerCertificate :: Connection -> IO (Maybe X509.X509)-getPeerCertificate (Connection _ h) =+getPeerCertificate (Connection _ hVar) =+  withMVar hVar $ \h ->   case h of     Socket{} -> return Nothing     SSL _ ssl -> SSL.getPeerCertificate ssl  -- | Get peer certificate if one exists.-getClientCertificate :: Connection -> Maybe X509.X509-getClientCertificate (Connection _ h) =-  case h of-    Socket{} -> Nothing-    SSL c _  -> c+getClientCertificate :: Connection -> IO (Maybe X509.X509)+getClientCertificate (Connection _ hVar) =+  do h <- readMVar hVar+     return $ case h of+                Socket{} -> Nothing+                SSL c _  -> c  getPeerCertFingerprintSha1 :: Connection -> IO (Maybe ByteString) getPeerCertFingerprintSha1 = getPeerCertFingerprint "sha1"

@@ -0,0 +1,99 @@+{-# Language BlockArguments, ScopedTypeVariables #-}+{-|+Module      : Hookup.Concurrent+Description : Concurrently run actions until one succeeds or all fail+Copyright   : (c) Eric Mertens, 2020+License     : ISC+Maintainer  : emertens@gmail.com++-}+module Hookup.Concurrent (concurrentAttempts) where++import Control.Concurrent (forkIO, throwTo)+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 Data.Foldable (for_)++concurrentAttempts ::+  Int {- ^ microsecond delay between attempts -} ->+  (a -> IO ()) {- ^ release unneeded success -} ->+  [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)++data St a = St+  { threads :: [Async a]+  , errors  :: [SomeException]+  , work    :: [IO a]+  , delay   :: !Int+  , clean   :: a -> IO ()+  , readySTM :: STM ()+  }++type Answer a = IO (Either [SomeException] a)++-- | 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++-- | 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))+    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+     ready <- if null (work st) then pure retry else startTimer (delay st)+     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))++-- 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++-- 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'}++-- Handle a new thread timer event+fresh :: St a -> STM (Answer a)+fresh st =+  case work st of+    [] -> retry+    x:xs -> start x st{work = xs} <$ readySTM st++-- | Create an STM action that only succeeds after at least 'n' microseconds have passed.+startTimer :: Int -> IO (STM ())+startTimer n =+  do v <- registerDelay n+     pure (check =<< readTVar v)++-- 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

@@ -15,16 +15,59 @@ #error "OpenSSL 1.0.2 or later is required. This version was released in Jan 2015 and adds hostname verification" #endif -module Hookup.OpenSSL (installVerification, getPubKeyDer) where+module Hookup.OpenSSL (withDefaultPassword, installVerification, getPubKeyDer) where +import           Control.Exception (bracket, bracket_) import           Control.Monad (unless)-import           Foreign.C (CString(..), CSize(..), CUInt(..), CInt(..), withCStringLen)-import           Foreign.Ptr (Ptr, castPtr, nullPtr)+import           Foreign.C (CStringLen, CString(..), CSize(..), CUInt(..), CInt(..), withCStringLen, CChar(..))+import           Foreign.Ptr (FunPtr, Ptr, castPtr, nullPtr, nullFunPtr)+import           Foreign.StablePtr (StablePtr, deRefStablePtr, castPtrToStablePtr) import           Foreign.Marshal (with) import           OpenSSL.Session (SSLContext, SSLContext_, withContext) import           OpenSSL.X509 (withX509Ptr, X509, X509_) import           Data.ByteString (ByteString) import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Unsafe as Unsafe++------------------------------------------------------------------------+-- Bindings to password callback+------------------------------------------------------------------------++foreign import ccall unsafe "hookup_new_userdata"+  hookup_new_userdata :: CString -> CInt -> IO (Ptr ())++foreign import ccall unsafe "hookup_free_userdata"+  hookup_free_userdata :: Ptr () -> IO ()++foreign import ccall "&hookup_pem_passwd_cb"+  hookup_pem_passwd_cb :: FunPtr PemPasswdCb++-- int pem_passwd_cb(char *buf, int size, int rwflag, void *userdata);+type PemPasswdCb = Ptr CChar -> CInt -> CInt -> Ptr () -> IO CInt++-- void SSL_CTX_set_default_passwd_cb(SSL_CTX *ctx, pem_password_cb *cb);+foreign import ccall unsafe "SSL_CTX_set_default_passwd_cb"+  sslCtxSetDefaultPasswdCb :: Ptr SSLContext_ -> FunPtr PemPasswdCb -> IO ()++-- void SSL_CTX_set_default_passwd_cb_userdata(SSL_CTX *ctx, void *u);+foreign import ccall unsafe "SSL_CTX_set_default_passwd_cb_userdata"+  sslCtxSetDefaultPasswdCbUserdata ::+    Ptr SSLContext_ -> Ptr a -> IO ()++withDefaultPassword :: SSLContext -> Maybe ByteString -> IO a -> IO a+withDefaultPassword ctx mbBs m =+  withCPassword mbBs $ \ptr len ->+  bracket (hookup_new_userdata ptr len) hookup_free_userdata $ \ud ->+  bracket_ (setup hookup_pem_passwd_cb ud) (setup nullFunPtr nullPtr) m++  where+  withCPassword Nothing k = k nullPtr (-1)+  withCPassword (Just bs) k = Unsafe.unsafeUseAsCStringLen bs $ \(ptr, len) -> k ptr (fromIntegral len)++  setup cb ud =+    withContext ctx $ \ctxPtr ->+    do sslCtxSetDefaultPasswdCb         ctxPtr cb+       sslCtxSetDefaultPasswdCbUserdata ctxPtr ud  ------------------------------------------------------------------------ -- Bindings to hostname verification interface