{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

-- | HTTP over TLS support for Warp via the TLS package.
--
--   If HTTP\/2 is negotiated by ALPN, HTTP\/2 over TLS is used.
--   Otherwise HTTP\/1.1 over TLS is used.
--
--   Support for SSL is now obsoleted.
module Network.Wai.Handler.WarpTLS (
    -- * Runner
    runTLS,
    runTLSSocket,

    -- * Settings
    TLSSettings,
    defaultTlsSettings,

    -- * Smart constructors

    -- ** From files
    tlsSettings,
    tlsSettingsChain,

    -- ** From memory
    tlsSettingsMemory,
    tlsSettingsChainMemory,

    -- ** From references
    tlsSettingsRef,
    tlsSettingsChainRef,
    CertSettings,

    -- ** Dynamically retrieved
    tlsSettingsSni,

    -- * Accessors
    tlsCredentials,
    tlsLogging,
    tlsAllowedVersions,
    tlsCiphers,
    tlsWantClientCert,
    tlsServerHooks,
    tlsServerDHEParams,
    tlsSessionManagerConfig,
    tlsSessionManager,
    onInsecure,
    OnInsecure (..),

    -- * Exception
    WarpTLSException (..),

    -- * Low-level
    attachConn
) where

import Control.Applicative ((<|>))
import Control.Exception (
    Exception,
    IOException,
    SomeException (..),
    bracket,
    finally,
    fromException,
    handle,
    handleJust,
    onException,
    throwIO,
    try,
 )
import Control.Monad (guard, void)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.IORef as I
import Data.Streaming.Network (bindPortTCP, safeRecv)
import Data.Typeable (Typeable)
import GHC.IO.Exception (IOErrorType (..))
import Network.Socket (
    SockAddr,
    Socket,
    close,
    getSocketName,
#if MIN_VERSION_network(3,1,1)
    gracefulClose,
#endif
    withSocketsDo,
 )
import qualified Control.Exception as E
import Network.Socket.BufferPool
import Network.Socket.ByteString (sendAll)
import qualified Network.TLS as TLS
import qualified Network.TLS.SessionManager as SM
import Network.Wai (Application)
import Network.Wai.Handler.Warp
import Network.Wai.Handler.Warp.Internal
import Network.Wai.Handler.WarpTLS.Internal
import System.IO.Error (ioeGetErrorType, isEOFError)
import System.Timeout (timeout)

----------------------------------------------------------------

-- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'.
tlsSettings
    :: FilePath
    -- ^ Certificate file
    -> FilePath
    -- ^ Key file
    -> TLSSettings
tlsSettings :: FilePath -> FilePath -> TLSSettings
tlsSettings FilePath
cert FilePath
key =
    TLSSettings
defaultTlsSettings
        { certSettings = CertFromFile cert [] key
        }

-- | A smart constructor for 'TLSSettings' that allows specifying
-- chain certificates based on 'defaultTlsSettings'.
--
-- Since 3.0.3
tlsSettingsChain
    :: FilePath
    -- ^ Certificate file
    -> [FilePath]
    -- ^ Chain certificate files
    -> FilePath
    -- ^ Key file
    -> TLSSettings
tlsSettingsChain :: FilePath -> [FilePath] -> FilePath -> TLSSettings
tlsSettingsChain FilePath
cert [FilePath]
chainCerts FilePath
key =
    TLSSettings
defaultTlsSettings
        { certSettings = CertFromFile cert chainCerts key
        }

-- | A smart constructor for 'TLSSettings', but uses in-memory representations
-- of the certificate and key based on 'defaultTlsSettings'.
--
-- Since 3.0.1
tlsSettingsMemory
    :: S.ByteString
    -- ^ Certificate bytes
    -> S.ByteString
    -- ^ Key bytes
    -> TLSSettings
tlsSettingsMemory :: ByteString -> ByteString -> TLSSettings
tlsSettingsMemory ByteString
cert ByteString
key =
    TLSSettings
defaultTlsSettings
        { certSettings = CertFromMemory cert [] key
        }

-- | A smart constructor for 'TLSSettings', but uses in-memory representations
-- of the certificate and key based on 'defaultTlsSettings'.
--
-- Since 3.0.3
tlsSettingsChainMemory
    :: S.ByteString
    -- ^ Certificate bytes
    -> [S.ByteString]
    -- ^ Chain certificate bytes
    -> S.ByteString
    -- ^ Key bytes
    -> TLSSettings
tlsSettingsChainMemory :: ByteString -> [ByteString] -> ByteString -> TLSSettings
tlsSettingsChainMemory ByteString
cert [ByteString]
chainCerts ByteString
key =
    TLSSettings
defaultTlsSettings
        { certSettings = CertFromMemory cert chainCerts key
        }

-- | Smart constructor for TLS settings that obtains its credentials during
-- Server Name Indication. Can be used to return different credentials
-- depending on the hostname but also to retrieve dynamically updated
-- credentials from an IORef. Credentials can be loaded from PEM-encoded chain
-- and key files using 'TLS.credentialLoadX509'.
--
-- @since 3.4.13
tlsSettingsSni :: (Maybe TLS.HostName -> IO TLS.Credentials) -> TLSSettings
tlsSettingsSni :: (Maybe FilePath -> IO Credentials) -> TLSSettings
tlsSettingsSni Maybe FilePath -> IO Credentials
onServerNameIndicationHook =
  TLSSettings
defaultTlsSettings
    { tlsCredentials = Just (TLS.Credentials [])
    , tlsServerHooks = (tlsServerHooks defaultTlsSettings)
      { TLS.onServerNameIndication =  onServerNameIndicationHook
      }
    }

-- | A smart constructor for 'TLSSettings', but uses references to in-memory
-- representations of the certificate and key based on 'defaultTlsSettings'.
--
-- @since 3.3.0
tlsSettingsRef
    :: I.IORef S.ByteString
    -- ^ Reference to certificate bytes
    -> I.IORef S.ByteString
    -- ^ Reference to key bytes
    -> TLSSettings
tlsSettingsRef :: IORef ByteString -> IORef ByteString -> TLSSettings
tlsSettingsRef IORef ByteString
cert IORef ByteString
key =
    TLSSettings
defaultTlsSettings
        { certSettings = CertFromRef cert [] key
        }

{-# DEPRECATED tlsSettingsRef "This function was added to allow Warp to serve new certificates without restarting, but it has always behaved the same as 'tlsSettingsMemory'. It will be removed in the next major release. To retain existing behavior, swich to 'tlsSettingsMemory'. To dynamically update credentials, see 'tlsSettingsSni'." #-}

-- | A smart constructor for 'TLSSettings', but uses references to in-memory
-- representations of the certificate and key based on 'defaultTlsSettings'.
--
-- @since 3.3.0
tlsSettingsChainRef
    :: I.IORef S.ByteString
    -- ^ Reference to certificate bytes
    -> [I.IORef S.ByteString]
    -- ^ Reference to chain certificate bytes
    -> I.IORef S.ByteString
    -- ^ Reference to key bytes
    -> TLSSettings
tlsSettingsChainRef :: IORef ByteString
-> [IORef ByteString] -> IORef ByteString -> TLSSettings
tlsSettingsChainRef IORef ByteString
cert [IORef ByteString]
chainCerts IORef ByteString
key =
    TLSSettings
defaultTlsSettings
        { certSettings = CertFromRef cert chainCerts key
        }

{-# DEPRECATED tlsSettingsChainRef "This function was added to allow Warp to serve new certificates without restarting, but it has always behaved the same as 'tlsSettingsChainMemory'. It will be removed in the next major release. To retain existing behavior, swich to 'tlsSettingsChainMemory'. To dynamically update credentials, see 'tlsSettingsSni'." #-}

----------------------------------------------------------------

-- | Running 'Application' with 'TLSSettings' and 'Settings'.
runTLS :: TLSSettings -> Settings -> Application -> IO ()
runTLS :: TLSSettings -> Settings -> Application -> IO ()
runTLS TLSSettings
tset Settings
set Application
app =
    IO () -> IO ()
forall a. IO a -> IO a
withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
            (Int -> HostPreference -> IO Socket
bindPortTCP (Settings -> Int
getPort Settings
set) (Settings -> HostPreference
getHost Settings
set))
            Socket -> IO ()
close
            ( \Socket
sock -> do
                Socket -> IO ()
setSocketCloseOnExec Socket
sock
                TLSSettings -> Settings -> Socket -> Application -> IO ()
runTLSSocket TLSSettings
tset Settings
set Socket
sock Application
app
            )

----------------------------------------------------------------

loadCredentials :: TLSSettings -> IO TLS.Credentials
loadCredentials :: TLSSettings -> IO Credentials
loadCredentials TLSSettings{tlsCredentials :: TLSSettings -> Maybe Credentials
tlsCredentials = Just Credentials
creds} = Credentials -> IO Credentials
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Credentials
creds
loadCredentials TLSSettings{Bool
[HashAndSignatureAlgorithm]
[Cipher]
[Version]
Maybe Credentials
Maybe SessionManager
Maybe Config
Maybe DHParams
Logging
ServerHooks
OnInsecure
CertSettings
tlsCredentials :: TLSSettings -> Maybe Credentials
tlsLogging :: TLSSettings -> Logging
tlsAllowedVersions :: TLSSettings -> [Version]
tlsCiphers :: TLSSettings -> [Cipher]
tlsWantClientCert :: TLSSettings -> Bool
tlsServerHooks :: TLSSettings -> ServerHooks
tlsServerDHEParams :: TLSSettings -> Maybe DHParams
tlsSessionManagerConfig :: TLSSettings -> Maybe Config
tlsSessionManager :: TLSSettings -> Maybe SessionManager
onInsecure :: TLSSettings -> OnInsecure
certSettings :: TLSSettings -> CertSettings
certSettings :: CertSettings
onInsecure :: OnInsecure
tlsLogging :: Logging
tlsAllowedVersions :: [Version]
tlsCiphers :: [Cipher]
tlsWantClientCert :: Bool
tlsServerHooks :: ServerHooks
tlsServerDHEParams :: Maybe DHParams
tlsSessionManagerConfig :: Maybe Config
tlsCredentials :: Maybe Credentials
tlsSessionManager :: Maybe SessionManager
tlsSupportedHashSignatures :: [HashAndSignatureAlgorithm]
tlsSupportedHashSignatures :: TLSSettings -> [HashAndSignatureAlgorithm]
..} = case CertSettings
certSettings of
    CertFromFile FilePath
cert [FilePath]
chainFiles FilePath
key -> do
        cred <- (FilePath -> Credential)
-> (Credential -> Credential)
-> Either FilePath Credential
-> Credential
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Credential
forall a. HasCallStack => FilePath -> a
error Credential -> Credential
forall a. a -> a
id (Either FilePath Credential -> Credential)
-> IO (Either FilePath Credential) -> IO Credential
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> [FilePath] -> FilePath -> IO (Either FilePath Credential)
TLS.credentialLoadX509Chain FilePath
cert [FilePath]
chainFiles FilePath
key
        return $ TLS.Credentials [cred]
    CertFromRef IORef ByteString
certRef [IORef ByteString]
chainCertsRef IORef ByteString
keyRef -> do
        cert <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
I.readIORef IORef ByteString
certRef
        chainCerts <- mapM I.readIORef chainCertsRef
        key <- I.readIORef keyRef
        cred <-
            either error return $ TLS.credentialLoadX509ChainFromMemory cert chainCerts key
        return $ TLS.Credentials [cred]
    CertFromMemory ByteString
certMemory [ByteString]
chainCertsMemory ByteString
keyMemory -> do
        cred <-
            (FilePath -> IO Credential)
-> (Credential -> IO Credential)
-> Either FilePath Credential
-> IO Credential
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO Credential
forall a. HasCallStack => FilePath -> a
error Credential -> IO Credential
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath Credential -> IO Credential)
-> Either FilePath Credential -> IO Credential
forall a b. (a -> b) -> a -> b
$
                ByteString
-> [ByteString] -> ByteString -> Either FilePath Credential
TLS.credentialLoadX509ChainFromMemory ByteString
certMemory [ByteString]
chainCertsMemory ByteString
keyMemory
        return $ TLS.Credentials [cred]

getSessionManager :: TLSSettings -> IO TLS.SessionManager
getSessionManager :: TLSSettings -> IO SessionManager
getSessionManager TLSSettings{tlsSessionManager :: TLSSettings -> Maybe SessionManager
tlsSessionManager = Just SessionManager
mgr} = SessionManager -> IO SessionManager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SessionManager
mgr
getSessionManager TLSSettings{Bool
[HashAndSignatureAlgorithm]
[Cipher]
[Version]
Maybe Credentials
Maybe SessionManager
Maybe Config
Maybe DHParams
Logging
ServerHooks
OnInsecure
CertSettings
tlsCredentials :: TLSSettings -> Maybe Credentials
tlsLogging :: TLSSettings -> Logging
tlsAllowedVersions :: TLSSettings -> [Version]
tlsCiphers :: TLSSettings -> [Cipher]
tlsWantClientCert :: TLSSettings -> Bool
tlsServerHooks :: TLSSettings -> ServerHooks
tlsServerDHEParams :: TLSSettings -> Maybe DHParams
tlsSessionManagerConfig :: TLSSettings -> Maybe Config
tlsSessionManager :: TLSSettings -> Maybe SessionManager
onInsecure :: TLSSettings -> OnInsecure
certSettings :: TLSSettings -> CertSettings
tlsSupportedHashSignatures :: TLSSettings -> [HashAndSignatureAlgorithm]
certSettings :: CertSettings
onInsecure :: OnInsecure
tlsLogging :: Logging
tlsAllowedVersions :: [Version]
tlsCiphers :: [Cipher]
tlsWantClientCert :: Bool
tlsServerHooks :: ServerHooks
tlsServerDHEParams :: Maybe DHParams
tlsSessionManagerConfig :: Maybe Config
tlsCredentials :: Maybe Credentials
tlsSessionManager :: Maybe SessionManager
tlsSupportedHashSignatures :: [HashAndSignatureAlgorithm]
..} = case Maybe Config
tlsSessionManagerConfig of
    Maybe Config
Nothing -> SessionManager -> IO SessionManager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SessionManager
TLS.noSessionManager
    Just Config
config -> Config -> IO SessionManager
SM.newSessionManager Config
config

-- | Running 'Application' with 'TLSSettings' and 'Settings' using
--   specified 'Socket'.
runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()
runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()
runTLSSocket TLSSettings
tlsset Settings
set Socket
sock Application
app = do
    Settings -> IO () -> IO ()
settingsInstallShutdownHandler Settings
set (Socket -> IO ()
close Socket
sock)
    credentials <- TLSSettings -> IO Credentials
loadCredentials TLSSettings
tlsset
    mgr <- getSessionManager tlsset
    runTLSSocket' tlsset set credentials mgr sock app

runTLSSocket'
    :: TLSSettings
    -> Settings
    -> TLS.Credentials
    -> TLS.SessionManager
    -> Socket
    -> Application
    -> IO ()
runTLSSocket' :: TLSSettings
-> Settings
-> Credentials
-> SessionManager
-> Socket
-> Application
-> IO ()
runTLSSocket' tlsset :: TLSSettings
tlsset@TLSSettings{Bool
[HashAndSignatureAlgorithm]
[Cipher]
[Version]
Maybe Credentials
Maybe SessionManager
Maybe Config
Maybe DHParams
Logging
ServerHooks
OnInsecure
CertSettings
tlsCredentials :: TLSSettings -> Maybe Credentials
tlsLogging :: TLSSettings -> Logging
tlsAllowedVersions :: TLSSettings -> [Version]
tlsCiphers :: TLSSettings -> [Cipher]
tlsWantClientCert :: TLSSettings -> Bool
tlsServerHooks :: TLSSettings -> ServerHooks
tlsServerDHEParams :: TLSSettings -> Maybe DHParams
tlsSessionManagerConfig :: TLSSettings -> Maybe Config
tlsSessionManager :: TLSSettings -> Maybe SessionManager
onInsecure :: TLSSettings -> OnInsecure
certSettings :: TLSSettings -> CertSettings
tlsSupportedHashSignatures :: TLSSettings -> [HashAndSignatureAlgorithm]
certSettings :: CertSettings
onInsecure :: OnInsecure
tlsLogging :: Logging
tlsAllowedVersions :: [Version]
tlsCiphers :: [Cipher]
tlsWantClientCert :: Bool
tlsServerHooks :: ServerHooks
tlsServerDHEParams :: Maybe DHParams
tlsSessionManagerConfig :: Maybe Config
tlsCredentials :: Maybe Credentials
tlsSessionManager :: Maybe SessionManager
tlsSupportedHashSignatures :: [HashAndSignatureAlgorithm]
..} Settings
set Credentials
credentials SessionManager
mgr Socket
sock =
    Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> IO ()
runSettingsConnectionMakerSecure Settings
set IO (IO (Connection, Transport), SockAddr)
get
  where
    get :: IO (IO (Connection, Transport), SockAddr)
get = TLSSettings
-> Settings
-> Socket
-> ServerParams
-> IO (IO (Connection, Transport), SockAddr)
forall params.
TLSParams params =>
TLSSettings
-> Settings
-> Socket
-> params
-> IO (IO (Connection, Transport), SockAddr)
getter TLSSettings
tlsset Settings
set Socket
sock ServerParams
params
    params :: ServerParams
params =
        ServerParams
TLS.defaultParamsServer
            { TLS.serverWantClientCert = tlsWantClientCert
            , TLS.serverCACertificates = []
            , TLS.serverDHEParams = tlsServerDHEParams
            , TLS.serverHooks = hooks
            , TLS.serverShared = shared
            , TLS.serverSupported = supported
#if MIN_VERSION_tls(1,5,0)
            , TLS.serverEarlyDataSize = 2018
#endif
            }
    -- Adding alpn to user's tlsServerHooks.
    hooks :: ServerHooks
hooks =
        ServerHooks
tlsServerHooks
            { TLS.onALPNClientSuggest =
                TLS.onALPNClientSuggest tlsServerHooks
                    <|> (if settingsHTTP2Enabled set then Just alpn else Nothing)
            }
    shared :: Shared
shared =
        Shared
TLS.defaultShared
            { TLS.sharedCredentials = credentials
            , TLS.sharedSessionManager = mgr
            }
    supported :: Supported
supported =
        Supported
TLS.defaultSupported
            { TLS.supportedVersions = tlsAllowedVersions
            , TLS.supportedCiphers = tlsCiphers
            , TLS.supportedCompressions = [TLS.nullCompression]
            , TLS.supportedSecureRenegotiation = True
            , TLS.supportedClientInitiatedRenegotiation = False
            , TLS.supportedSession = True
            , TLS.supportedFallbackScsv = True
            , TLS.supportedHashSignatures = tlsSupportedHashSignatures
#if MIN_VERSION_tls(1,5,0)
            , TLS.supportedGroups = [TLS.X25519,TLS.P256,TLS.P384]
#endif
            }

alpn :: [S.ByteString] -> IO S.ByteString
alpn :: [ByteString] -> IO ByteString
alpn [ByteString]
xs
    | ByteString
"h2" ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
xs = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"h2"
    | Bool
otherwise = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"http/1.1"

----------------------------------------------------------------

getter
    :: TLS.TLSParams params
    => TLSSettings
    -> Settings
    -> Socket
    -> params
    -> IO (IO (Connection, Transport), SockAddr)
getter :: forall params.
TLSParams params =>
TLSSettings
-> Settings
-> Socket
-> params
-> IO (IO (Connection, Transport), SockAddr)
getter TLSSettings
tlsset set :: Settings
set@Settings{settingsAccept :: Settings -> Socket -> IO (Socket, SockAddr)
settingsAccept = Socket -> IO (Socket, SockAddr)
accept'} Socket
sock params
params = do
    (s, sa) <- Socket -> IO (Socket, SockAddr)
accept' Socket
sock
    setSocketCloseOnExec s
    return (mkConn tlsset set s params, sa)

mkConn
    :: TLS.TLSParams params
    => TLSSettings
    -> Settings
    -> Socket
    -> params
    -> IO (Connection, Transport)
mkConn :: forall params.
TLSParams params =>
TLSSettings
-> Settings -> Socket -> params -> IO (Connection, Transport)
mkConn TLSSettings
tlsset Settings
set Socket
s params
params = do
    let tm :: Int
tm = Settings -> Int
settingsTimeout Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
    mbs <- Int -> IO ByteString -> IO (Maybe ByteString)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
tm IO ByteString
recvFirstBS
    case mbs of
      Maybe ByteString
Nothing -> InvalidRequest -> IO (Connection, Transport)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO InvalidRequest
IncompleteHeaders
      Just ByteString
bs -> ByteString -> IO (Connection, Transport)
switch ByteString
bs
  where
    recvFirstBS :: IO ByteString
recvFirstBS = Socket -> Int -> IO ByteString
safeRecv Socket
s Int
4096 IO ByteString -> IO () -> IO ByteString
forall a b. IO a -> IO b -> IO a
`onException` Socket -> IO ()
close Socket
s
    switch :: ByteString -> IO (Connection, Transport)
switch ByteString
firstBS
        | ByteString -> Bool
S.null ByteString
firstBS = Socket -> IO ()
close Socket
s IO () -> IO (Connection, Transport) -> IO (Connection, Transport)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WarpTLSException -> IO (Connection, Transport)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO WarpTLSException
ClientClosedConnectionPrematurely
        | HasCallStack => ByteString -> Word8
ByteString -> Word8
S.head ByteString
firstBS Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x16 = TLSSettings
-> Settings
-> Socket
-> ByteString
-> params
-> IO (Connection, Transport)
forall params.
TLSParams params =>
TLSSettings
-> Settings
-> Socket
-> ByteString
-> params
-> IO (Connection, Transport)
httpOverTls TLSSettings
tlsset Settings
set Socket
s ByteString
firstBS params
params
        | Bool
otherwise = TLSSettings
-> Settings -> Socket -> ByteString -> IO (Connection, Transport)
plainHTTP TLSSettings
tlsset Settings
set Socket
s ByteString
firstBS

----------------------------------------------------------------

isAsyncException :: Exception e => e -> Bool
isAsyncException :: forall e. Exception e => e -> Bool
isAsyncException e
e =
    case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
E.fromException (e -> SomeException
forall e. Exception e => e -> SomeException
E.toException e
e) of
        Just (E.SomeAsyncException e
_) -> Bool
True
        Maybe SomeAsyncException
Nothing -> Bool
False

throughAsync :: IO a -> SomeException -> IO a
throughAsync :: forall a. IO a -> SomeException -> IO a
throughAsync IO a
action (SomeException e
e)
  | e -> Bool
forall e. Exception e => e -> Bool
isAsyncException e
e = e -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO e
e
  | Bool
otherwise          = IO a
action

httpOverTls
    :: TLS.TLSParams params
    => TLSSettings
    -> Settings
    -> Socket
    -> S.ByteString
    -> params
    -> IO (Connection, Transport)
httpOverTls :: forall params.
TLSParams params =>
TLSSettings
-> Settings
-> Socket
-> ByteString
-> params
-> IO (Connection, Transport)
httpOverTls TLSSettings{Bool
[HashAndSignatureAlgorithm]
[Cipher]
[Version]
Maybe Credentials
Maybe SessionManager
Maybe Config
Maybe DHParams
Logging
ServerHooks
OnInsecure
CertSettings
tlsCredentials :: TLSSettings -> Maybe Credentials
tlsLogging :: TLSSettings -> Logging
tlsAllowedVersions :: TLSSettings -> [Version]
tlsCiphers :: TLSSettings -> [Cipher]
tlsWantClientCert :: TLSSettings -> Bool
tlsServerHooks :: TLSSettings -> ServerHooks
tlsServerDHEParams :: TLSSettings -> Maybe DHParams
tlsSessionManagerConfig :: TLSSettings -> Maybe Config
tlsSessionManager :: TLSSettings -> Maybe SessionManager
onInsecure :: TLSSettings -> OnInsecure
certSettings :: TLSSettings -> CertSettings
tlsSupportedHashSignatures :: TLSSettings -> [HashAndSignatureAlgorithm]
certSettings :: CertSettings
onInsecure :: OnInsecure
tlsLogging :: Logging
tlsAllowedVersions :: [Version]
tlsCiphers :: [Cipher]
tlsWantClientCert :: Bool
tlsServerHooks :: ServerHooks
tlsServerDHEParams :: Maybe DHParams
tlsSessionManagerConfig :: Maybe Config
tlsCredentials :: Maybe Credentials
tlsSessionManager :: Maybe SessionManager
tlsSupportedHashSignatures :: [HashAndSignatureAlgorithm]
..} Settings
set Socket
s ByteString
bs0 params
params =
    IO (Connection, Transport)
makeConn IO (Connection, Transport) -> IO () -> IO (Connection, Transport)
forall a b. IO a -> IO b -> IO a
`onException` Socket -> IO ()
close Socket
s
  where
    makeConn :: IO (Connection, Transport)
makeConn = do
        pool <- Int -> Int -> IO BufferPool
newBufferPool Int
2048 Int
16384
        rawRecvN <- makeRecvN bs0 $ receive s pool
        let recvN = (Int -> IO ByteString) -> Int -> IO ByteString
forall {a} {t}. IsString a => (t -> IO a) -> t -> IO a
wrappedRecvN Int -> IO ByteString
rawRecvN
        ctx <- TLS.contextNew (backend recvN) params
        TLS.contextHookSetLogging ctx tlsLogging
        let tm = Settings -> Int
settingsTimeout Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
        mconn <- timeout tm $ do
            TLS.handshake ctx
            mysa <- getSocketName s
            attachConn mysa ctx
        case mconn of
          Maybe (Connection, Transport)
Nothing -> InvalidRequest -> IO (Connection, Transport)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO InvalidRequest
IncompleteHeaders
          Just (Connection, Transport)
conn -> (Connection, Transport) -> IO (Connection, Transport)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection, Transport)
conn
    wrappedRecvN :: (t -> IO a) -> t -> IO a
wrappedRecvN t -> IO a
recvN t
n = (SomeException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (IO a -> SomeException -> IO a
forall a. IO a -> SomeException -> IO a
throughAsync (a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
"")) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ t -> IO a
recvN t
n
    backend :: (Int -> IO ByteString) -> Backend
backend Int -> IO ByteString
recvN =
        TLS.Backend
            { backendFlush :: IO ()
TLS.backendFlush = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if MIN_VERSION_network(3,1,1)
            , backendClose :: IO ()
TLS.backendClose =
                Socket -> Int -> IO ()
gracefulClose Socket
s Int
5000 IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` IO () -> SomeException -> IO ()
forall a. IO a -> SomeException -> IO a
throughAsync (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
#else
            , TLS.backendClose = close s
#endif
            , backendSend :: ByteString -> IO ()
TLS.backendSend = Socket -> ByteString -> IO ()
sendAll' Socket
s
            , backendRecv :: Int -> IO ByteString
TLS.backendRecv = Int -> IO ByteString
recvN
            }
    sendAll' :: Socket -> ByteString -> IO ()
sendAll' Socket
sock ByteString
bs =
        (IOError -> Maybe InvalidRequest)
-> (InvalidRequest -> IO ()) -> IO () -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
E.handleJust
            ( \IOError
e ->
                if IOError -> IOErrorType
ioeGetErrorType IOError
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
ResourceVanished
                    then InvalidRequest -> Maybe InvalidRequest
forall a. a -> Maybe a
Just InvalidRequest
ConnectionClosedByPeer
                    else Maybe InvalidRequest
forall a. Maybe a
Nothing
            )
            InvalidRequest -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO
            (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO ()
sendAll Socket
sock ByteString
bs

-- | Get "Connection" and "Transport" for a TLS connection that is already did the handshake.
-- @since 3.4.7
attachConn :: SockAddr -> TLS.Context -> IO (Connection, Transport)
attachConn :: SockAddr -> Context -> IO (Connection, Transport)
attachConn SockAddr
mysa Context
ctx = do
    h2 <- (Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"h2") (Maybe ByteString -> Bool) -> IO (Maybe ByteString) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO (Maybe ByteString)
forall (m :: * -> *). MonadIO m => Context -> m (Maybe ByteString)
TLS.getNegotiatedProtocol Context
ctx
    isH2 <- I.newIORef h2
    writeBuffer <- createWriteBuffer 16384
    writeBufferRef <- I.newIORef writeBuffer
    -- Creating a cache for leftover input data.
    tls <- getTLSinfo ctx
    return (conn writeBufferRef isH2, tls)
  where
    conn :: IORef WriteBuffer -> IORef Bool -> Connection
conn IORef WriteBuffer
writeBufferRef IORef Bool
isH2 =
        Connection
            { connSendMany :: [ByteString] -> IO ()
connSendMany = Context -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
TLS.sendData Context
ctx (ByteString -> IO ())
-> ([ByteString] -> ByteString) -> [ByteString] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
L.fromChunks
            , connSendAll :: ByteString -> IO ()
connSendAll = ByteString -> IO ()
sendall
            , connSendFile :: SendFile
connSendFile = SendFile
sendfile
            , connClose :: IO ()
connClose = IO ()
close'
            , connRecv :: IO ByteString
connRecv = IO ByteString
recv
            , connRecvBuf :: RecvBuf
connRecvBuf = \Buffer
_ Int
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- obsoleted
            , connWriteBuffer :: IORef WriteBuffer
connWriteBuffer = IORef WriteBuffer
writeBufferRef
            , connHTTP2 :: IORef Bool
connHTTP2 = IORef Bool
isH2
            , connMySockAddr :: SockAddr
connMySockAddr = SockAddr
mysa
            }
      where
        sendall :: ByteString -> IO ()
sendall = Context -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
TLS.sendData Context
ctx (ByteString -> IO ())
-> (ByteString -> ByteString) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return
        recv :: IO ByteString
recv = (SomeException -> IO ByteString) -> IO ByteString -> IO ByteString
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ByteString
onEOF (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
TLS.recvData Context
ctx
          where
            onEOF :: SomeException -> IO ByteString
onEOF SomeException
e
#if MIN_VERSION_tls(1,8,0)
                | Just (TLS.PostHandshake TLSError
TLS.Error_EOF) <- SomeException -> Maybe TLSException
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty
#else
                | Just TLS.Error_EOF <- fromException e = return S.empty
#endif
                | Just IOError
ioe <- SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e, IOError -> Bool
isEOFError IOError
ioe = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty
                | Bool
otherwise = SomeException -> IO ByteString
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
        sendfile :: SendFile
sendfile FileId
fid Integer
offset Integer
len IO ()
hook [ByteString]
headers = do
            writeBuffer <- IORef WriteBuffer -> IO WriteBuffer
forall a. IORef a -> IO a
I.readIORef IORef WriteBuffer
writeBufferRef
            readSendFile
                (bufBuffer writeBuffer)
                (bufSize writeBuffer)
                sendall
                fid
                offset
                len
                hook
                headers

        close' :: IO ()
close' =
            IO (Either IOError ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO (Either IOError ())
forall a. IO a -> IO (Either IOError a)
tryIO IO ()
sendBye)
                IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Context -> IO ()
TLS.contextClose Context
ctx

        sendBye :: IO ()
sendBye =
            -- It's fine if the connection was closed by the other side before
            -- receiving close_notify, see RFC 5246 section 7.2.1.
            (InvalidRequest -> Maybe InvalidRequest)
-> (InvalidRequest -> IO ()) -> IO () -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust
                (\InvalidRequest
e -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (InvalidRequest
e InvalidRequest -> InvalidRequest -> Bool
forall a. Eq a => a -> a -> Bool
== InvalidRequest
ConnectionClosedByPeer) Maybe () -> Maybe InvalidRequest -> Maybe InvalidRequest
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InvalidRequest -> Maybe InvalidRequest
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return InvalidRequest
e)
                (IO () -> InvalidRequest -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
                (Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.bye Context
ctx)

getTLSinfo :: TLS.Context -> IO Transport
getTLSinfo :: Context -> IO Transport
getTLSinfo Context
ctx = do
    proto <- Context -> IO (Maybe ByteString)
forall (m :: * -> *). MonadIO m => Context -> m (Maybe ByteString)
TLS.getNegotiatedProtocol Context
ctx
    minfo <- TLS.contextGetInformation ctx
    case minfo of
        Maybe Information
Nothing -> Transport -> IO Transport
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Transport
TCP
        Just Information
info -> do
            let (Int
major, Int
minor) = case Information -> Version
TLS.infoVersion Information
info of
                    Version
TLS.SSL2 -> (Int
2, Int
0)
                    Version
TLS.SSL3 -> (Int
3, Int
0)
                    Version
TLS.TLS10 -> (Int
3, Int
1)
                    Version
TLS.TLS11 -> (Int
3, Int
2)
                    Version
TLS.TLS12 -> (Int
3, Int
3)
                    Version
_ -> (Int
3,Int
4)
            clientCert <- Context -> IO (Maybe CertificateChain)
TLS.getClientCertificateChain Context
ctx
            return
                TLS
                    { tlsMajorVersion = major
                    , tlsMinorVersion = minor
                    , tlsNegotiatedProtocol = proto
                    , tlsChiperID = TLS.cipherID $ TLS.infoCipher info
                    , tlsClientCertificate = clientCert
                    }

tryIO :: IO a -> IO (Either IOException a)
tryIO :: forall a. IO a -> IO (Either IOError a)
tryIO = IO a -> IO (Either IOError a)
forall e a. Exception e => IO a -> IO (Either e a)
try

----------------------------------------------------------------

plainHTTP
    :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)
plainHTTP :: TLSSettings
-> Settings -> Socket -> ByteString -> IO (Connection, Transport)
plainHTTP TLSSettings{Bool
[HashAndSignatureAlgorithm]
[Cipher]
[Version]
Maybe Credentials
Maybe SessionManager
Maybe Config
Maybe DHParams
Logging
ServerHooks
OnInsecure
CertSettings
tlsCredentials :: TLSSettings -> Maybe Credentials
tlsLogging :: TLSSettings -> Logging
tlsAllowedVersions :: TLSSettings -> [Version]
tlsCiphers :: TLSSettings -> [Cipher]
tlsWantClientCert :: TLSSettings -> Bool
tlsServerHooks :: TLSSettings -> ServerHooks
tlsServerDHEParams :: TLSSettings -> Maybe DHParams
tlsSessionManagerConfig :: TLSSettings -> Maybe Config
tlsSessionManager :: TLSSettings -> Maybe SessionManager
onInsecure :: TLSSettings -> OnInsecure
certSettings :: TLSSettings -> CertSettings
tlsSupportedHashSignatures :: TLSSettings -> [HashAndSignatureAlgorithm]
certSettings :: CertSettings
onInsecure :: OnInsecure
tlsLogging :: Logging
tlsAllowedVersions :: [Version]
tlsCiphers :: [Cipher]
tlsWantClientCert :: Bool
tlsServerHooks :: ServerHooks
tlsServerDHEParams :: Maybe DHParams
tlsSessionManagerConfig :: Maybe Config
tlsCredentials :: Maybe Credentials
tlsSessionManager :: Maybe SessionManager
tlsSupportedHashSignatures :: [HashAndSignatureAlgorithm]
..} Settings
set Socket
s ByteString
bs0 = case OnInsecure
onInsecure of
    OnInsecure
AllowInsecure -> do
        conn' <- Settings -> Socket -> IO Connection
socketConnection Settings
set Socket
s
        cachedRef <- I.newIORef bs0
        let conn'' =
                Connection
conn'
                    { connRecv = recvPlain cachedRef (connRecv conn')
                    }
        return (conn'', TCP)
    DenyInsecure ByteString
lbs -> do
        -- Listening port 443 but TLS records do not arrive.
        -- We want to let the browser know that TLS is required.
        -- So, we use 426.
        --     http://tools.ietf.org/html/rfc2817#section-4.2
        --     https://tools.ietf.org/html/rfc7231#section-6.5.15
        -- FIXME: should we distinguish HTTP/1.1 and HTTP/2?
        --        In the case of HTTP/2, should we send
        --        GOAWAY + INADEQUATE_SECURITY?
        -- FIXME: Content-Length:
        -- FIXME: TLS/<version>
        Socket -> ByteString -> IO ()
sendAll
            Socket
s
            "HTTP/1.1 426 Upgrade Required\
            \\r\nUpgrade: TLS/1.0, HTTP/1.1\
            \\r\nConnection: Upgrade\
            \\r\nContent-Type: text/plain\r\n\r\n"
        (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Socket -> ByteString -> IO ()
sendAll Socket
s) ([ByteString] -> IO ()) -> [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
lbs
        Socket -> IO ()
close Socket
s
        WarpTLSException -> IO (Connection, Transport)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO WarpTLSException
InsecureConnectionDenied

----------------------------------------------------------------

-- | Modify the given receive function to first check the given @IORef@ for a
-- chunk of data. If present, takes the chunk of data from the @IORef@ and
-- empties out the @IORef@. Otherwise, calls the supplied receive function.
recvPlain :: I.IORef S.ByteString -> IO S.ByteString -> IO S.ByteString
recvPlain :: IORef ByteString -> IO ByteString -> IO ByteString
recvPlain IORef ByteString
ref IO ByteString
fallback = do
    bs <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
I.readIORef IORef ByteString
ref
    if S.null bs
        then fallback
        else do
            I.writeIORef ref S.empty
            return bs

----------------------------------------------------------------

data WarpTLSException
    = InsecureConnectionDenied
    | ClientClosedConnectionPrematurely
    deriving (Int -> WarpTLSException -> ShowS
[WarpTLSException] -> ShowS
WarpTLSException -> FilePath
(Int -> WarpTLSException -> ShowS)
-> (WarpTLSException -> FilePath)
-> ([WarpTLSException] -> ShowS)
-> Show WarpTLSException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WarpTLSException -> ShowS
showsPrec :: Int -> WarpTLSException -> ShowS
$cshow :: WarpTLSException -> FilePath
show :: WarpTLSException -> FilePath
$cshowList :: [WarpTLSException] -> ShowS
showList :: [WarpTLSException] -> ShowS
Show, Typeable)
instance Exception WarpTLSException