{-# 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: <https://haskell-lang.org/library/http-client>
module Network.HTTP.Client.TLS
    ( -- * Settings
      tlsManagerSettings
    , mkManagerSettings
    , mkManagerSettingsContext
    , newTlsManager
    , newTlsManagerWith
      -- * Digest authentication
    , applyDigestAuth
    , DigestAuthException (..)
    , DigestAuthExceptionDetails (..)
    , displayDigestAuthException
      -- * Global manager
    , getGlobalManager
    , setGlobalManager
    ) where

import Control.Applicative ((<|>))
import Control.Arrow (first)
import System.Environment (getEnvironment)
import Data.Default.Class
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 Crypto.Hash (hash, Digest, MD5)
import Control.Arrow ((***))
import Data.ByteArray.Encoding (convertToBase, Base (Base16))
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 :: TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings = Maybe ConnectionContext
-> TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettingsContext Maybe ConnectionContext
forall a. Maybe a
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:
--
-- <https://github.com/snoyberg/http-client/pull/227>
--
-- @since 0.3.2
mkManagerSettingsContext
    :: Maybe NC.ConnectionContext
    -> NC.TLSSettings
    -> Maybe NC.SockSettings
    -> ManagerSettings
mkManagerSettingsContext :: Maybe ConnectionContext
-> TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettingsContext Maybe ConnectionContext
mcontext TLSSettings
tls Maybe SockSettings
sock = ManagerSettings
-> Maybe ConnectionContext
-> TLSSettings
-> Maybe SockSettings
-> Maybe SockSettings
-> ManagerSettings
mkManagerSettingsContext' ManagerSettings
defaultManagerSettings Maybe ConnectionContext
mcontext TLSSettings
tls Maybe SockSettings
sock Maybe SockSettings
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' :: ManagerSettings
-> Maybe ConnectionContext
-> TLSSettings
-> Maybe SockSettings
-> Maybe SockSettings
-> ManagerSettings
mkManagerSettingsContext' ManagerSettings
set Maybe ConnectionContext
mcontext TLSSettings
tls Maybe SockSettings
sockHTTP Maybe SockSettings
sockHTTPS = ManagerSettings
set
    { managerTlsConnection :: IO (Maybe HostAddress -> String -> Int -> IO Connection)
managerTlsConnection = Maybe ConnectionContext
-> Maybe TLSSettings
-> Maybe SockSettings
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
getTlsConnection Maybe ConnectionContext
mcontext (TLSSettings -> Maybe TLSSettings
forall a. a -> Maybe a
Just TLSSettings
tls) Maybe SockSettings
sockHTTPS
    , managerTlsProxyConnection :: IO
  (ByteString
   -> (Connection -> IO ())
   -> String
   -> Maybe HostAddress
   -> String
   -> Int
   -> IO Connection)
managerTlsProxyConnection = Maybe ConnectionContext
-> TLSSettings
-> Maybe SockSettings
-> IO
     (ByteString
      -> (Connection -> IO ())
      -> String
      -> Maybe HostAddress
      -> String
      -> Int
      -> IO Connection)
getTlsProxyConnection Maybe ConnectionContext
mcontext TLSSettings
tls Maybe SockSettings
sockHTTPS
    , managerRawConnection :: IO (Maybe HostAddress -> String -> Int -> IO Connection)
managerRawConnection =
        case Maybe SockSettings
sockHTTP of
            Maybe SockSettings
Nothing -> ManagerSettings
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
managerRawConnection ManagerSettings
defaultManagerSettings
            Just SockSettings
_ -> Maybe ConnectionContext
-> Maybe TLSSettings
-> Maybe SockSettings
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
getTlsConnection Maybe ConnectionContext
mcontext Maybe TLSSettings
forall a. Maybe a
Nothing Maybe SockSettings
sockHTTP
    , managerRetryableException :: SomeException -> Bool
managerRetryableException = \SomeException
e ->
        case () of
            ()
                | ((SomeException -> Maybe TLSError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e)::(Maybe TLS.TLSError))Maybe TLSError -> Maybe TLSError -> Bool
forall a. Eq a => a -> a -> Bool
==TLSError -> Maybe TLSError
forall a. a -> Maybe a
Just TLSError
TLS.Error_EOF -> Bool
True
                | Bool
otherwise -> ManagerSettings -> SomeException -> Bool
managerRetryableException ManagerSettings
defaultManagerSettings SomeException
e
    , managerWrapException :: forall a. Request -> IO a -> IO a
managerWrapException = \Request
req ->
        let wrapper :: SomeException -> SomeException
wrapper SomeException
se
              | Just (IOException
_ :: IOException)          <- SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
              | Just (TLSException
_ :: TLS.TLSException)     <- SomeException -> Maybe TLSException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
              | Just (TLSError
_ :: TLS.TLSError)         <- SomeException -> Maybe TLSError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
              | Just (LineTooLong
_ :: NC.LineTooLong)       <- SomeException -> Maybe LineTooLong
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
#if MIN_VERSION_connection(0,2,7)
              | Just (HostNotResolved
_ :: NC.HostNotResolved)   <- SomeException -> Maybe HostNotResolved
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
              | Just (HostCannotConnect
_ :: NC.HostCannotConnect) <- SomeException -> Maybe HostCannotConnect
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
#endif
              | Bool
otherwise = SomeException
se
              where
                se' :: SomeException
se' = HttpException -> SomeException
forall e. Exception e => e -> SomeException
toException (HttpException -> SomeException) -> HttpException -> SomeException
forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HttpExceptionRequest Request
req (HttpExceptionContent -> HttpException)
-> HttpExceptionContent -> HttpException
forall a b. (a -> b) -> a -> b
$ SomeException -> HttpExceptionContent
InternalException SomeException
se
         in (SomeException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((SomeException -> IO a) -> IO a -> IO a)
-> (SomeException -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO (SomeException -> IO a)
-> (SomeException -> SomeException) -> SomeException -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> SomeException
wrapper
    }

-- | Default TLS-enabled manager settings
tlsManagerSettings :: ManagerSettings
tlsManagerSettings :: ManagerSettings
tlsManagerSettings = TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings TLSSettings
forall a. Default a => a
def Maybe SockSettings
forall a. Maybe a
Nothing

getTlsConnection :: Maybe NC.ConnectionContext
                 -> Maybe NC.TLSSettings
                 -> Maybe NC.SockSettings
                 -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
getTlsConnection :: Maybe ConnectionContext
-> Maybe TLSSettings
-> Maybe SockSettings
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
getTlsConnection Maybe ConnectionContext
mcontext Maybe TLSSettings
tls Maybe SockSettings
sock = do
    ConnectionContext
context <- IO ConnectionContext
-> (ConnectionContext -> IO ConnectionContext)
-> Maybe ConnectionContext
-> IO ConnectionContext
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ConnectionContext
NC.initConnectionContext ConnectionContext -> IO ConnectionContext
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ConnectionContext
mcontext
    (Maybe HostAddress -> String -> Int -> IO Connection)
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe HostAddress -> String -> Int -> IO Connection)
 -> IO (Maybe HostAddress -> String -> Int -> IO Connection))
-> (Maybe HostAddress -> String -> Int -> IO Connection)
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
forall a b. (a -> b) -> a -> b
$ \Maybe HostAddress
_ha String
host Int
port -> IO Connection
-> (Connection -> IO ())
-> (Connection -> IO Connection)
-> IO Connection
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (ConnectionContext -> ConnectionParams -> IO Connection
NC.connectTo ConnectionContext
context ConnectionParams :: String
-> PortNumber
-> Maybe TLSSettings
-> Maybe SockSettings
-> ConnectionParams
NC.ConnectionParams
            { connectionHostname :: String
NC.connectionHostname = String -> String
strippedHostName String
host
            , connectionPort :: PortNumber
NC.connectionPort = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port
            , connectionUseSecure :: Maybe TLSSettings
NC.connectionUseSecure = Maybe TLSSettings
tls
            , connectionUseSocks :: Maybe SockSettings
NC.connectionUseSocks = Maybe SockSettings
sock
            })
        Connection -> IO ()
NC.connectionClose
        Connection -> IO Connection
convertConnection

getTlsProxyConnection
    :: Maybe NC.ConnectionContext
    -> NC.TLSSettings
    -> Maybe NC.SockSettings
    -> IO (S.ByteString -> (Connection -> IO ()) -> String -> Maybe HostAddress -> String -> Int -> IO Connection)
getTlsProxyConnection :: Maybe ConnectionContext
-> TLSSettings
-> Maybe SockSettings
-> IO
     (ByteString
      -> (Connection -> IO ())
      -> String
      -> Maybe HostAddress
      -> String
      -> Int
      -> IO Connection)
getTlsProxyConnection Maybe ConnectionContext
mcontext TLSSettings
tls Maybe SockSettings
sock = do
    ConnectionContext
context <- IO ConnectionContext
-> (ConnectionContext -> IO ConnectionContext)
-> Maybe ConnectionContext
-> IO ConnectionContext
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ConnectionContext
NC.initConnectionContext ConnectionContext -> IO ConnectionContext
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ConnectionContext
mcontext
    (ByteString
 -> (Connection -> IO ())
 -> String
 -> Maybe HostAddress
 -> String
 -> Int
 -> IO Connection)
-> IO
     (ByteString
      -> (Connection -> IO ())
      -> String
      -> Maybe HostAddress
      -> String
      -> Int
      -> IO Connection)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString
  -> (Connection -> IO ())
  -> String
  -> Maybe HostAddress
  -> String
  -> Int
  -> IO Connection)
 -> IO
      (ByteString
       -> (Connection -> IO ())
       -> String
       -> Maybe HostAddress
       -> String
       -> Int
       -> IO Connection))
