diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,103 @@ +# Changelog for http-client-tls + +## 0.4.0 + +* For MD5 hashes in Base16 format, depend on packages `cryptohash-md5` and + `base16` rather than `crypton` and `memory` (the latter is unmaintained). + +## 0.3.6.4 + +* data-default-class -> data-default [#546](https://github.com/snoyberg/http-client/pull/546/files) + +## 0.3.6.3 + +* catching up to tls 1.8.0 [#515](https://github.com/snoyberg/http-client/pull/515) + +## 0.3.6.2 + +* Migrate to `crypton` + +## 0.3.6.1 + +* [#482](https://github.com/snoyberg/http-client/issues/482): + Raise lower bound on `http-client` to fix build. + +## 0.3.6 + +* Allow making requests to raw IPv6 hosts [#477](https://github.com/snoyberg/http-client/pull/477) + +## 0.3.5.3 + +* Fix `newTlsManager` [#325](https://github.com/snoyberg/http-client/issues/325) + +## 0.3.5.2 + +* [#289](https://github.com/snoyberg/http-client/issues/289): + Keep original `TLSSettings` when creating a `Manager` using `newTlsManagerWith`. + +## 0.3.5.1 + +* Also catch TLSError exceptions [#273](https://github.com/snoyberg/http-client/pull/273) + +## 0.3.5 + +* Add `newTlsManagerWith` + [#278](https://github.com/snoyberg/http-client/issues/278), which + provides a variant of `newTlsManager` that takes a `ManagerSettings` + to base its settings off of. + +## 0.3.4.2 + +* Never throw exceptions on 401 status in `applyDigestAuth` + +## 0.3.4.1 + +* Better exception cleanup behavior + +## 0.3.4 + +* Add 'newTlsManager' + [#263](https://github.com/snoyberg/http-client/issues/263), which adds + support for respecting `socks5://` and `socks5h://` `http_proxy` and + `https_proxy` environment variables. + +## 0.3.3.2 + +* Better handling of internal exceptions + +## 0.3.3.1 + +* Better exception safety via `bracketOnError` + +## 0.3.3 + +* Add `DigestAuthException` and generalize `applyDigestAuth` +* Global manager uses a shared TLS context (faster init) + +## 0.3.2 + +* Add `mkManagerSettingsContext` [#228](https://github.com/snoyberg/http-client/issues/228) + +## 0.3.1.1 + +* Minor doc updates + +## 0.3.1 + +* Add `applyDigestAuth` + +## 0.3.0 + +* Support http-client 0.5 + +## 0.2.4.1 + +* Cabal description fix + +## 0.2.4 + +* Global manager + +## 0.2.3 + +* Exception catching cleanup diff --git a/Network/HTTP/Client/TLS.hs b/Network/HTTP/Client/TLS.hs --- a/Network/HTTP/Client/TLS.hs +++ b/Network/HTTP/Client/TLS.hs @@ -1,107 +1,166 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} -- | Support for making connections via the connection package and, in turn, -- the tls package suite. +-- +-- Recommended reading: module Network.HTTP.Client.TLS - ( tlsManagerSettings + ( -- * Settings + tlsManagerSettings , mkManagerSettings - , getTlsConnection + , mkManagerSettingsContext + , newTlsManager + , newTlsManagerWith + -- * Digest authentication + , applyDigestAuth + , DigestAuthException (..) + , DigestAuthExceptionDetails (..) + , displayDigestAuthException + -- * Global manager + , getGlobalManager + , setGlobalManager ) where -import Data.Default.Class -import Network.HTTP.Client -import Network.HTTP.Client.Internal +import Control.Applicative ((<|>)) +import Control.Arrow (first) +import System.Environment (getEnvironment) +import Data.Default +import Network.HTTP.Client hiding (host, port) +import Network.HTTP.Client.Internal hiding (host, port) import Control.Exception import qualified Network.Connection as NC import Network.Socket (HostAddress) import qualified Network.TLS as TLS import qualified Data.ByteString as S +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad (guard, unless) +import qualified Data.CaseInsensitive as CI +import Data.Maybe (fromMaybe, isJust) +import Network.HTTP.Types (status401) +import qualified Crypto.Hash.MD5 as MD5 +import Control.Arrow ((***)) +import Data.Base16.Types (extractBase16) +import Data.ByteString.Base16 (encodeBase16') +import Data.Typeable (Typeable) +import Control.Monad.Catch (MonadThrow, throwM) +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Text.Read (decimal) +import qualified Network.URI as U +-- | Create a TLS-enabled 'ManagerSettings' with the given 'NC.TLSSettings' and +-- 'NC.SockSettings' mkManagerSettings :: NC.TLSSettings -> Maybe NC.SockSettings -> ManagerSettings -mkManagerSettings tls sock = defaultManagerSettings - { managerTlsConnection = getTlsConnection (Just tls) sock - , managerTlsProxyConnection = getTlsProxyConnection tls sock +mkManagerSettings = mkManagerSettingsContext Nothing + +-- | Same as 'mkManagerSettings', but also takes an optional +-- 'NC.ConnectionContext'. Providing this externally can be an +-- optimization, though that may change in the future. For more +-- information, see: +-- +-- +-- +-- @since 0.3.2 +mkManagerSettingsContext + :: Maybe NC.ConnectionContext + -> NC.TLSSettings + -> Maybe NC.SockSettings + -> ManagerSettings +mkManagerSettingsContext mcontext tls sock = mkManagerSettingsContext' defaultManagerSettings mcontext tls sock sock + +-- | Internal, allow different SockSettings for HTTP and HTTPS +mkManagerSettingsContext' + :: ManagerSettings + -> Maybe NC.ConnectionContext + -> NC.TLSSettings + -> Maybe NC.SockSettings -- ^ insecure + -> Maybe NC.SockSettings -- ^ secure + -> ManagerSettings +mkManagerSettingsContext' set mcontext tls sockHTTP sockHTTPS = set + { managerTlsConnection = getTlsConnection mcontext (Just tls) sockHTTPS + , managerTlsProxyConnection = getTlsProxyConnection mcontext tls sockHTTPS , managerRawConnection = - case sock of + case sockHTTP of Nothing -> managerRawConnection defaultManagerSettings - Just _ -> getTlsConnection Nothing sock + Just _ -> getTlsConnection mcontext Nothing sockHTTP , managerRetryableException = \e -> case () of () +#if MIN_VERSION_tls(1,8,0) + | ((fromException e)::(Maybe TLS.TLSException))==Just (TLS.PostHandshake TLS.Error_EOF) -> True +#else | ((fromException e)::(Maybe TLS.TLSError))==Just TLS.Error_EOF -> True - | otherwise -> case fromException e of - Just (_ :: IOException) -> True - _ -> - case fromException e of - -- Note: Some servers will timeout connections by accepting - -- the incoming packets for the new request, but closing - -- the connection as soon as we try to read. To make sure - -- we open a new connection under these circumstances, we - -- check for the NoResponseDataReceived exception. - Just NoResponseDataReceived -> True - Just IncompleteHeaders -> True - _ -> False - , managerWrapIOException = - let wrapper se = - case fromException se of - Just e -> toException $ InternalIOException e - Nothing -> - case fromException se of - Just TLS.Terminated{} -> toException $ TlsException se - _ -> - case fromException se of - Just TLS.HandshakeFailed{} -> toException $ TlsException se - _ -> - case fromException se of - Just TLS.ConnectionNotEstablished -> toException $ TlsException se - _ -> se +#endif + | otherwise -> managerRetryableException defaultManagerSettings e + , managerWrapException = \req -> + let wrapper se + | Just (_ :: IOException) <- fromException se = se' + | Just (_ :: TLS.TLSException) <- fromException se = se' +#if !MIN_VERSION_tls(1,8,0) + | Just (_ :: TLS.TLSError) <- fromException se = se' +#endif + | Just (_ :: NC.LineTooLong) <- fromException se = se' + | Just (_ :: NC.HostNotResolved) <- fromException se = se' + | Just (_ :: NC.HostCannotConnect) <- fromException se = se' + | otherwise = se + where + se' = toException $ HttpExceptionRequest req $ InternalException se in handle $ throwIO . wrapper } +-- | Default TLS-enabled manager settings tlsManagerSettings :: ManagerSettings tlsManagerSettings = mkManagerSettings def Nothing -getTlsConnection :: Maybe NC.TLSSettings +getTlsConnection :: Maybe NC.ConnectionContext + -> Maybe NC.TLSSettings -> Maybe NC.SockSettings -> IO (Maybe HostAddress -> String -> Int -> IO Connection) -getTlsConnection tls sock = do - context <- NC.initConnectionContext - return $ \_ha host port -> do - conn <- NC.connectTo context NC.ConnectionParams - { NC.connectionHostname = host +getTlsConnection mcontext tls sock = do + context <- maybe NC.initConnectionContext return mcontext + return $ \_ha host port -> bracketOnError + (NC.connectTo context NC.ConnectionParams + { NC.connectionHostname = strippedHostName host , NC.connectionPort = fromIntegral port , NC.connectionUseSecure = tls , NC.connectionUseSocks = sock - } - convertConnection conn + }) + NC.connectionClose + convertConnection getTlsProxyConnection - :: NC.TLSSettings + :: Maybe NC.ConnectionContext + -> NC.TLSSettings -> Maybe NC.SockSettings -> IO (S.ByteString -> (Connection -> IO ()) -> String -> Maybe HostAddress -> String -> Int -> IO Connection) -getTlsProxyConnection tls sock = do - context <- NC.initConnectionContext - return $ \connstr checkConn serverName _ha host port -> do - --error $ show (connstr, host, port) - conn <- NC.connectTo context NC.ConnectionParams - { NC.connectionHostname = serverName +getTlsProxyConnection mcontext tls sock = do + context <- maybe NC.initConnectionContext return mcontext + return $ \connstr checkConn serverName _ha host port -> bracketOnError + (NC.connectTo context NC.ConnectionParams + { NC.connectionHostname = strippedHostName serverName , NC.connectionPort = fromIntegral port , NC.connectionUseSecure = Nothing , NC.connectionUseSocks = case sock of Just _ -> error "Cannot use SOCKS and TLS proxying together" - Nothing -> Just $ NC.OtherProxy host $ fromIntegral port - } - - NC.connectionPut conn connstr - conn' <- convertConnection conn + Nothing -> Just $ NC.OtherProxy (strippedHostName host) $ fromIntegral port + }) + NC.connectionClose + $ \conn -> do + NC.connectionPut conn connstr + conn' <- convertConnection conn - checkConn conn' + checkConn conn' - NC.connectionSetSecure context conn tls + NC.connectionSetSecure context conn tls - return conn' + return conn' convertConnection :: NC.Connection -> IO Connection convertConnection conn = makeConnection @@ -111,3 +170,267 @@ -- on the socket. But when this is called the socket might be -- already closed, and we get a @ResourceVanished@. (NC.connectionClose conn `Control.Exception.catch` \(_ :: IOException) -> return ()) + +-- We may decide in the future to just have a global +-- ConnectionContext and use it directly in tlsManagerSettings, at +-- which point this can again be a simple (newManager +-- tlsManagerSettings >>= newIORef). See: +-- https://github.com/snoyberg/http-client/pull/227. +globalConnectionContext :: NC.ConnectionContext +globalConnectionContext = unsafePerformIO NC.initConnectionContext +{-# NOINLINE globalConnectionContext #-} + +-- | Load up a new TLS manager with default settings, respecting proxy +-- environment variables. +-- +-- @since 0.3.4 +newTlsManager :: MonadIO m => m Manager +newTlsManager = liftIO $ do + env <- getEnvironment + let lenv = Map.fromList $ map (first $ T.toLower . T.pack) env + msocksHTTP = parseSocksSettings env lenv "http_proxy" + msocksHTTPS = parseSocksSettings env lenv "https_proxy" + settings = mkManagerSettingsContext' defaultManagerSettings (Just globalConnectionContext) def msocksHTTP msocksHTTPS + settings' = maybe id (const $ managerSetInsecureProxy proxyFromRequest) msocksHTTP + $ maybe id (const $ managerSetSecureProxy proxyFromRequest) msocksHTTPS + settings + newManager settings' + +-- | Load up a new TLS manager based upon specified settings, +-- respecting proxy environment variables. +-- +-- @since 0.3.5 +newTlsManagerWith :: MonadIO m => ManagerSettings -> m Manager +newTlsManagerWith set = liftIO $ do + env <- getEnvironment + let lenv = Map.fromList $ map (first $ T.toLower . T.pack) env + msocksHTTP = parseSocksSettings env lenv "http_proxy" + msocksHTTPS = parseSocksSettings env lenv "https_proxy" + settings = mkManagerSettingsContext' set (Just globalConnectionContext) def msocksHTTP msocksHTTPS + settings' = maybe id (const $ managerSetInsecureProxy proxyFromRequest) msocksHTTP + $ maybe id (const $ managerSetSecureProxy proxyFromRequest) msocksHTTPS + settings + -- We want to keep the original TLS settings that were + -- passed in. Sadly they aren't available as a record + -- field on `ManagerSettings`. So instead we grab the + -- fields that depend on the TLS settings. + -- https://github.com/snoyberg/http-client/issues/289 + { managerTlsConnection = managerTlsConnection set + , managerTlsProxyConnection = managerTlsProxyConnection set + } + newManager settings' + +parseSocksSettings :: [(String, String)] -- ^ original environment + -> Map.Map T.Text String -- ^ lower-cased keys + -> T.Text -- ^ env name + -> Maybe NC.SockSettings +parseSocksSettings env lenv n = do + str <- lookup (T.unpack n) env <|> Map.lookup n lenv + let allowedScheme x = x == "socks5:" || x == "socks5h:" + uri <- U.parseURI str + + guard $ allowedScheme $ U.uriScheme uri + guard $ null (U.uriPath uri) || U.uriPath uri == "/" + guard $ null $ U.uriQuery uri + guard $ null $ U.uriFragment uri + + auth <- U.uriAuthority uri + port' <- + case U.uriPort auth of + "" -> Nothing -- should we use some default? + ':':rest -> + case decimal $ T.pack rest of + Right (p, "") -> Just p + _ -> Nothing + _ -> Nothing + + Just $ NC.SockSettingsSimple (U.uriRegName auth) port' + +-- | Evil global manager, to make life easier for the common use case +globalManager :: IORef Manager +globalManager = unsafePerformIO $ newTlsManager >>= newIORef +{-# NOINLINE globalManager #-} + +-- | Get the current global 'Manager' +-- +-- @since 0.2.4 +getGlobalManager :: IO Manager +getGlobalManager = readIORef globalManager +{-# INLINE getGlobalManager #-} + +-- | Set the current global 'Manager' +-- +-- @since 0.2.4 +setGlobalManager :: Manager -> IO () +setGlobalManager = writeIORef globalManager + +-- | Generated by 'applyDigestAuth' when it is unable to apply the +-- digest credentials to the request. +-- +-- @since 0.3.3 +data DigestAuthException + = DigestAuthException Request (Response ()) DigestAuthExceptionDetails + deriving (Show, Typeable) +instance Exception DigestAuthException where +#if MIN_VERSION_base(4, 8, 0) + displayException = displayDigestAuthException +#endif + +-- | User friendly display of a 'DigestAuthException' +-- +-- @since 0.3.3 +displayDigestAuthException :: DigestAuthException -> String +displayDigestAuthException (DigestAuthException req res det) = concat + [ "Unable to submit digest credentials due to: " + , details + , ".\n\nRequest: " + , show req + , ".\n\nResponse: " + , show res + ] + where + details = + case det of + UnexpectedStatusCode -> "received unexpected status code" + MissingWWWAuthenticateHeader -> + "missing WWW-Authenticate response header" + WWWAuthenticateIsNotDigest -> + "WWW-Authenticate response header does not indicate Digest" + MissingRealm -> + "WWW-Authenticate response header does include realm" + MissingNonce -> + "WWW-Authenticate response header does include nonce" + +-- | Detailed explanation for failure for 'DigestAuthException' +-- +-- @since 0.3.3 +data DigestAuthExceptionDetails + = UnexpectedStatusCode + | MissingWWWAuthenticateHeader + | WWWAuthenticateIsNotDigest + | MissingRealm + | MissingNonce + deriving (Show, Read, Typeable, Eq, Ord) + +-- | Apply digest authentication to this request. +-- +-- Note that this function will need to make an HTTP request to the +-- server in order to get the nonce, thus the need for a @Manager@ and +-- to live in @IO@. This also means that the request body will be sent +-- to the server. If the request body in the supplied @Request@ can +-- only be read once, you should replace it with a dummy value. +-- +-- In the event of successfully generating a digest, this will return +-- a @Just@ value. If there is any problem with generating the digest, +-- it will return @Nothing@. +-- +-- @since 0.3.1 +applyDigestAuth :: (MonadIO m, MonadThrow n) + => S.ByteString -- ^ username + -> S.ByteString -- ^ password + -> Request + -> Manager + -> m (n Request) +applyDigestAuth user pass req0 man = liftIO $ do + res <- httpNoBody req man + let throw' = throwM . DigestAuthException req res + return $ do + unless (responseStatus res == status401) + $ throw' UnexpectedStatusCode + h1 <- maybe (throw' MissingWWWAuthenticateHeader) return + $ lookup "WWW-Authenticate" $ responseHeaders res + h2 <- maybe (throw' WWWAuthenticateIsNotDigest) return + $ stripCI "Digest " h1 + let pieces = map (strip *** strip) (toPairs h2) + realm <- maybe (throw' MissingRealm) return + $ lookup "realm" pieces + nonce <- maybe (throw' MissingNonce) return + $ lookup "nonce" pieces + let qop = isJust $ lookup "qop" pieces + digest + | qop = md5 $ S.concat + [ ha1 + , ":" + , nonce + , ":00000001:deadbeef:auth:" + , ha2 + ] + | otherwise = md5 $ S.concat [ha1, ":", nonce, ":", ha2] + where + ha1 = md5 $ S.concat [user, ":", realm, ":", pass] + + -- we always use no qop or qop=auth + ha2 = md5 $ S.concat [method req, ":", path req] + + md5 = extractBase16 . encodeBase16' . MD5.hash + key = "Authorization" + val = S.concat + [ "Digest username=\"" + , user + , "\", realm=\"" + , realm + , "\", nonce=\"" + , nonce + , "\", uri=\"" + , path req + , "\", response=\"" + , digest + , "\"" + -- FIXME algorithm? + , case lookup "opaque" pieces of + Nothing -> "" + Just o -> S.concat [", opaque=\"", o, "\""] + , if qop + then ", qop=auth, nc=00000001, cnonce=\"deadbeef\"" + else "" + ] + return req + { requestHeaders = (key, val) + : filter + (\(x, _) -> x /= key) + (requestHeaders req) + , cookieJar = Just $ responseCookieJar res + } + where + -- Since we're expecting a non-200 response, ensure we do not + -- throw exceptions for such responses. + req = req0 { checkResponse = \_ _ -> return () } + + stripCI x y + | CI.mk x == CI.mk (S.take len y) = Just $ S.drop len y + | otherwise = Nothing + where + len = S.length x + + _comma = 44 + _equal = 61 + _dquot = 34 + _space = 32 + + strip = fst . S.spanEnd (== _space) . S.dropWhile (== _space) + + toPairs bs0 + | S.null bs0 = [] + | otherwise = + let bs1 = S.dropWhile (== _space) bs0 + (key, bs2) = S.break (\w -> w == _equal || w == _comma) bs1 + in case () of + () + | S.null bs2 -> [(key, "")] + | S.head bs2 == _equal -> + let (val, rest) = parseVal $ S.tail bs2 + in (key, val) : toPairs rest + | otherwise -> + assert (S.head bs2 == _comma) $ + (key, "") : toPairs (S.tail bs2) + + parseVal bs0 = fromMaybe (parseUnquoted bs0) $ do + guard $ not $ S.null bs0 + guard $ S.head bs0 == _dquot + let (x, y) = S.break (== _dquot) $ S.tail bs0 + guard $ not $ S.null y + Just (x, S.drop 1 $ S.dropWhile (/= _comma) y) + + parseUnquoted bs = + let (x, y) = S.break (== _comma) bs + in (x, S.drop 1 y) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,18 @@ +## http-client-tls + +Full tutorial docs are available at: +https://haskell-lang.org/library/http-client + +Use the http-client package with the pure-Haskell tls package for secure +connections. For the most part, you'll just want to replace +`defaultManagerSettings` with `tlsManagerSettings`, e.g.: + +```haskell +import Network.HTTP.Client +import Network.HTTP.Client.TLS + +main :: IO () +main = do + manager <- newManager tlsManagerSettings + ... +``` diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} +module Main where + +#if MIN_VERSION_gauge(0, 2, 0) +import Gauge +#else +import Gauge.Main +#endif +import Network.HTTP.Client +import Network.HTTP.Client.TLS + +main :: IO () +main = defaultMain [ + bgroup "newManager" [ + bench "defaultManagerSettings" $ + whnfIO (newManager defaultManagerSettings) + , bench "tlsManagerSettings" $ + whnfIO (newManager tlsManagerSettings) + ] + ] diff --git a/http-client-tls.cabal b/http-client-tls.cabal --- a/http-client-tls.cabal +++ b/http-client-tls.cabal @@ -1,7 +1,7 @@ name: http-client-tls -version: 0.2.2 +version: 0.4.0 synopsis: http-client backend using the connection package and tls library -description: Intended for use by higher-level libraries, such as http-conduit. +description: Hackage documentation generation is not reliable. For up to date documentation, please see: . homepage: https://github.com/snoyberg/http-client license: MIT license-file: LICENSE @@ -10,18 +10,30 @@ category: Network build-type: Simple cabal-version: >=1.10 +extra-source-files: README.md + ChangeLog.md library exposed-modules: Network.HTTP.Client.TLS other-extensions: ScopedTypeVariables - build-depends: base >= 4 && < 5 - , data-default-class - , http-client >= 0.3.5 - , connection >= 0.2.2 + build-depends: base >= 4.10 && < 5 + , base16 >= 1.0 + , cryptohash-md5 + , data-default + , http-client >= 0.7.11 + , crypton-connection , network - , tls >=1.1 + , tls >= 2.1.2 , bytestring + , case-insensitive + , transformers + , http-types + , exceptions + , containers + , text + , network-uri default-language: Haskell2010 + ghc-options: -Wall test-suite spec main-is: Spec.hs @@ -33,3 +45,16 @@ , http-client , http-client-tls , http-types + , crypton-connection + , data-default + , tls + +benchmark benchmark + main-is: Bench.hs + type: exitcode-stdio-1.0 + hs-source-dirs: bench + default-language: Haskell2010 + build-depends: base + , gauge + , http-client + , http-client-tls diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,15 +1,87 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} import Test.Hspec +import Network.Connection import Network.HTTP.Client -import Network.HTTP.Client.TLS -import Network.HTTP.Client.Internal +import Network.HTTP.Client.TLS hiding (tlsManagerSettings) import Network.HTTP.Types +import Control.Monad (join) +import Data.Default +import qualified Network.TLS as TLS main :: IO () main = hspec $ do + let tlsSettings = def + -- Since the release of v2.0.0 of the `tls` package , the default value of + -- the `supportedExtendedMainSecret` parameter `is `RequireEMS`, this means + -- that all the connections to a server not supporting TLS1.2+EMS will fail. + -- The badssl.com service does not yet support TLS1.2+EMS connections, so + -- let's switch to the value `AllowEMS`, ie: TLS1.2 conenctions without EMS. +#if MIN_VERSION_crypton_connection(0,4,0) + {settingClientSupported = def {TLS.supportedExtendedMainSecret = TLS.AllowEMS}} +#endif + + let tlsManagerSettings = mkManagerSettings tlsSettings Nothing + it "make a TLS connection" $ do manager <- newManager tlsManagerSettings - withResponse "https://httpbin.org/status/418" - { checkStatus = \_ _ _ -> Nothing - } manager $ \res -> do + withResponse "https://httpbin.org/status/418" manager $ \res -> responseStatus res `shouldBe` status418 + + it "digest authentication" $ do + man <- newManager defaultManagerSettings + req <- join $ applyDigestAuth + "user" + "passwd" + "http://httpbin.org/digest-auth/qop/user/passwd" + man + response <- httpNoBody req man + responseStatus response `shouldBe` status200 + + it "incorrect digest authentication" $ do + man <- newManager defaultManagerSettings + join (applyDigestAuth "user" "passwd" "http://httpbin.org/" man) + `shouldThrow` \(DigestAuthException _ _ det) -> + det == UnexpectedStatusCode + + it "BadSSL: expired" $ do + manager <- newManager tlsManagerSettings + let action = withResponse "https://expired.badssl.com/" manager (const (return ())) + action `shouldThrow` anyException + + it "BadSSL: self-signed" $ do + manager <- newManager tlsManagerSettings + let action = withResponse "https://self-signed.badssl.com/" manager (const (return ())) + action `shouldThrow` anyException + + it "BadSSL: wrong.host" $ do + manager <- newManager tlsManagerSettings + let action = withResponse "https://wrong.host.badssl.com/" manager (const (return ())) + action `shouldThrow` anyException + + it "BadSSL: we do have case-insensitivity though" $ do + manager <- newManager $ tlsManagerSettings + withResponse "https://BADSSL.COM" manager $ \res -> + responseStatus res `shouldBe` status200 + + -- https://github.com/snoyberg/http-client/issues/289 + it "accepts TLS settings" $ do + let + tlsSettings' = tlsSettings + { settingDisableCertificateValidation = True + , settingDisableSession = False + , settingUseServerName = False + } + socketSettings = Nothing + managerSettings = mkManagerSettings tlsSettings' socketSettings + manager <- newTlsManagerWith managerSettings + let url = "https://wrong.host.badssl.com" + request <- parseRequest url + response <- httpNoBody request manager + responseStatus response `shouldBe` status200 + + it "global supports TLS" $ do + manager <- getGlobalManager + request <- parseRequest "https://httpbin.org" + response <- httpNoBody request manager + responseStatus response `shouldBe` status200