diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ See also http://pvp.haskell.org/faq +### 0.1.6.0 + +* New function `voidContextSSL` for creating a _void_ SSL Context which rejects any TLS handshake attempts +* New function `contextSetCASystemStore` exposing functionality embedded in `baselineContextSSL` +* New function `openConnectionAddress''` supporting supplying local `SSLContext`s as well as modifying the `SSL` connection before initiating the client SSL handshake. +* New function `openConnectionSSL'` which allows to customize the 'SSL' connection /before/ a client SSL handshake is attempted. +* New convenience function `getContextSSL` function allowing to retrieve global `SSLContext`. + ### 0.1.5.0 * New function `openConnectionAddress'` function supporting supplying local `SSLContext`s. diff --git a/http-io-streams.cabal b/http-io-streams.cabal --- a/http-io-streams.cabal +++ b/http-io-streams.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: http-io-streams -version: 0.1.5.0 +version: 0.1.6.0 synopsis: HTTP and WebSocket client based on io-streams description: diff --git a/http-streams/lib/Network/Http/Client.hs b/http-streams/lib/Network/Http/Client.hs --- a/http-streams/lib/Network/Http/Client.hs +++ b/http-streams/lib/Network/Http/Client.hs @@ -175,8 +175,12 @@ -- * Secure connections openConnectionSSL, + openConnectionSSL', baselineContextSSL, + voidContextSSL, + contextSetCASystemStore, modifyContextSSL, + getContextSSL, establishConnection, -- * Alternative 'ConnectionAddress' API @@ -185,6 +189,7 @@ connectionAddressFromURL, openConnectionAddress, openConnectionAddress', + openConnectionAddress'', -- -- * Testing support -- makeConnection, diff --git a/http-streams/lib/Network/Http/Connection.hs b/http-streams/lib/Network/Http/Connection.hs --- a/http-streams/lib/Network/Http/Connection.hs +++ b/http-streams/lib/Network/Http/Connection.hs @@ -22,6 +22,7 @@ withConnection, openConnection, openConnectionSSL, + openConnectionSSL', openConnectionUnix, closeConnection, getHostname, @@ -234,7 +235,31 @@ -- NB: /There is no longer a need to call 'OpenSSL.withOpenSSL' explicitly; the initialization is invoked once per process for you/ -- openConnectionSSL :: SSLContext -> Hostname -> Port -> IO Connection -openConnectionSSL ctx h1' p = withOpenSSL $ do +openConnectionSSL ctx h1' = openConnectionSSL' modssl ctx h1' + where + modssl ssl = SSL.setTlsextHostName ssl h1 + h1 = S.unpack h1' + +-- | Variant of 'openConnectionSSL' which allows to customize the +-- 'SSL' connection /before/ a client SSL handshake is +-- attempted. This is useful if you want to have more control over +-- the use of TLS extensions such as +-- or +-- enable features such as +-- . +-- +-- For reference, the 'openConnectionSSL' function can be defined in +-- terms of 'openConnectionSSL'' like so +-- +-- > openConnectionSSL :: SSLContext -> Hostname -> Port -> IO Connection +-- > openConnectionSSL ctx h1' = openConnectionSSL' modssl ctx h1' +-- > where +-- > modssl ssl = SSL.setTlsextHostName ssl h1 +-- > h1 = S.unpack h1' +-- +-- @since 0.1.6.0 +openConnectionSSL' :: (SSL -> IO ()) -> SSLContext -> Hostname -> Port -> IO Connection +openConnectionSSL' modssl ctx h1' p = withOpenSSL $ do is <- getAddrInfo Nothing (Just h1) (Just $ show p) let a = addrAddress $ head is @@ -244,7 +269,7 @@ connect s a ssl <- SSL.connection ctx s - SSL.setTlsextHostName ssl h1 + modssl ssl SSL.connect ssl (i,o1) <- Streams.sslToStreams ssl diff --git a/http-streams/lib/Network/Http/Inconvenience.hs b/http-streams/lib/Network/Http/Inconvenience.hs --- a/http-streams/lib/Network/Http/Inconvenience.hs +++ b/http-streams/lib/Network/Http/Inconvenience.hs @@ -20,6 +20,7 @@ module Network.Http.Inconvenience ( URL, modifyContextSSL, + getContextSSL, establishConnection, get, post, @@ -27,6 +28,8 @@ encodedFormBody, put, baselineContextSSL, + voidContextSSL, + contextSetCASystemStore, concatHandler', TooManyRedirects(..), HttpClientError(..), @@ -36,6 +39,7 @@ connectionAddressFromURL, openConnectionAddress, openConnectionAddress', + openConnectionAddress'', -- for testing splitURI @@ -166,8 +170,12 @@ -- -- | Modify the context being used to configure the SSL tunnel used by -- the convenience API functions to make @https://@ connections. The --- default is that setup by 'baselineContextSSL'. +-- default is that setup by 'baselineContextSSL'. See also 'getContextSSL'. -- +-- __NOTE__: This operation is /not/ reentrant; it is assumed this +-- operation is called once during program initialization and thus +-- there is currently no provision implemented to protected against +-- parallel execution from multiple threads! modifyContextSSL :: (SSLContext -> IO SSLContext) -> IO () modifyContextSSL f = do ctx <- readIORef global @@ -175,6 +183,15 @@ writeIORef global ctx' -- +-- | Retrieve the /global/ context being used to configure the SSL +-- connection used by the convenience API functions to make @https://@ +-- connections. See also 'modifyContextSSL'. +-- +-- @since 0.1.6.0 +getContextSSL :: IO SSLContext +getContextSSL = readIORef global + +-- -- | Given a URL, work out whether it is normal, secure, or unix domain, -- and then open the connection to the webserver including setting the -- appropriate default port if one was not specified in the URL. This @@ -268,6 +285,23 @@ c <- openConnectionUnix (S.unpack fp) return c { cHost = mempty } -- NB: HTTP RFC allows empty Host: headers +-- | Yet another variant of 'openConnectionAddress' allowing to supply local 'SSLContext' as well as an 'SSL.SSL' connection modifier (see 'openConnectionSSL'' for details). +-- +-- The @IO (SSLContext@ action is only evaluated in case of a 'ConnectionAddressHttps' target. +-- +-- See also 'baselineContextSSL' which may be convenient to use as a starting point; you may want to implement your own variant of 'baselineContextSSL'. +-- +-- @since 0.1.6.0 +openConnectionAddress'' :: ((Hostname,Word16) -> IO (SSLContext, SSL.SSL -> IO ())) -> ConnectionAddress -> IO Connection +openConnectionAddress'' getCtx ca = case ca of + ConnectionAddressHttp host port -> openConnection host port + ConnectionAddressHttps host ports -> do + (ctx,modssl) <- getCtx (host,ports) + openConnectionSSL' modssl ctx host ports + ConnectionAddressHttpUnix fp -> do + c <- openConnectionUnix (S.unpack fp) + return c { cHost = mempty } -- NB: HTTP RFC allows empty Host: headers + -- | Decode 'URL' into 'ConnectionAddress', user-info-part, (escaped) URL path, and optional fragment. -- -- The 'URL' argument is expected to be properly escaped according to RFC 3986. @@ -365,6 +399,7 @@ -- you are encouraged to install the system -- certificates somewhere and create your own 'SSLContext'. -- +-- See also 'contextSetCASystemStore' {- We would like to turn certificate verification on for everyone, but this has proved contingent on leveraging platform specific mechanisms @@ -375,26 +410,66 @@ baselineContextSSL = withOpenSSL $ do ctx <- SSL.context SSL.contextSetDefaultCiphers ctx + + caSet <- contextSetCASystemStore ctx + if caSet + then SSL.contextSetVerificationMode ctx (SSL.VerifyPeer True True Nothing) + else SSL.contextSetVerificationMode ctx SSL.VerifyNone + + return ctx + +-- | Construct a /void/ 'SSL.Context' in a configuration which uses +-- the @HIGH@ cipher-suite and rejects /any/ presented server +-- certificate. +-- +-- This is mostly useful for testing purposes or intentionally +-- thwarting any attempt to connect to @https://@ uris. +-- +-- @since 0.1.6.0 +voidContextSSL :: IO SSLContext +voidContextSSL = do + ctx <- SSL.context + SSL.contextSetCiphers ctx "HIGH" + SSL.contextSetVerificationMode ctx (SSL.VerifyPeer True True (Just (\_ _ -> return False))) + return ctx + +-- | Configure system-wide certificate store based on OS-specific heuristics. +-- +-- This function returns 'True' if the 'SSLContext' was configured; or +-- 'False' if the location couldn't be termined for the current OS. +-- +-- This function is used by 'baselineContextSSL' but in contrast does +-- *not* invoke 'SSL.contextSetDefaultCiphers' nor +-- 'SSL.contextSetVerificationMode'. See source-code for details on +-- the heuristic used to determine the location of the system +-- certificate store. +-- +-- @since 0.1.6.0 +contextSetCASystemStore :: SSLContext -> IO Bool +contextSetCASystemStore ctx = do #if defined(darwin_HOST_OS) - SSL.contextSetVerificationMode ctx SSL.VerifyNone + return False #elif defined(mingw32_HOST_OS) - SSL.contextSetVerificationMode ctx SSL.VerifyNone + return False #elif defined(freebsd_HOST_OS) SSL.contextSetCAFile ctx "/usr/local/etc/ssl/cert.pem" - SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing + return True #elif defined(openbsd_HOST_OS) SSL.contextSetCAFile ctx "/etc/ssl/cert.pem" - SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing + return True #else - fedora <- doesDirectoryExist "/etc/pki/tls" - if fedora - then do - SSL.contextSetCAFile ctx "/etc/pki/tls/certs/ca-bundle.crt" - else do - SSL.contextSetCADirectory ctx "/etc/ssl/certs" - SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing + hasFedoraEtcPkiTls <- doesDirectoryExist "/etc/pki/tls" + if hasFedoraEtcPkiTls + then do + SSL.contextSetCAFile ctx "/etc/pki/tls/certs/ca-bundle.crt" + return True + else do + -- Setting this as fallback effectively will cause systems to + -- either fail to verify any certificates (if peer + -- verification is enabled) if the folder doesn't exist. + SSL.contextSetCADirectory ctx "/etc/ssl/certs" + return True #endif - return ctx parseURL :: URL -> URI