-> (ByteString
    -> (Connection -> IO ())
    -> String
    -> Maybe HostAddress
    -> String
    -> Int
    -> IO Connection)
-> IO
     (ByteString
      -> (Connection -> IO ())
      -> String
      -> Maybe HostAddress
      -> String
      -> Int
      -> IO Connection)
forall a b. (a -> b) -> a -> b
$ \ByteString
connstr Connection -> IO ()
checkConn String
serverName Maybe HostAddress
_ha String
host Int
port -> IO Connection
-> (Connection -> IO ())
-> (Connection -> IO Connection)
-> IO Connection
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (ConnectionContext -> ConnectionParams -> IO Connection
NC.connectTo ConnectionContext
context ConnectionParams :: String
-> PortNumber
-> Maybe TLSSettings
-> Maybe SockSettings
-> ConnectionParams
NC.ConnectionParams
            { connectionHostname :: String
NC.connectionHostname = String -> String
strippedHostName String
serverName
            , connectionPort :: PortNumber
NC.connectionPort = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port
            , connectionUseSecure :: Maybe TLSSettings
NC.connectionUseSecure = Maybe TLSSettings
forall a. Maybe a
Nothing
            , connectionUseSocks :: Maybe SockSettings
NC.connectionUseSocks =
                case Maybe SockSettings
sock of
                    Just SockSettings
_ -> String -> Maybe SockSettings
forall a. HasCallStack => String -> a
error String
"Cannot use SOCKS and TLS proxying together"
                    Maybe SockSettings
Nothing -> SockSettings -> Maybe SockSettings
forall a. a -> Maybe a
Just (SockSettings -> Maybe SockSettings)
-> SockSettings -> Maybe SockSettings
forall a b. (a -> b) -> a -> b
$ String -> PortNumber -> SockSettings
NC.OtherProxy (String -> String
strippedHostName String
host) (PortNumber -> SockSettings) -> PortNumber -> SockSettings
forall a b. (a -> b) -> a -> b
$ Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port
            })
        Connection -> IO ()
