{-# 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 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 -> [Char] -> Int -> IO Connection)
managerTlsConnection = Maybe ConnectionContext
-> Maybe TLSSettings
-> Maybe SockSettings
-> IO (Maybe HostAddress -> [Char] -> Int -> IO Connection)
getTlsConnection Maybe ConnectionContext
mcontext (forall a. a -> Maybe a
Just TLSSettings
tls) Maybe SockSettings
sockHTTPS
    , managerTlsProxyConnection :: IO
  (ByteString
   -> (Connection -> IO ())
   -> [Char]
   -> Maybe HostAddress
   -> [Char]
   -> Int
   -> IO Connection)
managerTlsProxyConnection = Maybe ConnectionContext
-> TLSSettings
-> Maybe SockSettings
-> IO
     (ByteString
      -> (Connection -> IO ())
      -> [Char]
      -> Maybe HostAddress
      -> [Char]
      -> Int
      -> IO Connection)
getTlsProxyConnection Maybe ConnectionContext
mcontext TLSSettings
tls Maybe SockSettings
sockHTTPS
    , managerRawConnection :: IO (Maybe HostAddress -> [Char] -> Int -> IO Connection)
managerRawConnection =
        case Maybe SockSettings
sockHTTP of
            Maybe SockSettings
Nothing -> ManagerSettings
-> IO (Maybe HostAddress -> [Char] -> Int -> IO Connection)
managerRawConnection ManagerSettings
defaultManagerSettings
            Just SockSettings
_ -> Maybe ConnectionContext
-> Maybe TLSSettings
-> Maybe SockSettings
-> IO (Maybe HostAddress -> [Char] -> Int -> IO Connection)
getTlsConnection Maybe ConnectionContext
mcontext forall a. Maybe a
Nothing Maybe SockSettings
sockHTTP
    , managerRetryableException :: SomeException -> Bool
managerRetryableException = \SomeException
e ->
        case () of
            ()
                | ((forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e)::(Maybe TLS.TLSError))forall a. Eq a => a -> a -> Bool
==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)          <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
              | Just (TLSException
_ :: TLS.TLSException)     <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
              | Just (TLSError
_ :: TLS.TLSError)         <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
              | Just (LineTooLong
_ :: NC.LineTooLong)       <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
              | Just (HostNotResolved
_ :: NC.HostNotResolved)   <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
              | Just (HostCannotConnect
_ :: NC.HostCannotConnect) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
              | Bool
otherwise = SomeException
se
              where
                se' :: SomeException
se' = forall e. Exception e => e -> SomeException
toException forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HttpExceptionRequest Request
req forall a b. (a -> b) -> a -> b
$ SomeException -> HttpExceptionContent
InternalException SomeException
se
         in forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO 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 forall a. Default a => a
def 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 -> [Char] -> Int -> IO Connection)
getTlsConnection Maybe ConnectionContext
mcontext Maybe TLSSettings
tls Maybe SockSettings
sock = do
    ConnectionContext
context <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ConnectionContext
NC.initConnectionContext forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ConnectionContext
mcontext
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Maybe HostAddress
_ha [Char]
host Int
port -> forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (ConnectionContext -> ConnectionParams -> IO Connection
NC.connectTo ConnectionContext
context NC.ConnectionParams
            { connectionHostname :: [Char]
NC.connectionHostname = [Char] -> [Char]
strippedHostName [Char]
host
            , connectionPort :: PortNumber
NC.connectionPort = 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 ())
      -> [Char]
      -> Maybe HostAddress
      -> [Char]
      -> Int
      -> IO Connection)
getTlsProxyConnection Maybe ConnectionContext
mcontext TLSSettings
tls Maybe SockSettings
sock = do
    ConnectionContext
context <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ConnectionContext
NC.initConnectionContext forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ConnectionContext
mcontext
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ByteString
connstr Connection -> IO ()
checkConn [Char]
serverName Maybe HostAddress
_ha [Char]
host Int
port -> forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (ConnectionContext -> ConnectionParams -> IO Connection
NC.connectTo ConnectionContext
context NC.ConnectionParams
            { connectionHostname :: [Char]
NC.connectionHostname = [Char] -> [Char]
strippedHostName [Char]
serverName
            , connectionPort :: PortNumber
NC.connectionPort = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port
            , connectionUseSecure :: Maybe TLSSettings
NC.connectionUseSecure = forall a. Maybe a
Nothing
            , connectionUseSocks :: Maybe SockSettings
NC.connectionUseSocks =
                case Maybe SockSettings
sock of
                    Just SockSettings
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use SOCKS and TLS proxying together"
                    Maybe SockSettings
Nothing -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> PortNumber -> SockSettings
NC.OtherProxy ([Char] -> [Char]
strippedHostName [Char]
host) forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port
            })
        Connection -> IO ()
