From 0b0dd980200a920e69bc2fd28b275e3455317536 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 16 Jan 2024 11:45:18 +0900 Subject: [PATCH 1/5] moving default values into Internal --- warp-tls/Network/Wai/Handler/WarpTLS.hs | 39 +------------------ .../Network/Wai/Handler/WarpTLS/Internal.hs | 36 +++++++++++++++++ 2 files changed, 37 insertions(+), 38 deletions(-) diff --git a/warp-tls/Network/Wai/Handler/WarpTLS.hs b/warp-tls/Network/Wai/Handler/WarpTLS.hs index 2a4605916..da1c7fc05 100644 --- a/warp-tls/Network/Wai/Handler/WarpTLS.hs +++ b/warp-tls/Network/Wai/Handler/WarpTLS.hs @@ -74,16 +74,11 @@ import Network.Socket ( 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 (..), - OnInsecure (..), - TLSSettings (..), - ) +import Network.Wai.Handler.WarpTLS.Internal import System.IO.Error (ioeGetErrorType, isEOFError) import UnliftIO.Exception ( Exception, @@ -101,38 +96,6 @@ import UnliftIO.Exception ( ) import qualified UnliftIO.Exception as E --- | 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 - ---------------------------------------------------------------- -- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'. diff --git a/warp-tls/Network/Wai/Handler/WarpTLS/Internal.hs b/warp-tls/Network/Wai/Handler/WarpTLS/Internal.hs index 4549873ae..75b252f79 100644 --- a/warp-tls/Network/Wai/Handler/WarpTLS/Internal.hs +++ b/warp-tls/Network/Wai/Handler/WarpTLS/Internal.hs @@ -1,18 +1,22 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.WarpTLS.Internal ( CertSettings (..), TLSSettings (..), + defaultTlsSettings, OnInsecure (..), -- * Accessors getCertSettings, ) where +import Data.Default.Class (def) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L 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 ---------------------------------------------------------------- @@ -147,3 +151,35 @@ data TLSSettings = TLSSettings -- | Some programs need access to cert settings getCertSettings :: TLSSettings -> CertSettings 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 +#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 From ddc8fa3cc3c0b369d9c056e39c98e463bbf4e980 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 16 Jan 2024 11:51:07 +0900 Subject: [PATCH 2/5] using TLS's default values --- .../Network/Wai/Handler/WarpTLS/Internal.hs | 36 +++---------------- 1 file changed, 4 insertions(+), 32 deletions(-) diff --git a/warp-tls/Network/Wai/Handler/WarpTLS/Internal.hs b/warp-tls/Network/Wai/Handler/WarpTLS/Internal.hs index 75b252f79..8559dee0a 100644 --- a/warp-tls/Network/Wai/Handler/WarpTLS/Internal.hs +++ b/warp-tls/Network/Wai/Handler/WarpTLS/Internal.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.WarpTLS.Internal ( @@ -11,9 +10,9 @@ module Network.Wai.Handler.WarpTLS.Internal ( getCertSettings, ) where -import Data.Default.Class (def) 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 @@ -65,37 +64,14 @@ data TLSSettings = TLSSettings -- -- Since 1.4.0 , tlsAllowedVersions :: [TLS.Version] -#if MIN_VERSION_tls(1,5,0) - -- ^ 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) - -- ^ 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 + , 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] - -- -- Since 1.4.2 -#endif , 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 @@ -165,11 +141,7 @@ defaultTlsSettings = { 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 + , tlsAllowedVersions = TLS.supportedVersions def , tlsCiphers = ciphers , tlsWantClientCert = False , tlsServerHooks = def From 4183569910de4d2c8a1f3752b2c89c82bc145994 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 16 Jan 2024 11:51:53 +0900 Subject: [PATCH 3/5] workaround for a warning --- warp-tls/Network/Wai/Handler/WarpTLS.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/warp-tls/Network/Wai/Handler/WarpTLS.hs b/warp-tls/Network/Wai/Handler/WarpTLS.hs index da1c7fc05..70cd3d034 100644 --- a/warp-tls/Network/Wai/Handler/WarpTLS.hs +++ b/warp-tls/Network/Wai/Handler/WarpTLS.hs @@ -437,9 +437,7 @@ getTLSinfo ctx = do TLS.TLS10 -> (3, 1) TLS.TLS11 -> (3, 2) TLS.TLS12 -> (3, 3) -#if MIN_VERSION_tls(1,5,0) - TLS.TLS13 -> (3,4) -#endif + _ -> (3,4) clientCert <- TLS.getClientCertificateChain ctx return TLS From 3fc0ac1f5b41a3559f0d30b596459441d51a5422 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 16 Jan 2024 13:25:21 +0900 Subject: [PATCH 4/5] implementing PackIntSpec --- warp/Network/Wai/Handler/Warp/File.hs | 3 --- warp/Network/Wai/Handler/Warp/PackInt.hs | 8 -------- warp/warp.cabal | 1 + 3 files changed, 1 insertion(+), 11 deletions(-) diff --git a/warp/Network/Wai/Handler/Warp/File.hs b/warp/Network/Wai/Handler/Warp/File.hs index 8da87dde1..807597fbf 100644 --- a/warp/Network/Wai/Handler/Warp/File.hs +++ b/warp/Network/Wai/Handler/Warp/File.hs @@ -21,9 +21,6 @@ import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.PackInt --- $setup --- >>> import Test.QuickCheck - ---------------------------------------------------------------- data RspFileInfo diff --git a/warp/Network/Wai/Handler/Warp/PackInt.hs b/warp/Network/Wai/Handler/Warp/PackInt.hs index db0e8e8ff..852aa4845 100644 --- a/warp/Network/Wai/Handler/Warp/PackInt.hs +++ b/warp/Network/Wai/Handler/Warp/PackInt.hs @@ -11,14 +11,6 @@ import qualified Network.HTTP.Types as H import Network.Wai.Handler.Warp.Imports --- $setup --- >>> import Data.ByteString.Char8 as C8 --- >>> import Test.QuickCheck (Large(..)) - --- | --- --- prop> packIntegral (abs n) == C8.pack (show (abs n)) --- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == C8.pack (show n') packIntegral :: Integral a => a -> ByteString packIntegral 0 = "0" packIntegral n | n < 0 = error "packIntegral" diff --git a/warp/warp.cabal b/warp/warp.cabal index 63a738733..88a385830 100644 --- a/warp/warp.cabal +++ b/warp/warp.cabal @@ -139,6 +139,7 @@ Test-Suite spec ExceptionSpec FdCacheSpec FileSpec + PackIntSpec ReadIntSpec RequestSpec ResponseHeaderSpec From fdb875aeb97a2f161f5032b5f62f8af59a55b9f4 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 16 Jan 2024 13:47:29 +0900 Subject: [PATCH 5/5] change a broken doctest to a doc --- auto-update/Control/Debounce.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/auto-update/Control/Debounce.hs b/auto-update/Control/Debounce.hs index 2f77d734f..33b123574 100644 --- a/auto-update/Control/Debounce.hs +++ b/auto-update/Control/Debounce.hs @@ -7,18 +7,17 @@ -- Example usage: -- -- @ --- printString <- 'mkDebounce' 'defaultDebounceSettings' +-- > printString <- 'mkDebounce' 'defaultDebounceSettings' -- { 'debounceAction' = putStrLn "Running action" -- , 'debounceFreq' = 5000000 -- 5 seconds -- , 'debounceEdge' = 'DI.trailingEdge' -- Trigger on the trailing edge -- } --- @ --- --- >>> printString +-- > printString -- Running action --- >>> printString --- +-- > printString +-- \ -- Running action +-- @ -- -- See the fast-logger package ("System.Log.FastLogger") for real-world usage. --