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

-- | 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
    -- * Accessors
    , tlsCredentials
    , tlsLogging
    , tlsAllowedVersions
    , tlsCiphers
    , tlsWantClientCert
    , tlsServerHooks
    , tlsServerDHEParams
    , tlsSessionManagerConfig
    , tlsSessionManager
    , onInsecure
    , OnInsecure (..)
    -- * Exception
    , WarpTLSException (..)
    -- * DH parameters (re-exports)
    --
    -- | This custom DH parameters are not necessary anymore because
    --   pre-defined DH parameters are supported in the TLS package.
    , DH.Params
    , DH.generateParams
    ) where

import Control.Applicative ((<|>))
import UnliftIO.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException, SomeException(..), handleJust)
import qualified UnliftIO.Exception as E
import Control.Monad (void, guard)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Default.Class (def)
import qualified Data.IORef as I
import Data.Streaming.Network (bindPortTCP, safeRecv)
import Data.Typeable (Typeable)
import GHC.IO.Exception (IOErrorType(..))
import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)
#if MIN_VERSION_network(3,1,1)
import Network.Socket (gracefulClose)
#endif
import Network.Socket.ByteString (sendAll)
import qualified Network.TLS as TLS
import qualified Crypto.PubKey.DH as DH
import qualified Network.TLS.Extra as TLSExtra
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(CertSettings(..), TLSSettings(..), OnInsecure(..))
import System.IO.Error (isEOFError, ioeGetErrorType)

-- | The default 'CertSettings'.
defaultCertSettings :: CertSettings
defaultCertSettings :: CertSettings
defaultCertSettings = FilePath -> [FilePath] -> FilePath -> CertSettings
CertFromFile FilePath
"certificate.pem" [] FilePath
"key.pem"

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

-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors).
defaultTlsSettings :: TLSSettings
defaultTlsSettings :: TLSSettings
defaultTlsSettings = TLSSettings :: CertSettings
-> OnInsecure
-> Logging
-> [Version]
-> [Cipher]
-> Bool
-> ServerHooks
-> Maybe Params
-> Maybe Config
-> Maybe Credentials
-> Maybe SessionManager
-> TLSSettings
TLSSettings {
    certSettings :: CertSettings
certSettings = CertSettings
defaultCertSettings
  , onInsecure :: OnInsecure
onInsecure = ByteString -> OnInsecure
DenyInsecure ByteString
"This server only accepts secure HTTPS connections."
  , tlsLogging :: Logging
tlsLogging = Logging
forall a. Default a => a
def
#if MIN_VERSION_tls(1,5,0)
  , tlsAllowedVersions :: [Version]
tlsAllowedVersions = [Version
TLS.TLS13,Version
TLS.TLS12,Version
TLS.TLS11,Version
TLS.TLS10]
#else
  , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]
#endif
  , tlsCiphers :: [Cipher]
tlsCiphers = [Cipher]
ciphers
  , tlsWantClientCert :: Bool
tlsWantClientCert = Bool
False
  , tlsServerHooks :: ServerHooks
tlsServerHooks = ServerHooks
forall a. Default a => a
def
  , tlsServerDHEParams :: Maybe Params
tlsServerDHEParams = Maybe Params
forall a. Maybe a
Nothing
  , tlsSessionManagerConfig :: Maybe Config
tlsSessionManagerConfig = Maybe Config
forall a. Maybe a
Nothing
  , tlsCredentials :: Maybe Credentials
tlsCredentials = Maybe Credentials
forall a. Maybe a
Nothing
  , tlsSessionManager :: Maybe SessionManager
tlsSessionManager = Maybe SessionManager
forall a. Maybe a
Nothing
  }

-- taken from stunnel example in tls-extra
ciphers :: [TLS.Cipher]
ciphers :: [Cipher]
ciphers = [Cipher]
TLSExtra.ciphersuite_strong

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

