warp-s2n-tls (empty) → 0.1.0.0
raw patch · 15 files changed
+1841/−0 lines, 15 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, connection, data-default-class, entropy, hspec, http-types, mtl, network, s2n-tls, stm, streaming-commons, tls, unbounded-delays, unliftio, wai, warp, warp-s2n-tls, x509-store
Files
- CHANGELOG.md +13/−0
- LICENSE +190/−0
- README.md +125/−0
- Setup.hs +2/−0
- src/Network/Wai/Handler/WarpS2N.hs +592/−0
- test/AppMonadTests.hs +59/−0
- test/CertLoadingTests.hs +138/−0
- test/IntegrationTests.hs +139/−0
- test/Main.hs +20/−0
- test/ProtocolTests.hs +167/−0
- test/SessionTicketTests.hs +134/−0
- test/TestUtils.hs +135/−0
- test/certs/server-key.pem +28/−0
- test/certs/server.pem +19/−0
- warp-s2n-tls.cabal +80/−0
+ CHANGELOG.md view
@@ -0,0 +1,13 @@+# Changelog++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).++## [Unreleased]++## [0.1.0.0] - 2026-04-28++### Added+- Initial release
+ LICENSE view
@@ -0,0 +1,190 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to the Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ Copyright 2026 Daniel Goertzen++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ README.md view
@@ -0,0 +1,125 @@+# warp-s2n-tls++TLS support for the Warp web server using [s2n-tls](https://github.com/aws/s2n-tls).++## Overview++This library provides an alternative to `warp-tls` by using AWS's s2n-tls+library for TLS termination instead of the Haskell `tls` package.++## Usage++```haskell+import Network.Wai.Handler.WarpS2N+import Network.Wai.Handler.Warp (defaultSettings, setPort)+import Network.Wai (Application)++main :: IO ()+main = do+ let tlsSet = tlsSettings "cert.pem" "key.pem"+ runTLS tlsSet defaultSettings myApp++myApp :: Application+myApp = ...+```+++### Dynamic library loading++To load libs2n.so at runtime instead of linking:++```haskell+main :: IO ()+main = withS2nTls (Dynamic "/usr/local/lib/libs2n.so") $ \tls -> do+ runTLSLib tls tlsSet warpSet myApp+```++## Memory Locking (mlock)++### What is mlock?++s2n-tls uses the Linux `mlock()` system call to lock memory pages containing+cryptographic secrets (private keys, session keys, etc.) into RAM. This prevents+the operating system from swapping these pages to disk, where they could+potentially be recovered by an attacker after your application terminates.++### The RLIMIT_MEMLOCK limit++Linux enforces a per-process limit on how much memory can be locked, controlled+by `RLIMIT_MEMLOCK`. On many systems, this defaults to just **64 KB** (or even+32 KB on some Debian versions). Since s2n-tls locks memory for all TLS+connections and cryptographic operations, this limit can be exhausted quickly+in applications handling multiple connections.++When the limit is exceeded, you'll see errors like:++```+Error Message: 'error calling mlock'+Debug String: 'Error encountered in s2n_mem.c line 106'+```++### Solutions++**Option 1: Increase the mlock limit (recommended for production)**++Raise the limit for your shell session:++```bash+ulimit -l unlimited+```++Or set it to a specific value (in KB):++```bash+ulimit -l 65536 # 64 MB+```++For systemd services, add to your unit file:++```ini+[Service]+LimitMEMLOCK=infinity+```++**Option 2: Disable mlock (acceptable for development/testing)**++Set the environment variable to disable memory locking entirely:++```bash+S2N_DONT_MLOCK=1 ./your-application+```++### Security considerations++- **With mlock enabled**: Secrets are protected from being written to swap,+ reducing the risk of recovery from disk. This is the recommended setting+ for production deployments handling sensitive data.++- **With mlock disabled**: Secrets may be swapped to disk under memory+ pressure. This is generally acceptable for development, testing, and+ applications where the threat model doesn't include disk forensics.++- **Note**: Even with mlock enabled, laptop suspend/hibernate modes may+ save RAM contents to disk regardless of memory locks.++## Development++### Running tests++Tests require `S2N_DONT_MLOCK=1` to avoid exhausting the default mlock limit:++```bash+S2N_DONT_MLOCK=1 cabal test+```++See the [Memory Locking](#memory-locking-mlock) section above for details.+++## Related Packages++- [s2n-tls](https://github.com/goertzenator/s2n-tls) - High-level Haskell bindings (used internally by this package)+- [s2n-tls-ffi](https://github.com/goertzenator/s2n-tls-ffi) - Low-level FFI bindings for direct s2n-tls access++## License++Apache-2.0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Network/Wai/Handler/WarpS2N.hs view
@@ -0,0 +1,592 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : Network.Wai.Handler.WarpS2N+Copyright : (c) 2026 Daniel Goertzen+License : Apache-2.0+Maintainer : daniel.goertzen@gmail.com+Stability : experimental+Portability : non-portable (requires s2n-tls C library)++TLS support for Warp via s2n-tls.++This module provides an alternative to @warp-tls@ using AWS's s2n-tls+library for TLS termination.++Basic usage:++@+import Network.Wai.Handler.WarpS2N+import Network.Wai.Handler.Warp (defaultSettings, setPort)++main :: IO ()+main = do+ let tlsSet = tlsSettings "cert.pem" "key.pem"+ warpSet = setPort 443 defaultSettings+ runTLS tlsSet warpSet myApp+@++For dynamic library loading (ie, to pick FIPS or non-FIPS at runtime):++@+main = withS2nTls (Dynamic "/path/to/libs2n.so") $ \\tls -> do+ let tlsSet = tlsSettings "cert.pem" "key.pem"+ warpSet = setPort 443 defaultSettings+ runTLSLib tls tlsSet warpSet myApp+@++= Memory Locking (mlock)++== What is mlock?++s2n-tls uses the Linux @mlock()@ system call to lock memory pages containing+cryptographic secrets (private keys, session keys, etc.) into RAM. This prevents+the operating system from swapping these pages to disk, where they could+potentially be recovered by an attacker after your application terminates.++== The RLIMIT_MEMLOCK Limit++Linux enforces a per-process limit on how much memory can be locked, controlled+by @RLIMIT_MEMLOCK@. On many systems, this defaults to just __64 KB__ (or even+32 KB on some Debian versions). Since s2n-tls locks memory for all TLS+connections and cryptographic operations, this limit can be exhausted quickly+in applications handling multiple connections.++When the limit is exceeded, you'll see errors like:++> Error Message: 'error calling mlock'+> Debug String: 'Error encountered in s2n_mem.c line 106'++== Solutions++__Option 1: Increase the mlock limit (recommended for production)__++Raise the limit for your shell session:++> ulimit -l unlimited++Or set it to a specific value (in KB):++> ulimit -l 65536 # 64 MB++For systemd services, add to your unit file:++> [Service]+> LimitMEMLOCK=infinity++For persistent user limits, add to @\/etc\/security\/limits.conf@:++> youruser soft memlock unlimited+> youruser hard memlock unlimited++__Option 2: Disable mlock (acceptable for development\/testing)__++Set the environment variable to disable memory locking entirely:++> S2N_DONT_MLOCK=1 ./your-application++== Security Considerations++* __With mlock enabled__: Secrets are protected from being written to swap,+ reducing the risk of recovery from disk. This is the recommended setting+ for production deployments handling sensitive data.++* __With mlock disabled__: Secrets may be swapped to disk under memory+ pressure. This is generally acceptable for development, testing, and+ applications where the threat model doesn't include disk forensics.++* __Note__: Even with mlock enabled, laptop suspend\/hibernate modes may+ save RAM contents to disk regardless of memory locks.++== Running Tests++Tests may exhaust the default mlock limit. Use:++> S2N_DONT_MLOCK=1 cabal test+-}+module Network.Wai.Handler.WarpS2N (+ -- * Running TLS+ runTLS,+ runTLSSocket,+ runTLSLib,+ runTLSSocketLib,++ -- * s2n Initialization (re-exported from s2n-tls)+ withS2nTls,+ S2nTls,+ Library (..),++ -- * Settings+ TLSSettings (..),+ defaultTlsSettings,++ -- * Certificate Settings+ CertSettings (..),++ -- * Smart Constructors+ tlsSettings,+ tlsSettingsChain,+ tlsSettingsMemory,+ tlsSettingsChainMemory,++ -- * Session Tickets+ TicketKeyOps (..),+ basicTicketKeyManager,++ -- * Re-exports from s2n-tls++ -- | Client certificate authentication mode, used with 'tlsWantClientCert'.+ CertAuthType (CertAuthType),+ -- | Do not request a client certificate.+ pattern CertAuthNone,+ -- | Request a client certificate but accept connections that do not provide one.+ pattern CertAuthOptional,+ -- | Require a client certificate; reject connections that do not provide one.+ pattern CertAuthRequired,+) where++import Control.Concurrent.Async (withAsync)+import Control.Concurrent.STM (newTVarIO)+import Control.Concurrent.Thread.Delay (delay)+import Control.Exception (bracket, catch, onException)+import Control.Monad (void)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8+import Data.IORef (IORef, newIORef)+import Data.Streaming.Network (bindPortTCP)+import Data.Word+import Network.Socket (SockAddr, Socket)+import Network.Socket qualified as Socket+import Network.Wai (Application)+import Network.Wai.Handler.Warp (Settings)+import Network.Wai.Handler.Warp qualified as Warp+import Network.Wai.Handler.Warp.Internal qualified as WarpI+import S2nTls+import S2nTls qualified as S2N+import System.Entropy (getEntropy)+import System.IO (IOMode (..), SeekMode (..), hSeek, withBinaryFile)++--------------------------------------------------------------------------------+-- Types+--------------------------------------------------------------------------------++-- | Certificate configuration for TLS.+data CertSettings+ = -- | Load certificate, chain certificates, and key from files.+ -- @CertFromFile certFile chainFiles keyFile@+ CertFromFile !FilePath ![FilePath] !FilePath+ | -- | Use in-memory PEM ByteStrings.+ -- @CertFromMemory certPem chainPems keyPem@+ CertFromMemory !ByteString ![ByteString] !ByteString++{- | Operations available to a ticket key manager.++This record provides an abstraction over the underlying TLS library,+allowing key managers to configure ticket encryption without depending+on s2n-tls internals.+-}+data TicketKeyOps = TicketKeyOps+ { setEncryptDecryptLifetime :: Word64 -> IO ()+ -- ^ Set the lifetime (in seconds) for which a key can both encrypt and decrypt tickets.+ -- After this time, the key will only be used for decryption.+ , setDecryptLifetime :: Word64 -> IO ()+ -- ^ Set the lifetime (in seconds) for which a key can decrypt tickets+ -- after it can no longer encrypt. Total key validity is encrypt/decrypt + decrypt lifetime.+ , addTicketKey :: ByteString -> ByteString -> IO ()+ -- ^ Add a ticket encryption key. Arguments: key name (unique identifier),+ -- key data (should be 32 bytes of cryptographically random data).+ -- The key becomes valid immediately.+ }++{- | Ticket key manager callback type.++The callback receives 'TicketKeyOps' and should:++1. Set up initial ticket encryption keys (runs before server accepts connections)+2. Return an action to be run in an async that rotates keys over time++The separation allows initialization to complete before the server starts+accepting connections, while key rotation continues in the background.+-}++-- | TLS settings for the server.+data TLSSettings = TLSSettings+ { tlsCertSettings :: !CertSettings+ -- ^ Certificate configuration (cert, chain, key).+ , tlsCipherPreferences :: !String+ -- ^ s2n cipher policy name (e.g., "default_tls13", "default").+ -- See s2n documentation for available policies.+ , tlsWantClientCert :: !CertAuthType+ -- ^ Client certificate authentication type.+ , tlsTicketKeyManager :: !(Maybe (TicketKeyOps -> IO (IO ())))+ -- ^ Optional ticket key manager for session resumption via tickets.+ -- This callback registers an initial ticket key and returns a forever running action that adds new keys over time.+ }++{- | Default TLS settings.++* Loads certificate from @certificate.pem@ and key from @key.pem@+* Uses @default_tls13@ cipher policy+* No client certificate authentication+* Uses 'basicTicketKeyManager' with 2 hour encrypt\/decrypt and 13 hour decrypt lifetimes+-}+defaultTlsSettings :: TLSSettings+defaultTlsSettings =+ TLSSettings+ { tlsCertSettings = CertFromFile "certificate.pem" [] "key.pem"+ , tlsCipherPreferences = "default_tls13"+ , tlsWantClientCert = CertAuthNone+ , tlsTicketKeyManager = Just $ basicTicketKeyManager (2 * 60 * 60) (13 * 60 * 60)+ }++--------------------------------------------------------------------------------+-- Smart Constructors+--------------------------------------------------------------------------------++-- | Create TLS settings from certificate and key files.+tlsSettings ::+ -- | Certificate file+ FilePath ->+ -- | Key file+ FilePath ->+ TLSSettings+tlsSettings cert key =+ defaultTlsSettings+ { tlsCertSettings = CertFromFile cert [] key+ }++-- | Create TLS settings from certificate, chain certificates, and key files.+tlsSettingsChain ::+ -- | Certificate file+ FilePath ->+ -- | Chain certificate files+ [FilePath] ->+ -- | Key file+ FilePath ->+ TLSSettings+tlsSettingsChain cert chain key =+ defaultTlsSettings+ { tlsCertSettings = CertFromFile cert chain key+ }++-- | Create TLS settings from in-memory PEM data.+tlsSettingsMemory ::+ -- | Certificate PEM+ ByteString ->+ -- | Key PEM+ ByteString ->+ TLSSettings+tlsSettingsMemory cert key =+ defaultTlsSettings+ { tlsCertSettings = CertFromMemory cert [] key+ }++-- | Create TLS settings from in-memory PEM data with chain certificates.+tlsSettingsChainMemory ::+ -- | Certificate PEM+ ByteString ->+ -- | Chain certificate PEMs+ [ByteString] ->+ -- | Key PEM+ ByteString ->+ TLSSettings+tlsSettingsChainMemory cert chain key =+ defaultTlsSettings+ { tlsCertSettings = CertFromMemory cert chain key+ }++--------------------------------------------------------------------------------+-- Session Tickets+--------------------------------------------------------------------------------++{- | Basic ticket key manager with automatic key rotation.++Parameters:++* @encryptDecryptLifetimeSecs@: How long (in seconds) a key can both encrypt and decrypt tickets+* @decryptLifetimeSecs@: How long (in seconds) a key can decrypt after it stops encrypting++This manager:++* Sets the encrypt\/decrypt and decrypt lifetimes as specified+* Installs an initial key immediately+* Rotates in a new key every @encryptDecryptLifetimeSecs / 2@ seconds++The key rotation schedule ensures that:++* New tickets are always encrypted with a key that won't expire soon+* Old tickets remain valid for decryption during the overlap period+* Gradual key rollover provides seamless session resumption+-}+basicTicketKeyManager :: Word64 -> Word64 -> TicketKeyOps -> IO (IO ())+basicTicketKeyManager encryptDecryptLifetimeSecs decryptLifetimeSecs ops = do+ -- Set key lifetimes+ ops.setEncryptDecryptLifetime encryptDecryptLifetimeSecs+ ops.setDecryptLifetime decryptLifetimeSecs+ -- Install initial key+ installKey 0+ -- Return the rotation action+ pure $ rotateKeys 1+ where+ rotateIntervalMicros :: Integer+ rotateIntervalMicros = fromIntegral encryptDecryptLifetimeSecs * 1_000_000 `div` 2++ installKey :: Word64 -> IO ()+ installKey counter = do+ let keyName = BS8.pack $ "key" <> show counter+ keyData <- getEntropy 32+ ops.addTicketKey keyName keyData++ rotateKeys :: Word64 -> IO ()+ rotateKeys counter = do+ delay rotateIntervalMicros+ installKey counter+ rotateKeys (counter + 1)++--------------------------------------------------------------------------------+-- Running a Warp Server with TLS+--------------------------------------------------------------------------------++{- | Run a Warp server with TLS support.++This is the simplest way to run a TLS server. It initializes the s2n-tls+library, binds to the port specified in 'Settings', and+handles TLS connections.++@+import Network.Wai.Handler.WarpS2N+import Network.Wai.Handler.Warp (defaultSettings, setPort)++main :: IO ()+main = do+ let tlsSet = tlsSettings "cert.pem" "key.pem"+ warpSet = setPort 443 defaultSettings+ runTLS tlsSet warpSet myApp+@+-}+runTLS :: TLSSettings -> Settings -> Application -> IO ()+runTLS tlsSet settings app =+ withS2nTls Linked $ \tls ->+ runTLSLib tls tlsSet settings app++{- | Run a Warp server with TLS support on an existing socket.++This is useful when you need more control over socket creation,+such as for Unix domain sockets or when using socket activation.+Initializes s2n-tls automatically.+-}+runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()+runTLSSocket tlsSet settings sock app =+ withS2nTls Linked $ \tls ->+ runTLSSocketLib tls tlsSet settings sock app++{- | Run a Warp server with TLS support, using an existing 'S2nTls' handle.++This binds to the port specified in 'Settings' and+handles TLS connections using s2n-tls.++Use this when the specific s2n-tls library will be dynamically selected at runtime.+-}+runTLSLib :: S2nTls -> TLSSettings -> Settings -> Application -> IO ()+runTLSLib tls tlsSet settings app = do+ let host = Warp.getHost settings+ port = Warp.getPort settings+ bracket+ (bindPortTCP port host)+ Socket.close+ (\sock -> runTLSSocketLib tls tlsSet settings sock app)++{- | Run a Warp server with TLS support on an existing socket, using an existing 'S2nTls' handle.++This is useful when you need more control over socket creation,+such as for Unix domain sockets or when using socket activation.++Use this when the specific s2n-tls library will be dynamically selected at runtime+-}+runTLSSocketLib :: S2nTls -> TLSSettings -> Settings -> Socket -> Application -> IO ()+runTLSSocketLib tls tlsSet@TLSSettings{..} settings sock app = do+ -- Initialize s2n config+ config <- initS2nConfig tls tlsSet++ -- Set up ticket key manager if configured, then run the server+ rotateAction <- case tlsTicketKeyManager of+ Nothing -> pure (pure ()) -- dummy rotation action+ Just keyManager -> do+ -- Turn on session tickets in config since we have a key manager+ tls.setSessionTicketsOnOff config True+ -- Create TicketKeyOps for the key manager+ let ops =+ TicketKeyOps+ { setEncryptDecryptLifetime = tls.setTicketEncryptDecryptKeyLifetime config+ , setDecryptLifetime = tls.setTicketDecryptKeyLifetime config+ , addTicketKey = \keyName keyData ->+ tls.addTicketCryptoKey config keyName keyData Nothing+ }+ -- Call the key manager to set up initial keys and get rotation action+ keyManager ops++ -- Run server with key rotation in background+ withAsync rotateAction $ \_ ->+ WarpI.runSettingsConnectionMakerSecure settings (getter tls config) app+ where+ getter :: S2nTls -> S2N.Config -> IO (IO (WarpI.Connection, WarpI.Transport), SockAddr)+ getter tls' config = do+ (clientSock, clientAddr) <- Socket.accept sock+ let mkConn =+ makeTLSConnection tls' config clientSock clientAddr+ `onException` Socket.close clientSock+ pure (mkConn, clientAddr)++--------------------------------------------------------------------------------+-- Internal: s2n Configuration+--------------------------------------------------------------------------------++-- | Initialize an s2n Config from TLSSettings.+initS2nConfig :: S2nTls -> TLSSettings -> IO S2N.Config+initS2nConfig tls TLSSettings{..} = do+ config <- tls.newConfig++ -- Set cipher preferences+ tls.setCipherPreferences config tlsCipherPreferences++ -- Set client auth type+ tls.setClientAuthType config tlsWantClientCert++ -- Load certificates+ loadCertSettings tls config tlsCertSettings++ pure config++-- | Load certificates into an s2n Config based on CertSettings.+loadCertSettings :: S2nTls -> S2N.Config -> CertSettings -> IO ()+loadCertSettings tls config certSettings = case certSettings of+ CertFromFile certFile chainFiles keyFile -> do+ certPem <- BS.readFile certFile+ keyPem <- BS.readFile keyFile+ chainPems <- mapM BS.readFile chainFiles+ loadCertPems tls config certPem chainPems keyPem+ CertFromMemory certPem chainPems keyPem ->+ loadCertPems tls config certPem chainPems keyPem++-- | Load certificate PEMs into config. Chain certs are concatenated with the main cert.+loadCertPems :: S2nTls -> S2N.Config -> ByteString -> [ByteString] -> ByteString -> IO ()+loadCertPems tls config certPem chainPems keyPem = do+ -- s2n expects the full chain in one PEM blob (cert + intermediates)+ let fullChain = BS.concat (certPem : chainPems)+ certKey <- tls.loadCertChainAndKeyPem fullChain keyPem+ tls.addCertChainAndKeyToStore config certKey++--------------------------------------------------------------------------------+-- Internal: Connection Handling+--------------------------------------------------------------------------------++-- | Create a TLS-wrapped Warp Connection from an accepted socket.+makeTLSConnection ::+ S2nTls ->+ S2N.Config ->+ Socket ->+ SockAddr ->+ IO (WarpI.Connection, WarpI.Transport)+makeTLSConnection tls config clientSock clientAddr = do+ -- Create s2n connection+ conn <- tls.newConnection Server+ tls.setConnectionConfig conn config+ tls.setSocket conn clientSock++ -- Perform TLS handshake+ tls.blockingNegotiate conn++ -- Get connection info for Transport+ tlsVersion <- tls.getActualProtocolVersion conn+ alpn <- tls.getApplicationProtocol conn++ -- Create Warp connection+ warpConn <- wrapS2nConnection tls conn clientSock clientAddr++ -- Create transport info+ let (major, minor) = tlsVersionToMajorMinor tlsVersion+ transport =+ WarpI.TLS+ { tlsMajorVersion = major+ , tlsMinorVersion = minor+ , tlsNegotiatedProtocol = BS8.pack <$> alpn+ , tlsChiperID = 0 -- TODO: parse cipher ID from cipher name+ , tlsClientCertificate = Nothing -- TODO: extract from s2n if client auth enabled+ }++ pure (warpConn, transport)++-- | Wrap an s2n Connection as a Warp Connection.+wrapS2nConnection ::+ S2nTls ->+ S2N.Connection ->+ Socket ->+ SockAddr ->+ IO WarpI.Connection+wrapS2nConnection tls conn clientSock clientAddr = do+ writeBuffer <- allocateWriteBuffer+ http2Ref <- newIORef False+ inProgressTVar <- newTVarIO 0++ pure+ WarpI.Connection+ { connSendMany = mapM_ (tls.blockingSendAll conn)+ , connSendAll = tls.blockingSendAll conn+ , connSendFile = sendFileTLS tls conn+ , connClose = closeTLSConnection tls conn clientSock+ , connRecv = tls.blockingRecv conn 4096+ , connRecvBuf = recvBufTLS tls conn+ , connWriteBuffer = writeBuffer+ , connHTTP2 = http2Ref+ , connMySockAddr = clientAddr+ , connAppsInProgress = inProgressTVar+ }++-- | Receive data into a buffer over TLS.+recvBufTLS :: S2nTls -> S2N.Connection -> WarpI.Buffer -> WarpI.BufSize -> IO Bool+recvBufTLS tls conn buf bufSize = do+ bs <- tls.blockingRecv conn bufSize+ if BS.null bs+ then pure False+ else do+ _ <- WarpI.copy buf bs+ pure True++-- | Send a file over TLS by reading and sending chunks.+sendFileTLS :: S2nTls -> S2N.Connection -> WarpI.FileId -> Integer -> Integer -> IO () -> [ByteString] -> IO ()+sendFileTLS tls conn fileId offset len hook headers = do+ -- Send headers first+ mapM_ (tls.blockingSendAll conn) headers+ -- Read the file portion and send via TLS+ let path = WarpI.fileIdPath fileId+ bs <- withBinaryFile path ReadMode $ \h -> do+ hSeek h AbsoluteSeek (fromIntegral offset)+ BS.hGet h (fromIntegral len)+ tls.blockingSendAll conn bs+ hook++-- | Close a TLS connection properly.+closeTLSConnection :: S2nTls -> S2N.Connection -> Socket -> IO ()+closeTLSConnection tls conn sock = do+ -- Attempt graceful TLS shutdown, ignore errors+ void (tls.blockingShutdown conn) `catch` \(_ :: S2nError) -> pure ()+ Socket.close sock++-- | Convert TlsVersion to (major, minor) for Warp's Transport.+tlsVersionToMajorMinor :: TlsVersion -> (Int, Int)+tlsVersionToMajorMinor v = case v of+ SSLv2 -> (2, 0)+ SSLv3 -> (3, 0)+ TLS10 -> (3, 1)+ TLS11 -> (3, 2)+ TLS12 -> (3, 3)+ TLS13 -> (3, 4)++-- | Allocate a write buffer for Warp Connection.+allocateWriteBuffer :: IO (IORef WarpI.WriteBuffer)+allocateWriteBuffer = WarpI.createWriteBuffer 16_384 >>= newIORef
+ test/AppMonadTests.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE NumericUnderscores #-}++module AppMonadTests (appMonadSpec) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (race_)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Data.ByteString.Lazy.Char8 qualified as LBS8+import Network.HTTP.Types (status200)+import Network.Wai (Application, responseLBS)+import Network.Wai.Handler.Warp (defaultSettings)+import S2nTls (S2nTls (..))+import Test.Hspec (SpecWith, it)+import UnliftIO (MonadIO (..), withRunInIO)++import Network.Wai.Handler.WarpS2N (runTLSLib, tlsSettings)++import TestUtils (testCertPath, testKeyPath)++-- | Dummy environment for testing MonadUnliftIO ergonomics+data Env = Env+ { envName :: String+ , envTls :: S2nTls+ }++-- | Our application monad+type AppM = ReaderT Env IO++-- | Run a brief server in AppM to test API ergonomics+runBriefServer :: AppM ()+runBriefServer = do+ env <- ask+ liftIO $ putStrLn $ "Starting server with env: " ++ envName env++ let tlsSet = tlsSettings testCertPath testKeyPath++ -- AppM Application pattern - demonstrates creating a WAI Application+ -- that can access the ReaderT environment+ let mkApp :: AppM Application+ mkApp = withRunInIO $ \runInIO -> pure $ \_request respond -> do+ Env{envName} <- runInIO ask+ respond $ responseLBS status200 [] (LBS8.pack envName)+ app <- mkApp++ -- Run server for 2 seconds then kill it+ -- Server runs in IO, but we're orchestrating from AppM+ liftIO $+ race_+ (threadDelay 2_000_000)+ (runTLSLib (envTls env) tlsSet defaultSettings app)++ liftIO $ putStrLn "Server stopped"++-- | Test that the API works ergonomically with a custom monad stack+appMonadSpec :: SpecWith S2nTls+appMonadSpec = do+ it "runs server in ReaderT Env IO" $ \tls -> do+ let env = Env{envName = "test-env", envTls = tls}+ runReaderT runBriefServer env
+ test/CertLoadingTests.hs view
@@ -0,0 +1,138 @@+module CertLoadingTests (certLoadingSpec) where++import Control.Exception (SomeException, try)+import Data.ByteString qualified as BS+import S2nTls (S2nTls (..))+import Test.Hspec (SpecWith, describe, expectationFailure, it, shouldBe, shouldSatisfy)++import Network.Wai.Handler.WarpS2N (+ CertSettings (..),+ TLSSettings (..),+ defaultTlsSettings,+ tlsSettings,+ tlsSettingsChain,+ tlsSettingsChainMemory,+ tlsSettingsMemory,+ )++import TestUtils++certLoadingSpec :: SpecWith S2nTls+certLoadingSpec = do+ describe "Smart constructors" smartConstructorsSpec+ describe "File loading" fileLoadingSpec+ describe "Memory loading" memoryLoadingSpec+ describe "Invalid certificates" invalidCertsSpec++smartConstructorsSpec :: SpecWith S2nTls+smartConstructorsSpec = do+ it "tlsSettings creates CertFromFile with empty chain" $ \_ -> do+ let settings = tlsSettings "cert.pem" "key.pem"+ case tlsCertSettings settings of+ CertFromFile cert chain key -> do+ cert `shouldBe` "cert.pem"+ chain `shouldBe` []+ key `shouldBe` "key.pem"+ _ -> expectationFailure "Expected CertFromFile"++ it "tlsSettingsChain includes chain files" $ \_ -> do+ let settings = tlsSettingsChain "cert.pem" ["inter1.pem", "inter2.pem"] "key.pem"+ case tlsCertSettings settings of+ CertFromFile cert chain key -> do+ cert `shouldBe` "cert.pem"+ chain `shouldBe` ["inter1.pem", "inter2.pem"]+ key `shouldBe` "key.pem"+ _ -> expectationFailure "Expected CertFromFile"++ it "tlsSettingsMemory creates CertFromMemory" $ \_ -> do+ let settings = tlsSettingsMemory "CERT" "KEY"+ case tlsCertSettings settings of+ CertFromMemory cert chain key -> do+ cert `shouldBe` "CERT"+ chain `shouldBe` []+ key `shouldBe` "KEY"+ _ -> expectationFailure "Expected CertFromMemory"++ it "tlsSettingsChainMemory includes chain data" $ \_ -> do+ let settings = tlsSettingsChainMemory "CERT" ["INTER1", "INTER2"] "KEY"+ case tlsCertSettings settings of+ CertFromMemory cert chain key -> do+ cert `shouldBe` "CERT"+ chain `shouldBe` ["INTER1", "INTER2"]+ key `shouldBe` "KEY"+ _ -> expectationFailure "Expected CertFromMemory"++ it "defaultTlsSettings has expected defaults" $ \_ -> do+ let settings = defaultTlsSettings+ tlsCipherPreferences settings `shouldBe` "default_tls13"+ case tlsCertSettings settings of+ CertFromFile cert _ key -> do+ cert `shouldBe` "certificate.pem"+ key `shouldBe` "key.pem"+ _ -> expectationFailure "Expected CertFromFile"++fileLoadingSpec :: SpecWith S2nTls+fileLoadingSpec = do+ it "loads valid cert and key from files" $ \tls -> do+ let settings = tlsSettings testCertPath testKeyPath+ result <- try @SomeException $ withTestServer tls settings $ \_ -> pure ()+ result `shouldSatisfy` isRight++ it "loads cert with empty chain" $ \tls -> do+ let settings = tlsSettingsChain testCertPath [] testKeyPath+ result <- try @SomeException $ withTestServer tls settings $ \_ -> pure ()+ result `shouldSatisfy` isRight++memoryLoadingSpec :: SpecWith S2nTls+memoryLoadingSpec = do+ it "loads valid cert and key from memory" $ \tls -> do+ cert <- loadTestCert+ key <- loadTestKey+ let settings = tlsSettingsMemory cert key+ result <- try @SomeException $ withTestServer tls settings $ \_ -> pure ()+ result `shouldSatisfy` isRight++ it "loads cert with empty chain from memory" $ \tls -> do+ cert <- loadTestCert+ key <- loadTestKey+ let settings = tlsSettingsChainMemory cert [] key+ result <- try @SomeException $ withTestServer tls settings $ \_ -> pure ()+ result `shouldSatisfy` isRight++invalidCertsSpec :: SpecWith S2nTls+invalidCertsSpec = do+ it "fails with nonexistent cert file" $ \tls -> do+ let settings = tlsSettings "nonexistent-cert.pem" testKeyPath+ result <- try @SomeException $ withTestServer tls settings $ \_ -> pure ()+ result `shouldSatisfy` isLeft++ it "fails with nonexistent key file" $ \tls -> do+ let settings = tlsSettings testCertPath "nonexistent-key.pem"+ result <- try @SomeException $ withTestServer tls settings $ \_ -> pure ()+ result `shouldSatisfy` isLeft++ it "fails with invalid PEM data" $ \tls -> do+ let settings = tlsSettingsMemory "not a valid cert" "not a valid key"+ result <- try @SomeException $ withTestServer tls settings $ \_ -> pure ()+ result `shouldSatisfy` isLeft++ it "fails with empty cert" $ \tls -> do+ let settings = tlsSettingsMemory BS.empty BS.empty+ result <- try @SomeException $ withTestServer tls settings $ \_ -> pure ()+ result `shouldSatisfy` isLeft++ it "fails with mismatched cert and key" $ \tls -> do+ cert <- loadTestCert+ let fakeKey = "-----BEGIN PRIVATE KEY-----\nMIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQC7\n-----END PRIVATE KEY-----\n"+ let settings = tlsSettingsMemory cert fakeKey+ result <- try @SomeException $ withTestServer tls settings $ \_ -> pure ()+ result `shouldSatisfy` isLeft++-- Helpers+isRight :: Either a b -> Bool+isRight (Right _) = True+isRight _ = False++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False
+ test/IntegrationTests.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE NumericUnderscores #-}++module IntegrationTests (integrationSpec) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (replicateConcurrently)+import Control.Exception (SomeException, try)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Network.Connection qualified as Conn+import S2nTls (S2nTls (..))+import Test.Hspec (SpecWith, describe, expectationFailure, it, shouldBe, shouldSatisfy)++import Network.Wai.Handler.WarpS2N (tlsSettings)++import TestUtils++integrationSpec :: SpecWith S2nTls+integrationSpec = do+ describe "Basic TLS roundtrip" basicRoundtripSpec+ describe "Multiple requests" multipleRequestsSpec+ describe "Concurrent connections" concurrentSpec+ describe "Large payloads" largePayloadSpec++basicRoundtripSpec :: SpecWith S2nTls+basicRoundtripSpec = do+ it "establishes TLS connection and receives response" $ \tls -> do+ let settings = tlsSettings testCertPath testKeyPath+ withTestServer tls settings $ \port -> do+ result <- makeSecureRequest port+ case result of+ Left err -> expectationFailure $ "Request failed: " ++ err+ Right response -> do+ let responseStr = LBS.toStrict response+ responseStr `shouldSatisfy` BS.isInfixOf "HTTP"+ responseStr `shouldSatisfy` BS.isInfixOf "200"+ responseStr `shouldSatisfy` BS.isInfixOf "blarg"++ it "handles connection close gracefully" $ \tls -> do+ let settings = tlsSettings testCertPath testKeyPath+ withTestServer tls settings $ \port -> do+ result <- makeSecureRequest port+ case result of+ Left err -> expectationFailure $ "Request failed: " ++ err+ Right _ -> pure ()+ result2 <- makeSecureRequest port+ case result2 of+ Left err -> expectationFailure $ "Second request failed: " ++ err+ Right _ -> pure ()++multipleRequestsSpec :: SpecWith S2nTls+multipleRequestsSpec = do+ it "handles 10 sequential requests" $ \tls -> do+ let settings = tlsSettings testCertPath testKeyPath+ withTestServer tls settings $ \port -> do+ results <- mapM (\_ -> makeSecureRequest port) [1 .. 10 :: Int]+ let failures = [e | Left e <- results]+ failures `shouldBe` []++ it "handles requests with small delays" $ \tls -> do+ let settings = tlsSettings testCertPath testKeyPath+ withTestServer tls settings $ \port -> do+ results <-+ mapM+ ( \_ -> do+ threadDelay 50_000+ makeSecureRequest port+ )+ [1 .. 5 :: Int]+ let failures = [e | Left e <- results]+ failures `shouldBe` []++concurrentSpec :: SpecWith S2nTls+concurrentSpec = do+ it "handles 10 concurrent connections" $ \tls -> do+ let settings = tlsSettings testCertPath testKeyPath+ withTestServer tls settings $ \port -> do+ results <- replicateConcurrently 10 (makeSecureRequest port)+ let successes = length [() | Right _ <- results]+ successes `shouldBe` 10++ it "handles 25 concurrent connections" $ \tls -> do+ let settings = tlsSettings testCertPath testKeyPath+ withTestServer tls settings $ \port -> do+ results <- replicateConcurrently 25 (makeSecureRequest port)+ let successes = length [() | Right _ <- results]+ successes `shouldSatisfy` (>= 23)++largePayloadSpec :: SpecWith S2nTls+largePayloadSpec = do+ it "client can send larger request" $ \tls -> do+ let settings = tlsSettings testCertPath testKeyPath+ withTestServer tls settings $ \port -> do+ result <- try @SomeException $ do+ ctx <- Conn.initConnectionContext+ conn <-+ Conn.connectTo+ ctx+ Conn.ConnectionParams+ { Conn.connectionHostname = "localhost"+ , Conn.connectionPort = fromIntegral port+ , Conn.connectionUseSecure =+ Just+ Conn.TLSSettingsSimple+ { Conn.settingDisableCertificateValidation = True+ , Conn.settingDisableSession = False+ , Conn.settingUseServerName = True+ }+ , Conn.connectionUseSocks = Nothing+ }++ let body = BS.replicate 1_000_000 0x41+ request =+ BS.concat+ [ "POST / HTTP/1.1\r\n"+ , "Host: localhost\r\n"+ , "Content-Length: 1000000\r\n"+ , "Connection: close\r\n"+ , "\r\n"+ , body+ ]+ Conn.connectionPut conn request++ response <- readAll conn+ Conn.connectionClose conn+ pure response++ case result of+ Left e -> expectationFailure $ "Large request failed: " ++ show e+ Right response ->+ BS.length response `shouldSatisfy` (> 0)+ where+ readAll conn = do+ chunk <- Conn.connectionGetChunk conn+ if BS.null chunk+ then pure BS.empty+ else do+ rest <- readAll conn+ pure (chunk <> rest)
+ test/Main.hs view
@@ -0,0 +1,20 @@+module Main (main) where++import Test.Hspec++import Network.Wai.Handler.WarpS2N (Library (..), withS2nTls)++import AppMonadTests (appMonadSpec)+import CertLoadingTests (certLoadingSpec)+import IntegrationTests (integrationSpec)+import ProtocolTests (protocolSpec)+import SessionTicketTests (sessionTicketSpec)++main :: IO ()+main = hspec $ do+ aroundAll (withS2nTls Linked) $ do+ describe "Certificate Loading" certLoadingSpec+ describe "Integration" integrationSpec+ describe "Protocol" protocolSpec+ describe "AppMonad ergonomics" appMonadSpec+ sessionTicketSpec
+ test/ProtocolTests.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE NumericUnderscores #-}++module ProtocolTests (protocolSpec) where++import Control.Applicative+import Control.Exception (SomeException, bracket, try)+import Data.Default.Class (def)+import Network.HTTP.Types (status200)+import Network.Socket qualified as Socket+import Network.Socket.ByteString qualified as SocketBS+import Network.TLS qualified as TLS+import Network.TLS.Extra.Cipher qualified as TLS+import Network.Wai (responseLBS)+import Network.Wai.Handler.Warp (defaultSettings, setBeforeMainLoop)+import Network.Wai.Handler.WarpS2N (+ TLSSettings (..),+ runTLSSocketLib,+ tlsSettings,+ )+import S2nTls (S2nTls (..))+import Test.Hspec (SpecWith, describe, expectationFailure, it, shouldBe)+import TestUtils+import UnliftIO.Async+import UnliftIO.Concurrent+import UnliftIO.STM++protocolSpec :: SpecWith S2nTls+protocolSpec = do+ describe "TLS version negotiation" versionNegotiationSpec+ describe "Cipher preferences" cipherPreferencesSpec++versionNegotiationSpec :: SpecWith S2nTls+versionNegotiationSpec = do+ it "negotiates TLS 1.3 with default settings" $ \tls -> do+ let serverSettings = tlsSettings testCertPath testKeyPath+ negotiatedVersion <- withTestServerGetVersion tls serverSettings [TLS.TLS13, TLS.TLS12]+ case negotiatedVersion of+ Just TLS.TLS13 -> pure ()+ Just v -> expectationFailure $ "Expected TLS 1.3, got " ++ show v+ Nothing -> expectationFailure "Failed to get negotiated version"++ it "negotiates TLS 1.2 when client only supports TLS 1.2" $ \tls -> do+ let serverSettings =+ (tlsSettings testCertPath testKeyPath)+ { tlsCipherPreferences = "default"+ }+ negotiatedVersion <- withTestServerGetVersion tls serverSettings [TLS.TLS12]+ case negotiatedVersion of+ Just TLS.TLS12 -> pure ()+ Just v -> expectationFailure $ "Expected TLS 1.2, got " ++ show v+ Nothing -> expectationFailure "Failed to get negotiated version"++ it "fails when no common TLS version" $ \tls -> do+ let serverSettings =+ (tlsSettings testCertPath testKeyPath)+ { tlsCipherPreferences = "default_tls13"+ }+ result <-+ try @SomeException $+ withTestServerGetVersion tls serverSettings [TLS.TLS10]+ case result of+ Left _ -> pure ()+ Right (Just v) -> expectationFailure $ "Should have failed but got " ++ show v+ Right Nothing -> pure ()++cipherPreferencesSpec :: SpecWith S2nTls+cipherPreferencesSpec = do+ it "accepts connection with default_tls13 policy" $ \tls -> do+ let serverSettings =+ (tlsSettings testCertPath testKeyPath)+ { tlsCipherPreferences = "default_tls13"+ }+ result <- withTestServerConnect tls serverSettings+ result `shouldBe` True++ it "accepts connection with default policy" $ \tls -> do+ let serverSettings =+ (tlsSettings testCertPath testKeyPath)+ { tlsCipherPreferences = "default"+ }+ result <- withTestServerConnect tls serverSettings+ result `shouldBe` True++-- | Helper: Start server and get negotiated TLS version from client perspective+withTestServerGetVersion :: S2nTls -> TLSSettings -> [TLS.Version] -> IO (Maybe TLS.Version)+withTestServerGetVersion tls tlsSet clientVersions =+ bracket bindFreePort (Socket.close . fst) $ \(sock, port) -> do+ serverReady <- newEmptyTMVarIO+ let app _ respond = respond $ responseLBS status200 [] "blarg!"+ warpSet = setBeforeMainLoop (atomically $ putTMVar serverReady ()) defaultSettings+ withAsync (runTLSSocketLib tls tlsSet warpSet sock app) $ \as -> do+ atomically $ waitSTM as <|> takeTMVar serverReady+ threadDelay 10_000+ backend <- makeClientSocket port+ params <- makeClientParams clientVersions+ ctx <- TLS.contextNew backend params+ TLS.handshake ctx+ info <- TLS.contextGetInformation ctx+ let version = TLS.infoVersion <$> info+ TLS.bye ctx+ pure version++-- | Helper: Start server and test if connection succeeds+withTestServerConnect :: S2nTls -> TLSSettings -> IO Bool+withTestServerConnect tls tlsSet =+ bracket bindFreePort (Socket.close . fst) $ \(sock, port) -> do+ serverReady <- newEmptyTMVarIO++ let app _ respond = respond $ responseLBS status200 [] "blarg!"+ warpSet = setBeforeMainLoop (atomically $ putTMVar serverReady ()) defaultSettings++ withAsync (runTLSSocketLib tls tlsSet warpSet sock app) $ \as -> do+ atomically $ waitSTM as <|> takeTMVar serverReady+ threadDelay 10_000++ result <- try @SomeException $ do+ backend <- makeClientSocket port+ params <- makeClientParams [TLS.TLS13, TLS.TLS12]+ ctx <- TLS.contextNew backend params+ TLS.handshake ctx+ TLS.sendData ctx "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ _ <- TLS.recvData ctx+ TLS.bye ctx++ pure $ case result of+ Left _ -> False+ Right _ -> True++-- | Create client TLS parameters+makeClientParams :: [TLS.Version] -> IO TLS.ClientParams+makeClientParams versions = do+ pure $+ (TLS.defaultParamsClient "localhost" "")+ { TLS.clientSupported =+ def+ { TLS.supportedCiphers = TLS.ciphersuite_strong+ , TLS.supportedVersions = versions+ }+ , TLS.clientShared = def+ , TLS.clientHooks =+ def+ { TLS.onServerCertificate = \_ _ _ _ -> pure []+ }+ }++-- | Create a client socket connected to localhost:port+makeClientSocket :: Int -> IO TLS.Backend+makeClientSocket port = do+ sock <- Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol+ Socket.connect sock (Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (127, 0, 0, 1)))+ pure $+ TLS.Backend+ { TLS.backendFlush = pure ()+ , TLS.backendClose = Socket.close sock+ , TLS.backendSend = SocketBS.sendAll sock+ , TLS.backendRecv = SocketBS.recv sock+ }++-- | Bind to a free port+bindFreePort :: IO (Socket.Socket, Int)+bindFreePort = do+ sock <- Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol+ Socket.setSocketOption sock Socket.ReuseAddr 1+ Socket.bind sock (Socket.SockAddrInet 0 (Socket.tupleToHostAddress (127, 0, 0, 1)))+ Socket.listen sock 5+ port <- Socket.socketPort sock+ pure (sock, fromIntegral port)
+ test/SessionTicketTests.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE NumericUnderscores #-}++module SessionTicketTests (sessionTicketSpec) where++import Control.Applicative+import Control.Exception (bracket)+import Data.ByteString qualified as BS+import Data.IORef (newIORef, readIORef, writeIORef)+import Network.HTTP.Types (status200)+import Network.Socket qualified as Net+import Network.Wai (Application, responseLBS)+import Network.Wai.Handler.Warp (defaultSettings, setBeforeMainLoop)+import Network.Wai.Handler.WarpS2N (S2nTls, runTLSSocketLib, tlsSettings)+import S2nTls qualified+import Test.Hspec+import TestUtils (testCertPath, testKeyPath)+import UnliftIO.Async+import UnliftIO.Concurrent+import UnliftIO.STM++-- | Simple application that echoes back the request path+echoApp :: Application+echoApp _req respond = respond $ responseLBS status200 [] "OK"++-- | Run a test server and execute an action with its port+withTicketTestServer :: S2nTls -> (Net.PortNumber -> IO a) -> IO a+withTicketTestServer tls action = do+ -- Create and bind socket+ sock <- Net.socket Net.AF_INET Net.Stream Net.defaultProtocol+ Net.setSocketOption sock Net.ReuseAddr 1+ Net.bind sock (Net.SockAddrInet 0 (Net.tupleToHostAddress (127, 0, 0, 1)))+ Net.listen sock 5+ port <- Net.socketPort sock++ serverReady <- newEmptyTMVarIO+ let warpSet = setBeforeMainLoop (atomically $ putTMVar serverReady ()) defaultSettings+ -- Use default tlsSettings which includes basicTicketKeyManager+ tlsSet = tlsSettings testCertPath testKeyPath++ -- Run server in background+ withAsync (runTLSSocketLib tls tlsSet warpSet sock echoApp) $ \as -> do+ startupResult <-+ atomically $+ (Left <$> waitCatchSTM as)+ <|> (Right <$> takeTMVar serverReady)+ case startupResult of+ Right () -> pure ()+ Left e -> do+ Net.close sock+ error $ "Server failed to start: " <> show e++ -- Small delay for server to be fully ready+ threadDelay 50_000++ -- Run the test action+ result <- action port++ -- Cleanup+ Net.close sock+ threadDelay 100_000+ pure result++-- | Connect to the test server+connectToServer :: Net.PortNumber -> IO Net.Socket+connectToServer port = do+ sock <- Net.socket Net.AF_INET Net.Stream Net.defaultProtocol+ let hints = Net.defaultHints{Net.addrSocketType = Net.Stream}+ addr : _ <- Net.getAddrInfo (Just hints) (Just "127.0.0.1") (Just (show port))+ Net.connect sock (Net.addrAddress addr)+ pure sock++sessionTicketSpec :: SpecWith S2nTls+sessionTicketSpec = describe "Session Tickets" $ do+ it "resumes session using ticket from first connection" $ \tls -> do+ -- IORef to store the session ticket+ ticketRef <- newIORef Nothing++ -- Create client config with session ticket callback+ clientConfig <- tls.newConfig+ tls.disableX509Verification clientConfig+ tls.setCipherPreferences clientConfig "default_tls13"+ tls.setSessionTicketsOnOff clientConfig True+ tls.setSessionTicketCallback clientConfig $ \ticketData _lifetime -> do+ writeIORef ticketRef (Just ticketData)++ withTicketTestServer tls $ \port -> do+ -- First connection: establish and get ticket+ bracket (connectToServer port) Net.close $ \sock1 -> do+ conn1 <- tls.newConnection S2nTls.Client+ tls.setConnectionConfig conn1 clientConfig+ tls.setServerName conn1 "localhost"+ tls.setSocket conn1 sock1+ tls.blockingNegotiate conn1++ -- First connection should NOT be resumed+ resumed1 <- tls.isSessionResumed conn1+ resumed1 `shouldBe` False++ -- Send a simple HTTP request+ tls.blockingSendAll conn1 "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"++ -- Read response+ response1 <- tls.blockingRecv conn1 4096+ BS.isInfixOf "200 OK" response1 `shouldBe` True++ -- Wait for ticket callback to fire+ threadDelay 200_000++ -- Verify we got a ticket+ mTicket <- readIORef ticketRef+ mTicket `shouldSatisfy` (/= Nothing)++ -- Second connection: use the ticket for resumption+ bracket (connectToServer port) Net.close $ \sock2 -> do+ conn2 <- tls.newConnection S2nTls.Client+ tls.setConnectionConfig conn2 clientConfig+ tls.setServerName conn2 "localhost"++ -- Set the session ticket for resumption+ case mTicket of+ Just ticket -> tls.setSession conn2 ticket+ Nothing -> error "No ticket available"++ tls.setSocket conn2 sock2+ tls.blockingNegotiate conn2++ -- Second connection SHOULD be resumed+ resumed2 <- tls.isSessionResumed conn2+ resumed2 `shouldBe` True++ -- Verify connection still works+ tls.blockingSendAll conn2 "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ response2 <- tls.blockingRecv conn2 4096+ BS.isInfixOf "200 OK" response2 `shouldBe` True
+ test/TestUtils.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE NumericUnderscores #-}++module TestUtils (+ withTestServer,+ makeSecureRequest,+ testCertPath,+ testKeyPath,+ loadTestCert,+ loadTestKey,+) where++-- import Control.Concurrent (threadDelay)+-- import Control.Concurrent.Async (race, withAsync)+-- import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)++import Control.Applicative+import Control.Exception (SomeException, try)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Network.Connection qualified as Conn+import Network.HTTP.Types (status200)+import Network.Socket+import Network.Wai (Application, responseLBS)+import Network.Wai.Handler.Warp (Port, defaultSettings, setBeforeMainLoop)+import Network.Wai.Handler.WarpS2N (S2nTls, TLSSettings, runTLSSocketLib)+import UnliftIO.Async+import UnliftIO.Concurrent+import UnliftIO.STM++-- | Path to test server certificate+testCertPath :: FilePath+testCertPath = "test/certs/server.pem"++-- | Path to test server key+testKeyPath :: FilePath+testKeyPath = "test/certs/server-key.pem"++-- | Load test certificate as ByteString+loadTestCert :: IO ByteString+loadTestCert = BS.readFile testCertPath++-- | Load test key as ByteString+loadTestKey :: IO ByteString+loadTestKey = BS.readFile testKeyPath++-- | Simple echo application for testing+echoApp :: Application+echoApp _req respond = respond $ responseLBS status200 [] "blarg!"++-- | Run a test server and execute an action with its port.+withTestServer :: S2nTls -> TLSSettings -> (Port -> IO a) -> IO a+withTestServer tls tlsSet action = do+ -- Create and bind socket+ sock <- socket AF_INET Stream defaultProtocol+ setSocketOption sock ReuseAddr 1+ bind sock (SockAddrInet 0 (tupleToHostAddress (127, 0, 0, 1)))+ listen sock 5+ port <- fromIntegral <$> socketPort sock++ serverReady <- newEmptyTMVarIO+ let warpSet = setBeforeMainLoop (atomically $ putTMVar serverReady ()) defaultSettings++ -- Run server in background, execute action, then cleanup+ withAsync (runTLSSocketLib tls tlsSet warpSet sock echoApp) $ \as -> do+ startupResult <-+ atomically $+ (Left <$> waitCatchSTM as)+ <|> (Right <$> takeTMVar serverReady)+ case startupResult of+ Right () -> pure ()+ Left e -> do+ close sock+ error $ "Server failed to start: " <> show e++ -- Small additional delay for server to be fully ready+ threadDelay 50_000++ -- Run the test action+ result <- action port++ -- Cleanup+ close sock+ threadDelay 100_000 -- 100ms cleanup delay+ pure result++-- | Make a secure HTTPS request to localhost, returning response body.+makeSecureRequest :: Port -> IO (Either String LBS.ByteString)+makeSecureRequest port = do+ result <- try @SomeException $ do+ -- Connect with TLS+ ctx <- Conn.initConnectionContext+ conn <-+ Conn.connectTo+ ctx+ Conn.ConnectionParams+ { Conn.connectionHostname = "localhost"+ , Conn.connectionPort = fromIntegral port+ , Conn.connectionUseSecure =+ Just+ Conn.TLSSettingsSimple+ { Conn.settingDisableCertificateValidation = True+ , Conn.settingDisableSession = False+ , Conn.settingUseServerName = True+ }+ , Conn.connectionUseSocks = Nothing+ }++ -- Send HTTP request+ Conn.connectionPut conn "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"++ -- Read response with timeout+ response <- readAllWithTimeout conn 5_000_000+ Conn.connectionClose conn+ pure $ LBS.fromStrict response++ pure $ case result of+ Left e -> Left (show e)+ Right bs -> Right bs++-- | Read all data from connection with a timeout+readAllWithTimeout :: Conn.Connection -> Int -> IO ByteString+readAllWithTimeout conn timeoutMicros = do+ result <- race (threadDelay timeoutMicros) (readAll conn)+ case result of+ Left () -> pure BS.empty -- Timeout, return what we have+ Right bs -> pure bs+ where+ readAll c = do+ chunk <- Conn.connectionGetChunk c+ if BS.null chunk+ then pure BS.empty+ else do+ rest <- readAll c+ pure (chunk <> rest)
+ test/certs/server-key.pem view
@@ -0,0 +1,28 @@+-----BEGIN PRIVATE KEY-----+MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQC5+Y6Rbv0V2SRG+9Ps/JSC7WxAFpMVZ2LD7zqoaDZvnzCjSTwUZt0LC4+C3HmZPsZBlr+rcvmjM6xp3+V0T/pk4yutmQudUek4X4/5ggnOSDyxgtX1Nrf/YXEW+Bdh4HBxJsZo1GayeaZVxO+As3/dzQAbWO9tYRKgChU2tvFg1HYEsoZLEeAuEuGvWRU6foguBfUfuOQ1nOY/Jjg+8FUSsYeMJJoC/SDoBAVayRkvGhsMhXy/wGhEHnWNj63mbJHXBuuu4x7MNcJnzwpF+oEEeAaFGfU1ATCW5jUeWwSneuZfZc/7BkN9nyfXN9rbt1E7DHNiWI6Dd3lglvH1B+tU83fSx9AgMBAAECggEAF06Kerj3YEXUiUz58MWxJrHIngBymCozMfeKM1YpyAC6+y/KJv9mK9Rw0ZRaa+VlWMJw9mZkGTsoXCMZH2CcqLSrkCcJ0Tk7sLxKvKMUo0UiC+WOtVq8b/WxA9EnMwW66b9Thb86uJrMyPpxosYVv5ySTsZ1HIiMKra0j7WnM07lhj+KcyTG5VQFEXm8czF4pb7KtRfAHdqFzmy9zHsLjet4kAysSlBoAu6gFfq85ctlqGe+YuoE6FH+59tEbVkQHr+/PrfBLBUv9Ri1eXplajRmyqLDBTv+V8U6tjeHVod4WBWe+so+J4RI+gp+iQ0/VBxfOtwtl9YL13rqTHbS1NjzSUQKBgQD9tM42nEJnzl1NLIlW+O8liQFmyhP0XxZbSCYoKl7HB7ZrCebXq7AFNExOfNJxW7LINwCHI8fcFcZ5Jdj4N+kF6pFvx+reCCuUy0ZuO0rW0gvwpmiLkQ2+A+17xnoOobadYkkOGB7Hg9Ulc5B7W7+KlZsOpifC8n7oreJ0/bG8AnsjQKBgQC7p/1B7KMYZrR5YYjxpmVOw+8mSEvjUE6C+w3RuFjvO8Oh9JG6Xis8QNL63e5UBQsCVX991sRUsbhF43bHfTbajGBl/N3ur2Gku+AbZbaFVyboMIwQC1cu1YLrKsT+kAgXpHjp0aFzE5aRCpp39mlUQSdG2TVitKO6TK+hqlk+VTbsQKBgQDScB57/bC3Gd0aHk7sUDsCXA4KnXSxOxuWrILrtlejW8p6dSoH+6ipKHACylZj4IOyvqyZa3xjeUxfQJ1vhNFbQOljFWsRWqgyNtqo5O4DBILUnx1B6+Q2cFuTx1WGvWwTr2qZXjhplVg+8FRvfef4efzhq6EbVAG//ROxf+eyxAIQKBgQCT+U2Plad7xvVBbK1PURAqtN+59Y60QnW/GAaVa+GGkKkacWQnqN7QwyPgiHQfyoXGI+1GgfghNZemCFP6fx5JVKnhUGZ4zUcWbCE94TDWpoGJMPQFdKHRxxatgjp+kJ2J0j+qLd2UFb49595UmMXKoDy7C1Kyw/Zi9HonqhG+ejBQQKBgQDE5dQTvU7DR/Ai4UbM+nYL3BqbJcMETExQnZ+WsWWARc8wJBvFnG+H306D9xRjaDEP2l4RujCQ3xCFNKqRV+4c4YVw1UR29YYuQ9fEWiBDY4DkRZo4dS1H23SDdoDvId712K/lQy+xKgS1fy3BfF+lmIrmAVSBabLi63yRvpaCxN4QQ==+-----END PRIVATE KEY-----
+ test/certs/server.pem view
@@ -0,0 +1,19 @@+-----BEGIN CERTIFICATE-----+MIIDCTCCAfGgAwIBAgIUAXfXRh9ugOXypL+orxq0EJJ9wYMwDQYJKoZIhvcNAQEL+BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MB4XDTI2MDQwNzE5MDcwM1oXDTI3MDQw+NzE5MDcwM1owFDESMBAGA1UEAwwJbG9jYWxob3N0MIIBIjANBgkqhkiG9w0BAQEF+AAOCAQ8AMIIBCgKCAQEAufmOkW79FdkkRvT7PyUgu1sQBaTFWdiw+86qGg2b58wo+0k8FGbdCwuPgtx5mT7GQZa/q3L5ozOsad1dE/6ZOMrrZkLnVHpOF+P+YIJzkg8sY+LV9Ta3/2FxFvgXYeBwcSbGaNRmsnmmVcTgLN/3c0AG1jvbWESoAoVNrbxYNR2BLK+GSxHgLhLhr1kVOn6ILgX1H7jkNZzmPyY4PBVErGHjCSaAv0g6AQFWskZLxobDIV8+v8BoRB51jY+t5myR1wbrruMezDXCZ88KRaBBHgGhRn1NQEwluY1HlsEp3rmX2XP++wZDfZ8n1zfa27dROwxzYliOg3d5YJbx9QbVPN30sfQIDAQABo1MwUTAdBgNVHQ4E+FgQUkSS3vIhjKZutMn7kr4fyYSdHItMwHwYDVR0jBBgwFoAUkSS3vIhjKZutMn7k+r4fyYSdHItMwDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAQEACisM+sKmfEFS7GYEWJ9Wkozvostjhy8G3Zt+GiMsfJvPJyDv8Icdb99YR1KdguMhPm0oY+ECELiLagdXbzZJrcHtdeOhs6gZXgd8pMQc40Fjgzu/1avD8mzJhAqYabhDMQMBDH+8ZS/x6eagB4ocGCH1ghcGuzFmNqlaUjCYWgADrSAd4MCz5M4/95YTvkTZV1qQw9/+ujqX5DkMLK6qkUKpcLqy1ErUb3x6jpr8k7KkGYOdN5ygbx/49CXvTlFcphcW+EJY+vEnHvB6O+BL4HjHfx0+RWA6KAWfRAZFv6kEzJ+iLhnCc7eSQGXtWmKAJLPk5rrWG+hwB/oLg+YZvlXLCCXA==+-----END CERTIFICATE-----
+ warp-s2n-tls.cabal view
@@ -0,0 +1,80 @@+cabal-version: 3.0+name: warp-s2n-tls+version: 0.1.0.0+synopsis: TLS support for Warp via s2n-tls+description:+ This package provides TLS support for the Warp web server using+ the s2n-tls library.++license: Apache-2.0+license-file: LICENSE+author: Daniel Goertzen+maintainer: daniel.goertzen@gmail.com+copyright: 2026 Daniel Goertzen+category: Web, Network+build-type: Simple+extra-doc-files: CHANGELOG.md+ README.md+extra-source-files: test/certs/server.pem+ test/certs/server-key.pem+tested-with: GHC == 9.8.2+homepage: https://github.com/goertzenator/warp-s2n-tls+bug-reports: https://github.com/goertzenator/warp-s2n-tls/issues++source-repository head+ type: git+ location: https://github.com/goertzenator/warp-s2n-tls.git++source-repository this+ type: git+ location: https://github.com/goertzenator/warp-s2n-tls.git+ tag: v0.1.0.0++library+ exposed-modules: Network.Wai.Handler.WarpS2N+ build-depends: base >= 4.16 && < 5+ , warp >= 3.4.13 && < 4+ , wai >= 3.2 && < 4+ , s2n-tls ^>= 0.1+ , async >= 2.2 && < 2.3+ , bytestring >= 0.10 && < 0.13+ , entropy >= 0.4 && < 0.5+ , network >= 3.0 && < 3.3+ , streaming-commons >= 0.2 && < 0.3+ , unbounded-delays >= 0.1 && < 0.2+ , stm >= 2.5 && < 2.6+ hs-source-dirs: src+ default-language: GHC2021+ default-extensions: OverloadedRecordDot+ ghc-options: -Wall++test-suite warp-s2n-tls-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: TestUtils+ , AppMonadTests+ , CertLoadingTests+ , IntegrationTests+ , ProtocolTests+ , SessionTicketTests+ build-depends: base >= 4.16 && < 5+ , warp-s2n-tls+ , warp+ , wai+ , s2n-tls+ , hspec+ , bytestring+ , network+ , http-types+ , async+ , tls+ , x509-store+ , data-default-class+ , connection+ , unliftio+ , mtl+ hs-source-dirs: test+ default-language: GHC2021+ default-extensions: OverloadedStrings+ , OverloadedRecordDot+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N