diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for hookup +## 0.7 + +* Add ability to specify TLS 1.3 cipher suites + ## 0.6 * Include SockAddr in connection exceptions diff --git a/hookup.cabal b/hookup.cabal --- a/hookup.cabal +++ b/hookup.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hookup -version: 0.6 +version: 0.7 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) @@ -37,11 +37,11 @@ cbits/pem_password_cb.c build-depends: - base >=4.11 && <4.16, + base >=4.11 && <4.17, async ^>=2.2, stm ^>=2.5, network >=3.0 && <3.2, - bytestring >=0.10 && <0.11, - attoparsec >=0.13 && <0.14, + bytestring >=0.10 && <0.12, + attoparsec ^>=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 @@ -43,6 +43,7 @@ ConnectionParams(..), SocksParams(..), TlsParams(..), + TlsVerify(..), PEM.PemPasswordSupply(..), defaultTlsParams, @@ -128,9 +129,16 @@ , 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' + , tpCipherSuiteTls13 :: Maybe String -- ^ OpenSSL cipher suites for TLS 1.3 + , tpVerify :: TlsVerify -- ^ Hostname to use when checking certificate validity } +data TlsVerify + = VerifyDefault -- ^ Use the connection hostname to verify + | VerifyNone -- ^ No verification + | VerifyHostname String -- ^ Use the given hostname to verify + deriving Show + -- | Type for errors that can be thrown by this package. data ConnectionFailure -- | Failure during 'getAddrInfo' resolving remote host @@ -195,7 +203,8 @@ , tpClientPrivateKeyPassword = Nothing , tpServerCertificate = Nothing -- use system provided CAs , tpCipherSuite = "HIGH" - , tpInsecure = False + , tpCipherSuiteTls13 = Nothing + , tpVerify = VerifyDefault } ------------------------------------------------------------------------ @@ -549,8 +558,15 @@ -- configure context SSL.contextSetCiphers ctx (tpCipherSuite tp) - installVerification ctx hostname - SSL.contextSetVerificationMode ctx (verificationMode (tpInsecure 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 @@ -568,13 +584,23 @@ -- leaking the file descriptor in the cases of exceptions above. ssl <- SSL.connection ctx =<< mkSocket - -- configure hostname used for certificate validation - SSL.setTlsextHostName ssl hostname + -- configure hostname used for SNI + isip <- isIpAddress hostname + unless isip (SSL.setTlsextHostName ssl hostname) SSL.connect ssl return (clientCert, ssl) +isIpAddress :: HostName -> IO Bool +isIpAddress host = + do res <- try (Socket.getAddrInfo + (Just Socket.defaultHints{Socket.addrFlags=[Socket.AI_NUMERICHOST]}) + (Just host) Nothing) + case res :: Either IOError [AddrInfo] of + Right{} -> pure True + Left {} -> pure False + setupCaCertificates :: SSLContext -> Maybe FilePath -> IO () setupCaCertificates ctx mbPath = case mbPath of @@ -588,15 +614,12 @@ SSL.contextSetCertificate ctx x509 pure x509 - -verificationMode :: Bool {- ^ insecure -} -> SSL.VerificationMode -verificationMode insecure - | insecure = SSL.VerifyNone - | otherwise = SSL.VerifyPeer - { SSL.vpFailIfNoPeerCert = True - , SSL.vpClientOnce = True - , SSL.vpCallback = Nothing - } +verifyPeer :: SSL.VerificationMode +verifyPeer = SSL.VerifyPeer + { SSL.vpFailIfNoPeerCert = True + , SSL.vpClientOnce = True + , SSL.vpCallback = Nothing + } -- | Get peer certificate if one exists. getPeerCertificate :: Connection -> IO (Maybe X509.X509) diff --git a/src/Hookup/OpenSSL.hsc b/src/Hookup/OpenSSL.hsc --- a/src/Hookup/OpenSSL.hsc +++ b/src/Hookup/OpenSSL.hsc @@ -15,11 +15,11 @@ #error "OpenSSL 1.0.2 or later is required. This version was released in Jan 2015 and adds hostname verification" #endif -module Hookup.OpenSSL (withDefaultPassword, installVerification, getPubKeyDer) where +module Hookup.OpenSSL (withDefaultPassword, installVerification, getPubKeyDer, contextSetTls13Ciphers) where import Control.Exception (bracket, bracket_) -import Control.Monad (unless) -import Foreign.C (CStringLen, CString(..), CSize(..), CUInt(..), CInt(..), withCStringLen, CChar(..)) +import Control.Monad (when) +import Foreign.C (CStringLen, CString(..), CSize(..), CUInt(..), CInt(..), withCString, withCStringLen, CChar(..)) import Foreign.Ptr (FunPtr, Ptr, castPtr, nullPtr, nullFunPtr) import Foreign.StablePtr (StablePtr, deRefStablePtr, castPtrToStablePtr) import Foreign.Marshal (with) @@ -98,6 +98,13 @@ CSize {- ^ namelen -} -> IO CInt {- ^ 1 success, 0 failure -} +-- int X509_VERIFY_PARAM_set1_ip_asc(X509_VERIFY_PARAM *param, const char *ipasc); +foreign import ccall unsafe "X509_VERIFY_PARAM_set1_ip_asc" + x509VerifyParamSet1IpAsc :: + Ptr X509_VERIFY_PARAM_ {- ^ param -} -> + CString {- ^ IP address as string -} -> + IO CInt {- ^ 1 success, 0 failure -} + -- X509_PUBKEY *X509_get_X509_PUBKEY(X509 *x); foreign import capi unsafe "openssl/x509.h X509_get_X509_PUBKEY" x509getX509Pubkey :: @@ -124,10 +131,34 @@ -- Partial wildcards matching is disabled. installVerification :: SSLContext -> String {- ^ hostname -} -> IO () installVerification ctx host = - withContext ctx $ \ctxPtr -> - withCStringLen host $ \(ptr,len) -> + withContext ctx $ \ctxPtr -> do param <- sslGet0Param ctxPtr x509VerifyParamSetHostflags param (#const X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS) - success <- x509VerifyParamSet1Host param ptr (fromIntegral len) - unless (success == 1) (fail "Unable to set verification host") + + ip_success <- + withCString host $ \ptr -> + x509VerifyParamSet1IpAsc param ptr + + when (ip_success == 0) $ + do success <- + withCStringLen host $ \(ptr,len) -> + x509VerifyParamSet1Host param ptr (fromIntegral len) + + when (success == 0) + (fail "Unable to set verification host") + +foreign import ccall unsafe "SSL_CTX_set_ciphersuites" + sslCtxSetCiphersuites :: Ptr SSLContext_ -> CString -> IO CInt + +-- | Set the ciphers to be used by the given context for TLS 1.3 +-- https://www.openssl.org/docs/man1.1.1/man3/SSL_CTX_set_cipher_list.html +-- +-- Unrecognised ciphers are ignored. If no ciphers from the list are +-- recognised, an exception is raised. +contextSetTls13Ciphers :: SSLContext -> String -> IO () +contextSetTls13Ciphers context list = + withContext context $ \ctx -> + withCString list $ \cpath -> + do success <- sslCtxSetCiphersuites ctx cpath + when (success == 0) (fail "Unable to set ciphersuites") diff --git a/src/Hookup/Socks5.hs b/src/Hookup/Socks5.hs --- a/src/Hookup/Socks5.hs +++ b/src/Hookup/Socks5.hs @@ -1,5 +1,4 @@ {-# Language PatternSynonyms #-} -{-# OPTIONS_GHC -Wall -Wno-missing-pattern-synonym-signatures #-} {-| Module : Hookup.Socks5 Description : SOCKS5 network protocol implementation @@ -80,6 +79,9 @@ -- | SOCKS authentication methods newtype AuthMethod = AuthMethod Word8 deriving (Eq, Show) + +pattern AuthNoAuthenticationRequired, AuthGssApi, AuthUsernamePassword, AuthNoAcceptableMethods :: AuthMethod + pattern AuthNoAuthenticationRequired = AuthMethod 0x00 pattern AuthGssApi = AuthMethod 0x01 pattern AuthUsernamePassword = AuthMethod 0x02 @@ -87,18 +89,28 @@ -- | SOCKS client commands newtype Command = Command Word8 deriving (Eq, Show) + +pattern Connect, Bind, UdpAssociate :: Command + pattern Connect = Command 1 pattern Bind = Command 2 pattern UdpAssociate = Command 3 -- | Tags used in the protocol messages for encoded 'Host' values newtype HostTag = HostTag Word8 deriving (Eq, Show) + +pattern IPv4Tag, DomainNameTag, IPv6Tag :: HostTag + pattern IPv4Tag = HostTag 1 pattern DomainNameTag = HostTag 3 pattern IPv6Tag = HostTag 4 -- | SOCKS command reply codes newtype CommandReply = CommandReply Word8 deriving (Eq, Show) + +pattern Succeeded, GeneralFailure, NotAllowed, NetUnreachable, HostUnreachable, + ConnectionRefused, TTLExpired, CmdNotSupported, AddrNotSupported :: CommandReply + pattern Succeeded = CommandReply 0 pattern GeneralFailure = CommandReply 1 pattern NotAllowed = CommandReply 2 @@ -122,13 +134,13 @@ -- | Initial SOCKS sent by client with proposed list of authentication methods. -data ClientHello = ClientHello +newtype ClientHello = ClientHello { cHelloMethods :: [AuthMethod] -- ^ proposed methods (maximum length 255) } deriving Show -- | Initial SOCKS sent by server with chosen authentication method. -data ServerHello = ServerHello +newtype ServerHello = ServerHello { sHelloMethod :: AuthMethod } deriving Show