{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PatternGuards #-}
module Network.Wai.Handler.WarpTLS (
runTLS
, runTLSSocket
, TLSSettings
, defaultTlsSettings
, tlsSettings
, tlsSettingsChain
, tlsSettingsMemory
, tlsSettingsChainMemory
, tlsSettingsRef
, tlsSettingsChainRef
, CertSettings
, tlsCredentials
, tlsLogging
, tlsAllowedVersions
, tlsCiphers
, tlsWantClientCert
, tlsServerHooks
, tlsServerDHEParams
, tlsSessionManagerConfig
, tlsSessionManager
, onInsecure
, OnInsecure (..)
, WarpTLSException (..)
, DH.Params
, DH.generateParams
) where
import Control.Applicative ((<|>))
import UnliftIO.Exception (Exception, throwIO, bracket, finally, handle, handleAny, 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 (
SockAddr,
Socket,
close,
#if MIN_VERSION_network(3,1,1)
gracefulClose,
#endif
withSocketsDo,
)
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)
defaultCertSettings :: CertSettings
defaultCertSettings :: CertSettings
defaultCertSettings = FilePath -> [FilePath] -> FilePath -> CertSettings
CertFromFile FilePath
"certificate.pem" [] FilePath
"key.pem"
defaultTlsSettings :: TLSSettings
defaultTlsSettings :: TLSSettings
defaultTlsSettings = TLSSettings {
certSettings :: CertSettings
certSettings = CertSettings
defaultCertSettings
, onInsecure :: OnInsecure
onInsecure = ByteString -> OnInsecure
DenyInsecure ByteString
"This server only accepts secure HTTPS connections."
, tlsLogging :: Logging
tlsLogging = 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 = forall a. Default a => a
def
, tlsServerDHEParams :: Maybe Params
tlsServerDHEParams = forall a. Maybe a
Nothing
, tlsSessionManagerConfig :: Maybe Config
tlsSessionManagerConfig = forall a. Maybe a
Nothing
, tlsCredentials :: Maybe Credentials
tlsCredentials = forall a. Maybe a
Nothing
, tlsSessionManager :: Maybe SessionManager
tlsSessionManager = forall a. Maybe a
Nothing
, tlsSupportedHashSignatures :: [HashAndSignatureAlgorithm]
tlsSupportedHashSignatures = Supported -> [HashAndSignatureAlgorithm]
TLS.supportedHashSignatures forall a. Default a => a
def
}
ciphers :: [TLS.Cipher]
ciphers :: [Cipher]
ciphers = [Cipher]
TLSExtra.ciphersuite_strong
tlsSettings :: FilePath
-> FilePath
-> TLSSettings
tlsSettings :: FilePath -> FilePath -> TLSSettings
tlsSettings FilePath
cert FilePath
key = TLSSettings
defaultTlsSettings {
certSettings :: CertSettings
certSettings = FilePath -> [FilePath] -> FilePath -> CertSettings
CertFromFile FilePath
cert [] FilePath
key
}
tlsSettingsChain
:: FilePath
-> [FilePath]
-> FilePath
-> 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
}
tlsSettingsMemory
:: S.ByteString
-> S.ByteString
-> TLSSettings
tlsSettingsMemory :: ByteString -> ByteString -> TLSSettings
tlsSettingsMemory ByteString
cert ByteString
key = TLSSettings
defaultTlsSettings {
certSettings :: CertSettings
certSettings = ByteString -> [ByteString] -> ByteString -> CertSettings
CertFromMemory ByteString
cert [] ByteString
key
}
tlsSettingsChainMemory
:: S.ByteString
-> [S.ByteString]
-> S.ByteString
-> 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
}
tlsSettingsRef
:: I.IORef S.ByteString
-> I.IORef S.ByteString
-> 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
}
tlsSettingsChainRef
:: I.IORef S.ByteString
-> [I.IORef S.ByteString]
-> I.IORef S.ByteString
-> 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
}
runTLS :: TLSSettings -> Settings -> Application -> IO ()
runTLS :: TLSSettings -> Settings -> Application -> IO ()
runTLS TLSSettings
tset Settings
set Application
app = forall a. IO a -> IO a
withSocketsDo forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(BufSize -> HostPreference -> IO Socket
bindPortTCP (Settings -> BufSize
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 } = forall (m :: * -> *) a. Monad m => a -> m a
return Credentials
creds
loadCredentials TLSSettings{Bool
[HashAndSignatureAlgorithm]
[Cipher]
[Version]
Maybe Params
Maybe Credentials
Maybe SessionManager
Maybe Config
ServerHooks
Logging
OnInsecure
CertSettings
tlsSupportedHashSignatures :: [HashAndSignatureAlgorithm]
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
tlsSupportedHashSignatures :: TLSSettings -> [HashAndSignatureAlgorithm]
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 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => FilePath -> a
error forall a. a -> a
id 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall a. IORef a -> IO a
I.readIORef IORef ByteString
certRef
[ByteString]
chainCerts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. IORef a -> IO a
I.readIORef [IORef ByteString]
chainCertsRef
ByteString
key <- forall a. IORef a -> IO a
I.readIORef IORef ByteString
keyRef
Credential
cred <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => FilePath -> a
error forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString
-> [ByteString] -> ByteString -> Either FilePath Credential
TLS.credentialLoadX509ChainFromMemory ByteString
cert [ByteString]
chainCerts ByteString
key
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Credential] -> Credentials
TLS.Credentials [Credential
cred]
CertFromMemory ByteString
certMemory [ByteString]
chainCertsMemory ByteString
keyMemory -> do
Credential
cred <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => FilePath -> a
error forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString
-> [ByteString] -> ByteString -> Either FilePath Credential
TLS.credentialLoadX509ChainFromMemory ByteString
certMemory [ByteString]
chainCertsMemory ByteString
keyMemory
forall (m :: * -> *) a. Monad m => a -> m a
return 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 } = forall (m :: * -> *) a. Monad m => a -> m a
return SessionManager
mgr
getSessionManager TLSSettings{Bool
[HashAndSignatureAlgorithm]
[Cipher]
[Version]
Maybe Params
Maybe Credentials
Maybe SessionManager
Maybe Config
ServerHooks
Logging
OnInsecure
CertSettings
tlsSupportedHashSignatures :: [HashAndSignatureAlgorithm]
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
tlsSupportedHashSignatures :: TLSSettings -> [HashAndSignatureAlgorithm]
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return SessionManager
TLS.noSessionManager
Just Config
config -> Config -> IO SessionManager
SM.newSessionManager Config
config
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
[HashAndSignatureAlgorithm]
[Cipher]
[Version]
Maybe Params
Maybe Credentials
Maybe SessionManager
Maybe Config
ServerHooks
Logging
OnInsecure
CertSettings
tlsSupportedHashSignatures :: [HashAndSignatureAlgorithm]
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
tlsSupportedHashSignatures :: TLSSettings -> [HashAndSignatureAlgorithm]
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 =
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 = 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 = forall a. Default a => a
def {
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 :: BufSize
TLS.serverEarlyDataSize = BufSize
2018
#endif
}
hooks :: ServerHooks
hooks = ServerHooks
tlsServerHooks {
onALPNClientSuggest :: Maybe ([ByteString] -> IO ByteString)
TLS.onALPNClientSuggest = ServerHooks -> Maybe ([ByteString] -> IO ByteString)
TLS.onALPNClientSuggest ServerHooks
tlsServerHooks forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(if Settings -> Bool
settingsHTTP2Enabled Settings
set then forall a. a -> Maybe a
Just [ByteString] -> IO ByteString
alpn else forall a. Maybe a
Nothing)
}
shared :: Shared
shared = forall a. Default a => a
def {
sharedCredentials :: Credentials
TLS.sharedCredentials = Credentials
credentials
, sharedSessionManager :: SessionManager
TLS.sharedSessionManager = SessionManager
mgr
}
supported :: Supported
supported = forall a. Default a => a
def {
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
, supportedHashSignatures :: [HashAndSignatureAlgorithm]
TLS.supportedHashSignatures = [HashAndSignatureAlgorithm]
tlsSupportedHashSignatures
#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" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
xs = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"h2"
| Bool
otherwise = 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
(Socket
s, SockAddr
sa) <- Socket -> IO (Socket, SockAddr)
accept' Socket
sock
Socket -> IO ()
setSocketCloseOnExec Socket
s
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: forall params.
TLSParams params =>
TLSSettings
-> Settings -> Socket -> params -> IO (Connection, Transport)
mkConn TLSSettings
tlsset Settings
set Socket
s params
params = (Socket -> BufSize -> IO ByteString
safeRecv Socket
s BufSize
4096 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO (Connection, Transport)
switch) 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO WarpTLSException
ClientClosedConnectionPrematurely
| HasCallStack => ByteString -> Word8
S.head ByteString
firstBS forall a. Eq a => a -> a -> Bool
== Word8
0x16 = 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 :: forall params.
TLSParams params =>
TLSSettings
-> Settings
-> Socket
-> ByteString
-> params
-> IO (Connection, Transport)
httpOverTls TLSSettings{Bool
[HashAndSignatureAlgorithm]
[Cipher]
[Version]
Maybe Params
Maybe Credentials
Maybe SessionManager
Maybe Config
ServerHooks
Logging
OnInsecure
CertSettings
tlsSupportedHashSignatures :: [HashAndSignatureAlgorithm]
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
tlsSupportedHashSignatures :: TLSSettings -> [HashAndSignatureAlgorithm]
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
BufSize -> IO ByteString
rawRecvN <- Socket
-> BufSize
-> BufSize
-> ByteString
-> IO (BufSize -> IO ByteString)
makePlainReceiveN Socket
s BufSize
2048 BufSize
16384 ByteString
bs0
let recvN :: BufSize -> IO ByteString
recvN = forall {t}. (t -> IO ByteString) -> t -> IO ByteString
wrappedRecvN BufSize -> IO ByteString
rawRecvN
Context
ctx <- forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
TLS.contextNew ((BufSize -> IO ByteString) -> Backend
backend BufSize -> IO ByteString
recvN) params
params
Context -> Logging -> IO ()
TLS.contextHookSetLogging Context
ctx Logging
tlsLogging
forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.handshake Context
ctx
Bool
h2 <- (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
"h2") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Context -> m (Maybe ByteString)
TLS.getNegotiatedProtocol Context
ctx
IORef Bool
isH2 <- forall a. a -> IO (IORef a)
I.newIORef Bool
h2
WriteBuffer
writeBuffer <- BufSize -> IO WriteBuffer
createWriteBuffer BufSize
16384
IORef WriteBuffer
writeBufferRef <- forall a. a -> IO (IORef a)
I.newIORef WriteBuffer
writeBuffer
IORef ByteString
ref <- forall a. a -> IO (IORef a)
I.newIORef ByteString
""
Transport
tls <- Context -> IO Transport
getTLSinfo Context
ctx
forall (m :: * -> *) a. Monad m => a -> m a
return (Context
-> IORef WriteBuffer
-> IORef ByteString
-> IORef Bool
-> Connection
conn Context
ctx IORef WriteBuffer
writeBufferRef IORef ByteString
ref IORef Bool
isH2, Transport
tls)
where
backend :: (BufSize -> IO ByteString) -> Backend
backend BufSize -> IO ByteString
recvN = TLS.Backend {
backendFlush :: IO ()
TLS.backendFlush = forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if MIN_VERSION_network(3,1,1)
, backendClose :: IO ()
TLS.backendClose = Socket -> BufSize -> IO ()
gracefulClose Socket
s BufSize
5000 forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \(SomeException e
_) -> 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 :: BufSize -> IO ByteString
TLS.backendRecv = BufSize -> IO ByteString
recvN
}
sendAll' :: Socket -> ByteString -> IO ()
sendAll' Socket
sock ByteString
bs = 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 forall a. Eq a => a -> a -> Bool
== IOErrorType
ResourceVanished
then forall a. a -> Maybe a
Just InvalidRequest
ConnectionClosedByPeer
else forall a. Maybe a
Nothing)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO ()
sendAll Socket
sock ByteString
bs
conn :: Context
-> IORef WriteBuffer
-> IORef ByteString
-> IORef Bool
-> Connection
conn Context
ctx IORef WriteBuffer
writeBufferRef IORef ByteString
ref IORef Bool
isH2 = Connection {
connSendMany :: [ByteString] -> IO ()
connSendMany = forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
TLS.sendData Context
ctx 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 = IORef ByteString -> IO ByteString
recv IORef ByteString
ref
, connRecvBuf :: RecvBuf
connRecvBuf = IORef ByteString -> RecvBuf
recvBuf IORef ByteString
ref
, connWriteBuffer :: IORef WriteBuffer
connWriteBuffer = IORef WriteBuffer
writeBufferRef
, connHTTP2 :: IORef Bool
connHTTP2 = IORef Bool
isH2
}
where
sendall :: ByteString -> IO ()
sendall = forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
TLS.sendData Context
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
L.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
sendfile :: SendFile
sendfile FileId
fid Integer
offset Integer
len IO ()
hook [ByteString]
headers = do
WriteBuffer
writeBuffer <- forall a. IORef a -> IO a
I.readIORef IORef WriteBuffer
writeBufferRef
Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile
readSendFile (WriteBuffer -> Buffer
bufBuffer WriteBuffer
writeBuffer) (WriteBuffer -> BufSize
bufSize WriteBuffer
writeBuffer) ByteString -> IO ()
sendall FileId
fid Integer
offset Integer
len IO ()
hook [ByteString]
headers
close' :: IO ()
close' = forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a. IO a -> IO (Either IOError a)
tryIO IO ()
sendBye) forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally`
Context -> IO ()
TLS.contextClose Context
ctx
sendBye :: IO ()
sendBye =
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust
(\InvalidRequest
e -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard (InvalidRequest
e forall a. Eq a => a -> a -> Bool
== InvalidRequest
ConnectionClosedByPeer) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return InvalidRequest
e)
(forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ()))
(forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.bye Context
ctx)
recv :: IORef ByteString -> IO ByteString
recv IORef ByteString
cref = do
ByteString
cached <- forall a. IORef a -> IO a
I.readIORef IORef ByteString
cref
if ByteString
cached forall a. Eq a => a -> a -> Bool
/= ByteString
"" then do
forall a. IORef a -> a -> IO ()
I.writeIORef IORef ByteString
cref ByteString
""
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
cached
else
IO ByteString
recv'
recv' :: IO ByteString
recv' = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle forall {m :: * -> *}. MonadIO m => SomeException -> m ByteString
onEOF IO ByteString
go
where
onEOF :: SomeException -> m ByteString
onEOF SomeException
e
| Just TLSError
TLS.Error_EOF <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty
| Just IOError
ioe <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e, IOError -> Bool
isEOFError IOError
ioe = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty | Bool
otherwise = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e
go :: IO ByteString
go = do
ByteString
x <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
TLS.recvData Context
ctx
if ByteString -> Bool
S.null ByteString
x then
IO ByteString
go
else
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
recvBuf :: IORef ByteString -> RecvBuf
recvBuf IORef ByteString
cref Buffer
buf BufSize
siz = do
ByteString
cached <- forall a. IORef a -> IO a
I.readIORef IORef ByteString
cref
(Bool
ret, ByteString
leftover) <- ByteString
-> Buffer -> BufSize -> IO ByteString -> IO (Bool, ByteString)
fill ByteString
cached Buffer
buf BufSize
siz IO ByteString
recv'
forall a. IORef a -> a -> IO ()
I.writeIORef IORef ByteString
cref ByteString
leftover
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ret
wrappedRecvN :: (t -> IO ByteString) -> t -> IO ByteString
wrappedRecvN t -> IO ByteString
recvN t
n = forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny SomeException -> IO ByteString
handler forall a b. (a -> b) -> a -> b
$ t -> IO ByteString
recvN t
n
handler :: SomeException -> IO S.ByteString
handler :: SomeException -> IO ByteString
handler SomeException
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
fill :: S.ByteString -> Buffer -> BufSize -> Recv -> IO (Bool,S.ByteString)
fill :: ByteString
-> Buffer -> BufSize -> IO ByteString -> IO (Bool, ByteString)
fill ByteString
bs0 Buffer
buf0 BufSize
siz0 IO ByteString
recv
| BufSize
siz0 forall a. Ord a => a -> a -> Bool
<= BufSize
len0 = do
let (ByteString
bs, ByteString
leftover) = BufSize -> ByteString -> (ByteString, ByteString)
S.splitAt BufSize
siz0 ByteString
bs0
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Buffer -> ByteString -> IO Buffer
copy Buffer
buf0 ByteString
bs
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 -> BufSize -> IO (Bool, ByteString)
loop Buffer
buf (BufSize
siz0 forall a. Num a => a -> a -> a
- BufSize
len0)
where
len0 :: BufSize
len0 = ByteString -> BufSize
S.length ByteString
bs0
loop :: Buffer -> BufSize -> IO (Bool, ByteString)
loop Buffer
_ BufSize
0 = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, ByteString
"")
loop Buffer
buf BufSize
siz = do
ByteString
bs <- IO ByteString
recv
let len :: BufSize
len = ByteString -> BufSize
S.length ByteString
bs
if BufSize
len forall a. Eq a => a -> a -> Bool
== BufSize
0 then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, ByteString
"")
else if BufSize
len forall a. Ord a => a -> a -> Bool
<= BufSize
siz then do
Buffer
buf' <- Buffer -> ByteString -> IO Buffer
copy Buffer
buf ByteString
bs
Buffer -> BufSize -> IO (Bool, ByteString)
loop Buffer
buf' (BufSize
siz forall a. Num a => a -> a -> a
- BufSize
len)
else do
let (ByteString
bs1,ByteString
bs2) = BufSize -> ByteString -> (ByteString, ByteString)
S.splitAt BufSize
siz ByteString
bs
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Buffer -> ByteString -> IO Buffer
copy Buffer
buf ByteString
bs1
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 <- 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 -> 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 (BufSize
major, BufSize
minor) = case Version
infoVersion of
Version
TLS.SSL2 -> (BufSize
2,BufSize
0)
Version
TLS.SSL3 -> (BufSize
3,BufSize
0)
Version
TLS.TLS10 -> (BufSize
3,BufSize
1)
Version
TLS.TLS11 -> (BufSize
3,BufSize
2)
Version
TLS.TLS12 -> (BufSize
3,BufSize
3)
#if MIN_VERSION_tls(1,5,0)
Version
TLS.TLS13 -> (BufSize
3,BufSize
4)
#endif
Maybe CertificateChain
clientCert <- Context -> IO (Maybe CertificateChain)
TLS.getClientCertificateChain Context
ctx
forall (m :: * -> *) a. Monad m => a -> m a
return TLS {
tlsMajorVersion :: BufSize
tlsMajorVersion = BufSize
major
, tlsMinorVersion :: BufSize
tlsMinorVersion = BufSize
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 :: forall a. IO a -> IO (Either IOError a)
tryIO = 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
[HashAndSignatureAlgorithm]
[Cipher]
[Version]
Maybe Params
Maybe Credentials
Maybe SessionManager
Maybe Config
ServerHooks
Logging
OnInsecure
CertSettings
tlsSupportedHashSignatures :: [HashAndSignatureAlgorithm]
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
tlsSupportedHashSignatures :: TLSSettings -> [HashAndSignatureAlgorithm]
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 <- 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')
}
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection
conn'', Transport
TCP)
DenyInsecure ByteString
lbs -> do
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"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Socket -> ByteString -> IO ()
sendAll Socket
s) forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
lbs
Socket -> IO ()
close Socket
s
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO WarpTLSException
InsecureConnectionDenied
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 <- forall a. IORef a -> IO a
I.readIORef IORef ByteString
ref
if ByteString -> Bool
S.null ByteString
bs
then IO ByteString
fallback
else do
forall a. IORef a -> a -> IO ()
I.writeIORef IORef ByteString
ref ByteString
S.empty
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
data WarpTLSException
= InsecureConnectionDenied
| ClientClosedConnectionPrematurely
deriving (BufSize -> WarpTLSException -> ShowS
[WarpTLSException] -> ShowS
WarpTLSException -> FilePath
forall a.
(BufSize -> a -> ShowS)
-> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [WarpTLSException] -> ShowS
$cshowList :: [WarpTLSException] -> ShowS
show :: WarpTLSException -> FilePath
$cshow :: WarpTLSException -> FilePath
showsPrec :: BufSize -> WarpTLSException -> ShowS
$cshowsPrec :: BufSize -> WarpTLSException -> ShowS
Show, Typeable)
instance Exception WarpTLSException