hookup 0.3.1.0 → 0.4

raw patch · 3 files changed

+119/−52 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• hookup.cabal +2/−2
• src/Hookup.hs +111/−50

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

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

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