diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Network/Wai/Handler/WarpS2N.hs b/src/Network/Wai/Handler/WarpS2N.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Handler/WarpS2N.hs @@ -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 diff --git a/test/AppMonadTests.hs b/test/AppMonadTests.hs new file mode 100644 --- /dev/null +++ b/test/AppMonadTests.hs @@ -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 diff --git a/test/CertLoadingTests.hs b/test/CertLoadingTests.hs new file mode 100644 --- /dev/null +++ b/test/CertLoadingTests.hs @@ -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 diff --git a/test/IntegrationTests.hs b/test/IntegrationTests.hs new file mode 100644 --- /dev/null +++ b/test/IntegrationTests.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/ProtocolTests.hs b/test/ProtocolTests.hs new file mode 100644 --- /dev/null +++ b/test/ProtocolTests.hs @@ -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) diff --git a/test/SessionTicketTests.hs b/test/SessionTicketTests.hs new file mode 100644 --- /dev/null +++ b/test/SessionTicketTests.hs @@ -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 diff --git a/test/TestUtils.hs b/test/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils.hs @@ -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) diff --git a/test/certs/server-key.pem b/test/certs/server-key.pem new file mode 100644 --- /dev/null +++ b/test/certs/server-key.pem @@ -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----- diff --git a/test/certs/server.pem b/test/certs/server.pem new file mode 100644 --- /dev/null +++ b/test/certs/server.pem @@ -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----- diff --git a/warp-s2n-tls.cabal b/warp-s2n-tls.cabal new file mode 100644 --- /dev/null +++ b/warp-s2n-tls.cabal @@ -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