NC.connectionClose
        ((Connection -> IO Connection) -> IO Connection)
-> (Connection -> IO Connection) -> IO Connection
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
            Connection -> ByteString -> IO ()
NC.connectionPut Connection
conn ByteString
connstr
            Connection
conn' <- Connection -> IO Connection
convertConnection Connection
conn

            Connection -> IO ()
checkConn Connection
conn'

            ConnectionContext -> Connection -> TLSSettings -> IO ()
NC.connectionSetSecure ConnectionContext
context Connection
conn TLSSettings
tls

            Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
conn'

convertConnection :: NC.Connection -> IO Connection
convertConnection :: Connection -> IO Connection
convertConnection Connection
conn = IO ByteString -> (ByteString -> IO ()) -> IO () -> IO Connection
makeConnection
    (Connection -> IO ByteString
NC.connectionGetChunk Connection
conn)
    (Connection -> ByteString -> IO ()
NC.connectionPut Connection
conn)
    -- Closing an SSL connection gracefully involves writing/reading
    -- on the socket.  But when this is called the socket might be
    -- already closed, and we get a @ResourceVanished@.
    (Connection -> IO ()
NC.connectionClose Connection
conn IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Control.Exception.catch` \(IOException
_ :: IOException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: ConnectionContext
globalConnectionContext = IO ConnectionContext -> ConnectionContext
forall a. IO a -> a
unsafePerformIO IO ConnectionContext
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 :: m Manager
newTlsManager = IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ do
    [(String, String)]
env <- IO [(String, String)]
getEnvironment
    let lenv :: Map Text String
lenv = [(Text, String)] -> Map Text String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, String)] -> Map Text String)
-> [(Text, String)] -> Map Text String
forall a b. (a -> b) -> a -> b
$ ((String, String) -> (Text, String))
-> [(String, String)] -> [(Text, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Text) -> (String, String) -> (Text, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((String -> Text) -> (String, String) -> (Text, String))
-> (String -> Text) -> (String, String) -> (Text, String)
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) [(String, String)]
env
        msocksHTTP :: Maybe SockSettings
msocksHTTP = [(String, String)] -> Map Text String -> Text -> Maybe SockSettings
parseSocksSettings [(String, String)]
env Map Text String
lenv Text
"http_proxy"
        msocksHTTPS :: Maybe SockSettings
msocksHTTPS = [(String, String)] -> Map Text String -> Text -> Maybe SockSettings
parseSocksSettings [(String, String)]
env Map Text String
lenv Text
"https_proxy"
        settings :: ManagerSettings
settings = ManagerSettings
-> Maybe ConnectionContext
-> TLSSettings
-> Maybe SockSettings
-> Maybe SockSettings
-> ManagerSettings
mkManagerSettingsContext' ManagerSettings
defaultManagerSettings (ConnectionContext -> Maybe ConnectionContext
forall a. a -> Maybe a
Just ConnectionContext
globalConnectionContext) TLSSettings
forall a. Default a => a
def Maybe SockSettings
msocksHTTP Maybe SockSettings
msocksHTTPS
        settings' :: ManagerSettings
settings' = (ManagerSettings -> ManagerSettings)
-> (SockSettings -> ManagerSettings -> ManagerSettings)
-> Maybe SockSettings
-> ManagerSettings
-> ManagerSettings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ManagerSettings -> ManagerSettings
forall a. a -> a
id ((ManagerSettings -> ManagerSettings)
-> SockSettings -> ManagerSettings -> ManagerSettings
forall a b. a -> b -> a
const ((ManagerSettings -> ManagerSettings)
 -> SockSettings -> ManagerSettings -> ManagerSettings)
-> (ManagerSettings -> ManagerSettings)
-> SockSettings
-> ManagerSettings
-> ManagerSettings
forall a b. (a -> b) -> a -> b
$ ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetInsecureProxy ProxyOverride
proxyFromRequest) Maybe SockSettings
msocksHTTP
                  (ManagerSettings -> ManagerSettings)
-> ManagerSettings -> ManagerSettings
forall a b. (a -> b) -> a -> b
$ (ManagerSettings -> ManagerSettings)
-> (SockSettings -> ManagerSettings -> ManagerSettings)
-> Maybe SockSettings
-> ManagerSettings
-> ManagerSettings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ManagerSettings -> ManagerSettings
forall a. a -> a
id ((ManagerSettings -> ManagerSettings)
-> SockSettings -> ManagerSettings -> ManagerSettings
forall a b. a -> b -> a
const ((ManagerSettings -> ManagerSettings)
 -> SockSettings -> ManagerSettings -> ManagerSettings)
-> (ManagerSettings -> ManagerSettings)
-> SockSettings
-> ManagerSettings
-> ManagerSettings
forall a b. (a -> b) -> a -> b
$ ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetSecureProxy ProxyOverride
proxyFromRequest) Maybe SockSettings
msocksHTTPS
                    ManagerSettings
settings
    ManagerSettings -> IO Manager
newManager ManagerSettings
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 :: ManagerSettings -> m Manager
newTlsManagerWith ManagerSettings
set = IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ do
    [(String, String)]
env <- IO [(String, String)]
getEnvironment
    let lenv :: Map Text String
lenv = [(Text, String)] -> Map Text String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, String)] -> Map Text String)
-> [(Text, String)] -> Map Text String
forall a b. (a -> b) -> a -> b
$ ((String, String) -> (Text, String))
-> [(String, String)] -> [(Text, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Text) -> (String, String) -> (Text, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((String -> Text) -> (String, String) -> (Text, String))
-> (String -> Text) -> (String, String) -> (Text, String)
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) [(String, String)]
env
        msocksHTTP :: Maybe SockSettings
msocksHTTP = [(String, String)] -> Map Text String -> Text -> Maybe SockSettings
parseSocksSettings [(String, String)]
env Map Text String
lenv Text
"http_proxy"
        msocksHTTPS :: Maybe SockSettings
msocksHTTPS = [(String, String)] -> Map Text String -> Text -> Maybe SockSettings
parseSocksSettings [(String, String)]
env Map Text String
lenv Text
"https_proxy"
        settings :: ManagerSettings
settings = ManagerSettings
-> Maybe ConnectionContext
-> TLSSettings
-> Maybe SockSettings
-> Maybe SockSettings
-> ManagerSettings
mkManagerSettingsContext' ManagerSettings
set (ConnectionContext -> Maybe ConnectionContext
forall a. a -> Maybe a
Just ConnectionContext
globalConnectionContext) TLSSettings
forall a. Default a => a
def Maybe SockSettings
msocksHTTP Maybe SockSettings
msocksHTTPS
        settings' :: ManagerSettings
settings' = (ManagerSettings -> ManagerSettings)
-> (SockSettings -> ManagerSettings -> ManagerSettings)
-> Maybe SockSettings
-> ManagerSettings
-> ManagerSettings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ManagerSettings -> ManagerSettings
forall a. a -> a
id ((ManagerSettings -> ManagerSettings)
-> SockSettings -> ManagerSettings -> ManagerSettings
forall a b. a -> b -> a
const ((ManagerSettings -> ManagerSettings)
 -> SockSettings -> ManagerSettings -> ManagerSettings)
-> (ManagerSettings -> ManagerSettings)
-> SockSettings
-> ManagerSettings
-> ManagerSettings
forall a b. (a -> b) -> a -> b
$ ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetInsecureProxy ProxyOverride
proxyFromRequest) Maybe SockSettings
msocksHTTP
                  (ManagerSettings -> ManagerSettings)
-> ManagerSettings -> ManagerSettings
forall a b. (a -> b) -> a -> b
$ (ManagerSettings -> ManagerSettings)
-> (SockSettings -> ManagerSettings -> ManagerSettings)
-> Maybe SockSettings
-> ManagerSettings
-> ManagerSettings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ManagerSettings -> ManagerSettings
forall a. a -> a
id ((ManagerSettings -> ManagerSettings)
-> SockSettings -> ManagerSettings -> ManagerSettings
forall a b. a -> b -> a
const ((ManagerSettings -> ManagerSettings)
 -> SockSettings -> ManagerSettings -> ManagerSettings)
-> (ManagerSettings -> ManagerSettings)
-> SockSettings
-> ManagerSettings
-> ManagerSettings
forall a b. (a -> b) -> a -> b
$ ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetSecureProxy ProxyOverride
proxyFromRequest) Maybe SockSettings
msocksHTTPS
                    ManagerSettings
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 :: IO (Maybe HostAddress -> String -> Int -> IO Connection)
managerTlsConnection = ManagerSettings
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
managerTlsConnection ManagerSettings
set
                        , managerTlsProxyConnection :: IO
  (ByteString
   -> (Connection -> IO ())
   -> String
   -> Maybe HostAddress
   -> String
   -> Int
   -> IO Connection)
managerTlsProxyConnection = ManagerSettings
-> IO
     (ByteString
      -> (Connection -> IO ())
      -> String
      -> Maybe HostAddress
      -> String
      -> Int
      -> IO Connection)
managerTlsProxyConnection ManagerSettings
set
                        }
    ManagerSettings -> IO Manager
newManager ManagerSettings
settings'

parseSocksSettings :: [(String, String)] -- ^ original environment
                   -> Map.Map T.Text String -- ^ lower-cased keys
                   -> T.Text -- ^ env name
                   -> Maybe NC.SockSettings
parseSocksSettings :: [(String, String)] -> Map Text String -> Text -> Maybe SockSettings
parseSocksSettings [(String, String)]
env Map Text String
lenv Text
n = do
  String
str <- String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> String
T.unpack Text
n) [(String, String)]
env Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Map Text String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
n Map Text String
lenv
  let allowedScheme :: a -> Bool
allowedScheme a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"socks5:" Bool -> Bool -> Bool
|| a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"socks5h:"
  URI
uri <- String -> Maybe URI
U.parseURI String
str

  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. (Eq a, IsString a) => a -> Bool
allowedScheme (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ URI -> String
U.uriScheme URI
uri
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
U.uriPath URI
uri) Bool -> Bool -> Bool
|| URI -> String
U.uriPath URI
uri String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"/"
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ URI -> String
U.uriQuery URI
uri
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ URI -> String
U.uriFragment URI
uri

  URIAuth
auth <- URI -> Maybe URIAuth
U.uriAuthority URI
uri
  PortNumber
port' <-
      case URIAuth -> String
U.uriPort URIAuth
auth of
          String
"" -> Maybe PortNumber
forall a. Maybe a
Nothing -- should we use some default?
          Char
':':String
rest ->
              case Reader PortNumber
forall a. Integral a => Reader a
decimal Reader PortNumber -> Reader PortNumber
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
rest of
                  Right (PortNumber
p, Text
"") -> PortNumber -> Maybe PortNumber
forall a. a -> Maybe a
Just PortNumber
p
                  Either String (PortNumber, Text)
_ -> Maybe PortNumber
forall a. Maybe a
Nothing
          String
_ -> Maybe PortNumber
forall a. Maybe a
Nothing

  SockSettings -> Maybe SockSettings
forall a. a -> Maybe a
Just (SockSettings -> Maybe SockSettings)
-> SockSettings -> Maybe SockSettings
forall a b. (a -> b) -> a -> b
$ String -> PortNumber -> SockSettings
NC.SockSettingsSimple (URIAuth -> String
U.uriRegName URIAuth
auth) PortNumber
port'

-- | Evil global manager, to make life easier for the common use case
globalManager :: IORef Manager
globalManager :: IORef Manager
globalManager = IO (IORef Manager) -> IORef Manager
forall a. IO a -> a
unsafePerformIO (IO (IORef Manager) -> IORef Manager)
-> IO (IORef Manager) -> IORef Manager
forall a b. (a -> b) -> a -> b
$ IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager IO Manager -> (Manager -> IO (IORef Manager)) -> IO (IORef Manager)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Manager -> IO (IORef Manager)
forall a. a -> IO (IORef a)
newIORef
{-# NOINLINE globalManager #-}

-- | Get the current global 'Manager'
--
-- @since 0.2.4
getGlobalManager :: IO Manager
getGlobalManager :: IO Manager
getGlobalManager = IORef Manager -> IO Manager
forall a. IORef a -> IO a
readIORef IORef Manager
globalManager
{-# INLINE getGlobalManager #-}

-- | Set the current global 'Manager'
--
-- @since 0.2.4
setGlobalManager :: Manager -> IO ()
setGlobalManager :: Manager -> IO ()
setGlobalManager = IORef Manager -> Manager -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Manager
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 (Int -> DigestAuthException -> String -> String
[DigestAuthException] -> String -> String
DigestAuthException -> String
(Int -> DigestAuthException -> String -> String)
-> (DigestAuthException -> String)
-> ([DigestAuthException] -> String -> String)
-> Show DigestAuthException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DigestAuthException] -> String -> String
$cshowList :: [DigestAuthException] -> String -> String
show :: DigestAuthException -> String
$cshow :: DigestAuthException -> String
showsPrec :: Int -> DigestAuthException -> String -> String
$cshowsPrec :: Int -> DigestAuthException -> String -> String
Show, Typeable)
instance Exception DigestAuthException where
#if MIN_VERSION_base(4, 8, 0)
    displayException :: DigestAuthException -> String
displayException = DigestAuthException -> String
displayDigestAuthException
#endif

-- | User friendly display of a 'DigestAuthException'
--
-- @since 0.3.3
displayDigestAuthException :: DigestAuthException -> String
displayDigestAuthException :: DigestAuthException -> String
displayDigestAuthException (DigestAuthException Request
req Response ()
res DigestAuthExceptionDetails
det) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Unable to submit digest credentials due to: "
    , String
details
    , String
".\n\nRequest: "
    , Request -> String
forall a. Show a => a -> String
show Request
req
    , String
".\n\nResponse: "
    , Response () -> String
forall a. Show a => a -> String
show Response ()
res
    ]
  where
    details :: String
details =
        case DigestAuthExceptionDetails
det of
            DigestAuthExceptionDetails
UnexpectedStatusCode -> String
"received unexpected status code"
            DigestAuthExceptionDetails
MissingWWWAuthenticateHeader ->
                String
"missing WWW-Authenticate response header"
            DigestAuthExceptionDetails
WWWAuthenticateIsNotDigest ->
                String
"WWW-Authenticate response header does not indicate Digest"
            DigestAuthExceptionDetails
MissingRealm ->
                String
"WWW-Authenticate response header does include realm"
            DigestAuthExceptionDetails
MissingNonce ->
                String
"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 (Int -> DigestAuthExceptionDetails -> String -> String
[DigestAuthExceptionDetails] -> String -> String
DigestAuthExceptionDetails -> String
(Int -> DigestAuthExceptionDetails -> String -> String)
-> (DigestAuthExceptionDetails -> String)
-> ([DigestAuthExceptionDetails] -> String -> String)
-> Show DigestAuthExceptionDetails
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DigestAuthExceptionDetails] -> String -> String
$cshowList :: [DigestAuthExceptionDetails] -> String -> String
show :: DigestAuthExceptionDetails -> String
$cshow :: DigestAuthExceptionDetails -> String
showsPrec :: Int -> DigestAuthExceptionDetails -> String -> String
$cshowsPrec :: Int -> DigestAuthExceptionDetails -> String -> String
Show, ReadPrec [DigestAuthExceptionDetails]
ReadPrec DigestAuthExceptionDetails
Int -> ReadS DigestAuthExceptionDetails
ReadS [DigestAuthExceptionDetails]
(Int -> ReadS DigestAuthExceptionDetails)
-> ReadS [DigestAuthExceptionDetails]
-> ReadPrec DigestAuthExceptionDetails
-> ReadPrec [DigestAuthExceptionDetails]
-> Read DigestAuthExceptionDetails
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DigestAuthExceptionDetails]
$creadListPrec :: ReadPrec [DigestAuthExceptionDetails]
readPrec :: ReadPrec DigestAuthExceptionDetails
$creadPrec :: ReadPrec DigestAuthExceptionDetails
readList :: ReadS [DigestAuthExceptionDetails]
$creadList :: ReadS [DigestAuthExceptionDetails]
readsPrec :: Int -> ReadS DigestAuthExceptionDetails
$creadsPrec :: Int -> ReadS DigestAuthExceptionDetails
Read, Typeable, DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
(DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool)
-> (DigestAuthExceptionDetails
    -> DigestAuthExceptionDetails -> Bool)
-> Eq DigestAuthExceptionDetails
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
$c/= :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
== :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
$c== :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
Eq, Eq DigestAuthExceptionDetails
Eq DigestAuthExceptionDetails
-> (DigestAuthExceptionDetails
    -> DigestAuthExceptionDetails -> Ordering)
-> (DigestAuthExceptionDetails
    -> DigestAuthExceptionDetails -> Bool)
-> (DigestAuthExceptionDetails
    -> DigestAuthExceptionDetails -> Bool)
-> (DigestAuthExceptionDetails
    -> DigestAuthExceptionDetails -> Bool)
-> (DigestAuthExceptionDetails
    -> DigestAuthExceptionDetails -> Bool)
-> (DigestAuthExceptionDetails
    -> DigestAuthExceptionDetails -> DigestAuthExceptionDetails)
-> (DigestAuthExceptionDetails
    -> DigestAuthExceptionDetails -> DigestAuthExceptionDetails)
-> Ord DigestAuthExceptionDetails
DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
DigestAuthExceptionDetails
-> DigestAuthExceptionDetails -> Ordering
DigestAuthExceptionDetails
-> DigestAuthExceptionDetails -> DigestAuthExceptionDetails
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DigestAuthExceptionDetails
-> DigestAuthExceptionDetails -> DigestAuthExceptionDetails
$cmin :: DigestAuthExceptionDetails
-> DigestAuthExceptionDetails -> DigestAuthExceptionDetails
max :: DigestAuthExceptionDetails
-> DigestAuthExceptionDetails -> DigestAuthExceptionDetails
$cmax :: DigestAuthExceptionDetails
-> DigestAuthExceptionDetails -> DigestAuthExceptionDetails
>= :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
$c>= :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
> :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
$c> :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
<= :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
$c<= :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
< :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
$c< :: DigestAuthExceptionDetails -> DigestAuthExceptionDetails -> Bool
compare :: DigestAuthExceptionDetails
-> DigestAuthExceptionDetails -> Ordering
$ccompare :: DigestAuthExceptionDetails
-> DigestAuthExceptionDetails -> Ordering
$cp1Ord :: Eq DigestAuthExceptionDetails
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 :: ByteString -> ByteString -> Request -> Manager -> m (n Request)
applyDigestAuth ByteString
user ByteString
pass Request
req0 Manager
man = IO (n Request) -> m (n Request)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (n Request) -> m (n Request))
-> IO (n Request) -> m (n Request)
forall a b. (a -> b) -> a -> b
$ do
    Response ()
res <- Request -> Manager -> IO (Response ())
httpNoBody Request
req Manager
man
    let throw' :: DigestAuthExceptionDetails -> n a
throw' = DigestAuthException -> n a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (DigestAuthException -> n a)
-> (DigestAuthExceptionDetails -> DigestAuthException)
-> DigestAuthExceptionDetails
-> n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request
-> Response () -> DigestAuthExceptionDetails -> DigestAuthException
DigestAuthException Request
req Response ()
res
    n Request -> IO (n Request)
forall (m :: * -> *) a. Monad m => a -> m a
return (n Request -> IO (n Request)) -> n Request -> IO (n Request)
forall a b. (a -> b) -> a -> b
$ do
        Bool -> n () -> n ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
res Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status401)
            (n () -> n ()) -> n () -> n ()
forall a b. (a -> b) -> a -> b
$ DigestAuthExceptionDetails -> n ()
forall a. DigestAuthExceptionDetails -> n a
throw' DigestAuthExceptionDetails
UnexpectedStatusCode
        ByteString
h1 <- n ByteString
-> (ByteString -> n ByteString) -> Maybe ByteString -> n ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DigestAuthExceptionDetails -> n ByteString
forall a. DigestAuthExceptionDetails -> n a
throw' DigestAuthExceptionDetails
MissingWWWAuthenticateHeader) ByteString -> n ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Maybe ByteString -> n ByteString)
-> Maybe ByteString -> n ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"WWW-Authenticate" ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Response () -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ()
res
        ByteString
h2 <- n ByteString
-> (ByteString -> n ByteString) -> Maybe ByteString -> n ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DigestAuthExceptionDetails -> n ByteString
forall a. DigestAuthExceptionDetails -> n a
throw' DigestAuthExceptionDetails
WWWAuthenticateIsNotDigest) ByteString -> n ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Maybe ByteString -> n ByteString)
-> Maybe ByteString -> n ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Maybe ByteString
stripCI ByteString
"Digest " ByteString
h1
        let pieces :: [(ByteString, ByteString)]
pieces = ((ByteString, ByteString) -> (ByteString, ByteString))
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString
strip (ByteString -> ByteString)
-> (ByteString -> ByteString)
-> (ByteString, ByteString)
-> (ByteString, ByteString)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> ByteString
strip) (ByteString -> [(ByteString, ByteString)]
toPairs ByteString
h2)
        ByteString
realm <- n ByteString
-> (ByteString -> n ByteString) -> Maybe ByteString -> n ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DigestAuthExceptionDetails -> n ByteString
forall a. DigestAuthExceptionDetails -> n a
throw' DigestAuthExceptionDetails
MissingRealm) ByteString -> n ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
               (Maybe ByteString -> n ByteString)
-> Maybe ByteString -> n ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"realm" [(ByteString, ByteString)]
pieces
        ByteString
nonce <- n ByteString
-> (ByteString -> n ByteString) -> Maybe ByteString -> n ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DigestAuthExceptionDetails -> n ByteString
forall a. DigestAuthExceptionDetails -> n a
throw' DigestAuthExceptionDetails
MissingNonce) ByteString -> n ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
               (Maybe ByteString -> n ByteString)
-> Maybe ByteString -> n ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"nonce" [(ByteString, ByteString)]
pieces
        let qop :: Bool
qop = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"qop" [(ByteString, ByteString)]
pieces
            digest :: ByteString
digest
                | Bool
qop = ByteString -> ByteString
forall bout ba. (ByteArray bout, ByteArrayAccess ba) => ba -> bout
md5 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat
                    [ ByteString
ha1
                    , ByteString
":"
                    , ByteString
nonce
                    , ByteString
":00000001:deadbeef:auth:"
                    , ByteString
ha2
                    ]
                | Bool
otherwise = ByteString -> ByteString
forall bout ba. (ByteArray bout, ByteArrayAccess ba) => ba -> bout
md5 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat [ByteString
ha1, ByteString
":", ByteString
nonce, ByteString
":", ByteString
ha2]
              where
                ha1 :: ByteString
ha1 = ByteString -> ByteString
forall bout ba. (ByteArray bout, ByteArrayAccess ba) => ba -> bout
md5 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat [ByteString
user, ByteString
":", ByteString
realm, ByteString
":", ByteString
pass]

                -- we always use no qop or qop=auth
                ha2 :: ByteString
ha2 = ByteString -> ByteString
forall bout ba. (ByteArray bout, ByteArrayAccess ba) => ba -> bout
md5 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat [Request -> ByteString
method Request
req, ByteString
":", Request -> ByteString
path Request
req]

                md5 :: ba -> bout
md5 ba
bs = Base -> Digest MD5 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16 (ba -> Digest MD5
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash ba
bs :: Digest MD5)
            key :: HeaderName
key = HeaderName
"Authorization"
            val :: ByteString
val = [ByteString] -> ByteString
S.concat
                [ ByteString
"Digest username=\""
                , ByteString
user
                , ByteString
"\", realm=\""
                , ByteString
realm
                , ByteString
"\", nonce=\""
                , ByteString
nonce
                , ByteString
"\", uri=\""
                , Request -> ByteString
path Request
req
                , ByteString
"\", response=\""
                , ByteString
digest
                , ByteString
"\""
                -- FIXME algorithm?
                , case ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"opaque" [(ByteString, ByteString)]
pieces of
                    Maybe ByteString
Nothing -> ByteString
""
                    Just ByteString
o -> [ByteString] -> ByteString
S.concat [ByteString
", opaque=\"", ByteString
o, ByteString
"\""]
                , if Bool
qop
                    then ByteString
", qop=auth, nc=00000001, cnonce=\"deadbeef\""
                    else ByteString
""
                ]
        Request -> n Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req
            { requestHeaders :: [(HeaderName, ByteString)]
requestHeaders = (HeaderName
key, ByteString
val)
                             (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: ((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter
                                    (\(HeaderName
x, ByteString
_) -> HeaderName
x HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
key)
                                    (Request -> [(HeaderName, ByteString)]
requestHeaders Request
req)
            , cookieJar :: Maybe CookieJar
cookieJar = CookieJar -> Maybe CookieJar
forall a. a -> Maybe a
Just (CookieJar -> Maybe CookieJar) -> CookieJar -> Maybe CookieJar
forall a b. (a -> b) -> a -> b
$ Response () -> CookieJar
forall body. Response body -> CookieJar
responseCookieJar Response ()
res
            }
  where
    -- Since we're expecting a non-200 response, ensure we do not
    -- throw exceptions for such responses.
    req :: Request
req = Request
req0 { checkResponse :: Request -> Response (IO ByteString) -> IO ()
checkResponse = \Request
_ Response (IO ByteString)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }

    stripCI :: ByteString -> ByteString -> Maybe ByteString
stripCI ByteString
x ByteString
y
        | ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk ByteString
x HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (Int -> ByteString -> ByteString
S.take Int
len ByteString
y) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
len ByteString
y
        | Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing
      where
        len :: Int
len = ByteString -> Int
S.length ByteString
x

    _comma :: Word8
_comma = Word8
44
    _equal :: Word8
_equal = Word8
61
    _dquot :: Word8
_dquot = Word8
34
    _space :: Word8
_space = Word8
32

    strip :: ByteString -> ByteString
strip = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.spanEnd (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space) (ByteString -> (ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space)

    toPairs :: ByteString -> [(ByteString, ByteString)]
toPairs ByteString
bs0
        | ByteString -> Bool
S.null ByteString
bs0 = []
        | Bool
otherwise =
            let bs1 :: ByteString
bs1 = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space) ByteString
bs0
                (ByteString
key, ByteString
bs2) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (\Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_equal Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_comma) ByteString
bs1
             in case () of
                  ()
                    | ByteString -> Bool
S.null ByteString
bs2 -> [(ByteString
key, ByteString
"")]
                    | ByteString -> Word8
S.head ByteString
bs2 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_equal ->
                        let (ByteString
val, ByteString
rest) = ByteString -> (ByteString, ByteString)
parseVal (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
S.tail ByteString
bs2
                         in (ByteString
key, ByteString
val) (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: ByteString -> [(ByteString, ByteString)]
toPairs ByteString
rest
                    | Bool
otherwise ->
                        Bool -> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. HasCallStack => Bool -> a -> a
assert (ByteString -> Word8
S.head ByteString
bs2 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_comma) ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$
                        (ByteString
key, ByteString
"") (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: ByteString -> [(ByteString, ByteString)]
toPairs (ByteString -> ByteString
S.tail ByteString
bs2)

    parseVal :: ByteString -> (ByteString, ByteString)
parseVal ByteString
bs0 = (ByteString, ByteString)
-> Maybe (ByteString, ByteString) -> (ByteString, ByteString)
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> (ByteString, ByteString)
parseUnquoted ByteString
bs0) (Maybe (ByteString, ByteString) -> (ByteString, ByteString))
-> Maybe (ByteString, ByteString) -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
S.null ByteString
bs0
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Word8
S.head ByteString
bs0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_dquot
        let (ByteString
x, ByteString
y) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_dquot) (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
S.tail ByteString
bs0
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
S.null ByteString
y
        (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
x, Int -> ByteString -> ByteString
S.drop Int
1 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
_comma) ByteString
y)

    parseUnquoted :: ByteString -> (ByteString, ByteString)
parseUnquoted ByteString
bs =
        let (ByteString
x, ByteString
y) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_comma) ByteString
bs
         in (ByteString
x, Int -> ByteString -> ByteString
S.drop Int
1 ByteString
y)