diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/cbits/pem_password_cb.c b/cbits/pem_password_cb.c new file mode 100644 --- /dev/null +++ b/cbits/pem_password_cb.c @@ -0,0 +1,49 @@ +#include +#include + +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; +} diff --git a/hookup.cabal b/hookup.cabal --- a/hookup.cabal +++ b/hookup.cabal @@ -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, diff --git a/src/Hookup.hs b/src/Hookup.hs --- a/src/Hookup.hs +++ b/src/Hookup.hs @@ -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" diff --git a/src/Hookup/Concurrent.hs b/src/Hookup/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Hookup/Concurrent.hs @@ -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 diff --git a/src/Hookup/OpenSSL.hsc b/src/Hookup/OpenSSL.hsc --- a/src/Hookup/OpenSSL.hsc +++ b/src/Hookup/OpenSSL.hsc @@ -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