diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog +## 3.4.4 + +* Allow warp v3.4. + ## 3.4.3 * Install shutdown handlers passed via `Settings` to `run...` functions diff --git a/Network/Wai/Handler/WarpTLS.hs b/Network/Wai/Handler/WarpTLS.hs --- a/Network/Wai/Handler/WarpTLS.hs +++ b/Network/Wai/Handler/WarpTLS.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PatternGuards #-} -- | HTTP over TLS support for Warp via the TLS package. -- @@ -11,213 +11,226 @@ -- Otherwise HTTP\/1.1 over TLS is used. -- -- Support for SSL is now obsoleted. - module Network.Wai.Handler.WarpTLS ( -- * Runner - runTLS - , runTLSSocket + runTLS, + runTLSSocket, + -- * Settings - , TLSSettings - , defaultTlsSettings + TLSSettings, + defaultTlsSettings, + -- * Smart constructors + -- ** From files - , tlsSettings - , tlsSettingsChain + tlsSettings, + tlsSettingsChain, + -- ** From memory - , tlsSettingsMemory - , tlsSettingsChainMemory + tlsSettingsMemory, + tlsSettingsChainMemory, + -- ** From references - , tlsSettingsRef - , tlsSettingsChainRef - , CertSettings + tlsSettingsRef, + tlsSettingsChainRef, + CertSettings, + -- * Accessors - , tlsCredentials - , tlsLogging - , tlsAllowedVersions - , tlsCiphers - , tlsWantClientCert - , tlsServerHooks - , tlsServerDHEParams - , tlsSessionManagerConfig - , tlsSessionManager - , onInsecure - , OnInsecure (..) + tlsCredentials, + tlsLogging, + tlsAllowedVersions, + tlsCiphers, + tlsWantClientCert, + tlsServerHooks, + tlsServerDHEParams, + tlsSessionManagerConfig, + tlsSessionManager, + onInsecure, + OnInsecure (..), + -- * Exception - , WarpTLSException (..) - ) where + WarpTLSException (..), +) where import Control.Applicative ((<|>)) -import UnliftIO.Exception (Exception, throwIO, bracket, finally, handleAny, try, IOException, onException, SomeException(..), handleJust) -import qualified UnliftIO.Exception as E -import Control.Monad (void, guard) +import Control.Monad (guard, void) 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 GHC.IO.Exception (IOErrorType (..)) import Network.Socket ( SockAddr, Socket, close, + getSocketName, #if MIN_VERSION_network(3,1,1) gracefulClose, #endif withSocketsDo, - getSocketName, ) import Network.Socket.BufferPool import Network.Socket.ByteString (sendAll) import qualified Network.TLS as TLS -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 Network.Wai.Handler.WarpTLS.Internal import System.IO.Error (ioeGetErrorType, isEOFError) -import UnliftIO.Exception (handle, fromException) - --- | The default 'CertSettings'. -defaultCertSettings :: CertSettings -defaultCertSettings = CertFromFile "certificate.pem" [] "key.pem" - ----------------------------------------------------------------- - --- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors). -defaultTlsSettings :: TLSSettings -defaultTlsSettings = TLSSettings { - certSettings = defaultCertSettings - , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections." - , tlsLogging = def -#if MIN_VERSION_tls(1,5,0) - , tlsAllowedVersions = [TLS.TLS13,TLS.TLS12,TLS.TLS11,TLS.TLS10] -#else - , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10] -#endif - , tlsCiphers = ciphers - , tlsWantClientCert = False - , tlsServerHooks = def - , tlsServerDHEParams = Nothing - , tlsSessionManagerConfig = Nothing - , tlsCredentials = Nothing - , tlsSessionManager = Nothing - , tlsSupportedHashSignatures = TLS.supportedHashSignatures def - } - --- taken from stunnel example in tls-extra -ciphers :: [TLS.Cipher] -ciphers = TLSExtra.ciphersuite_strong +import UnliftIO.Exception ( + Exception, + IOException, + SomeException (..), + bracket, + finally, + fromException, + handle, + handleAny, + handleJust, + onException, + throwIO, + try, + ) +import qualified UnliftIO.Exception as E ---------------------------------------------------------------- -- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'. -tlsSettings :: FilePath -- ^ Certificate file - -> FilePath -- ^ Key file - -> TLSSettings -tlsSettings cert key = defaultTlsSettings { - certSettings = CertFromFile cert [] key - } +tlsSettings + :: FilePath + -- ^ Certificate file + -> FilePath + -- ^ Key file + -> TLSSettings +tlsSettings cert key = + 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 cert chainCerts key = defaultTlsSettings { - certSettings = CertFromFile cert chainCerts key - } + :: FilePath + -- ^ Certificate file + -> [FilePath] + -- ^ Chain certificate files + -> FilePath + -- ^ Key file + -> TLSSettings +tlsSettingsChain cert chainCerts key = + 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 + :: S.ByteString + -- ^ Certificate bytes + -> S.ByteString + -- ^ Key bytes -> TLSSettings -tlsSettingsMemory cert key = defaultTlsSettings { - certSettings = CertFromMemory cert [] key - } +tlsSettingsMemory cert key = + 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 + :: S.ByteString + -- ^ Certificate bytes + -> [S.ByteString] + -- ^ Chain certificate bytes + -> S.ByteString + -- ^ Key bytes -> TLSSettings -tlsSettingsChainMemory cert chainCerts key = defaultTlsSettings { - certSettings = CertFromMemory cert chainCerts key - } +tlsSettingsChainMemory cert chainCerts key = + defaultTlsSettings + { certSettings = CertFromMemory cert chainCerts 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 + :: I.IORef S.ByteString + -- ^ Reference to certificate bytes + -> I.IORef S.ByteString + -- ^ Reference to key bytes -> TLSSettings -tlsSettingsRef cert key = defaultTlsSettings { - certSettings = CertFromRef cert [] key - } +tlsSettingsRef cert key = + defaultTlsSettings + { certSettings = CertFromRef cert [] 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 + :: 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 cert chainCerts key = defaultTlsSettings { - certSettings = CertFromRef cert chainCerts key - } +tlsSettingsChainRef cert chainCerts key = + defaultTlsSettings + { certSettings = CertFromRef cert chainCerts key + } ---------------------------------------------------------------- -- | Running 'Application' with 'TLSSettings' and 'Settings'. runTLS :: TLSSettings -> Settings -> Application -> IO () -runTLS tset set app = withSocketsDo $ - bracket - (bindPortTCP (getPort set) (getHost set)) - close - (\sock -> do - setSocketCloseOnExec sock - runTLSSocket tset set sock app) +runTLS tset set app = + withSocketsDo $ + bracket + (bindPortTCP (getPort set) (getHost set)) + close + ( \sock -> do + setSocketCloseOnExec sock + runTLSSocket tset set sock app + ) ---------------------------------------------------------------- loadCredentials :: TLSSettings -> IO TLS.Credentials -loadCredentials TLSSettings{ tlsCredentials = Just creds } = return creds +loadCredentials TLSSettings{tlsCredentials = Just creds} = return creds loadCredentials TLSSettings{..} = case certSettings of - CertFromFile cert chainFiles key -> do - cred <- either error id <$> TLS.credentialLoadX509Chain cert chainFiles key - return $ TLS.Credentials [cred] - CertFromRef certRef chainCertsRef keyRef -> do - cert <- I.readIORef certRef - chainCerts <- mapM I.readIORef chainCertsRef - key <- I.readIORef keyRef - cred <- either error return $ TLS.credentialLoadX509ChainFromMemory cert chainCerts key - return $ TLS.Credentials [cred] - CertFromMemory certMemory chainCertsMemory keyMemory -> do - cred <- either error return $ TLS.credentialLoadX509ChainFromMemory certMemory chainCertsMemory keyMemory - return $ TLS.Credentials [cred] + CertFromFile cert chainFiles key -> do + cred <- either error id <$> TLS.credentialLoadX509Chain cert chainFiles key + return $ TLS.Credentials [cred] + CertFromRef certRef chainCertsRef keyRef -> do + cert <- I.readIORef certRef + chainCerts <- mapM I.readIORef chainCertsRef + key <- I.readIORef keyRef + cred <- + either error return $ TLS.credentialLoadX509ChainFromMemory cert chainCerts key + return $ TLS.Credentials [cred] + CertFromMemory certMemory chainCertsMemory keyMemory -> do + cred <- + either error return $ + TLS.credentialLoadX509ChainFromMemory certMemory chainCertsMemory keyMemory + return $ TLS.Credentials [cred] getSessionManager :: TLSSettings -> IO TLS.SessionManager -getSessionManager TLSSettings{ tlsSessionManager = Just mgr } = return mgr +getSessionManager TLSSettings{tlsSessionManager = Just mgr} = return mgr getSessionManager TLSSettings{..} = case tlsSessionManagerConfig of - Nothing -> return TLS.noSessionManager - Just config -> SM.newSessionManager config + Nothing -> return TLS.noSessionManager + Just config -> SM.newSessionManager config -- | Running 'Application' with 'TLSSettings' and 'Settings' using -- specified 'Socket'. @@ -228,59 +241,83 @@ mgr <- getSessionManager tlsset runTLSSocket' tlsset set credentials mgr sock app -runTLSSocket' :: TLSSettings -> Settings -> TLS.Credentials -> TLS.SessionManager -> Socket -> Application -> IO () +runTLSSocket' + :: TLSSettings + -> Settings + -> TLS.Credentials + -> TLS.SessionManager + -> Socket + -> Application + -> IO () runTLSSocket' tlsset@TLSSettings{..} set credentials mgr sock = runSettingsConnectionMakerSecure set get where get = getter tlsset set sock params - params = def { -- TLS.ServerParams - TLS.serverWantClientCert = tlsWantClientCert - , TLS.serverCACertificates = [] - , TLS.serverDHEParams = tlsServerDHEParams - , TLS.serverHooks = hooks - , TLS.serverShared = shared - , TLS.serverSupported = supported + params = + def -- TLS.ServerParams + { 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 + , TLS.serverEarlyDataSize = 2018 #endif - } + } -- Adding alpn to user's tlsServerHooks. - hooks = tlsServerHooks { - TLS.onALPNClientSuggest = TLS.onALPNClientSuggest tlsServerHooks <|> - (if settingsHTTP2Enabled set then Just alpn else Nothing) - } - shared = def { - TLS.sharedCredentials = credentials - , TLS.sharedSessionManager = mgr - } - supported = def { -- TLS.Supported - 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 + hooks = + tlsServerHooks + { TLS.onALPNClientSuggest = + TLS.onALPNClientSuggest tlsServerHooks + <|> (if settingsHTTP2Enabled set then Just alpn else Nothing) + } + shared = + def + { TLS.sharedCredentials = credentials + , TLS.sharedSessionManager = mgr + } + supported = + def -- TLS.Supported + { 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] + , TLS.supportedGroups = [TLS.X25519,TLS.P256,TLS.P384] #endif - } + } alpn :: [S.ByteString] -> IO S.ByteString alpn xs - | "h2" `elem` xs = return "h2" - | otherwise = return "http/1.1" + | "h2" `elem` xs = return "h2" + | otherwise = return "http/1.1" ---------------------------------------------------------------- -getter :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr) +getter + :: TLS.TLSParams params + => TLSSettings + -> Settings + -> Socket + -> params + -> IO (IO (Connection, Transport), SockAddr) getter tlsset set@Settings{settingsAccept = accept'} sock params = do (s, sa) <- accept' sock setSocketCloseOnExec s return (mkConn tlsset set s params, sa) -mkConn :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (Connection, Transport) +mkConn + :: TLS.TLSParams params + => TLSSettings + -> Settings + -> Socket + -> params + -> IO (Connection, Transport) mkConn tlsset set s params = (safeRecv s 4096 >>= switch) `onException` close s where switch firstBS @@ -290,7 +327,14 @@ ---------------------------------------------------------------- -httpOverTls :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> S.ByteString -> params -> IO (Connection, Transport) +httpOverTls + :: TLS.TLSParams params + => TLSSettings + -> Settings + -> Socket + -> S.ByteString + -> params + -> IO (Connection, Transport) httpOverTls TLSSettings{..} _set s bs0 params = do pool <- newBufferPool 2048 16384 rawRecvN <- makeRecvN bs0 $ receive s pool @@ -307,59 +351,74 @@ mysa <- getSocketName s return (conn ctx writeBufferRef isH2 mysa, tls) where - backend recvN = TLS.Backend { - TLS.backendFlush = return () + backend recvN = + TLS.Backend + { TLS.backendFlush = return () #if MIN_VERSION_network(3,1,1) - , TLS.backendClose = gracefulClose s 5000 `E.catch` \(SomeException _) -> return () + , TLS.backendClose = + gracefulClose s 5000 `E.catch` \(SomeException _) -> return () #else - , TLS.backendClose = close s + , TLS.backendClose = close s #endif - , TLS.backendSend = sendAll' s - , TLS.backendRecv = recvN - } - sendAll' sock bs = E.handleJust - (\ e -> if ioeGetErrorType e == ResourceVanished - then Just ConnectionClosedByPeer - else Nothing) - throwIO - $ sendAll sock bs - conn ctx writeBufferRef isH2 mysa = Connection { - connSendMany = TLS.sendData ctx . L.fromChunks - , connSendAll = sendall - , connSendFile = sendfile - , connClose = close' - , connRecv = recv - , connRecvBuf = \_ _ -> return True -- obsoleted - , connWriteBuffer = writeBufferRef - , connHTTP2 = isH2 - , connMySockAddr = mysa - } + , TLS.backendSend = sendAll' s + , TLS.backendRecv = recvN + } + sendAll' sock bs = + E.handleJust + ( \e -> + if ioeGetErrorType e == ResourceVanished + then Just ConnectionClosedByPeer + else Nothing + ) + throwIO + $ sendAll sock bs + conn ctx writeBufferRef isH2 mysa = + Connection + { connSendMany = TLS.sendData ctx . L.fromChunks + , connSendAll = sendall + , connSendFile = sendfile + , connClose = close' + , connRecv = recv + , connRecvBuf = \_ _ -> return True -- obsoleted + , connWriteBuffer = writeBufferRef + , connHTTP2 = isH2 + , connMySockAddr = mysa + } where sendall = TLS.sendData ctx . L.fromChunks . return recv = handle onEOF $ TLS.recvData ctx where onEOF e #if MIN_VERSION_tls(1,8,0) - | Just (TLS.PostHandshake TLS.Error_EOF) <- E.fromException e = return S.empty + | Just (TLS.PostHandshake TLS.Error_EOF) <- E.fromException e = return S.empty #else - | Just TLS.Error_EOF <- fromException e = return S.empty + | Just TLS.Error_EOF <- fromException e = return S.empty #endif - | Just ioe <- fromException e, isEOFError ioe = return S.empty | otherwise = throwIO e + | Just ioe <- fromException e, isEOFError ioe = return S.empty + | otherwise = throwIO e sendfile fid offset len hook headers = do writeBuffer <- I.readIORef writeBufferRef - readSendFile (bufBuffer writeBuffer) (bufSize writeBuffer) sendall fid offset len hook headers + readSendFile + (bufBuffer writeBuffer) + (bufSize writeBuffer) + sendall + fid + offset + len + hook + headers - close' = void (tryIO sendBye) `finally` - TLS.contextClose ctx + close' = + void (tryIO sendBye) + `finally` TLS.contextClose ctx sendBye = - -- It's fine if the connection was closed by the other side before - -- receiving close_notify, see RFC 5246 section 7.2.1. - handleJust - (\e -> guard (e == ConnectionClosedByPeer) >> return e) - (const (return ())) - (TLS.bye ctx) - + -- It's fine if the connection was closed by the other side before + -- receiving close_notify, see RFC 5246 section 7.2.1. + handleJust + (\e -> guard (e == ConnectionClosedByPeer) >> return e) + (const (return ())) + (TLS.bye ctx) wrappedRecvN recvN n = handleAny handler $ recvN n handler :: SomeException -> IO S.ByteString @@ -370,39 +429,40 @@ proto <- TLS.getNegotiatedProtocol ctx minfo <- TLS.contextGetInformation ctx case minfo of - Nothing -> return TCP + Nothing -> return TCP Just TLS.Information{..} -> do let (major, minor) = case infoVersion of - TLS.SSL2 -> (2,0) - TLS.SSL3 -> (3,0) - TLS.TLS10 -> (3,1) - TLS.TLS11 -> (3,2) - TLS.TLS12 -> (3,3) -#if MIN_VERSION_tls(1,5,0) - TLS.TLS13 -> (3,4) -#endif + TLS.SSL2 -> (2, 0) + TLS.SSL3 -> (3, 0) + TLS.TLS10 -> (3, 1) + TLS.TLS11 -> (3, 2) + TLS.TLS12 -> (3, 3) + _ -> (3,4) clientCert <- TLS.getClientCertificateChain ctx - return TLS { - tlsMajorVersion = major - , tlsMinorVersion = minor - , tlsNegotiatedProtocol = proto - , tlsChiperID = TLS.cipherID infoCipher - , tlsClientCertificate = clientCert - } + return + TLS + { tlsMajorVersion = major + , tlsMinorVersion = minor + , tlsNegotiatedProtocol = proto + , tlsChiperID = TLS.cipherID infoCipher + , tlsClientCertificate = clientCert + } tryIO :: IO a -> IO (Either IOException a) tryIO = try ---------------------------------------------------------------- -plainHTTP :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport) +plainHTTP + :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport) plainHTTP TLSSettings{..} set s bs0 = case onInsecure of AllowInsecure -> do conn' <- socketConnection set s cachedRef <- I.newIORef bs0 - let conn'' = conn' - { connRecv = recvPlain cachedRef (connRecv conn') - } + let conn'' = + conn' + { connRecv = recvPlain cachedRef (connRecv conn') + } return (conn'', TCP) DenyInsecure lbs -> do -- Listening port 443 but TLS records do not arrive. @@ -415,10 +475,12 @@ -- GOAWAY + INADEQUATE_SECURITY? -- FIXME: Content-Length: -- FIXME: TLS/ - sendAll 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" + sendAll + 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" mapM_ (sendAll s) $ L.toChunks lbs close s throwIO InsecureConnectionDenied diff --git a/Network/Wai/Handler/WarpTLS/Internal.hs b/Network/Wai/Handler/WarpTLS/Internal.hs --- a/Network/Wai/Handler/WarpTLS/Internal.hs +++ b/Network/Wai/Handler/WarpTLS/Internal.hs @@ -1,17 +1,21 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.WarpTLS.Internal ( - CertSettings(..) - , TLSSettings(..) - , OnInsecure(..) + CertSettings (..), + TLSSettings (..), + defaultTlsSettings, + OnInsecure (..), + -- * Accessors - , getCertSettings - ) where + getCertSettings, +) where 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 qualified Network.TLS as TLS +import qualified Network.TLS.Extra as TLSExtra import qualified Network.TLS.SessionManager as SM ---------------------------------------------------------------- @@ -19,75 +23,61 @@ -- | Determines where to load the certificate, chain -- certificates, and key from. data CertSettings - = CertFromFile !FilePath ![FilePath] !FilePath - | CertFromMemory !S.ByteString ![S.ByteString] !S.ByteString - | CertFromRef !(I.IORef S.ByteString) ![I.IORef S.ByteString] !(I.IORef S.ByteString) + = CertFromFile !FilePath ![FilePath] !FilePath + | CertFromMemory !S.ByteString ![S.ByteString] !S.ByteString + | CertFromRef + !(I.IORef S.ByteString) + ![I.IORef S.ByteString] + !(I.IORef S.ByteString) +instance Show CertSettings where + show (CertFromFile a b c) = "CertFromFile " ++ show a ++ " " ++ show b ++ " " ++ show c + show (CertFromMemory a b c) = "CertFromMemory " ++ show a ++ " " ++ show b ++ " " ++ show c + show (CertFromRef _ _ _) = "CertFromRef" + ---------------------------------------------------------------- -- | An action when a plain HTTP comes to HTTP over TLS/SSL port. -data OnInsecure = DenyInsecure L.ByteString - | AllowInsecure - deriving (Show) +data OnInsecure + = DenyInsecure L.ByteString + | AllowInsecure + deriving (Show) ---------------------------------------------------------------- -- | Settings for WarpTLS. -data TLSSettings = TLSSettings { - certSettings :: CertSettings +data TLSSettings = TLSSettings + { certSettings :: CertSettings -- ^ Where are the certificate, chain certificates, and key -- loaded from? -- -- >>> certSettings defaultTlsSettings - -- tlsSettings "certificate.pem" "key.pem" + -- CertFromFile "certificate.pem" [] "key.pem" -- -- @since 3.3.0 - , onInsecure :: OnInsecure + , onInsecure :: OnInsecure -- ^ Do we allow insecure connections with this server as well? -- -- >>> onInsecure defaultTlsSettings -- DenyInsecure "This server only accepts secure HTTPS connections." -- -- Since 1.4.0 - , tlsLogging :: TLS.Logging + , tlsLogging :: TLS.Logging -- ^ The level of logging to turn on. -- -- Default: 'TLS.defaultLogging'. -- -- Since 1.4.0 - , tlsAllowedVersions :: [TLS.Version] -#if MIN_VERSION_tls(1,5,0) + , tlsAllowedVersions :: [TLS.Version] -- ^ The TLS versions this server accepts. -- - -- >>> tlsAllowedVersions defaultTlsSettings - -- [TLS13,TLS12,TLS11,TLS10] - -- -- Since 1.4.2 -#else - -- ^ The TLS versions this server accepts. - -- - -- >>> tlsAllowedVersions defaultTlsSettings - -- [TLS12,TLS11,TLS10] - -- - -- Since 1.4.2 -#endif - , tlsCiphers :: [TLS.Cipher] -#if MIN_VERSION_tls(1,5,0) + , tlsCiphers + :: [TLS.Cipher] -- ^ The TLS ciphers this server accepts. -- - -- >>> tlsCiphers defaultTlsSettings - -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1,AES128GCM-SHA256,AES256GCM-SHA384] - -- -- Since 1.4.2 -#else - -- ^ The TLS ciphers this server accepts. - -- - -- >>> tlsCiphers defaultTlsSettings - -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1] - -- - -- Since 1.4.2 -#endif - , tlsWantClientCert :: Bool + , tlsWantClientCert :: Bool -- ^ Whether or not to demand a certificate from the client. If this -- is set to True, you must handle received certificates in a server hook -- or all connections will fail. @@ -96,7 +86,7 @@ -- False -- -- Since 3.0.2 - , tlsServerHooks :: TLS.ServerHooks + , tlsServerHooks :: TLS.ServerHooks -- ^ The server-side hooks called by the tls package, including actions -- to take when a client certificate is received. See the "Network.TLS" -- module for details. @@ -104,14 +94,14 @@ -- Default: def -- -- Since 3.0.2 - , tlsServerDHEParams :: Maybe TLS.DHParams + , tlsServerDHEParams :: Maybe TLS.DHParams -- ^ Configuration for ServerDHEParams -- more function lives in `crypton` package -- -- Default: Nothing -- -- Since 3.2.2 - , tlsSessionManagerConfig :: Maybe SM.Config + , tlsSessionManagerConfig :: Maybe SM.Config -- ^ Configuration for in-memory TLS session manager. -- If Nothing, 'TLS.noSessionManager' is used. -- Otherwise, an in-memory TLS session manager is created @@ -120,25 +110,53 @@ -- Default: Nothing -- -- Since 3.2.4 - , tlsCredentials :: Maybe TLS.Credentials + , tlsCredentials :: Maybe TLS.Credentials -- ^ Specifying 'TLS.Credentials' directly. If this value is -- specified, other fields such as 'certFile' are ignored. -- -- Since 3.2.12 - , tlsSessionManager :: Maybe TLS.SessionManager + , tlsSessionManager :: Maybe TLS.SessionManager -- ^ Specifying 'TLS.SessionManager' directly. If this value is -- specified, 'tlsSessionManagerConfig' is ignored. -- -- Since 3.2.12 - , tlsSupportedHashSignatures :: [TLS.HashAndSignatureAlgorithm] + , tlsSupportedHashSignatures :: [TLS.HashAndSignatureAlgorithm] -- ^ Specifying supported hash/signature algorithms, ordered by decreasing -- priority. See the "Network.TLS" module for details -- -- Since 3.3.3 - } - + } -- Since 3.3.1 + -- | Some programs need access to cert settings getCertSettings :: TLSSettings -> CertSettings -getCertSettings tlsSetgs = certSettings tlsSetgs +getCertSettings = certSettings + +-- | The default 'CertSettings'. +defaultCertSettings :: CertSettings +defaultCertSettings = CertFromFile "certificate.pem" [] "key.pem" + +---------------------------------------------------------------- + +-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors). +defaultTlsSettings :: TLSSettings +defaultTlsSettings = + TLSSettings + { certSettings = defaultCertSettings + , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections." + , tlsLogging = def + , tlsAllowedVersions = TLS.supportedVersions def + , tlsCiphers = ciphers + , tlsWantClientCert = False + , tlsServerHooks = def + , tlsServerDHEParams = Nothing + , tlsSessionManagerConfig = Nothing + , tlsCredentials = Nothing + , tlsSessionManager = Nothing + , tlsSupportedHashSignatures = TLS.supportedHashSignatures def + } + +-- taken from stunnel example in tls-extra +ciphers :: [TLS.Cipher] +ciphers = TLSExtra.ciphersuite_strong diff --git a/warp-tls.cabal b/warp-tls.cabal --- a/warp-tls.cabal +++ b/warp-tls.cabal @@ -1,5 +1,5 @@ Name: warp-tls -Version: 3.4.3 +Version: 3.4.4 Synopsis: HTTP over TLS support for Warp via the TLS package License: MIT License-file: LICENSE @@ -21,7 +21,7 @@ Build-Depends: base >= 4.12 && < 5 , bytestring >= 0.9 , wai >= 3.2 && < 3.3 - , warp >= 3.3.29 && < 3.4 + , warp >= 3.3.29 && < 3.5 , data-default-class >= 0.0.1 , tls >= 1.7 , network >= 2.2.1