acme-not-a-joke-wai (empty) → 0.1.0.0
raw patch · 11 files changed
+1655/−0 lines, 11 filesdep +acme-not-a-jokedep +acme-not-a-joke-waidep +base
Dependencies added: acme-not-a-joke, acme-not-a-joke-wai, base, bytestring, containers, crypton, crypton-asn1-encoding, crypton-asn1-types, crypton-x509, crypton-x509-validation, directory, filepath, http-types, network, text, time, time-hourglass, tls, wai, warp, warp-tls
Files
- CHANGELOG.md +23/−0
- LICENSE +30/−0
- README.md +196/−0
- acme-not-a-joke-wai.cabal +138/−0
- example/Main.hs +106/−0
- src/Acme/NotAJoke/Wai/Http01.hs +194/−0
- src/Acme/NotAJoke/Wai/TlsAlpn01.hs +280/−0
- src/Acme/NotAJoke/Wai/WarpTLS.hs +173/−0
- test/Main.hs +124/−0
- test/TlsAlpn01.hs +204/−0
- test/WarpTLS.hs +187/−0
+ CHANGELOG.md view
@@ -0,0 +1,23 @@+# Revision history for acme-not-a-joke-wai++## 0.1.0.0 -- 2026-10-23++* `Acme.NotAJoke.Wai.TlsAlpn01`: TLS-ALPN-01 challenges (RFC-8737) answered+ by a running warp-tls server, without port 80. A `TlsAlpn01Store` of+ challenge certificates, `withTlsAlpn01` and `tlsAlpn01Hooks` to present them+ to the handshakes asking for `acme-tls/1` (over TLS 1.3), `challengeCredential`+ to create them, and `runAcmeDance_tlsalpn01_wai` and `tlsAlpn01Steps` to fill+ and clear the store during an ACME dance. New dependency: `time`. A+ `tls-alpn-01` test-suite.++* First version: `Acme.NotAJoke.Wai.Http01` with a `ChallengeStore`, the+ `http01Middleware` answering `GET /.well-known/acme-challenge/{token}`, and+ `runAcmeDance_http01_wai` and `http01Steps` to fill and clear the store+ during an ACME dance.+* `Acme.NotAJoke.Wai.WarpTLS`: a `CertificateStore` read by warp-tls at each+ TLS handshake (`liveTlsSettings`, `sniCredentials`), so that certificates are+ served without restarting; `installCertificate`, `credentialFromCertificate`,+ `credentialFromPEM` and `loadCredential` to fill it. New dependencies:+ `warp-tls` (3.4.13 or later), `tls`, `crypton` and `crypton-x509`.+* A README telling who initiates which request and where keys, CSRs and+ certificates are stored, and an example program (behind the `example` flag).
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Lucas DiCioccio (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,196 @@+# acme-not-a-joke-wai++Lets a wai/warp application get its own TLS certificates with+[acme-not-a-joke](../README.md), using HTTP-01 challenges (RFC-8555 section+8.3) or TLS-ALPN-01 challenges (RFC-8737), and serve them without restarting.++Three modules, which can be used separately:++- `Acme.NotAJoke.Wai.Http01`: a wai `Middleware` answering the HTTP-01+ challenge, and a dance that tells the middleware what to answer.+- `Acme.NotAJoke.Wai.TlsAlpn01`: TLS settings making a warp-tls server answer+ the TLS-ALPN-01 challenge on port 443 (no port 80 needed), and a dance that+ tells the server what to answer.+- `Acme.NotAJoke.Wai.WarpTLS`: a certificate store that a warp-tls server+ reads at each TLS handshake, so that a new certificate is served live.++## who initiates what++Nothing is automatic: **your program is the ACME client**. It decides when to+get a certificate by calling `runAcmeDance_http01_wai`, which blocks until the+dance is over. The library has no background thread and no renewal timer.++```+your program ACME server (e.g. Let's Encrypt)+ | |+ | 1. account, new order, authorization |+ |--------------- HTTPS, outgoing ------------->|+ | |+ | 2. key authorization put in ChallengeStore |+ | "please validate the challenge" |+ |--------------- HTTPS, outgoing ------------->|+ | |+ | 3. GET /.well-known/acme-challenge/{token} |+ |<---------- HTTP on port 80, incoming --------|+ | answered by http01Middleware |+ | |+ | 4. poll the order, send the CSR, |+ | download the certificate chain |+ |--------------- HTTPS, outgoing ------------->|+ | |+ | 5. handleStep (Done _ certificate) |+```++Consequences:++- the HTTP server wrapped with `http01Middleware` must already be running on+ port 80, and reachable from the Internet under the domain of the order,+ before the dance starts;+- step 3 is the only incoming request, and it is plain HTTP: if your HTTP+ server redirects everything to HTTPS, the middleware must wrap the+ redirection;+- the dance is over in a few seconds when all goes well. Your `handleStep`+ decides how long to wait between two polls (the `WaitingForValidation n`+ step, `n` being the number of polls so far);+- renewing is running the dance again, e.g. from a thread that sleeps until+ some weeks before the certificate expires.++## where things are stored++The library writes no file on its own. Both stores (`ChallengeStore`,+`CertificateStore`) are in memory. What goes to disk, and where, is decided by+the functions your program calls:++| what | role | who creates it | typical helper |+|------|------|----------------|----------------|+| account key (JWK) | signs the requests to the ACME server, identifies your ACME account | you, once | `loadOrCreateJWKFile "state/account.jwk"` |+| certificate key (RSA, PEM) | the private key of the TLS server; signs the CSR; never leaves the machine | you, once (or at each renewal) | `loadOrCreateRSAKeyPEM "state/key.pem"` |+| CSR | tells the ACME server which names and which public key to certify | you, before each dance | `createCSR key names`, in memory; `writeCSRPEM` only if you want a copy |+| key authorization | the answer to the challenge | the dance | in memory, in the `ChallengeStore`, removed when the dance ends |+| certificate chain (PEM) | what the TLS server presents | the ACME server; given to your `handleStep` in the `Done` step | `storeCert "state/certificate.pem" cert` and `installCertificate store key cert` |++The helpers are in `Acme.NotAJoke.KeyManagement`,+`Acme.NotAJoke.CertManagement` and `Acme.NotAJoke.Api.Certificate` of the+`acme-not-a-joke` package. The paths are yours: nothing has a default+location. Keep the account key and the certificate key private (the helpers+create files with the default permissions of the process).++`certificate.pem` (leaf certificate first, then the intermediates) and+`key.pem` are in the formats that `warp-tls`, nginx, haproxy etc. read.++## serving the certificate live with warp-tls++`Network.Wai.Handler.WarpTLS.tlsSettings` reads the certificate files once,+when the server starts. Instead, start the HTTPS server on a+`CertificateStore`:++```hs+certificates <- newCertificateStore+forkIO $ runTLS (liveTlsSettings certificates) (setPort 443 defaultSettings) application+```++and put a credential in the store whenever you have one:++- `installCertificate certificates key cert` in the `Done` step of a dance;+- `setCredential certificates =<< loadCredential "state/certificate.pem" "state/key.pem"`+ (modulo the `Either`) at startup, to reuse the certificate of a previous run.++The store is read at each TLS handshake: the next connection gets the new+certificate, established connections are left alone, and the server is not+restarted. While the store is empty, TLS handshakes fail (there is nothing to+present); the HTTP server on port 80 is not affected, so the first dance can+run.++A server with several certificates uses `setCredentialFor store "name" cred`:+the store then picks the credential from the server name (SNI) asked by the+client, and falls back to the one set with `setCredential`.++`liveTlsSettings` is `tlsSettingsSni` from warp-tls (3.4.13 or later) applied to+`sniCredentials`, which you can call from your own TLS hooks.++## tls-alpn-01 challenges, without port 80++With a TLS-ALPN-01 challenge, the ACME server opens a TLS connection to port+443 of the domain asking for the `acme-tls/1` protocol (ALPN), and expects a+self-signed certificate carrying the digest of the key authorization. The+HTTPS server answers it itself: no HTTP server is needed.++```hs+challenges <- newTlsAlpn01Store+certificates <- newCertificateStore+forkIO $ runTLS (withTlsAlpn01 challenges (liveTlsSettings certificates)) (setPort 443 defaultSettings) application++runAcmeDance_tlsalpn01_wai challenges dancer+```++`withTlsAlpn01` wraps the server hooks: handshakes asking for `acme-tls/1`+get the challenge certificate of the store for their server name, the other+ones are untouched (they get the certificates of the live store, and `h2` or+`http/1.1`). `runAcmeDance_tlsalpn01_wai` creates the challenge certificate+(with a throw-away RSA-2048 key) when the ACME server gives the challenge, and+removes it when the dance is over. `challengeCredential`, `insertTlsAlpn01`+and `deleteTlsAlpn01` do the same by hand.++The server must keep its TLS 1.3 support enabled (the default of warp-tls):+the `tls` library chooses the certificate before the protocol with TLS 1.2,+so the challenge is only answered over TLS 1.3, which ACME servers use.++## complete example++[example/Main.hs](example/Main.hs) is a warp server doing all of the above:+keys created on the first run, HTTP on port 80 with the middleware, HTTPS on+port 443 with the live store, certificate requested when there is none on disk,+then written to disk and served.++```console+cabal build -fexample acme-not-a-joke-wai-example+sudo $(cabal list-bin -fexample acme-not-a-joke-wai-example) example.dicioccio.fr certmaster@dicioccio.fr ./state+```++It uses the staging environment of Let's Encrypt. The essential part:++```hs+accountKey <- orDie =<< loadOrCreateJWKFile "state/account.jwk"+key <- orDie =<< loadOrCreateRSAKeyPEM "state/key.pem"+csr <- orDie =<< createCSR key ("example.dicioccio.fr" :| [])++challenges <- newChallengeStore+certificates <- newCertificateStore+forkIO $ run 80 (http01Middleware challenges application)+forkIO $ runTLS (liveTlsSettings certificates) (setPort 443 defaultSettings) application++let handle step = case step of+ WaitingForValidation n -> threadDelay (n * 1000000)+ Done _ cert -> do+ storeCert "state/certificate.pem" cert+ orDie =<< installCertificate certificates key cert+ _ -> pure ()++runAcmeDance_http01_wai challenges $+ AcmeDancer+ staging_letsencryptv2+ accountKey+ (fetchAccount1 True False ["mailto:certmaster@dicioccio.fr"])+ csr+ (createOrder (Nothing, Nothing) [OrderIdentifier DNSOrder "example.dicioccio.fr"])+ handle+```++`fetchAccount1 True False` creates the ACME account if the account key has+none yet (and agrees to the terms of service of the ACME server); `fetchAccount`+only accepts an existing account.++## limits++- HTTP-01 and TLS-ALPN-01 cannot validate wildcard identifiers: these need+ DNS-01.+- TLS-ALPN-01 challenges are answered over TLS 1.3 only.+- The dance validates the first authorization of an order only: one+ certificate per name, rather than one certificate for several names.+- No renewal scheduling, no rate-limit handling: failures are reported to+ `handleStep` (`InvalidOrder`, `OtherError`, `AcmeFailure`) and the dance+ stops. The+ [acme-not-a-joke-warp](../acme-not-a-joke-warp/README.md) package has a+ certificate manager doing the scheduling (startup, renewals, retries) on+ top of this package.+- Certificate keys are RSA.
+ acme-not-a-joke-wai.cabal view
@@ -0,0 +1,138 @@+cabal-version: 2.4+name: acme-not-a-joke-wai+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: ACME http-01 and tls-alpn-01 challenges and live certificates for wai/warp++-- A longer description of the package.+description: a wai middleware and a step handler to validate HTTP-01 challenges (rfc-8555) with the acme-not-a-joke library, so that a wai/warp application can get its own TLS certificates, and TLS settings answering TLS-ALPN-01 challenges (rfc-8737) from a running warp-tls server, without port 80. Also has a certificate store read by warp-tls at each handshake, so that new certificates are served without restarting.++-- The license under which the package is released.+license: BSD-3-Clause+license-file: LICENSE+homepage: https://lucasdicioccio.github.io/acme-not-a-joke/+bug-reports: https://github.com/lucasdicioccio/acme-not-a-joke/issues+author: Lucas DiCioccio+maintainer: lucas@dicioccio.fr++-- A copyright notice.+copyright: Lucas DiCioccio 2023-2026+category: Security+tested-with: GHC == 9.8.2 || == 9.10.3+extra-doc-files: CHANGELOG.md README.md++source-repository head+ type: git+ location: https://github.com/lucasdicioccio/acme-not-a-joke.git+ subdir: acme-not-a-joke-wai++flag example+ description: build the example program (a warp server getting its own certificate)+ default: False+ manual: True++library+ hs-source-dirs: src+ ghc-options: -Wall+ default-language: Haskell2010+ default-extensions: OverloadedStrings OverloadedRecordDot+ exposed-modules:+ Acme.NotAJoke.Wai.Http01+ Acme.NotAJoke.Wai.TlsAlpn01+ Acme.NotAJoke.Wai.WarpTLS+ build-depends:+ acme-not-a-joke >= 0.2 && < 0.3,+ base >= 4.19.1 && < 5,+ bytestring >= 0.12.1 && < 0.13,+ containers >= 0.6.8 && < 0.8,+ text >= 2.1.1 && < 2.2,+ time >= 1.12.2 && < 1.13,+ http-types >= 0.12.4 && < 0.13,+ wai >= 3.2.4 && < 3.3,+ crypton >= 1.0 && < 1.1,+ crypton-x509 >= 1.8 && < 1.9,+ tls >= 2.1.3 && < 2.5,+ warp-tls >= 3.4.13 && < 3.5,++executable acme-not-a-joke-wai-example+ if !flag(example)+ buildable: False+ hs-source-dirs: example+ main-is: Main.hs+ ghc-options: -Wall -threaded+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ build-depends:+ acme-not-a-joke,+ acme-not-a-joke-wai,+ base,+ directory >= 1.3.8 && < 1.4,+ filepath >= 1.4.200 && < 1.6,+ http-types,+ text,+ wai,+ warp >= 3.4 && < 3.5,+ warp-tls,++test-suite http01+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ ghc-options: -Wall+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ build-depends:+ acme-not-a-joke,+ acme-not-a-joke-wai,+ base,+ bytestring,+ http-types,+ wai,++test-suite warp-tls+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: WarpTLS.hs+ ghc-options: -Wall -threaded+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ build-depends:+ acme-not-a-joke,+ acme-not-a-joke-wai,+ base,+ crypton,+ crypton-asn1-types,+ crypton-x509,+ http-types,+ network,+ time-hourglass,+ tls,+ wai,+ warp,+ warp-tls,++test-suite tls-alpn-01+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: TlsAlpn01.hs+ ghc-options: -Wall -threaded+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ build-depends:+ acme-not-a-joke,+ acme-not-a-joke-wai,+ base,+ bytestring,+ crypton,+ crypton-asn1-encoding,+ crypton-asn1-types,+ crypton-x509,+ crypton-x509-validation,+ http-types,+ network,+ time-hourglass,+ tls,+ wai,+ warp,+ warp-tls,
+ example/Main.hs view
@@ -0,0 +1,106 @@+{- | A warp server getting its own certificate with an HTTP-01 challenge.++> acme-not-a-joke-wai-example DOMAIN CONTACT-EMAIL STATE-DIRECTORY++The machine must be reachable from the Internet as DOMAIN, on ports 80 and+443. The certificate comes from the staging environment of Let's Encrypt+(browsers do not trust it): replace 'staging_letsencryptv2' with+'letsencryptv2' for a real one.++Files, all in STATE-DIRECTORY:++* @account.jwk@: the ACME account key, created on the first run+* @key.pem@: the private key of the certificate, created on the first run+* @certificate.pem@: the certificate chain, written when a dance succeeds++The CSR is built in memory at each dance, and is not written anywhere.+-}+module Main (main) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (forever, void)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Text as Text+import Network.HTTP.Types (status200)+import Network.Wai (Application, responseLBS)+import Network.Wai.Handler.Warp (defaultSettings, run, setPort)+import Network.Wai.Handler.WarpTLS (runTLS)+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.Environment (getArgs)+import System.FilePath ((</>))+import System.IO (hPutStrLn, stderr)++import Acme.NotAJoke.Api.Account (fetchAccount1)+import Acme.NotAJoke.Api.Certificate (storeCert)+import Acme.NotAJoke.Api.Endpoint (readProblem)+import Acme.NotAJoke.Api.Order (OrderIdentifier (..), OrderType (..), createOrder)+import Acme.NotAJoke.CertManagement (createCSR)+import Acme.NotAJoke.Dancer (AcmeDancer (..), DanceStep (..))+import Acme.NotAJoke.KeyManagement (loadOrCreateJWKFile, loadOrCreateRSAKeyPEM)+import Acme.NotAJoke.LetsEncrypt (staging_letsencryptv2)+import Acme.NotAJoke.Wai.Http01 (http01Middleware, newChallengeStore, runAcmeDance_http01_wai)+import Acme.NotAJoke.Wai.WarpTLS (installCertificate, liveTlsSettings, loadCredential, newCertificateStore, setCredential)++main :: IO ()+main = do+ args <- getArgs+ case args of+ [domain, email, dir] -> serve domain email dir+ _ -> hPutStrLn stderr "usage: acme-not-a-joke-wai-example DOMAIN CONTACT-EMAIL STATE-DIRECTORY"++serve :: String -> String -> FilePath -> IO ()+serve domain email dir = do+ let accountKeyPath = dir </> "account.jwk"+ let keyPath = dir </> "key.pem"+ let certPath = dir </> "certificate.pem"++ -- keys: loaded from the state directory, created on the first run+ createDirectoryIfMissing True dir+ accountKey <- orDie =<< loadOrCreateJWKFile accountKeyPath+ key <- orDie =<< loadOrCreateRSAKeyPEM keyPath++ -- the two stores, both in memory+ challenges <- newChallengeStore+ certificates <- newCertificateStore++ -- port 80: the ACME server fetches the challenge there+ void $ forkIO $ run 80 (http01Middleware challenges application)+ -- port 443: handshakes fail until the store has a certificate+ void $ forkIO $ runTLS (liveTlsSettings certificates) (setPort 443 defaultSettings) application++ known <- doesFileExist certPath+ if known+ then -- a certificate obtained by a previous run is served right away+ setCredential certificates =<< orDie =<< loadCredential certPath keyPath+ else do+ -- this program is the ACME client: it starts the dance, which+ -- returns once the certificate is installed (or on failure)+ request <- orDie =<< createCSR key (Text.pack domain :| [])+ let handle step = case step of+ WaitingForValidation n -> threadDelay (n * 1000000)+ Done _ cert -> do+ storeCert certPath cert+ orDie =<< installCertificate certificates key cert+ putStrLn ("serving the certificate written at " <> certPath)+ InvalidOrder _ -> hPutStrLn stderr "the ACME server could not validate the challenge"+ OtherError err -> hPutStrLn stderr (Text.unpack err)+ AcmeFailure err -> hPutStrLn stderr (show (readProblem err, err))+ _ -> pure ()+ runAcmeDance_http01_wai challenges $+ AcmeDancer+ { baseUrl = staging_letsencryptv2+ , accountJwk = accountKey+ , -- creates the account when the key has none yet+ account = fetchAccount1 True False [Text.pack ("mailto:" <> email)]+ , csr = request+ , order = createOrder (Nothing, Nothing) [OrderIdentifier DNSOrder (Text.pack domain)]+ , handleStep = handle+ }++ forever $ threadDelay 60000000++application :: Application+application _ respond = respond $ responseLBS status200 [] "hello\n"++orDie :: Either String a -> IO a+orDie = either fail pure
+ src/Acme/NotAJoke/Wai/Http01.hs view
@@ -0,0 +1,194 @@+{- | Serves HTTP-01 challenges (RFC-8555 section 8.3) from a wai application.++The ACME server validates an HTTP-01 challenge by fetching+@http:\/\/{domain}\/.well-known\/acme-challenge\/{token}@ (on port 80) and+expects the key authorization as a response.++This module provides a 'ChallengeStore' shared between two parties:++* a 'Middleware' ('http01Middleware') answering the requests of the ACME server+* a dance ('runAcmeDance_http01_wai') or a step handler ('http01Steps') adding+ the key authorization before the ACME server is told to validate the+ challenge and removing it once the dance is over++HTTP-01 challenges cannot validate wildcard identifiers.++= Who does what++Nothing happens on its own: your program is the ACME client and decides when+to get a certificate, by calling 'runAcmeDance_http01_wai' (typically at+startup when it has no certificate yet, and again before the certificate+expires). The call blocks until the dance is over. Meanwhile:++1. your program sends requests to the ACME server (account, order,+ authorization): these are outgoing HTTPS requests+2. the dance adds the key authorization of the challenge to the+ 'ChallengeStore' and tells the ACME server to validate it+3. the ACME server sends @GET \/.well-known\/acme-challenge\/{token}@ to+ port 80 of the domain: the only incoming request, which 'http01Middleware'+ answers. Hence the web server must already be running, and reachable from+ the Internet, when the dance starts+4. your program polls the order, sends the CSR, and downloads the certificate,+ which is given to the 'handleStep' of the dancer in a 'Done' step++= Where things are stored++This module writes no file. The 'ChallengeStore' is in memory and only holds+key authorizations for the time of a dance. Everything else is an input or an+output of the dance that your program reads and writes where it sees fit:++* the account key is an input ('accountJwk'), e.g. from+ 'Acme.NotAJoke.KeyManagement.loadOrCreateJWKFile'+* the private key of the certificate never is sent anywhere: it only signs the+ CSR, e.g. from 'Acme.NotAJoke.KeyManagement.loadOrCreateRSAKeyPEM'+* the CSR is an input ('csr'), e.g. built in memory by+ 'Acme.NotAJoke.CertManagement.createCSR': it needs no file+* the certificate chain (PEM) is in the 'Done' step: the 'handleStep' of the+ dancer writes it to a file (with 'Acme.NotAJoke.Api.Certificate.storeCert')+ and/or hands it to the TLS server (see "Acme.NotAJoke.Wai.WarpTLS")+-}+module Acme.NotAJoke.Wai.Http01 (+ -- * store+ ChallengeStore,+ newChallengeStore,+ insertChallenge,+ deleteChallenge,+ lookupChallenge,+ listChallenges,++ -- * wai+ http01Middleware,+ challengeResponse,++ -- * dance+ runAcmeDance_http01_wai,+ http01Steps,+) where++import Control.Exception (finally)+import qualified Data.ByteString.Lazy as LByteString+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Text.Encoding as Encoding+import Network.HTTP.Types (hContentType, methodGet, status200)+import Network.Wai (Middleware, Response, pathInfo, requestMethod, responseLBS)++import Acme.NotAJoke.Api.Challenge (Token (..))+import Acme.NotAJoke.Api.Validation (KeyAuthorization (..))+import Acme.NotAJoke.Dancer (AcmeDancer (..), DanceStep (..), runAcmeDance_http01)++{- | The challenges being served: the key authorization to reply for each+token.++A same store can be shared by concurrent dances.+-}+newtype ChallengeStore = ChallengeStore (IORef (Map Token KeyAuthorization))++-- | Creates an empty store.+newChallengeStore :: IO ChallengeStore+newChallengeStore = ChallengeStore <$> newIORef Map.empty++-- | Starts serving the key authorization of a token.+insertChallenge :: ChallengeStore -> Token -> KeyAuthorization -> IO ()+insertChallenge (ChallengeStore ref) tok keyAuth =+ atomicModifyIORef' ref (\m -> (Map.insert tok keyAuth m, ()))++-- | Stops serving the key authorization of a token.+deleteChallenge :: ChallengeStore -> Token -> IO ()+deleteChallenge (ChallengeStore ref) tok =+ atomicModifyIORef' ref (\m -> (Map.delete tok m, ()))++-- | Looks up the key authorization of a token.+lookupChallenge :: ChallengeStore -> Token -> IO (Maybe KeyAuthorization)+lookupChallenge (ChallengeStore ref) tok =+ Map.lookup tok <$> readIORef ref++-- | The tokens currently served.+listChallenges :: ChallengeStore -> IO [Token]+listChallenges (ChallengeStore ref) =+ Map.keys <$> readIORef ref++{- | Answers @GET \/.well-known\/acme-challenge\/{token}@ with the key+authorization when the token is in the store.++Any other request, including requests for a token that is not in the store, is+passed to the wrapped application.++The ACME server performs its request over HTTP on port 80. Hence the+middleware should wrap whatever redirects HTTP requests to HTTPS.+-}+http01Middleware :: ChallengeStore -> Middleware+http01Middleware store app req respond =+ case pathInfo req of+ [".well-known", "acme-challenge", tok]+ | requestMethod req == methodGet -> do+ found <- lookupChallenge store (Token tok)+ case found of+ Just keyAuth -> respond $ challengeResponse keyAuth+ Nothing -> app req respond+ _ -> app req respond++-- | The response expected by the ACME server for an HTTP-01 challenge.+challengeResponse :: KeyAuthorization -> Response+challengeResponse (KeyAuthorization keyAuth) =+ responseLBS+ status200+ [(hContentType, "application/octet-stream")]+ (LByteString.fromStrict $ Encoding.encodeUtf8 keyAuth)++{- | Runs the dance with an HTTP-01 challenge served from the store.++The key authorization is added to the store before the 'handleStep' of the+dancer sees the 'Validation' step, and is removed when the dance is over+(whether the dance succeeds, fails, or throws an exception).++The 'handleStep' of the dancer still is responsible for the other steps (e.g.,+waiting between two polls and storing the certificate).+-}+runAcmeDance_http01_wai :: ChallengeStore -> AcmeDancer -> IO ()+runAcmeDance_http01_wai store dancer = do+ served <- newIORef []+ runAcmeDance_http01 (dancer{handleStep = serveSteps store served dancer.handleStep})+ `finally` stopServing store served++{- | Wraps a step handler to serve HTTP-01 challenges from the store, for use+with 'runAcmeDance_http01' or with a custom matcher.++The key authorization is added to the store before the wrapped handler sees the+'Validation' step, and is removed after the wrapped handler has seen the last+step of the dance ('Done', 'InvalidOrder', 'OtherError' or 'AcmeFailure').++The key authorization is not removed if the dance throws an exception, see+'runAcmeDance_http01_wai' for a variant handling exceptions.+-}+http01Steps :: ChallengeStore -> (DanceStep -> IO ()) -> IO (DanceStep -> IO ())+http01Steps store handler = do+ served <- newIORef []+ pure (serveSteps store served handler)++-- | Step handler keeping track of the tokens it added to the store.+serveSteps :: ChallengeStore -> IORef [Token] -> (DanceStep -> IO ()) -> DanceStep -> IO ()+serveSteps store served handler step =+ case step of+ Validation (tok, keyAuth, _) -> do+ atomicModifyIORef' served (\toks -> (tok : toks, ()))+ insertChallenge store tok keyAuth+ handler step+ Done _ _ -> final+ InvalidOrder _ -> final+ OtherError _ -> final+ AcmeFailure _ -> final+ Authorizing _ -> handler step+ WaitingForValidation _ -> handler step+ OrderIsFinalized _ -> handler step+ ValidOrder _ -> handler step+ Prepare _ -> handler step+ where+ final = handler step `finally` stopServing store served++-- | Removes the tokens added by a step handler.+stopServing :: ChallengeStore -> IORef [Token] -> IO ()+stopServing store served = do+ toks <- atomicModifyIORef' served (\toks -> ([], toks))+ mapM_ (deleteChallenge store) toks
+ src/Acme/NotAJoke/Wai/TlsAlpn01.hs view
@@ -0,0 +1,280 @@+{- | Answers TLS-ALPN-01 challenges (RFC-8737) from a running warp-tls server.++The ACME server validates a TLS-ALPN-01 challenge by opening a TLS connection+to port 443 of the domain, asking for the domain (SNI) and for the+@acme-tls/1@ protocol only (ALPN). It expects a self-signed certificate for+the domain carrying the SHA-256 digest of the key authorization in a critical+@acmeIdentifier@ extension, and closes the connection after the handshake.+Hence no port 80 is needed: the HTTPS server answers the challenges itself.++This module provides a 'TlsAlpn01Store' shared between two parties:++* the HTTPS server, whose TLS settings are wrapped with 'withTlsAlpn01'. It+ presents the challenge certificate of the store to the handshakes asking for+ @acme-tls/1@, and behaves as before for every other handshake (e.g., with+ the certificates of a "Acme.NotAJoke.Wai.WarpTLS" store)+* a dance ('runAcmeDance_tlsalpn01_wai') or a step handler ('tlsAlpn01Steps')+ adding the challenge certificate before the ACME server is told to validate+ the challenge and removing it once the dance is over++TLS-ALPN-01 challenges cannot validate wildcard identifiers.++= Limits++The @tls@ library lets the server choose its certificate from the server name+only, before or after it chooses the protocol depending on the TLS version.+'withTlsAlpn01' relies on the order of TLS 1.3, where the protocol is chosen+first: the TLS 1.3 support of the server (the default of warp-tls) must be+left enabled. ACME servers (e.g. Let's Encrypt) use TLS 1.3 when the server+supports it. A client asking for @acme-tls/1@ over TLS 1.2 gets the regular+certificate, which fails the validation.++= Where things are stored++This module writes no file. The 'TlsAlpn01Store' is in memory and only holds+the challenge certificates for the time of a dance. The key of a challenge+certificate is generated for the dance and thrown away afterwards.+-}+module Acme.NotAJoke.Wai.TlsAlpn01 (+ -- * store+ TlsAlpn01Store,+ newTlsAlpn01Store,+ insertTlsAlpn01,+ deleteTlsAlpn01,+ lookupTlsAlpn01,+ listTlsAlpn01,++ -- * warp-tls+ withTlsAlpn01,+ tlsAlpn01Hooks,++ -- * certificates+ challengeCredential,++ -- * dance+ runAcmeDance_tlsalpn01_wai,+ tlsAlpn01Steps,+) where++import Control.Concurrent (ThreadId, myThreadId)+import Control.Exception (finally, throwIO)+import qualified Crypto.PubKey.RSA as RSA+import Data.ByteString (ByteString)+import Data.Char (toLower)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Text as Text+import Data.Time.Clock (addUTCTime, getCurrentTime)+import qualified Data.X509 as X509+import GHC.Clock (getMonotonicTime)+import Network.TLS (Credential, Credentials (..), HostName)+import qualified Network.TLS as TLS+import Network.Wai.Handler.WarpTLS (TLSSettings, tlsServerHooks)++import qualified Acme.NotAJoke.Api.Authorization as Authorization+import Acme.NotAJoke.Api.Validation (KeyAuthorization (..))+import Acme.NotAJoke.CertManagement (acmeTLSALPNProtocol, createTLSALPN01Certificate)+import Acme.NotAJoke.Client (PrepareStep (..))+import Acme.NotAJoke.Dancer (AcmeDancer (..), DanceStep (..), runAcmeDance_tlsalpn01)+import Acme.NotAJoke.KeyManagement (genRSAKey)++{- | The challenge certificates being served: one credential per server name.++A same store can be shared by concurrent dances (for different names).+-}+data TlsAlpn01Store = TlsAlpn01Store+ { challenges :: IORef (Map HostName Credential)+ , negotiating :: IORef (Map ThreadId Double)+ {- ^ the handshakes which chose @acme-tls/1@ and still have to choose their+ certificate, by thread, with the (monotonic) time they chose the protocol+ -}+ }++-- | Creates an empty store.+newTlsAlpn01Store :: IO TlsAlpn01Store+newTlsAlpn01Store = TlsAlpn01Store <$> newIORef Map.empty <*> newIORef Map.empty++{- | Starts presenting a challenge certificate (see 'challengeCredential') to+the clients asking for @acme-tls/1@ and for a server name.++Names are compared without regard to case.+-}+insertTlsAlpn01 :: TlsAlpn01Store -> HostName -> Credential -> IO ()+insertTlsAlpn01 store name cred =+ atomicModifyIORef' store.challenges (\m -> (Map.insert (normalize name) cred m, ()))++-- | Stops presenting the challenge certificate of a server name.+deleteTlsAlpn01 :: TlsAlpn01Store -> HostName -> IO ()+deleteTlsAlpn01 store name =+ atomicModifyIORef' store.challenges (\m -> (Map.delete (normalize name) m, ()))++-- | The challenge certificate of a server name.+lookupTlsAlpn01 :: TlsAlpn01Store -> HostName -> IO (Maybe Credential)+lookupTlsAlpn01 store name =+ Map.lookup (normalize name) <$> readIORef store.challenges++-- | The server names which currently have a challenge certificate.+listTlsAlpn01 :: TlsAlpn01Store -> IO [HostName]+listTlsAlpn01 store = Map.keys <$> readIORef store.challenges++normalize :: HostName -> HostName+normalize = map toLower++{- | Makes warp-tls settings answer the TLS-ALPN-01 challenges of the store,+see 'tlsAlpn01Hooks'.++Apply it last, on settings which already read their certificates (e.g.,+'Acme.NotAJoke.Wai.WarpTLS.liveTlsSettings'):++> runTLS (withTlsAlpn01 challenges (liveTlsSettings certificates)) settings application+-}+withTlsAlpn01 :: TlsAlpn01Store -> TLSSettings -> TLSSettings+withTlsAlpn01 store settings =+ settings{tlsServerHooks = tlsAlpn01Hooks store (tlsServerHooks settings)}++{- | Wraps the server hooks of a TLS server to answer the TLS-ALPN-01+challenges of the store.++* the protocol hook ('TLS.onALPNClientSuggest') chooses @acme-tls/1@ when+ the client asks for it. Otherwise it calls the hook it wraps or, when there+ is none, does what warp-tls does: choose @h2@ when the client asks for it,+ @http/1.1@ otherwise. Hence, when HTTP/2 is disabled in the warp settings,+ set a hook choosing @http/1.1@ before wrapping;+* the server name hook ('TLS.onServerNameIndication') presents the challenge+ certificate of the server name to a handshake which chose @acme-tls/1@, and+ nothing when there is none (the handshake fails). Other handshakes go to+ the hook it wraps.++See the limits in the description of the module: TLS 1.3 only.+-}+tlsAlpn01Hooks :: TlsAlpn01Store -> TLS.ServerHooks -> TLS.ServerHooks+tlsAlpn01Hooks store hooks =+ hooks+ { TLS.onALPNClientSuggest = Just chooseProtocol+ , TLS.onServerNameIndication = chooseCredentials+ }+ where+ otherProtocols :: [ByteString] -> IO ByteString+ otherProtocols = fromMaybe warpProtocols (TLS.onALPNClientSuggest hooks)++ chooseProtocol :: [ByteString] -> IO ByteString+ chooseProtocol protocols+ | acmeTLSALPNProtocol `elem` protocols = do+ tid <- myThreadId+ now <- getMonotonicTime+ -- with TLS 1.2, the server name hook runs before this one and+ -- never removes the entry: drop the old ones+ atomicModifyIORef' store.negotiating $ \m ->+ (Map.insert tid now (Map.filter (> now - 60) m), ())+ pure acmeTLSALPNProtocol+ | otherwise = otherProtocols protocols++ chooseCredentials :: Maybe HostName -> IO Credentials+ chooseCredentials name = do+ tid <- myThreadId+ acme <- atomicModifyIORef' store.negotiating (\m -> (Map.delete tid m, Map.member tid m))+ if acme+ then Credentials . maybe [] pure <$> maybe (pure Nothing) (lookupTlsAlpn01 store) name+ else TLS.onServerNameIndication hooks name++-- | The protocols warp-tls chooses when HTTP/2 is enabled.+warpProtocols :: [ByteString] -> IO ByteString+warpProtocols protocols+ | "h2" `elem` protocols = pure "h2"+ | otherwise = pure "http/1.1"++{- | Creates the challenge certificate for a server name and the key+authorization of a TLS-ALPN-01 challenge, signed with a key (see+'Acme.NotAJoke.CertManagement.createTLSALPN01Certificate'). It is valid from+a day before now to a week after now.++The key can be any RSA key except the account key, e.g. a throw-away one from+'Acme.NotAJoke.KeyManagement.genRSAKey'.+-}+challengeCredential :: RSA.PrivateKey -> HostName -> KeyAuthorization -> IO (Either String Credential)+challengeCredential key name keyAuth = do+ now <- getCurrentTime+ created <- createTLSALPN01Certificate key (addUTCTime (-86400) now, addUTCTime (7 * 86400) now) (Text.pack name) keyAuth+ pure $ fmap (\cert -> (X509.CertificateChain [cert], X509.PrivKeyRSA key)) created++{- | Runs the dance with a TLS-ALPN-01 challenge served from the store.++The challenge certificate (for the identifier of the authorization, with a new+RSA-2048 key) is added to the store before the 'handleStep' of the dancer sees+the 'Validation' step, and is removed when the dance is over (whether the+dance succeeds, fails, or throws an exception).++Throws an 'IOError' when the challenge certificate cannot be created (e.g., the+authorization of the ACME server has no identifier).++The 'handleStep' of the dancer still is responsible for the other steps (e.g.,+waiting between two polls and storing the certificate).+-}+runAcmeDance_tlsalpn01_wai :: TlsAlpn01Store -> AcmeDancer -> IO ()+runAcmeDance_tlsalpn01_wai store dancer = do+ st <- newStepState+ runAcmeDance_tlsalpn01 (dancer{handleStep = serveSteps store st dancer.handleStep})+ `finally` stopServing store st++{- | Wraps a step handler to serve TLS-ALPN-01 challenges from the store, for+use with 'runAcmeDance_tlsalpn01' or with a custom matcher.++The challenge certificate is added to the store before the wrapped handler sees+the 'Validation' step, and is removed after the wrapped handler has seen the+last step of the dance ('Done', 'InvalidOrder', 'OtherError' or+'AcmeFailure'). The server name comes from the authorization, in the+'GotAuthorization' step.++The certificate is not removed if the dance throws an exception, see+'runAcmeDance_tlsalpn01_wai' for a variant handling exceptions.+-}+tlsAlpn01Steps :: TlsAlpn01Store -> (DanceStep -> IO ()) -> IO (DanceStep -> IO ())+tlsAlpn01Steps store handler = do+ st <- newStepState+ pure (serveSteps store st handler)++data StepState = StepState+ { identifier :: IORef (Maybe HostName)+ -- ^ the name of the authorization+ , served :: IORef [HostName]+ -- ^ the names added to the store+ }++newStepState :: IO StepState+newStepState = StepState <$> newIORef Nothing <*> newIORef []++-- | Step handler keeping track of the names it added to the store.+serveSteps :: TlsAlpn01Store -> StepState -> (DanceStep -> IO ()) -> DanceStep -> IO ()+serveSteps store st handler step =+ case step of+ Prepare (GotAuthorization authz) -> do+ let name = Text.unpack . Authorization.value . Authorization.identifier <$> Authorization.readAuthorization authz+ writeIORef st.identifier name+ handler step+ Validation (_, keyAuth, _) -> do+ known <- readIORef st.identifier+ name <- maybe (throwIO (userError "tls-alpn-01: no identifier in the authorization")) pure known+ key <- genRSAKey 2048+ created <- challengeCredential key name keyAuth+ cred <- either (throwIO . userError . ("tls-alpn-01: " <>)) pure created+ atomicModifyIORef' st.served (\names -> (name : names, ()))+ insertTlsAlpn01 store name cred+ handler step+ Done _ _ -> final+ InvalidOrder _ -> final+ OtherError _ -> final+ AcmeFailure _ -> final+ WaitingForValidation _ -> handler step+ OrderIsFinalized _ -> handler step+ ValidOrder _ -> handler step+ Prepare _ -> handler step+ where+ final = handler step `finally` stopServing store st++-- | Removes the names added by a step handler.+stopServing :: TlsAlpn01Store -> StepState -> IO ()+stopServing store st = do+ names <- atomicModifyIORef' st.served (\names -> ([], names))+ mapM_ (deleteTlsAlpn01 store) names
+ src/Acme/NotAJoke/Wai/WarpTLS.hs view
@@ -0,0 +1,173 @@+{- | Hands certificates to a running warp-tls server.++A warp-tls server started with 'Network.Wai.Handler.WarpTLS.tlsSettings' reads+its certificate once, when it starts. This module provides a+'CertificateStore' shared between two parties:++* the HTTPS server, started with 'liveTlsSettings', which reads the store at+ every TLS handshake+* whatever obtains certificates (e.g., the 'Acme.NotAJoke.Dancer.Done' step of an ACME dance, see+ 'installCertificate'), which writes into the store++Hence a certificate that is obtained or renewed while the server runs is+presented to the next connection, without a restart. Connections that already+are established are left alone.++The store is in memory only: writing the certificate to a file (and loading it+back with 'loadCredential' when the program starts) is up to the application.++Until the store has a credential for a connection, TLS handshakes fail (the+server has no certificate to present); plain HTTP is not affected.+-}+module Acme.NotAJoke.Wai.WarpTLS (+ -- * store+ CertificateStore,+ newCertificateStore,+ setCredential,+ setCredentialFor,+ deleteCredentialFor,+ clearCredentials,+ lookupCredential,++ -- * warp-tls+ liveTlsSettings,+ sniCredentials,++ -- * credentials+ credentialFromCertificate,+ credentialFromPEM,+ loadCredential,++ -- * dance+ installCertificate,+) where++import qualified Crypto.PubKey.RSA as RSA+import Data.ByteString (ByteString)+import Data.Char (toLower)+import Data.IORef (IORef, atomicModifyIORef', atomicWriteIORef, newIORef, readIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.X509 as X509+import Network.TLS (Credential, Credentials (..), HostName)+import qualified Network.TLS as TLS+import Network.Wai.Handler.WarpTLS (TLSSettings, tlsSettingsSni)++import Acme.NotAJoke.Api.Certificate (Certificate, readPEM)+import Acme.NotAJoke.CertManagement (certificateChain)++data Stored = Stored+ { fallback :: Maybe Credential+ , byName :: Map HostName Credential+ }++{- | The credentials (certificate chain and private key) a TLS server+presents.++A store has at most one default credential and at most one credential per+server name.+-}+newtype CertificateStore = CertificateStore (IORef Stored)++-- | Creates an empty store.+newCertificateStore :: IO CertificateStore+newCertificateStore = CertificateStore <$> newIORef (Stored Nothing Map.empty)++{- | Sets the default credential: the one presented when there is no+credential for the server name asked by the client (or when the client asks+for no name).++This is all you need when the server has a single certificate.+-}+setCredential :: CertificateStore -> Credential -> IO ()+setCredential (CertificateStore ref) cred =+ atomicModifyIORef' ref (\s -> (s{fallback = Just cred}, ()))++{- | Sets the credential presented to clients asking for a given server name+(the SNI extension of TLS).++Names are compared without regard to case and must match exactly: there is no+wildcard matching (use 'setCredential' for a wildcard certificate).+-}+setCredentialFor :: CertificateStore -> HostName -> Credential -> IO ()+setCredentialFor (CertificateStore ref) name cred =+ atomicModifyIORef' ref (\s -> (s{byName = Map.insert (normalize name) cred s.byName}, ()))++-- | Removes the credential of a server name.+deleteCredentialFor :: CertificateStore -> HostName -> IO ()+deleteCredentialFor (CertificateStore ref) name =+ atomicModifyIORef' ref (\s -> (s{byName = Map.delete (normalize name) s.byName}, ()))++-- | Removes every credential, including the default one.+clearCredentials :: CertificateStore -> IO ()+clearCredentials (CertificateStore ref) =+ atomicWriteIORef ref (Stored Nothing Map.empty)++{- | The credential presented for a server name: the one set for this name if+any, the default one otherwise.+-}+lookupCredential :: CertificateStore -> Maybe HostName -> IO (Maybe Credential)+lookupCredential (CertificateStore ref) name = do+ s <- readIORef ref+ pure $ case (`Map.lookup` s.byName) . normalize =<< name of+ Just cred -> Just cred+ Nothing -> s.fallback++normalize :: HostName -> HostName+normalize = map toLower++{- | Settings for 'Network.Wai.Handler.WarpTLS.runTLS' which read the+credential in the store at every TLS handshake.++These are the default settings of warp-tls with a hook on the server name+indication: update the record to change other settings, but leave+'Network.Wai.Handler.WarpTLS.tlsCredentials' and the+'TLS.onServerNameIndication' hook alone (or call 'sniCredentials' from your own+hook).+-}+liveTlsSettings :: CertificateStore -> TLSSettings+liveTlsSettings = tlsSettingsSni . sniCredentials++{- | The 'TLS.onServerNameIndication' hook reading the store, for use with+'tlsSettingsSni' or with a TLS server which is not warp-tls.+-}+sniCredentials :: CertificateStore -> Maybe HostName -> IO Credentials+sniCredentials store name =+ Credentials . maybe [] pure <$> lookupCredential store name++{- | Builds a credential from the certificate returned by the ACME server (the+one given in the 'Acme.NotAJoke.Dancer.Done' step) and the private key that+signed the CSR.+-}+credentialFromCertificate :: RSA.PrivateKey -> Certificate -> Either String Credential+credentialFromCertificate key cert = do+ chain <- certificateChain (readPEM cert)+ case chain of+ [] -> Left "no certificate in the response of the ACME server"+ _ -> Right (X509.CertificateChain chain, X509.PrivKeyRSA key)++{- | Builds a credential from the content of PEM files: the certificate chain+(leaf certificate first) then the private key.+-}+credentialFromPEM :: ByteString -> ByteString -> Either String Credential+credentialFromPEM = TLS.credentialLoadX509FromMemory++{- | Loads a credential from PEM files: the certificate chain (leaf+certificate first, as written by 'Acme.NotAJoke.Api.Certificate.storeCert')+then the private key (as written by+'Acme.NotAJoke.KeyManagement.writeRSAKeyPEM').++Typically called when the program starts, to serve the certificate obtained+by a previous run.+-}+loadCredential :: FilePath -> FilePath -> IO (Either String Credential)+loadCredential = TLS.credentialLoadX509++{- | Makes a certificate returned by the ACME server the default credential+of the store, see 'credentialFromCertificate' and 'setCredential'.++The store is left unchanged when the certificate cannot be parsed.+-}+installCertificate :: CertificateStore -> RSA.PrivateKey -> Certificate -> IO (Either String ())+installCertificate store key cert =+ traverse (setCredential store) (credentialFromCertificate key cert)
+ test/Main.hs view
@@ -0,0 +1,124 @@+module Main (main) where++import Control.Exception (ErrorCall (..), throwIO, try)+import Control.Monad (unless)+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Lazy as LByteString+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Network.HTTP.Types (Status, methodPost, status200, status404)+import Network.Wai (Application, Request, Response, defaultRequest, pathInfo, requestMethod, responseLBS, responseStatus, responseToStream)+import System.Exit (exitFailure)++import Acme.NotAJoke.Api.Challenge (Token (..))+import Acme.NotAJoke.Api.Validation (KeyAuthorization (..), sha256digest)+import Acme.NotAJoke.Dancer (DanceStep (..))+import Acme.NotAJoke.Wai.Http01++main :: IO ()+main = do+ middlewareServesKnownTokens+ stepsFillAndClearStore+ stepsClearStoreWhenHandlerThrows+ putStrLn "ok"++token1 :: Token+token1 = Token "token-1"++keyAuth1 :: KeyAuthorization+keyAuth1 = KeyAuthorization "token-1.thumbprint"++validation1 :: DanceStep+validation1 = Validation (token1, keyAuth1, sha256digest keyAuth1)++-- | The application behind the middleware.+fallback :: Application+fallback _ respond = respond $ responseLBS status404 [] "fallback"++challengeRequest :: Request+challengeRequest = defaultRequest{pathInfo = [".well-known", "acme-challenge", "token-1"]}++middlewareServesKnownTokens :: IO ()+middlewareServesKnownTokens = do+ store <- newChallengeStore+ let app = http01Middleware store fallback++ before <- run app challengeRequest+ check "unknown token is passed to the application" (before == (status404, "fallback"))++ insertChallenge store token1 keyAuth1+ found <- run app challengeRequest+ check "known token gets the key authorization" (found == (status200, "token-1.thumbprint"))++ posted <- run app challengeRequest{requestMethod = methodPost}+ check "non-GET is passed to the application" (posted == (status404, "fallback"))++ other <- run app defaultRequest{pathInfo = [".well-known", "acme-challenge", "token-1", "extra"]}+ check "other path is passed to the application" (other == (status404, "fallback"))++ deleteChallenge store token1+ after <- run app challengeRequest+ check "deleted token is passed to the application" (after == (status404, "fallback"))++stepsFillAndClearStore :: IO ()+stepsFillAndClearStore = do+ store <- newChallengeStore+ seen <- newIORef (0 :: Int)+ servedAtValidation <- newIORef Nothing+ let handler step = do+ modifyIORef' seen succ+ case step of+ Validation _ -> writeIORef servedAtValidation =<< lookupChallenge store token1+ _ -> pure ()+ handle <- http01Steps store handler++ handle validation1+ atValidation <- readIORef servedAtValidation+ check "token is served when the handler sees the validation" (atValidation == Just keyAuth1)++ handle (WaitingForValidation 0)+ during <- listChallenges store+ check "token is served while waiting" (during == [token1])++ handle (OtherError "stop")+ after <- listChallenges store+ check "token is removed after the last step" (null after)++ n <- readIORef seen+ check "wrapped handler sees every step" (n == 3)++stepsClearStoreWhenHandlerThrows :: IO ()+stepsClearStoreWhenHandlerThrows = do+ store <- newChallengeStore+ let handler step =+ case step of+ OtherError _ -> throwIO (ErrorCall "boom")+ _ -> pure ()+ handle <- http01Steps store handler+ handle validation1+ res <- try (handle (OtherError "stop"))+ check "exception of the wrapped handler is rethrown" (res == Left (ErrorCall "boom"))+ after <- listChallenges store+ check "token is removed when the last step throws" (null after)++-- | Runs an application, returns the status and the body of the response.+run :: Application -> Request -> IO (Status, LByteString.ByteString)+run app req = do+ out <- newIORef Nothing+ _ <- app req $ \rsp -> do+ body <- responseBody rsp+ writeIORef out (Just (responseStatus rsp, body))+ pure (error "no ResponseReceived in tests")+ maybe (fail "no response") pure =<< readIORef out++responseBody :: Response -> IO LByteString.ByteString+responseBody rsp = do+ let (_, _, withBody) = responseToStream rsp+ chunks <- newIORef mempty+ withBody $ \streamingBody ->+ streamingBody (\chunk -> modifyIORef' chunks (<> chunk)) (pure ())+ toLazyByteString <$> readIORef chunks++check :: String -> Bool -> IO ()+check name ok = do+ putStrLn $ (if ok then "pass: " else "FAIL: ") <> name+ unless ok exitFailure
+ test/TlsAlpn01.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE TupleSections #-}++module Main (main) where++import Control.Concurrent (forkIO, killThread)+import Control.Exception (SomeException, bracket, try)+import Control.Monad (unless)+import Crypto.Hash.Algorithms (SHA256 (..))+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as PKCS15+import Data.ASN1.BinaryEncoding (DER (..))+import Data.ASN1.Encoding (decodeASN1')+import Data.ASN1.Types (ASN1 (..), ASN1StringEncoding (UTF8), asn1CharacterString, getObjectID)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import Data.IORef (newIORef, readIORef, writeIORef)+import qualified Data.X509 as X509+import Data.X509.Validation (SignatureVerification (..), verifySignedSignature)+import Network.HTTP.Types (status200)+import qualified Network.Socket as Socket+import qualified Network.TLS as TLS+import Network.Wai (responseLBS)+import Network.Wai.Handler.Warp (Port, Settings, defaultSettings, openFreePort, setOnException)+import Network.Wai.Handler.WarpTLS (runTLSSocket)+import System.Exit (exitFailure)+import Time.Types (Date (..), DateTime (..), Month (..), TimeOfDay (..))++import Acme.NotAJoke.Api.Validation (KeyAuthorization (..))+import Acme.NotAJoke.CertManagement (acmeIdentifierDigest, acmeIdentifierOID, acmeTLSALPNProtocol)+import Acme.NotAJoke.KeyManagement (genRSAKey)+import Acme.NotAJoke.Wai.TlsAlpn01+import Acme.NotAJoke.Wai.WarpTLS (liveTlsSettings, newCertificateStore, setCredential)++keyAuth :: KeyAuthorization+keyAuth = KeyAuthorization "token.thumbprint"++main :: IO ()+main = do+ key <- genRSAKey 2048+ Right challenge <- challengeCredential key "a.test" keyAuth+ challengeCertificateHasTheExtension key challenge+ storeLooksUpChallenges challenge+ serverAnswersChallenges challenge+ putStrLn "ok"++challengeCertificateHasTheExtension :: RSA.PrivateKey -> TLS.Credential -> IO ()+challengeCertificateHasTheExtension key (X509.CertificateChain chain, _) = do+ check "the challenge certificate is alone in its chain" (length chain == 1)+ leaf <- case chain of+ (leaf : _) -> pure leaf+ [] -> fail "empty chain"+ let cert = X509.getCertificate leaf+ X509.Extensions exts = X509.certExtensions cert+ acme = [e | e <- concat exts, X509.extRawOID e == acmeIdentifierOID]+ check "the certificate has one acmeIdentifier extension" (length acme == 1)+ check "the acmeIdentifier extension is critical" (all X509.extRawCritical acme)+ check "the digest is the SHA-256 of the key authorization" (acmeIdentifierDigest keyAuth == expectedDigest)+ check+ "the acmeIdentifier extension holds the digest as an octet string"+ (map (decodeASN1' DER . X509.extRawContent) acme == [Right [OctetString expectedDigest]])+ check+ "the certificate is for the name only"+ (X509.extensionGet (X509.certExtensions cert) == Just (X509.ExtSubjectAltName [X509.AltNameDNS "a.test"]))+ check "the certificate is for the key" (X509.certPubKey cert == X509.PubKeyRSA (RSA.private_pub key))+ check+ "the certificate is self-signed"+ (verifySignedSignature leaf (X509.certPubKey cert) == SignaturePass)+ where+ -- sha256sum of "token.thumbprint"+ expectedDigest :: ByteString+ expectedDigest =+ ByteString.pack+ [ 0xeb, 0x5a, 0xc1, 0x67, 0xfe, 0x24, 0x9c, 0x76, 0xe5, 0x3b, 0x43, 0x0d, 0xa3, 0x11, 0x6c, 0x5d+ , 0x9f, 0xde, 0x4c, 0x55, 0x07, 0xba, 0x6d, 0x01, 0xe8, 0x85, 0x51, 0x6e, 0x1b, 0xd4, 0x9f, 0x92+ ]++storeLooksUpChallenges :: TLS.Credential -> IO ()+storeLooksUpChallenges challenge = do+ store <- newTlsAlpn01Store+ insertTlsAlpn01 store "A.test" challenge+ found <- fmap fst <$> lookupTlsAlpn01 store "a.TEST"+ check "challenges are looked up regardless of case" (found == Just (fst challenge))+ names <- listTlsAlpn01 store+ check "challenges are listed" (names == ["a.test"])+ deleteTlsAlpn01 store "a.test"+ deleted <- lookupTlsAlpn01 store "a.test"+ check "deleted challenges are gone" (null (fmap fst deleted))++{- | Runs a warp-tls server with a regular certificate and the challenges of a+store, and checks what TLS clients get.+-}+serverAnswersChallenges :: TLS.Credential -> IO ()+serverAnswersChallenges challenge = do+ regular <- selfSigned "a.test"+ certificates <- newCertificateStore+ setCredential certificates regular+ challenges <- newTlsAlpn01Store+ (port, sock) <- openFreePort+ let app _ respond = respond $ responseLBS status200 [] "hello"+ let settings = withTlsAlpn01 challenges (liveTlsSettings certificates)+ bracket (forkIO $ runTLSSocket settings quiet sock app) killThread $ \_ -> do+ plain <- handshake port "a.test" Nothing TLS.TLS13+ check "a client without ALPN gets the regular certificate" (plain == Just (fst regular, Nothing))+ h2 <- handshake port "a.test" (Just ["h2", "http/1.1"]) TLS.TLS13+ check "a client asking for h2 still gets it" (h2 == Just (fst regular, Just "h2"))+ http1 <- handshake port "a.test" (Just ["http/1.1"]) TLS.TLS13+ check "a client asking for http/1.1 still gets it" (http1 == Just (fst regular, Just "http/1.1"))++ none <- handshake port "a.test" (Just [acmeTLSALPNProtocol]) TLS.TLS13+ check "acme-tls/1 handshakes fail without a challenge" (none == Nothing)++ insertTlsAlpn01 challenges "a.test" challenge+ answered <- handshake port "a.test" (Just [acmeTLSALPNProtocol]) TLS.TLS13+ check "acme-tls/1 handshakes get the challenge certificate" (answered == Just (fst challenge, Just acmeTLSALPNProtocol))+ other <- handshake port "b.test" (Just [acmeTLSALPNProtocol]) TLS.TLS13+ check "acme-tls/1 handshakes for another name fail" (other == Nothing)+ regularStill <- handshake port "a.test" (Just ["h2", "http/1.1"]) TLS.TLS13+ check "other handshakes still get the regular certificate" (regularStill == Just (fst regular, Just "h2"))+ tls12 <- handshake port "a.test" (Just [acmeTLSALPNProtocol]) TLS.TLS12+ check "acme-tls/1 handshakes over TLS 1.2 do not get the challenge certificate" (fmap fst tls12 /= Just (fst challenge))+ afterTls12 <- handshake port "a.test" (Just ["http/1.1"]) TLS.TLS12+ check "TLS 1.2 handshakes get the regular certificate" (afterTls12 == Just (fst regular, Just "http/1.1"))++ deleteTlsAlpn01 challenges "a.test"+ removed <- handshake port "a.test" (Just [acmeTLSALPNProtocol]) TLS.TLS13+ check "acme-tls/1 handshakes fail once the challenge is removed" (removed == Nothing)++-- | Failed handshakes are expected: they are not logged.+quiet :: Settings+quiet = setOnException (\_ _ -> pure ()) defaultSettings++{- | The certificate chain a server on localhost presents to a client asking+for a server name and some protocols, and the protocol chosen by the server,+if the handshake succeeds.+-}+handshake :: Port -> TLS.HostName -> Maybe [ByteString] -> TLS.Version -> IO (Maybe (X509.CertificateChain, Maybe ByteString))+handshake port name protocols version = do+ seen <- newIORef Nothing+ let hooks =+ TLS.defaultClientHooks+ { TLS.onServerCertificate = \_ _ _ chain -> do+ writeIORef seen (Just chain)+ -- test certificates are self-signed+ pure []+ , TLS.onSuggestALPN = pure protocols+ }+ let params =+ (TLS.defaultParamsClient name "")+ { TLS.clientHooks = hooks+ , TLS.clientSupported = TLS.defaultSupported{TLS.supportedVersions = [version]}+ }+ res <- try (bracket (connect port) Socket.close (run params))+ case res :: Either SomeException (Maybe ByteString) of+ Left _ -> pure Nothing+ Right protocol -> fmap (,protocol) <$> readIORef seen+ where+ run params sock = do+ ctx <- TLS.contextNew sock params+ TLS.handshake ctx+ protocol <- TLS.getNegotiatedProtocol ctx+ TLS.bye ctx+ pure protocol++connect :: Port -> IO Socket.Socket+connect 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 sock++selfSigned :: String -> IO TLS.Credential+selfSigned name = do+ key <- genRSAKey 2048+ signed <- X509.objectToSignedExactF (sign key) (certificate key)+ pure (X509.CertificateChain [signed], X509.PrivKeyRSA key)+ where+ alg :: X509.SignatureALG+ alg = X509.SignatureALG X509.HashSHA256 X509.PubKeyALG_RSA++ sign key bytes = do+ signature <- PKCS15.signSafer (Just SHA256) key bytes+ either (fail . show) (pure . (,alg)) signature++ dn :: X509.DistinguishedName+ dn = X509.DistinguishedName [(getObjectID X509.DnCommonName, asn1CharacterString UTF8 name)]++ midnight :: TimeOfDay+ midnight = TimeOfDay 0 0 0 0++ certificate key =+ X509.Certificate+ { X509.certVersion = 2+ , X509.certSerial = 1+ , X509.certSignatureAlg = alg+ , X509.certIssuerDN = dn+ , X509.certValidity = (DateTime (Date 2020 January 1) midnight, DateTime (Date 2120 January 1) midnight)+ , X509.certSubjectDN = dn+ , X509.certPubKey = X509.PubKeyRSA (RSA.private_pub key)+ , X509.certExtensions = X509.Extensions Nothing+ }++check :: String -> Bool -> IO ()+check name ok = do+ putStrLn $ (if ok then "pass: " else "FAIL: ") <> name+ unless ok exitFailure
+ test/WarpTLS.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE TupleSections #-}++module Main (main) where++import Control.Concurrent (forkIO, killThread)+import Control.Exception (SomeException, bracket, try)+import Control.Monad (unless)+import Crypto.Hash.Algorithms (SHA256 (..))+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as PKCS15+import Data.ASN1.Types (ASN1CharacterString, ASN1StringEncoding (UTF8), asn1CharacterString, getObjectID)+import Data.IORef (newIORef, readIORef, writeIORef)+import qualified Data.X509 as X509+import Network.HTTP.Types (status200)+import qualified Network.Socket as Socket+import qualified Network.TLS as TLS+import Network.Wai (responseLBS)+import Network.Wai.Handler.Warp (Port, Settings, defaultSettings, openFreePort, setOnException)+import Network.Wai.Handler.WarpTLS (runTLSSocket)+import System.Exit (exitFailure)+import Time.Types (Date (..), DateTime (..), Month (..), TimeOfDay (..))++import Acme.NotAJoke.CertManagement (encodeCertificateChain)+import Acme.NotAJoke.KeyManagement (encodeRSAKeyPEM, genRSAKey)+import Acme.NotAJoke.Wai.WarpTLS++main :: IO ()+main = do+ credA <- selfSigned "a.test"+ credB <- selfSigned "b.test"+ storeLooksUpCredentials credA credB+ credentialIsReadFromPEM+ serverPresentsLiveCredentials credA credB+ putStrLn "ok"++storeLooksUpCredentials :: TLS.Credential -> TLS.Credential -> IO ()+storeLooksUpCredentials credA credB = do+ store <- newCertificateStore+ let served name = fmap fst <$> lookupCredential store name++ empty <- served (Just "a.test")+ check "empty store has no credential" (empty == Nothing)++ setCredential store credA+ noName <- served Nothing+ check "default credential is presented without server name" (noName == Just (fst credA))+ unknown <- served (Just "unknown.test")+ check "default credential is presented for an unknown name" (unknown == Just (fst credA))++ setCredentialFor store "B.test" credB+ named <- served (Just "b.TEST")+ check "named credential is presented regardless of case" (named == Just (fst credB))+ other <- served (Just "a.test")+ check "default credential still is presented for other names" (other == Just (fst credA))++ hooked <- sniCredentials store (Just "b.test")+ check "the hook returns the credential of the name" (chains hooked == [fst credB])++ deleteCredentialFor store "b.test"+ deleted <- served (Just "b.test")+ check "deleted name falls back to the default credential" (deleted == Just (fst credA))++ clearCredentials store+ cleared <- sniCredentials store Nothing+ check "cleared store has no credential" (null (chains cleared))+ where+ chains (TLS.Credentials creds) = map fst creds++credentialIsReadFromPEM :: IO ()+credentialIsReadFromPEM = do+ key <- genRSAKey 2048+ chain <- selfSignedChain key "pem.test"+ let X509.CertificateChain certs = chain+ let loaded = credentialFromPEM (encodeCertificateChain certs) (encodeRSAKeyPEM key)+ check "credential is read from the PEM formats of the library" (fmap fst loaded == Right chain)+ check "credential without a key is refused" (isLeft (credentialFromPEM (encodeCertificateChain certs) ""))+ where+ isLeft = either (const True) (const False)++{- | Runs a warp-tls server on the store, and checks which certificate TLS+clients get while the store changes.+-}+serverPresentsLiveCredentials :: TLS.Credential -> TLS.Credential -> IO ()+serverPresentsLiveCredentials credA credB = do+ store <- newCertificateStore+ (port, sock) <- openFreePort+ let app _ respond = respond $ responseLBS status200 [] "hello"+ bracket (forkIO $ runTLSSocket (liveTlsSettings store) quiet sock app) killThread $ \_ -> do+ before <- presented port "a.test"+ check "handshake fails while the store is empty" (before == Nothing)++ setCredential store credA+ first <- presented port "a.test"+ check "running server presents the credential added to the store" (first == Just (fst credA))++ setCredential store credB+ renewed <- presented port "a.test"+ check "running server presents the credential replacing it" (renewed == Just (fst credB))++ setCredentialFor store "a.test" credA+ named <- presented port "a.test"+ check "running server presents the credential of the server name" (named == Just (fst credA))+ other <- presented port "b.test"+ check "running server presents the default credential for other names" (other == Just (fst credB))++-- | Failed handshakes are expected: they are not logged.+quiet :: Settings+quiet = setOnException (\_ _ -> pure ()) defaultSettings++{- | The certificate chain a server on localhost presents to a client asking+for a server name, if the handshake succeeds.+-}+presented :: Port -> TLS.HostName -> IO (Maybe X509.CertificateChain)+presented port name = do+ seen <- newIORef Nothing+ let hooks =+ TLS.defaultClientHooks+ { TLS.onServerCertificate = \_ _ _ chain -> do+ writeIORef seen (Just chain)+ -- test certificates are self-signed+ pure []+ }+ let params =+ (TLS.defaultParamsClient name "")+ { TLS.clientHooks = hooks+ , TLS.clientSupported = TLS.defaultSupported+ }+ res <- try (bracket (connect port) Socket.close (handshake params))+ case res :: Either SomeException () of+ Left _ -> pure Nothing+ Right () -> readIORef seen+ where+ handshake params sock = do+ ctx <- TLS.contextNew sock params+ TLS.handshake ctx+ TLS.bye ctx++connect :: Port -> IO Socket.Socket+connect 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 sock++selfSigned :: String -> IO TLS.Credential+selfSigned name = do+ key <- genRSAKey 2048+ chain <- selfSignedChain key name+ pure (chain, X509.PrivKeyRSA key)++selfSignedChain :: RSA.PrivateKey -> String -> IO X509.CertificateChain+selfSignedChain key name = do+ signed <- X509.objectToSignedExactF sign certificate+ pure $ X509.CertificateChain [signed]+ where+ alg :: X509.SignatureALG+ alg = X509.SignatureALG X509.HashSHA256 X509.PubKeyALG_RSA++ sign bytes = do+ signature <- PKCS15.signSafer (Just SHA256) key bytes+ either (fail . show) (pure . (,alg)) signature++ commonName :: ASN1CharacterString+ commonName = asn1CharacterString UTF8 name++ dn :: X509.DistinguishedName+ dn = X509.DistinguishedName [(getObjectID X509.DnCommonName, commonName)]++ midnight :: TimeOfDay+ midnight = TimeOfDay 0 0 0 0++ certificate :: X509.Certificate+ certificate =+ X509.Certificate+ { X509.certVersion = 2+ , X509.certSerial = 1+ , X509.certSignatureAlg = alg+ , X509.certIssuerDN = dn+ , X509.certValidity = (DateTime (Date 2020 January 1) midnight, DateTime (Date 2120 January 1) midnight)+ , X509.certSubjectDN = dn+ , X509.certPubKey = X509.PubKeyRSA (RSA.private_pub key)+ , X509.certExtensions = X509.Extensions Nothing+ }++check :: String -> Bool -> IO ()+check name ok = do+ putStrLn $ (if ok then "pass: " else "FAIL: ") <> name+ unless ok exitFailure