warp-tls 3.0.4.2 → 3.1.0
raw patch · 3 files changed
+168/−112 lines, 3 filesdep ~warpnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: warp
API changes (from Hackage documentation)
+ Network.Wai.Handler.WarpTLS: instance Show OnInsecure
Files
- ChangeLog.md +5/−0
- Network/Wai/Handler/WarpTLS.hs +156/−108
- warp-tls.cabal +7/−4
ChangeLog.md view
@@ -1,3 +1,8 @@+## 3.1.0++* Supporting HTTP/2 [#399](https://github.com/yesodweb/wai/pull/399)+* Removing RC4 [#400](https://github.com/yesodweb/wai/issues/400)+ ## 3.0.4.2 * tls 1.3 support [#390](https://github.com/yesodweb/wai/issues/390)
Network/Wai/Handler/WarpTLS.hs view
@@ -4,25 +4,33 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE CPP #-} --- | HTTP over SSL/TLS support for Warp via the TLS package.+-- | 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 ( -- * Settings TLSSettings+ , defaultTlsSettings+ -- * Smart constructors+ , tlsSettings+ , tlsSettingsMemory+ , tlsSettingsChain+ , tlsSettingsChainMemory+ -- * Accessors , certFile , keyFile- , onInsecure , tlsLogging , tlsAllowedVersions , tlsCiphers , tlsWantClientCert , tlsServerHooks- , defaultTlsSettings- , tlsSettings- , tlsSettingsMemory- , tlsSettingsChain- , tlsSettingsChainMemory+ , onInsecure , OnInsecure (..) -- * Runner , runTLS@@ -31,31 +39,30 @@ , WarpTLSException (..) ) where -import qualified Network.TLS as TLS-import Network.Wai.Handler.Warp-import Network.Wai (Application)-import Network.Socket (Socket, sClose, withSocketsDo, SockAddr, accept)+#if __GLASGOW_HASKELL__ < 709+import Control.Applicative ((<$>))+#endif+import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException)+import Control.Monad (void)+import qualified Crypto.Random.AESCtr import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L-import Control.Exception (bracket, finally, handle, fromException, try, IOException, onException)-import qualified Network.TLS.Extra as TLSExtra-import qualified Data.ByteString as B-import Data.Streaming.Network (bindPortTCP, safeRecv)-import Control.Applicative ((<$>))+import Data.Default.Class (def) import qualified Data.IORef as I-import Control.Exception (Exception, throwIO)+import Data.Streaming.Network (bindPortTCP, safeRecv) import Data.Typeable (Typeable)-import Data.Default.Class (def)-import qualified Crypto.Random.AESCtr-import Network.Wai.Handler.Warp.Buffer (allocateBuffer, bufferSize, freeBuffer)+import Network.Socket (Socket, sClose, withSocketsDo, SockAddr, accept) import Network.Socket.ByteString (sendAll)-import Control.Monad (unless, void)-import Data.ByteString.Lazy.Internal (defaultChunkSize)-import qualified System.IO as IO+import qualified Network.TLS as TLS+import qualified Network.TLS.Extra as TLSExtra+import Network.Wai (Application)+import Network.Wai.Handler.Warp+import Network.Wai.Handler.Warp.Internal import System.IO.Error (isEOFError) ---------------------------------------------------------------- +-- | Settings for WarpTLS. data TLSSettings = TLSSettings { certFile :: FilePath -- ^ File containing the certificate.@@ -67,9 +74,11 @@ , chainCertsMemory :: [S.ByteString] , keyMemory :: Maybe S.ByteString , onInsecure :: OnInsecure- -- ^ Do we allow insecure connections with this server as well? Default- -- is a simple text response stating that a secure connection is required.+ -- ^ 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 -- ^ The level of logging to turn on.@@ -80,13 +89,15 @@ , tlsAllowedVersions :: [TLS.Version] -- ^ The TLS versions this server accepts. --- -- Default: '[TLS.TLS10,TLS.TLS11,TLS.TLS12]'.+ -- >>> tlsAllowedVersions defaultTlsSettings+ -- [TLS12,TLS11,TLS10] -- -- Since 1.4.2 , tlsCiphers :: [TLS.Cipher] -- ^ The TLS ciphers this server accepts. --- -- Default: '[TLSExtra.cipher_AES128_SHA1, TLSExtra.cipher_AES256_SHA1, TLSEtra.cipher_RC4_128_MD5, TLSExtra.cipher_RC4_128_SHA1]'+ -- >>> tlsCiphers defaultTlsSettings+ -- [ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256-SHA256,DHE-RSA-AES128-SHA256,DHE-RSA-AES256-SHA1,DHE-RSA-AES128-SHA1,DHE-DSA-AES128-SHA1,DHE-DSA-AES256-SHA1,RSA-aes128-sha1,RSA-aes256-sha1] -- -- Since 1.4.2 , tlsWantClientCert :: Bool@@ -94,7 +105,8 @@ -- is set to True, you must handle received certificates in a server hook -- or all connections will fail. --- -- Default: False+ -- >>> tlsWantClientCert defaultTlsSettings+ -- False -- -- Since 3.0.2 , tlsServerHooks :: TLS.ServerHooks@@ -107,7 +119,7 @@ -- Since 3.0.2 } --- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name.+-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors). defaultTlsSettings :: TLSSettings defaultTlsSettings = TLSSettings { certFile = "certificate.pem"@@ -118,7 +130,7 @@ , keyMemory = Nothing , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections." , tlsLogging = def- , tlsAllowedVersions = [TLS.TLS10,TLS.TLS11,TLS.TLS12]+ , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10] , tlsCiphers = ciphers , tlsWantClientCert = False , tlsServerHooks = def@@ -135,11 +147,8 @@ , TLSExtra.cipher_DHE_RSA_AES128_SHA1 , TLSExtra.cipher_DHE_DSS_AES128_SHA1 , TLSExtra.cipher_DHE_DSS_AES256_SHA1- , TLSExtra.cipher_DHE_DSS_RC4_SHA1 , TLSExtra.cipher_AES128_SHA1 , TLSExtra.cipher_AES256_SHA1- , TLSExtra.cipher_RC4_128_MD5- , TLSExtra.cipher_RC4_128_SHA1 ] ----------------------------------------------------------------@@ -147,10 +156,11 @@ -- | An action when a plain HTTP comes to HTTP over TLS/SSL port. data OnInsecure = DenyInsecure L.ByteString | AllowInsecure+ deriving (Show) ---------------------------------------------------------------- --- | A smart constructor for 'TLSSettings'.+-- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'. tlsSettings :: FilePath -- ^ Certificate file -> FilePath -- ^ Key file -> TLSSettings@@ -160,7 +170,7 @@ } -- | A smart constructor for 'TLSSettings' that allows specifying--- chain certificates.+-- chain certificates based on 'defaultTlsSettings'. -- -- Since 3.0.3 tlsSettingsChain@@ -175,7 +185,7 @@ } -- | A smart constructor for 'TLSSettings', but uses in-memory representations--- of the certificate and key+-- of the certificate and key based on 'defaultTlsSettings'. -- -- Since 3.0.1 tlsSettingsMemory@@ -188,7 +198,7 @@ } -- | A smart constructor for 'TLSSettings', but uses in-memory representations--- of the certificate and key+-- of the certificate and key based on 'defaultTlsSettings'. -- -- Since 3.0.3 tlsSettingsChainMemory@@ -235,18 +245,45 @@ runSettingsConnectionMakerSecure set get app where get = getter tlsset sock params- params = def {+ params = TLS.ServerParams { TLS.serverWantClientCert = tlsWantClientCert- , TLS.serverSupported = def {- TLS.supportedVersions = tlsAllowedVersions- , TLS.supportedCiphers = tlsCiphers- }- , TLS.serverShared = def {- TLS.sharedCredentials = TLS.Credentials [credential]- }- , TLS.serverHooks = tlsServerHooks+ , TLS.serverCACertificates = []+ , TLS.serverDHEParams = Nothing+ , TLS.serverHooks = hooks+ , TLS.serverShared = shared+ , TLS.serverSupported = supported }+ -- Adding alpn to user's tlsServerHooks.+ hooks = tlsServerHooks {+ TLS.onALPNClientSuggest = Just alpn+ }+ shared = def {+ TLS.sharedCredentials = TLS.Credentials [credential]+ }+ supported = TLS.Supported {+ TLS.supportedVersions = tlsAllowedVersions+ , TLS.supportedCiphers = tlsCiphers+ , TLS.supportedCompressions = [TLS.nullCompression]+ , TLS.supportedHashSignatures = [+ (TLS.HashSHA512, TLS.SignatureRSA)+ , (TLS.HashSHA384, TLS.SignatureRSA)+ , (TLS.HashSHA256, TLS.SignatureRSA)+ , (TLS.HashSHA224, TLS.SignatureRSA)+ , (TLS.HashSHA1, TLS.SignatureRSA)+ , (TLS.HashSHA1, TLS.SignatureDSS)+ ]+ , TLS.supportedSecureRenegotiation = True+ , TLS.supportedSession = True+ } +alpn :: [S.ByteString] -> IO S.ByteString+alpn xs+ | "h2" `elem` xs = return "h2"+ | "h2-16" `elem` xs = return "h2-16"+ | "h2-15" `elem` xs = return "h2-15"+ | "h2-14" `elem` xs = return "h2-14"+ | otherwise = return "http/1.1"+ ---------------------------------------------------------------- getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)@@ -257,79 +294,109 @@ mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Transport) mkConn tlsset s params = do firstBS <- safeRecv s 4096- cachedRef <- I.newIORef firstBS- (if not (B.null firstBS) && B.head firstBS == 0x16 then- httpOverTls tlsset s cachedRef params+ (if not (S.null firstBS) && S.head firstBS == 0x16 then+ httpOverTls tlsset s firstBS params else- plainHTTP tlsset s cachedRef) `onException` sClose s+ plainHTTP tlsset s firstBS) `onException` sClose s ---------------------------------------------------------------- -httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> I.IORef B.ByteString -> params -> IO (Connection, Transport)-httpOverTls TLSSettings{..} s cachedRef params = do+httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)+httpOverTls TLSSettings{..} s bs0 params = do+ recvN <- makePlainReceiveN s bs0 #if MIN_VERSION_tls(1,3,0)- ctx <- TLS.contextNew backend params+ ctx <- TLS.contextNew (backend recvN) params #else gen <- Crypto.Random.AESCtr.makeSystem- ctx <- TLS.contextNew backend params gen+ ctx <- TLS.contextNew (backend recvN) params gen #endif TLS.contextHookSetLogging ctx tlsLogging TLS.handshake ctx- readBuf <- allocateBuffer bufferSize writeBuf <- allocateBuffer bufferSize+ -- Creating a cache for leftover input data.+ ref <- I.newIORef "" tls <- getTLSinfo ctx- return (conn ctx readBuf writeBuf, tls)+ return (conn ctx writeBuf ref, tls) where- backend = TLS.Backend {+ backend recvN = TLS.Backend { TLS.backendFlush = return () , TLS.backendClose = sClose s , TLS.backendSend = sendAll s- , TLS.backendRecv = recvTLS cachedRef s+ , TLS.backendRecv = recvN }- conn ctx readBuf writeBuf = Connection {+ conn ctx writeBuf ref = Connection { connSendMany = TLS.sendData ctx . L.fromChunks- , connSendAll = TLS.sendData ctx . L.fromChunks . return+ , connSendAll = sendall , connSendFile = sendfile , connClose = close- , connRecv = recv- , connSendFileOverride = NotOverride- , connReadBuffer = readBuf+ , connRecv = recv ref+ , connRecvBuf = recvBuf ref , connWriteBuffer = writeBuf , connBufferSize = bufferSize } where- sendfile fp offset len tickle' headers = do- TLS.sendData ctx $ L.fromChunks headers- IO.withBinaryFile fp IO.ReadMode $ \h -> do- IO.hSeek h IO.AbsoluteSeek offset- loop h $ fromIntegral len- where- loop _ remaining | remaining <= 0 = return ()- loop h remaining = do- bs <- B.hGetSome h defaultChunkSize- unless (B.null bs) $ do- let x = B.take remaining bs- TLS.sendData ctx $ L.fromChunks [x]- void $ tickle' -- This tickles the Timer. It MUST be called per chunk.- loop h $ remaining - B.length x+ sendall = TLS.sendData ctx . L.fromChunks . return+ sendfile fid offset len hook headers =+ readSendFile writeBuf bufferSize sendall fid offset len hook headers - close = freeBuffer readBuf `finally`- freeBuffer writeBuf `finally`+ close = freeBuffer writeBuf `finally` void (tryIO $ TLS.bye ctx) `finally` TLS.contextClose ctx - recv = handle onEOF go+ -- TLS version of recv with a cache for leftover input data.+ -- The cache is shared with recvBuf.+ recv cref = do+ cached <- I.readIORef cref+ if cached /= "" then do+ I.writeIORef cref ""+ return cached+ else+ recv'++ -- TLS version of recv (decrypting) without a cache.+ recv' = handle onEOF go where onEOF e- | Just TLS.Error_EOF <- fromException e = return B.empty- | Just ioe <- fromException e, isEOFError ioe = return B.empty | otherwise = throwIO e+ | Just TLS.Error_EOF <- fromException e = return S.empty+ | Just ioe <- fromException e, isEOFError ioe = return S.empty | otherwise = throwIO e go = do x <- TLS.recvData ctx- if B.null x then+ if S.null x then go else return x + -- TLS version of recvBuf with a cache for leftover input data.+ recvBuf cref buf siz = do+ cached <- I.readIORef cref+ (ret, leftover) <- fill cached buf siz recv'+ I.writeIORef cref leftover+ return ret++fill :: S.ByteString -> Buffer -> BufSize -> Recv -> IO (Bool,S.ByteString)+fill bs0 buf0 siz0 recv+ | siz0 <= len0 = do+ let (bs, leftover) = S.splitAt siz0 bs0+ void $ copy buf0 bs+ return (True, leftover)+ | otherwise = do+ buf <- copy buf0 bs0+ loop buf (siz0 - len0)+ where+ len0 = S.length bs0+ loop _ 0 = return (True, "")+ loop buf siz = do+ bs <- recv+ let len = S.length bs+ if len == 0 then return (False, "")+ else if (len <= siz) then do+ buf' <- copy buf bs+ loop buf' (siz - len)+ else do+ let (bs1,bs2) = S.splitAt siz bs+ void $ copy buf bs1+ return (True, bs2)+ getTLSinfo :: TLS.Context -> IO Transport getTLSinfo ctx = do proto <- TLS.getNegotiatedProtocol ctx@@ -355,10 +422,11 @@ ---------------------------------------------------------------- -plainHTTP :: TLSSettings -> Socket -> I.IORef B.ByteString -> IO (Connection, Transport)-plainHTTP TLSSettings{..} s cachedRef = case onInsecure of+plainHTTP :: TLSSettings -> Socket -> S.ByteString -> IO (Connection, Transport)+plainHTTP TLSSettings{..} s bs0 = case onInsecure of AllowInsecure -> do conn' <- socketConnection s+ cachedRef <- I.newIORef bs0 let conn'' = conn' { connRecv = recvPlain cachedRef (connRecv conn') }@@ -371,36 +439,16 @@ ---------------------------------------------------------------- -recvTLS :: I.IORef B.ByteString -> Socket -> Int -> IO B.ByteString-recvTLS cachedRef s size = do- cached <- I.readIORef cachedRef- loop cached- where- loop bs | B.length bs >= size = do- let (x, y) = B.splitAt size bs- I.writeIORef cachedRef y- return x- loop bs1 = do- bs2 <- safeRecv s 4096- if B.null bs2 then do- -- FIXME does this deserve an exception being thrown?- I.writeIORef cachedRef B.empty- return bs1- else- loop $ B.append bs1 bs2------------------------------------------------------------------- -- | 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 B.ByteString -> IO B.ByteString -> IO B.ByteString+recvPlain :: I.IORef S.ByteString -> IO S.ByteString -> IO S.ByteString recvPlain ref fallback = do bs <- I.readIORef ref- if B.null bs+ if S.null bs then fallback else do- I.writeIORef ref B.empty+ I.writeIORef ref S.empty return bs ----------------------------------------------------------------
warp-tls.cabal view
@@ -1,6 +1,6 @@ Name: warp-tls-Version: 3.0.4.2-Synopsis: HTTP over SSL/TLS support for Warp via the TLS package+Version: 3.1.0+Synopsis: HTTP over TLS support for Warp via the TLS package License: MIT License-file: LICENSE Author: Michael Snoyman@@ -10,14 +10,17 @@ Build-Type: Simple Cabal-Version: >=1.6 Stability: Stable-description: API docs and the README are available at <http://www.stackage.org/package/warp-tls>.+description: Support for SSL is now obsoleted.+ HTTP/2 can be negotiated by ALPN.+ API docs and the README are available at+ <http://www.stackage.org/package/warp-tls>. extra-source-files: ChangeLog.md README.md Library Build-Depends: base >= 4 && < 5 , bytestring >= 0.9 , wai >= 3.0 && < 3.1- , warp >= 3.0.8 && < 3.1+ , warp >= 3.1 && < 3.2 , data-default-class >= 0.0.1 , tls >= 1.2.16 , network >= 2.2.1