NC.connectionClose
        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

            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 forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Control.Exception.catch` \(IOException
_ :: IOException) -> 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 = 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 :: forall (m :: * -> *). MonadIO m => m Manager
newTlsManager = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    [([Char], [Char])]
env <- IO [([Char], [Char])]
getEnvironment
    let lenv :: Map Text [Char]
lenv = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack) [([Char], [Char])]
env
        msocksHTTP :: Maybe SockSettings
msocksHTTP = [([Char], [Char])] -> Map Text [Char] -> Text -> Maybe SockSettings
parseSocksSettings [([Char], [Char])]
env Map Text [Char]
lenv Text
"http_proxy"
        msocksHTTPS :: Maybe SockSettings
msocksHTTPS = [([Char], [Char])] -> Map Text [Char] -> Text -> Maybe SockSettings
parseSocksSettings [([Char], [Char])]
env Map Text [Char]
lenv Text
"https_proxy"
        settings :: ManagerSettings
settings = ManagerSettings
-> Maybe ConnectionContext
-> TLSSettings
-> Maybe SockSettings
-> Maybe SockSettings
-> ManagerSettings
mkManagerSettingsContext' ManagerSettings
defaultManagerSettings (forall a. a -> Maybe a
Just ConnectionContext
globalConnectionContext) forall a. Default a => a
def Maybe SockSettings
msocksHTTP Maybe SockSettings
msocksHTTPS
        settings' :: ManagerSettings
settings' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetInsecureProxy ProxyOverride
proxyFromRequest) Maybe SockSettings
msocksHTTP
                  forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b. a -> b -> a
const 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 :: forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
newTlsManagerWith ManagerSettings
set = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    [([Char], [Char])]
env <- IO [([Char], [Char])]
getEnvironment
    let lenv :: Map Text [Char]
lenv = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack) [([Char], [Char])]
env
        msocksHTTP :: Maybe SockSettings
msocksHTTP = [([Char], [Char])] -> Map Text [Char] -> Text -> Maybe SockSettings
parseSocksSettings [([Char], [Char])]
env Map Text [Char]
lenv Text
"http_proxy"
        msocksHTTPS :: Maybe SockSettings
msocksHTTPS = [([Char], [Char])] -> Map Text [Char] -> Text -> Maybe SockSettings
parseSocksSettings [([Char], [Char])]
env Map Text [Char]
lenv Text
"https_proxy"
        settings :: ManagerSettings
settings = ManagerSettings
-> Maybe ConnectionContext
-> TLSSettings
-> Maybe SockSettings
-> Maybe SockSettings
-> ManagerSettings
mkManagerSettingsContext' ManagerSettings
set (forall a. a -> Maybe a
Just ConnectionContext
globalConnectionContext) forall a. Default a => a
def Maybe SockSettings
msocksHTTP Maybe SockSettings
msocksHTTPS
        settings' :: ManagerSettings
settings' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetInsecureProxy ProxyOverride
proxyFromRequest) Maybe SockSettings
msocksHTTP
                  forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b. a -> b -> a
const 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 -> [Char] -> Int -> IO Connection)
managerTlsConnection = ManagerSettings
-> IO (Maybe HostAddress -> [Char] -> Int -> IO Connection)
managerTlsConnection ManagerSettings
set
                        , managerTlsProxyConnection :: IO
  (ByteString
   -> (Connection -> IO ())
   -> [Char]
   -> Maybe HostAddress
   -> [Char]
   -> Int
   -> IO Connection)
managerTlsProxyConnection = ManagerSettings
-> IO
     (ByteString
      -> (Connection -> IO ())
      -> [Char]
      -> Maybe HostAddress
      -> [Char]
      -> 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 :: [([Char], [Char])] -> Map Text [Char] -> Text -> Maybe SockSettings
parseSocksSettings [([Char], [Char])]
env Map Text [Char]
lenv Text
n = do
  [Char]
str <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> [Char]
T.unpack Text
n) [([Char], [Char])]
env forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
n Map Text [Char]
lenv
  let allowedScheme :: a -> Bool
allowedScheme a
x = a
x forall a. Eq a => a -> a -> Bool
== a
"socks5:" Bool -> Bool -> Bool
|| a
x forall a. Eq a => a -> a -> Bool
== a
"socks5h:"
  URI
uri <- [Char] -> Maybe URI
U.parseURI [Char]
str

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

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

  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> PortNumber -> SockSettings
NC.SockSettingsSimple (URIAuth -> [Char]
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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => m Manager
newTlsManager forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = 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 = 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 -> [Char] -> [Char]
[DigestAuthException] -> [Char] -> [Char]
DigestAuthException -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [DigestAuthException] -> [Char] -> [Char]
$cshowList :: [DigestAuthException] -> [Char] -> [Char]
show :: DigestAuthException -> [Char]
$cshow :: DigestAuthException -> [Char]
showsPrec :: Int -> DigestAuthException -> [Char] -> [Char]
$cshowsPrec :: Int -> DigestAuthException -> [Char] -> [Char]
Show, Typeable)
instance Exception DigestAuthException where
#if MIN_VERSION_base(4, 8, 0)
    displayException :: DigestAuthException -> [Char]
displayException = DigestAuthException -> [Char]
displayDigestAuthException
#endif

-- | User friendly display of a 'DigestAuthException'
--
-- @since 0.3.3
displayDigestAuthException :: DigestAuthException -> String
displayDigestAuthException :: DigestAuthException -> [Char]
displayDigestAuthException (DigestAuthException Request
req Response ()
res DigestAuthExceptionDetails
det) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"Unable to submit digest credentials due to: "
    , [Char]
details
    , [Char]
".\n\nRequest: "
    , forall a. Show a => a -> [Char]
show Request
req
    , [Char]
".\n\nResponse: "
    , forall a. Show a => a -> [Char]
show Response ()
res
    ]
  where
    details :: [Char]
details =
        case DigestAuthExceptionDetails
det of
            DigestAuthExceptionDetails
UnexpectedStatusCode -> [Char]
"received unexpected status code"
            DigestAuthExceptionDetails
MissingWWWAuthenticateHeader ->
                [Char]
"missing WWW-Authenticate response header"
            DigestAuthExceptionDetails
WWWAuthenticateIsNotDigest ->
                [Char]
"WWW-Authenticate response header does not indicate Digest"
            DigestAuthExceptionDetails
MissingRealm ->
                [Char]
"WWW-Authenticate response header does include realm"
            DigestAuthExceptionDetails
MissingNonce ->
                [Char]
"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 -> [Char] -> [Char]
[DigestAuthExceptionDetails] -> [Char] -> [Char]
DigestAuthExceptionDetails -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [DigestAuthExceptionDetails] -> [Char] -> [Char]
$cshowList :: [DigestAuthExceptionDetails] -> [Char] -> [Char]
show :: DigestAuthExceptionDetails -> [Char]
$cshow :: DigestAuthExceptionDetails -> [Char]
showsPrec :: Int -> DigestAuthExceptionDetails -> [Char] -> [Char]
$cshowsPrec :: Int -> DigestAuthExceptionDetails -> [Char] -> [Char]
Show, ReadPrec [DigestAuthExceptionDetails]
ReadPrec DigestAuthExceptionDetails
Int -> ReadS DigestAuthExceptionDetails
ReadS [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
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
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
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 :: forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadThrow n) =>
ByteString -> ByteString -> Request -> Manager -> m (n Request)
applyDigestAuth ByteString
user ByteString
pass Request
req0 Manager
man = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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' = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request
-> Response () -> DigestAuthExceptionDetails -> DigestAuthException
DigestAuthException Request
req Response ()
res
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall body. Response body -> Status
responseStatus Response ()
res forall a. Eq a => a -> a -> Bool
== Status
status401)
            forall a b. (a -> b) -> a -> b
$ forall {a}. DigestAuthExceptionDetails -> n a
throw' DigestAuthExceptionDetails
UnexpectedStatusCode
        ByteString
h1 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {a}. DigestAuthExceptionDetails -> n a
throw' DigestAuthExceptionDetails
MissingWWWAuthenticateHeader) forall (m :: * -> *) a. Monad m => a -> m a
return
            forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"WWW-Authenticate" forall a b. (a -> b) -> a -> b
$ forall body. Response body -> ResponseHeaders
responseHeaders Response ()
res
        ByteString
h2 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {a}. DigestAuthExceptionDetails -> n a
throw' DigestAuthExceptionDetails
WWWAuthenticateIsNotDigest) forall (m :: * -> *) a. Monad m => a -> m a
return
            forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Maybe ByteString
stripCI ByteString
"Digest " ByteString
h1
        let pieces :: [(ByteString, ByteString)]
pieces = forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString
strip 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 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {a}. DigestAuthExceptionDetails -> n a
throw' DigestAuthExceptionDetails
MissingRealm) forall (m :: * -> *) a. Monad m => a -> m a
return
               forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"realm" [(ByteString, ByteString)]
pieces
        ByteString
nonce <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {a}. DigestAuthExceptionDetails -> n a
throw' DigestAuthExceptionDetails
MissingNonce) forall (m :: * -> *) a. Monad m => a -> m a
return
               forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"nonce" [(ByteString, ByteString)]
pieces
        let qop :: Bool
qop = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"qop" [(ByteString, ByteString)]
pieces
            digest :: ByteString
digest
                | Bool
qop = forall {bout} {ba}.
(ByteArray bout, ByteArrayAccess ba) =>
ba -> bout
md5 forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat
                    [ ByteString
ha1
                    , ByteString
":"
                    , ByteString
nonce
                    , ByteString
":00000001:deadbeef:auth:"
                    , ByteString
ha2
                    ]
                | Bool
otherwise = forall {bout} {ba}.
(ByteArray bout, ByteArrayAccess ba) =>
ba -> bout
md5 forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat [ByteString
ha1, ByteString
":", ByteString
nonce, ByteString
":", ByteString
ha2]
              where
                ha1 :: ByteString
ha1 = forall {bout} {ba}.
(ByteArray bout, ByteArrayAccess ba) =>
ba -> bout
md5 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 = forall {bout} {ba}.
(ByteArray bout, ByteArrayAccess ba) =>
ba -> bout
md5 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 = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16 (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 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
""
                ]
        forall (m :: * -> *) a. Monad m => a -> m a
return Request
req
            { requestHeaders :: ResponseHeaders
requestHeaders = (HeaderName
key, ByteString
val)
                             forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter
                                    (\(HeaderName
x, ByteString
_) -> HeaderName
x forall a. Eq a => a -> a -> Bool
/= HeaderName
key)
                                    (Request -> ResponseHeaders
requestHeaders Request
req)
            , cookieJar :: Maybe CookieJar
cookieJar = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return () }

    stripCI :: ByteString -> ByteString -> Maybe ByteString
stripCI ByteString
x ByteString
y
        | forall s. FoldCase s => s -> CI s
CI.mk ByteString
x forall a. Eq a => a -> a -> Bool
== forall s. FoldCase s => s -> CI s
CI.mk (Int -> ByteString -> ByteString
S.take Int
len ByteString
y) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
len ByteString
y
        | Bool
otherwise = 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 = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.spanEnd (forall a. Eq a => a -> a -> Bool
== Word8
_space) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (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 (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 forall a. Eq a => a -> a -> Bool
== Word8
_equal Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
_comma) ByteString
bs1
             in case () of
                  ()
                    | ByteString -> Bool
S.null ByteString
bs2 -> [(ByteString
key, ByteString
"")]
                    | HasCallStack => ByteString -> Word8
S.head ByteString
bs2 forall a. Eq a => a -> a -> Bool
== Word8
_equal ->
                        let (ByteString
val, ByteString
rest) = ByteString -> (ByteString, ByteString)
parseVal forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
S.tail ByteString
bs2
                         in (ByteString
key, ByteString
val) forall a. a -> [a] -> [a]
: ByteString -> [(ByteString, ByteString)]
toPairs ByteString
rest
                    | Bool
otherwise ->
                        forall a. HasCallStack => Bool -> a -> a
assert (HasCallStack => ByteString -> Word8
S.head ByteString
bs2 forall a. Eq a => a -> a -> Bool
== Word8
_comma) forall a b. (a -> b) -> a -> b
$
                        (ByteString
key, ByteString
"") forall a. a -> [a] -> [a]
: ByteString -> [(ByteString, ByteString)]
toPairs (HasCallStack => ByteString -> ByteString
S.tail ByteString
bs2)

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