diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for hookup +## 0.4 + +* Added ability to specify TLS private key password +* Replace protocol family selection with more general bind hostname selection +* Implement staggered, concurrent connection strategy based on RFC 8305 + ## 0.3.1.0 -- 2020-02 * Added `getClientCertificate` diff --git a/hookup.cabal b/hookup.cabal --- a/hookup.cabal +++ b/hookup.cabal @@ -1,5 +1,5 @@ name: hookup -version: 0.3.1.0 +version: 0.4 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) @@ -25,7 +25,7 @@ exposed-modules: Hookup other-modules: Hookup.OpenSSL, Hookup.Socks5 - build-depends: base >=4.11 && <4.14, + build-depends: base >=4.11 && <4.15, network >=2.6 && <3.2, bytestring >=0.10 && <0.11, attoparsec >=0.13 && <0.14, diff --git a/src/Hookup.hs b/src/Hookup.hs --- a/src/Hookup.hs +++ b/src/Hookup.hs @@ -41,7 +41,7 @@ ConnectionParams(..), SocksParams(..), TlsParams(..), - defaultFamily, + PEM.PemPasswordSupply(..), defaultTlsParams, @@ -68,8 +68,8 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import Data.Foldable -import Data.List (intercalate) -import Network.Socket (Socket, AddrInfo, PortNumber, HostName, Family) +import Data.List (intercalate, partition) +import Network.Socket (AddrInfo, HostName, PortNumber, SockAddr, Socket, Family) import qualified Network.Socket as Socket import qualified Network.Socket.ByteString as SocketB import OpenSSL.Session (SSL, SSLContext) @@ -91,25 +91,22 @@ -- -- Common defaults for fields: 'defaultFamily', 'defaultTlsParams' -- --- The address family can be specified in order to force only --- IPv4 or IPv6 to be used. The default behavior is to support both. --- It can be useful to specify exactly one of these in the case that --- the other is misconfigured and a hostname is resolving to both. --- -- When a 'SocksParams' is provided the connection will be established -- using a SOCKS (version 5) proxy. -- -- When a 'TlsParams' is provided the connection negotiate TLS at connect -- time in order to protect the stream. +-- +-- The binding hostname can be used to force the connect to use a particular +-- interface or IP protocol version. data ConnectionParams = ConnectionParams - { cpFamily :: Family -- ^ IP Protocol family (default 'AF_UNSPEC') - , cpHost :: HostName -- ^ Destination host + { cpHost :: HostName -- ^ Destination host , cpPort :: PortNumber -- ^ Destination TCP port , cpSocks :: Maybe SocksParams -- ^ Optional SOCKS parameters , cpTls :: Maybe TlsParams -- ^ Optional TLS parameters + , cpBind :: Maybe HostName -- ^ Source address to bind } - -- | SOCKS connection parameters data SocksParams = SocksParams { spHost :: HostName -- ^ SOCKS server host @@ -122,6 +119,7 @@ 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 , tpServerCertificate :: Maybe FilePath -- ^ Path to CA certificate bundle , tpCipherSuite :: String -- ^ OpenSSL cipher suite name (e.g. @\"HIGH\"@) , tpInsecure :: Bool -- ^ Disables certificate checking when 'True' @@ -176,16 +174,13 @@ AddrNotSupported -> "address type not supported" CommandReply n -> "unknown reply " ++ show n --- | Default 'Family' value is unspecified and allows both INET and INET6. -defaultFamily :: Socket.Family -defaultFamily = Socket.AF_UNSPEC - -- | Default values for TLS that use no client certificates, use -- system CA root, @\"HIGH\"@ cipher suite, and which validate hostnames. defaultTlsParams :: TlsParams defaultTlsParams = TlsParams { tpClientCertificate = Nothing , tpClientPrivateKey = Nothing + , tpClientPrivateKeyPassword = PEM.PwNone , tpServerCertificate = Nothing -- use system provided CAs , tpCipherSuite = "HIGH" , tpInsecure = False @@ -200,9 +195,9 @@ openSocket :: ConnectionParams -> IO Socket openSocket params = case cpSocks params of - Nothing -> openSocket' (cpFamily params) (cpHost params) (cpPort params) + Nothing -> openSocket' (cpHost params) (cpPort params) (cpBind params) Just sp -> - do sock <- openSocket' (cpFamily params) (spHost sp) (spPort sp) + do sock <- openSocket' (spHost sp) (spPort sp) (cpBind params) (sock <$ socksConnect sock (cpHost params) (cpPort params)) `onException` Socket.close sock @@ -253,46 +248,112 @@ (throwIO (SocksError (rspReply response))) -openSocket' :: Family -> HostName -> PortNumber -> IO Socket -openSocket' family h p = - do let hints = Socket.defaultHints - { Socket.addrFamily = family - , Socket.addrSocketType = Socket.Stream - , Socket.addrFlags = [Socket.AI_ADDRCONFIG - ,Socket.AI_NUMERICSERV] - } - res <- try (Socket.getAddrInfo (Just hints) (Just h) (Just (show p))) +openSocket' :: + HostName {- ^ destination -} -> + PortNumber {- ^ destination port -} -> + Maybe HostName {- ^ source -} -> + IO Socket {- ^ connected socket -} +openSocket' h p mbBind = + do mbSrc <- traverse (resolve Nothing) mbBind + dst <- resolve (Just p) h + let pairs = interleaveAddressFamilies (matchBindAddrs mbSrc dst) + when (null pairs) + (throwIO (HostnameResolutionFailure h "No source/destination address family match")) + attempt pairs + +hints :: AddrInfo +hints = Socket.defaultHints + { Socket.addrSocketType = Socket.Stream + , Socket.addrFlags = [Socket.AI_ADDRCONFIG, Socket.AI_NUMERICSERV] + } + +resolve :: Maybe PortNumber -> HostName -> IO [AddrInfo] +resolve mbPort host = + do res <- try (Socket.getAddrInfo (Just hints) (Just host) (show<$>mbPort)) case res of - Right ais -> attemptConnections [] ais - Left ioe + Right ais -> return ais + Left ioe | isDoesNotExistError ioe -> - throwIO (HostnameResolutionFailure h (ioeGetErrorString ioe)) + throwIO (HostnameResolutionFailure host (ioeGetErrorString ioe)) | otherwise -> throwIO ioe -- unexpected +-- | When no bind address is specified return the full list of destination +-- addresses with no bind address specified. +-- +-- When bind addresses are specified return a subset of the destination list +-- matched up with the first address from the bind list that has the +-- correct address family. +matchBindAddrs :: Maybe [AddrInfo] -> [AddrInfo] -> [(Maybe SockAddr, AddrInfo)] +matchBindAddrs Nothing dst = [ (Nothing, x) | x <- dst ] +matchBindAddrs (Just src) dst = + [ (Just (Socket.addrAddress s), d) + | d <- dst + , let ss = [s | s <- src, Socket.addrFamily d == Socket.addrFamily s] + , s <- take 1 ss ] --- | Try establishing a connection to the services indicated by --- a given list of 'AddrInfo' values. Either return a socket that --- has successfully connected to one of the candidate 'AddrInfo's --- or throw a 'ConnectionFailure' exception will all of the --- encountered errors. -attemptConnections :: - [IOError] {- ^ accumulated errors -} -> - [Socket.AddrInfo] {- ^ candidate AddrInfos -} -> +connAttemptDelay :: Int +connAttemptDelay = 150 * 1000 -- 150ms + +attempt :: + [(Maybe SockAddr, AddrInfo)] {- ^ candidate AddrInfos -} -> IO Socket {- ^ connected socket -} -attemptConnections exs [] = throwIO (ConnectionFailure exs) -attemptConnections exs (ai:ais) = - do res <- try (connectToAddrInfo ai) +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 - Left ex -> attemptConnections (ex:exs) ais - Right s -> return s + 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 + where + (sixes, others) = partition is6 xs + is6 x = Socket.AF_INET6 == Socket.addrFamily (snd x) + + interleave (x:xs) (y:ys) = x : y : interleave xs ys + interleave [] ys = ys + interleave xs [] = xs + -- | Create a socket and connect to the service identified -- by the given 'AddrInfo' and return the connected socket. -connectToAddrInfo :: AddrInfo -> IO Socket -connectToAddrInfo info - = bracketOnError (socket' info) Socket.close - $ \s -> s <$ Socket.connect s (Socket.addrAddress info) +connectToAddrInfo :: Maybe SockAddr -> AddrInfo -> IO Socket +connectToAddrInfo mbSrc info + = bracketOnError (socket' info) Socket.close $ \s -> + do traverse_ (bind' s) mbSrc + Socket.connect s (Socket.addrAddress info) + pure s +-- | A version of 'Socket.bind' that doesn't bother binding on the wildcard +-- address. The effect of binding on a wildcard address in this library +-- is to pick an address family. Because of the matching done earlier this +-- is unnecessary for client connections and causes a local port to be +-- unnecessarily fixed early. +bind' :: Socket -> SockAddr -> IO () +bind' _ (Socket.SockAddrInet _ 0) = pure () +bind' _ (Socket.SockAddrInet6 _ _ (0,0,0,0) _) = pure () +bind' s a = Socket.bind s a + -- | Open a 'Socket' using the parameters from an 'AddrInfo' socket' :: AddrInfo -> IO Socket socket' ai = @@ -489,7 +550,7 @@ -- configure certificates setupCaCertificates ctx (tpServerCertificate tp) clientCert <- traverse (setupCertificate ctx) (tpClientCertificate tp) - traverse_ (setupPrivateKey ctx) (tpClientPrivateKey tp) + traverse_ (setupPrivateKey ctx (tpClientPrivateKeyPassword tp)) (tpClientPrivateKey tp) -- add socket to context -- creation of the socket is delayed until this point to avoid @@ -518,10 +579,10 @@ pure x509 -setupPrivateKey :: SSLContext -> FilePath -> IO () -setupPrivateKey ctx path = +setupPrivateKey :: SSLContext -> PEM.PemPasswordSupply -> FilePath -> IO () +setupPrivateKey ctx password path = do str <- readFile path -- EX - key <- PEM.readPrivateKey str PEM.PwNone -- TODO: add password support + key <- PEM.readPrivateKey str password SSL.contextSetPrivateKey ctx key