-- | 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 :: CertSettings
certSettings = FilePath -> [FilePath] -> FilePath -> CertSettings
CertFromFile FilePath
cert [] FilePath
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 :: CertSettings
certSettings = FilePath -> [FilePath] -> FilePath -> CertSettings
CertFromFile FilePath
cert [FilePath]
chainCerts FilePath
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 :: CertSettings
certSettings = ByteString -> [ByteString] -> ByteString -> CertSettings
CertFromMemory ByteString
cert [] ByteString
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 :: CertSettings
certSettings = ByteString -> [ByteString] -> ByteString -> CertSettings
CertFromMemory ByteString
cert [ByteString]
chainCerts ByteString
key
  }

-- | 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 :: CertSettings
certSettings = IORef ByteString
-> [IORef ByteString] -> IORef ByteString -> CertSettings
CertFromRef IORef ByteString
cert [] IORef ByteString
key
  }

-- | 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 :: CertSettings
certSettings = IORef ByteString
-> [IORef ByteString] -> IORef ByteString -> CertSettings
CertFromRef IORef ByteString
cert [IORef ByteString]
chainCerts IORef ByteString
key
  }

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

-- | 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 (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
        (Int -> HostPreference -> IO Socket
bindPortTCP (Settings -> Int
getPort Settings
set) (Settings -> HostPreference
getHost Settings
set))
        Socket -> IO ()
close
        (\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 (m :: * -> *) a. Monad m => a -> m a
return Credentials
creds
loadCredentials TLSSettings{Bool
[Cipher]
[Version]
Maybe Params
Maybe Credentials
Maybe SessionManager
Maybe Config
ServerHooks
Logging
OnInsecure
CertSettings
tlsSessionManager :: Maybe SessionManager
tlsCredentials :: Maybe Credentials
tlsSessionManagerConfig :: Maybe Config
tlsServerDHEParams :: Maybe Params
tlsServerHooks :: ServerHooks
tlsWantClientCert :: Bool
tlsCiphers :: [Cipher]
tlsAllowedVersions :: [Version]
tlsLogging :: Logging
onInsecure :: OnInsecure
certSettings :: CertSettings
certSettings :: TLSSettings -> CertSettings
onInsecure :: TLSSettings -> OnInsecure
tlsSessionManager :: TLSSettings -> Maybe SessionManager
tlsSessionManagerConfig :: TLSSettings -> Maybe Config
tlsServerDHEParams :: TLSSettings -> Maybe Params
tlsServerHooks :: TLSSettings -> ServerHooks
tlsWantClientCert :: TLSSettings -> Bool
tlsCiphers :: TLSSettings -> [Cipher]
tlsAllowedVersions :: TLSSettings -> [Version]
tlsLogging :: TLSSettings -> Logging
tlsCredentials :: TLSSettings -> Maybe Credentials
..} = case CertSettings
certSettings of 
  CertFromFile FilePath
cert [FilePath]
chainFiles FilePath
key -> do
    Credential
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
    Credentials -> IO Credentials
forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials -> IO Credentials) -> Credentials -> IO Credentials
forall a b. (a -> b) -> a -> b
$ [Credential] -> Credentials
TLS.Credentials [Credential
cred]
  CertFromRef IORef ByteString
certRef [IORef ByteString]
chainCertsRef IORef ByteString
keyRef -> do 
    ByteString
cert <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
I.readIORef IORef ByteString
certRef
    [ByteString]
chainCerts <- (IORef ByteString -> IO ByteString)
-> [IORef ByteString] -> IO [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
I.readIORef [IORef ByteString]
chainCertsRef
    ByteString
key <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
I.readIORef IORef ByteString
keyRef
    Credential
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 (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
cert [ByteString]
chainCerts ByteString
key
    Credentials -> IO Credentials
forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials -> IO Credentials) -> Credentials -> IO Credentials
forall a b. (a -> b) -> a -> b
$ [Credential] -> Credentials
TLS.Credentials [Credential
cred]
  CertFromMemory ByteString
certMemory [ByteString]
chainCertsMemory ByteString
keyMemory -> do
    Credential
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 (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
    Credentials -> IO Credentials
forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials -> IO Credentials) -> Credentials -> IO Credentials
forall a b. (a -> b) -> a -> b
$ [Credential] -> Credentials
TLS.Credentials [Credential
cred]

getSessionManager :: TLSSettings -> IO TLS.SessionManager
getSessionManager :: TLSSettings -> IO SessionManager
getSessionManager TLSSettings{ tlsSessionManager :: TLSSettings -> Maybe SessionManager
tlsSessionManager = Just SessionManager
mgr } = SessionManager -> IO SessionManager
forall (m :: * -> *) a. Monad m => a -> m a
return SessionManager
mgr
getSessionManager TLSSettings{Bool
[Cipher]
[Version]
Maybe Params
Maybe Credentials
Maybe SessionManager
Maybe Config
ServerHooks
Logging
OnInsecure
CertSettings
tlsSessionManager :: Maybe SessionManager
tlsCredentials :: Maybe Credentials
tlsSessionManagerConfig :: Maybe Config
tlsServerDHEParams :: Maybe Params
tlsServerHooks :: ServerHooks
tlsWantClientCert :: Bool
tlsCiphers :: [Cipher]
tlsAllowedVersions :: [Version]
tlsLogging :: Logging
onInsecure :: OnInsecure
certSettings :: CertSettings
certSettings :: TLSSettings -> CertSettings
onInsecure :: TLSSettings -> OnInsecure
tlsSessionManager :: TLSSettings -> Maybe SessionManager
tlsSessionManagerConfig :: TLSSettings -> Maybe Config
tlsServerDHEParams :: TLSSettings -> Maybe Params
tlsServerHooks :: TLSSettings -> ServerHooks
tlsWantClientCert :: TLSSettings -> Bool
tlsCiphers :: TLSSettings -> [Cipher]
tlsAllowedVersions :: TLSSettings -> [Version]
tlsLogging :: TLSSettings -> Logging
tlsCredentials :: TLSSettings -> Maybe Credentials
..} = case Maybe Config
tlsSessionManagerConfig of
      Maybe Config
Nothing     -> SessionManager -> IO SessionManager
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
    Credentials
credentials <- TLSSettings -> IO Credentials
loadCredentials TLSSettings
tlsset
    SessionManager
mgr <- TLSSettings -> IO SessionManager
getSessionManager TLSSettings
tlsset
    TLSSettings
-> Settings
-> Credentials
-> SessionManager
-> Socket
-> Application
-> IO ()
runTLSSocket' TLSSettings
tlsset Settings
set Credentials
credentials SessionManager
mgr Socket
sock Application
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
[Cipher]
[Version]
Maybe Params
Maybe Credentials
Maybe SessionManager
Maybe Config
ServerHooks
Logging
OnInsecure
CertSettings
tlsSessionManager :: Maybe SessionManager
tlsCredentials :: Maybe Credentials
tlsSessionManagerConfig :: Maybe Config
tlsServerDHEParams :: Maybe Params
tlsServerHooks :: ServerHooks
tlsWantClientCert :: Bool
tlsCiphers :: [Cipher]
tlsAllowedVersions :: [Version]
tlsLogging :: Logging
onInsecure :: OnInsecure
certSettings :: CertSettings
certSettings :: TLSSettings -> CertSettings
onInsecure :: TLSSettings -> OnInsecure
tlsSessionManager :: TLSSettings -> Maybe SessionManager
tlsSessionManagerConfig :: TLSSettings -> Maybe Config
tlsServerDHEParams :: TLSSettings -> Maybe Params
tlsServerHooks :: TLSSettings -> ServerHooks
tlsWantClientCert :: TLSSettings -> Bool
tlsCiphers :: TLSSettings -> [Cipher]
tlsAllowedVersions :: TLSSettings -> [Version]
tlsLogging :: TLSSettings -> Logging
tlsCredentials :: TLSSettings -> Maybe Credentials
..} Settings
set Credentials
credentials SessionManager
mgr Socket
sock Application
app =
    Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> IO ()
runSettingsConnectionMakerSecure Settings
set IO (IO (Connection, Transport), SockAddr)
get Application
app
  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
forall a. Default a => a
def { -- TLS.ServerParams
        serverWantClientCert :: Bool
TLS.serverWantClientCert = Bool
tlsWantClientCert
      , serverCACertificates :: [SignedCertificate]
TLS.serverCACertificates = []
      , serverDHEParams :: Maybe Params
TLS.serverDHEParams      = Maybe Params
tlsServerDHEParams
      , serverHooks :: ServerHooks
TLS.serverHooks          = ServerHooks
hooks
      , serverShared :: Shared
TLS.serverShared         = Shared
shared
      , serverSupported :: Supported
TLS.serverSupported      = Supported
supported
#if MIN_VERSION_tls(1,5,0)
      , serverEarlyDataSize :: Int
TLS.serverEarlyDataSize  = Int
2018
#endif
      }
    -- Adding alpn to user's tlsServerHooks.
    hooks :: ServerHooks
hooks = ServerHooks
tlsServerHooks {
        onALPNClientSuggest :: Maybe ([ByteString] -> IO ByteString)
TLS.onALPNClientSuggest = ServerHooks -> Maybe ([ByteString] -> IO ByteString)
TLS.onALPNClientSuggest ServerHooks
tlsServerHooks Maybe ([ByteString] -> IO ByteString)
-> Maybe ([ByteString] -> IO ByteString)
-> Maybe ([ByteString] -> IO ByteString)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          (if Settings -> Bool
settingsHTTP2Enabled Settings
set then ([ByteString] -> IO ByteString)
-> Maybe ([ByteString] -> IO ByteString)
forall a. a -> Maybe a
Just [ByteString] -> IO ByteString
alpn else Maybe ([ByteString] -> IO ByteString)
forall a. Maybe a
Nothing)
      }
    shared :: Shared
shared = Shared
forall a. Default a => a
def {
        sharedCredentials :: Credentials
TLS.sharedCredentials    = Credentials
credentials
      , sharedSessionManager :: SessionManager
TLS.sharedSessionManager = SessionManager
mgr
      }
    supported :: Supported
supported = Supported
forall a. Default a => a
def { -- TLS.Supported
        supportedVersions :: [Version]
TLS.supportedVersions       = [Version]
tlsAllowedVersions
      , supportedCiphers :: [Cipher]
TLS.supportedCiphers        = [Cipher]
tlsCiphers
      , supportedCompressions :: [Compression]
TLS.supportedCompressions   = [Compression
TLS.nullCompression]
      , supportedSecureRenegotiation :: Bool
TLS.supportedSecureRenegotiation = Bool
True
      , supportedClientInitiatedRenegotiation :: Bool
TLS.supportedClientInitiatedRenegotiation = Bool
False
      , supportedSession :: Bool
TLS.supportedSession             = Bool
True
      , supportedFallbackScsv :: Bool
TLS.supportedFallbackScsv        = Bool
True
#if MIN_VERSION_tls(1,5,0)
      , supportedGroups :: [Group]
TLS.supportedGroups              = [Group
TLS.X25519,Group
TLS.P256,Group
TLS.P384]
#endif
      }

alpn :: [S.ByteString] -> IO S.ByteString
alpn :: [ByteString] -> IO ByteString
alpn [ByteString]
xs
  | ByteString
"h2"    ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
xs = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"h2"
  | Bool
otherwise         = ByteString -> IO ByteString
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 :: TLSSettings
-> Settings
-> Socket
-> params
-> IO (IO (Connection, Transport), SockAddr)
getter TLSSettings
tlsset Settings
set Socket
sock params
params = do
#if WINDOWS
    (s, sa) <- windowsThreadBlockHack $ accept sock
#else
    (Socket
s, SockAddr
sa) <- Socket -> IO (Socket, SockAddr)
accept Socket
sock
#endif
    Socket -> IO ()
setSocketCloseOnExec Socket
s
    (IO (Connection, Transport), SockAddr)
-> IO (IO (Connection, Transport), SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (TLSSettings
-> Settings -> Socket -> params -> IO (Connection, Transport)
forall params.
TLSParams params =>
TLSSettings
-> Settings -> Socket -> params -> IO (Connection, Transport)
mkConn TLSSettings
tlsset Settings
set Socket
s params
params, SockAddr
sa)

mkConn :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (Connection, Transport)
mkConn :: TLSSettings
-> Settings -> Socket -> params -> IO (Connection, Transport)
mkConn TLSSettings
tlsset Settings
set Socket
s params
params = (Socket -> Int -> IO ByteString
safeRecv Socket
s Int
4096 IO ByteString
-> (ByteString -> IO (Connection, Transport))
-> IO (Connection, Transport)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO (Connection, Transport)
switch) IO (Connection, Transport) -> IO () -> IO (Connection, Transport)
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException` Socket -> IO ()
close Socket
s
  where
    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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WarpTLSException -> IO (Connection, Transport)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO WarpTLSException
ClientClosedConnectionPrematurely
        | 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

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

httpOverTls :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)
httpOverTls :: TLSSettings
-> Settings
-> Socket
-> ByteString
-> params
-> IO (Connection, Transport)
httpOverTls TLSSettings{Bool
[Cipher]
[Version]
Maybe Params
Maybe Credentials
Maybe SessionManager
Maybe Config
ServerHooks
Logging
OnInsecure
CertSettings
tlsSessionManager :: Maybe SessionManager
tlsCredentials :: Maybe Credentials
tlsSessionManagerConfig :: Maybe Config
tlsServerDHEParams :: Maybe Params
tlsServerHooks :: ServerHooks
tlsWantClientCert :: Bool
tlsCiphers :: [Cipher]
tlsAllowedVersions :: [Version]
tlsLogging :: Logging
onInsecure :: OnInsecure
certSettings :: CertSettings
certSettings :: TLSSettings -> CertSettings
onInsecure :: TLSSettings -> OnInsecure
tlsSessionManager :: TLSSettings -> Maybe SessionManager
tlsSessionManagerConfig :: TLSSettings -> Maybe Config
tlsServerDHEParams :: TLSSettings -> Maybe Params
tlsServerHooks :: TLSSettings -> ServerHooks
tlsWantClientCert :: TLSSettings -> Bool
tlsCiphers :: TLSSettings -> [Cipher]
tlsAllowedVersions :: TLSSettings -> [Version]
tlsLogging :: TLSSettings -> Logging
tlsCredentials :: TLSSettings -> Maybe Credentials
..} Settings
_set Socket
s ByteString
bs0 params
params = do
    Int -> IO ByteString
recvN <- Socket -> ByteString -> IO (Int -> IO ByteString)
makePlainReceiveN Socket
s ByteString
bs0
    Context
ctx <- Backend -> params -> IO Context
forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
TLS.contextNew ((Int -> IO ByteString) -> Backend
backend Int -> IO ByteString
recvN) params
params
    Context -> Logging -> IO ()
TLS.contextHookSetLogging Context
ctx Logging
tlsLogging
    Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.handshake Context
ctx
    Bool
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
    IORef Bool
isH2 <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
I.newIORef Bool
h2
    Buffer
writeBuf <- Int -> IO Buffer
allocateBuffer Int
bufferSize
    -- Creating a cache for leftover input data.
    IORef ByteString
ref <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
I.newIORef ByteString
""
    Transport
tls <- Context -> IO Transport
getTLSinfo Context
ctx
    (Connection, Transport) -> IO (Connection, Transport)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Buffer -> IORef ByteString -> IORef Bool -> Connection
conn Context
ctx Buffer
writeBuf IORef ByteString
ref IORef Bool
isH2, Transport
tls)
  where
    backend :: (Int -> IO ByteString) -> Backend
backend Int -> IO ByteString
recvN = Backend :: IO ()
-> IO ()
-> (ByteString -> IO ())
-> (Int -> IO ByteString)
-> Backend
TLS.Backend {
        backendFlush :: IO ()
TLS.backendFlush = () -> IO ()
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 (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \(SomeException e
_) -> () -> IO ()
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 (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m 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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO
      (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO ()
sendAll Socket
sock ByteString
bs
    conn :: Context -> Buffer -> IORef ByteString -> IORef Bool -> Connection
conn Context
ctx Buffer
writeBuf IORef ByteString
ref IORef Bool
isH2 = Connection :: ([ByteString] -> IO ())
-> (ByteString -> IO ())
-> SendFile
-> IO ()
-> IO ()
-> IO ByteString
-> RecvBuf
-> Buffer
-> Int
-> IORef Bool
-> Connection
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'
      , connFree :: IO ()
connFree             = Buffer -> IO ()
freeBuffer Buffer
writeBuf
      , connRecv :: IO ByteString
connRecv             = IORef ByteString -> IO ByteString
recv IORef ByteString
ref
      , connRecvBuf :: RecvBuf
connRecvBuf          = IORef ByteString -> RecvBuf
recvBuf IORef ByteString
ref
      , connWriteBuffer :: Buffer
connWriteBuffer      = Buffer
writeBuf
      , connBufferSize :: Int
connBufferSize       = Int
bufferSize
      , connHTTP2 :: IORef Bool
connHTTP2            = IORef Bool
isH2
      }
      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 (m :: * -> *) a. Monad m => a -> m a
return
        sendfile :: SendFile
sendfile FileId
fid Integer
offset Integer
len IO ()
hook [ByteString]
headers =
            Buffer -> Int -> (ByteString -> IO ()) -> SendFile
readSendFile Buffer
writeBuf Int
bufferSize ByteString -> IO ()
sendall FileId
fid Integer
offset Integer
len IO ()
hook [ByteString]
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 (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m 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 (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InvalidRequest -> Maybe InvalidRequest
forall (m :: * -> *) a. Monad m => a -> m a
return InvalidRequest
e)
            (IO () -> InvalidRequest -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
            (Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.bye Context
ctx)

        -- TLS version of recv with a cache for leftover input data.
        -- The cache is shared with recvBuf.
        recv :: IORef ByteString -> IO ByteString
recv IORef ByteString
cref = do
            ByteString
cached <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
I.readIORef IORef ByteString
cref
            if ByteString
cached ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"" then do
                IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef ByteString
cref ByteString
""
                ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
cached
              else
                IO ByteString
recv'

        -- TLS version of recv (decrypting) without a cache.
        recv' :: IO ByteString
recv' = (SomeException -> IO ByteString) -> IO ByteString -> IO ByteString
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle SomeException -> IO ByteString
forall (m :: * -> *). MonadIO m => SomeException -> m ByteString
onEOF IO ByteString
go
          where
            onEOF :: SomeException -> m ByteString
onEOF SomeException
e
              | Just TLSError
TLS.Error_EOF <- SomeException -> Maybe TLSError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e       = ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty
              | Just IOError
ioe <- SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e, IOError -> Bool
isEOFError IOError
ioe = ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty                  | Bool
otherwise                                   = SomeException -> m ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e
            go :: IO ByteString
go = do
                ByteString
x <- Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
TLS.recvData Context
ctx
                if ByteString -> Bool
S.null ByteString
x then
                    IO ByteString
go
                  else
                    ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x

        -- TLS version of recvBuf with a cache for leftover input data.
        recvBuf :: IORef ByteString -> RecvBuf
recvBuf IORef ByteString
cref Buffer
buf Int
siz = do
            ByteString
cached <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
I.readIORef IORef ByteString
cref
            (Bool
ret, ByteString
leftover) <- ByteString
-> Buffer -> Int -> IO ByteString -> IO (Bool, ByteString)
fill ByteString
cached Buffer
buf Int
siz IO ByteString
recv'
            IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef ByteString
cref ByteString
leftover
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ret

fill :: S.ByteString -> Buffer -> BufSize -> Recv -> IO (Bool,S.ByteString)
fill :: ByteString
-> Buffer -> Int -> IO ByteString -> IO (Bool, ByteString)
fill ByteString
bs0 Buffer
buf0 Int
siz0 IO ByteString
recv
  | Int
siz0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len0 = do
      let (ByteString
bs, ByteString
leftover) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt Int
siz0 ByteString
bs0
      IO Buffer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Buffer -> IO ()) -> IO Buffer -> IO ()
forall a b. (a -> b) -> a -> b
$ Buffer -> ByteString -> IO Buffer
copy Buffer
buf0 ByteString
bs
      (Bool, ByteString) -> IO (Bool, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, ByteString
leftover)
  | Bool
otherwise = do
      Buffer
buf <- Buffer -> ByteString -> IO Buffer
copy Buffer
buf0 ByteString
bs0
      Buffer -> Int -> IO (Bool, ByteString)
loop Buffer
buf (Int
siz0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len0)
  where
    len0 :: Int
len0 = ByteString -> Int
S.length ByteString
bs0
    loop :: Buffer -> Int -> IO (Bool, ByteString)
loop Buffer
_   Int
0   = (Bool, ByteString) -> IO (Bool, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, ByteString
"")
    loop Buffer
buf Int
siz = do
      ByteString
bs <- IO ByteString
recv
      let len :: Int
len = ByteString -> Int
S.length ByteString
bs
      if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then (Bool, ByteString) -> IO (Bool, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, ByteString
"")
        else if (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
siz) then do
          Buffer
buf' <- Buffer -> ByteString -> IO Buffer
copy Buffer
buf ByteString
bs
          Buffer -> Int -> IO (Bool, ByteString)
loop Buffer
buf' (Int
siz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len)
        else do
          let (ByteString
bs1,ByteString
bs2) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt Int
siz ByteString
bs
          IO Buffer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Buffer -> IO ()) -> IO Buffer -> IO ()
forall a b. (a -> b) -> a -> b
$ Buffer -> ByteString -> IO Buffer
copy Buffer
buf ByteString
bs1
          (Bool, ByteString) -> IO (Bool, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, ByteString
bs2)

getTLSinfo :: TLS.Context -> IO Transport
getTLSinfo :: Context -> IO Transport
getTLSinfo Context
ctx = do
    Maybe ByteString
proto <- Context -> IO (Maybe ByteString)
forall (m :: * -> *). MonadIO m => Context -> m (Maybe ByteString)
TLS.getNegotiatedProtocol Context
ctx
    Maybe Information
minfo <- Context -> IO (Maybe Information)
TLS.contextGetInformation Context
ctx
    case Maybe Information
minfo of
        Maybe Information
Nothing   -> Transport -> IO Transport
forall (m :: * -> *) a. Monad m => a -> m a
return Transport
TCP
        Just TLS.Information{Bool
Maybe ByteString
Maybe HandshakeMode13
Maybe ServerRandom
Maybe ClientRandom
Maybe Group
Cipher
Compression
Version
infoVersion :: Information -> Version
infoCipher :: Information -> Cipher
infoCompression :: Information -> Compression
infoMasterSecret :: Information -> Maybe ByteString
infoExtendedMasterSec :: Information -> Bool
infoClientRandom :: Information -> Maybe ClientRandom
infoServerRandom :: Information -> Maybe ServerRandom
infoNegotiatedGroup :: Information -> Maybe Group
infoTLS13HandshakeMode :: Information -> Maybe HandshakeMode13
infoIsEarlyDataAccepted :: Information -> Bool
infoIsEarlyDataAccepted :: Bool
infoTLS13HandshakeMode :: Maybe HandshakeMode13
infoNegotiatedGroup :: Maybe Group
infoServerRandom :: Maybe ServerRandom
infoClientRandom :: Maybe ClientRandom
infoExtendedMasterSec :: Bool
infoMasterSecret :: Maybe ByteString
infoCompression :: Compression
infoCipher :: Cipher
infoVersion :: Version
..} -> do
            let (Int
major, Int
minor) = case Version
infoVersion 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)
#if MIN_VERSION_tls(1,5,0)
                    Version
TLS.TLS13 -> (Int
3,Int
4)
#endif
            Maybe CertificateChain
clientCert <- Context -> IO (Maybe CertificateChain)
TLS.getClientCertificateChain Context
ctx
            Transport -> IO Transport
forall (m :: * -> *) a. Monad m => a -> m a
return TLS :: Int
-> Int
-> Maybe ByteString
-> Word16
-> Maybe CertificateChain
-> Transport
TLS {
                tlsMajorVersion :: Int
tlsMajorVersion = Int
major
              , tlsMinorVersion :: Int
tlsMinorVersion = Int
minor
              , tlsNegotiatedProtocol :: Maybe ByteString
tlsNegotiatedProtocol = Maybe ByteString
proto
              , tlsChiperID :: Word16
tlsChiperID = Cipher -> Word16
TLS.cipherID Cipher
infoCipher
              , tlsClientCertificate :: Maybe CertificateChain
tlsClientCertificate = Maybe CertificateChain
clientCert
              }

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

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

plainHTTP :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)
plainHTTP :: TLSSettings
-> Settings -> Socket -> ByteString -> IO (Connection, Transport)
plainHTTP TLSSettings{Bool
[Cipher]
[Version]
Maybe Params
Maybe Credentials
Maybe SessionManager
Maybe Config
ServerHooks
Logging
OnInsecure
CertSettings
tlsSessionManager :: Maybe SessionManager
tlsCredentials :: Maybe Credentials
tlsSessionManagerConfig :: Maybe Config
tlsServerDHEParams :: Maybe Params
tlsServerHooks :: ServerHooks
tlsWantClientCert :: Bool
tlsCiphers :: [Cipher]
tlsAllowedVersions :: [Version]
tlsLogging :: Logging
onInsecure :: OnInsecure
certSettings :: CertSettings
certSettings :: TLSSettings -> CertSettings
onInsecure :: TLSSettings -> OnInsecure
tlsSessionManager :: TLSSettings -> Maybe SessionManager
tlsSessionManagerConfig :: TLSSettings -> Maybe Config
tlsServerDHEParams :: TLSSettings -> Maybe Params
tlsServerHooks :: TLSSettings -> ServerHooks
tlsWantClientCert :: TLSSettings -> Bool
tlsCiphers :: TLSSettings -> [Cipher]
tlsAllowedVersions :: TLSSettings -> [Version]
tlsLogging :: TLSSettings -> Logging
tlsCredentials :: TLSSettings -> Maybe Credentials
..} Settings
set Socket
s ByteString
bs0 = case OnInsecure
onInsecure of
    OnInsecure
AllowInsecure -> do
        Connection
conn' <- Settings -> Socket -> IO Connection
socketConnection Settings
set Socket
s
        IORef ByteString
cachedRef <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
I.newIORef ByteString
bs0
        let conn'' :: Connection
conn'' = Connection
conn'
                { connRecv :: IO ByteString
connRecv = IORef ByteString -> IO ByteString -> IO ByteString
recvPlain IORef ByteString
cachedRef (Connection -> IO ByteString
connRecv Connection
conn')
                }
        (Connection, Transport) -> IO (Connection, Transport)
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection
conn'', Transport
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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m 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
    ByteString
bs <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
I.readIORef IORef ByteString
ref
    if ByteString -> Bool
S.null ByteString
bs
        then IO ByteString
fallback
        else do
            IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef ByteString
ref ByteString
S.empty
            ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
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
showList :: [WarpTLSException] -> ShowS
$cshowList :: [WarpTLSException] -> ShowS
show :: WarpTLSException -> FilePath
$cshow :: WarpTLSException -> FilePath
showsPrec :: Int -> WarpTLSException -> ShowS
$cshowsPrec :: Int -> WarpTLSException -> ShowS
Show, Typeable)
instance Exception WarpTLSException