acme-not-a-joke-warp (empty) → 0.1.0.0

raw patch · 8 files changed

+1705/−0 lines, 8 filesdep +acme-not-a-jokedep +acme-not-a-joke-waidep +acme-not-a-joke-warp

Dependencies added: acme-not-a-joke, acme-not-a-joke-wai, acme-not-a-joke-warp, async, base, bytestring, containers, crypton, crypton-asn1-types, crypton-x509, directory, filepath, http-types, network, text, time, time-hourglass, tls, transformers, wai, warp, warp-tls

Files

• CHANGELOG.md +24/−0
• LICENSE +30/−0
• README.md +208/−0
• acme-not-a-joke-warp.cabal +105/−0
• example/Main.hs +46/−0
• src/Acme/NotAJoke/Warp.hs +242/−0
• src/Acme/NotAJoke/Warp/CertificateManager.hs +534/−0
• test/Main.hs +516/−0

@@ -0,0 +1,24 @@+# Revision history for acme-not-a-joke-warp++## 0.1.0.0 -- 2026-10-23++* TLS-ALPN-01 challenges: `challengeMethod = TlsAlpn01` makes `runAutoHttps`+  get the certificates with challenges answered by the HTTPS server, and+  `serveHttp = False` leaves out the HTTP server (port 80). The HTTPS server+  always answers the TLS-ALPN-01 challenges of its store (`withTlsAlpn01`).+  `acmeTlsAlpn01Issuer` is the issuer doing so.+* `runAutoHttpsWith` gives the issuer `Challenges` (the stores of both+  challenge types, see `newChallenges`) rather than a `ChallengeStore`.++* First version: `Acme.NotAJoke.Warp` with `runAutoHttps`, running a wai+  application over HTTPS (warp-tls) next to an HTTP server which answers+  HTTP-01 challenges and redirects to HTTPS (`redirectToHttps`).+* `Acme.NotAJoke.Warp.CertificateManager`: a `CertificateManager` which+  obtains one certificate per domain when it starts, stores keys and+  certificates on disk, renews the certificates before they expire, hands them+  to the `CertificateStore` of a running warp-tls server, and retries with+  increasing delays when it fails (`runCertificateManager`,+  `checkCertificates`). `acmeIssuer` gets the certificates with an ACME dance;+  failures are reported as `Event`s instead of thrown.+* A README, an example program (behind the `example` flag) and a+  `certificate-manager` test-suite.

@@ -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.

@@ -0,0 +1,208 @@+# acme-not-a-joke-warp++Automatic HTTPS for warp, in the spirit of Caddy: runs a wai application over+HTTPS with certificates obtained from an ACME server (e.g. Let's Encrypt),+which are stored on disk, renewed before they expire, and served without+restarting.++Built on [acme-not-a-joke](../README.md) (the ACME client) and+[acme-not-a-joke-wai](../acme-not-a-joke-wai/README.md) (HTTP-01 challenges+and the live certificate store for warp-tls).++```hs+import Acme.NotAJoke.LetsEncrypt (letsencryptv2)+import Acme.NotAJoke.Warp+import Data.List.NonEmpty (NonEmpty (..))++main :: IO ()+main =+  runAutoHttps+    (defaultAutoHttps letsencryptv2 ("example.dicioccio.fr" :| []) ["mailto:certmaster@dicioccio.fr"] "state")+    application+```++Using an ACME server means agreeing to its terms of service: the account is+created saying so.++## what runs++`runAutoHttps` runs three things until one of the servers stops:++- an **HTTPS server** (port 443) running your application. It reads its+  certificate from a `CertificateStore` at each TLS handshake, and answers the+  TLS-ALPN-01 challenges of the ACME server;+- an **HTTP server** (port 80) answering the HTTP-01 challenges of the ACME+  server and redirecting any other request to HTTPS (308). Set+  `httpApplication` to run something else than the redirection, and+  `serveHttp = False` to leave it out (with TLS-ALPN-01 challenges);+- a **certificate manager**, which looks after one certificate per domain.++The machine must be reachable from the Internet under each domain, on port 80+(the ACME server connects there, whatever `httpSettings` says: change the port+only when something forwards port 80 to it) and on the HTTPS port.++## without port 80: tls-alpn-01++With `challengeMethod = TlsAlpn01`, the ACME server validates the domains with+TLS-ALPN-01 challenges (RFC-8737): it opens a TLS connection to port 443+asking for the `acme-tls/1` protocol, and the HTTPS server presents a+self-signed challenge certificate to this connection only. Port 80 is not+needed:++```hs+let cfg = defaultAutoHttps letsencryptv2 ("example.dicioccio.fr" :| []) contacts "state"+runAutoHttps cfg{challengeMethod = TlsAlpn01, serveHttp = False} application+```++The HTTPS server must then be reachable on port 443 (or behind something+forwarding port 443 without terminating TLS), and keep its TLS 1.3 support+(the default of warp-tls): the challenge is answered over TLS 1.3 only.+Answering the challenges takes over the choice of the protocol (ALPN), which+picks `h2` or `http/1.1` as warp-tls does: when HTTP/2 is disabled in+`httpsSettings`, set an `onALPNClientSuggest` hook choosing `http/1.1` with+`tweakTls`.++For each domain, the manager:++1. loads the certificate stored by a previous run, and serves it;+2. when there is none, or when it is due for renewal, runs an ACME dance with+   an HTTP-01 (or TLS-ALPN-01) challenge, writes the new certificate on disk and puts it in the+   `CertificateStore`: the next TLS connection gets it, established connections+   are left alone, nothing is restarted;+3. when the dance fails, reports the failure and tries again later.++Until the first certificate is there (a few seconds when all goes well), TLS+handshakes fail: the server has nothing to present.++## when++| what | default | setting (in `ManagerSettings`) |+|------|---------|--------------------------------|+| renewal | when two thirds of the validity period have elapsed (30 days before the end of a 90-days certificate) | `renewAt`, e.g. `renewBefore (20 * 86400)` |+| retry after a failure | 2 minutes, then twice as long after each failure in a row, up to 6 hours | `retryDelay` |+| looking at the clock | at least every hour | `checkInterval` |++A stored certificate which is due for renewal but still valid is served while+the manager tries to renew it. A failure never stops the servers and is not+thrown: errors of the ACME server, network failures, and errors while reading+or writing files all are reported as an `Event` to `onEvent` (which prints a+line on stderr by default).++ACME providers limit the number of failed validations (five per hour and per+name at Let's Encrypt): keep that in mind when changing `retryDelay`, and use+the staging environment (`staging_letsencryptv2`) while testing.++## where things are stored++Everything is in the state directory (the last argument of+`defaultAutoHttps`), which is created if missing:++| file | role |+|------|------|+| `account.jwk` | the ACME account key, created on the first run (and so is the account) |+| `{domain}/key.pem` | the private key of the certificate (RSA, PKCS#1), created on the first run and reused for renewals |+| `{domain}/certificate.pem` | the certificate chain, leaf certificate first, replaced at each renewal |++The CSR is built in memory at each dance. Files are written aside and renamed,+so that a reader never sees half a file. `key.pem` and `certificate.pem` are in+the formats that warp-tls, nginx, haproxy etc. read.++The directory holds private keys and files are created with the default+permissions of the process: restrict who can read the directory.++Removing `{domain}/certificate.pem` makes the manager ask for a new certificate+at the next start. A stored certificate which cannot be parsed, or which is not+for the stored key, is replaced. A key file which cannot be read is left alone:+this is reported as a failure, for you to sort out.++## settings++`defaultAutoHttps` gives an `AutoHttps` record to update:++```hs+let cfg = defaultAutoHttps letsencryptv2 ("example.dicioccio.fr" :| ["www.example.dicioccio.fr"]) contacts "state"+runAutoHttps+  cfg+    { httpsSettings = setPort 8443 defaultSettings+    , managerSettings = cfg.managerSettings{renewAt = renewBefore (20 * 86400), onEvent = myLogger}+    }+  application+```++- `managerSettings`: domains, state directory, renewal and retry times, key+  generation (`generateKey`, RSA-4096 by default), event handler;+- `acmeSettings`: ACME server, path of the account key, contacts, how long an+  order is polled;+- `challengeMethod`: `Http01` (the default) or `TlsAlpn01`;+- `serveHttp`: whether to run the HTTP server (`True` by default);+- `httpSettings`, `httpsSettings`: the warp settings of both servers;+- `tweakTls`: changes the warp-tls settings (leave the server name indication+  hook alone, it is the one reading the certificates). The settings are then+  wrapped with `withTlsAlpn01`;+- `httpApplication`: what the HTTP server runs besides answering challenges.++With several domains, each one has its own certificate, presented to clients+asking for this name (SNI). The certificate of the first domain also is the+default one.++## running the parts yourself++`runAutoHttps` is a dozen lines assembling parts that you can use directly,+e.g. when the HTTP server on port 80 is not a warp server of this program, or+to keep certificates fresh for something else than warp:++```hs+challenges <- newChallengeStore+certificates <- newCertificateStore+Right manager <-+  newCertificateManager+    (defaultManagerSettings ("example.dicioccio.fr" :| []) "state")+    (acmeIssuer (defaultAcmeSettings letsencryptv2 "state/account.jwk" contacts) challenges)+    certificates++forkIO $ run 80 (http01Middleware challenges (redirectToHttps 443))+forkIO $ runTLS (liveTlsSettings certificates) (setPort 443 defaultSettings) application+runCertificateManager manager+```++With TLS-ALPN-01 challenges, use a `TlsAlpn01Store` instead of the+`ChallengeStore`, and no HTTP server:++```hs+challenges <- newTlsAlpn01Store+-- ...+    (acmeTlsAlpn01Issuer (defaultAcmeSettings letsencryptv2 "state/account.jwk" contacts) challenges)+-- ...+forkIO $ runTLS (withTlsAlpn01 challenges (liveTlsSettings certificates)) (setPort 443 defaultSettings) application+```++`checkCertificates` is a single pass of `runCertificateManager`, and returns+when the next pass is due. An `Issuer` is a function from a domain and a key to+a certificate chain: `acmeIssuer` is the ACME one, the tests use one making+self-signed certificates.++## example++[example/Main.hs](example/Main.hs):++```console+cabal build -fexample acme-not-a-joke-warp-example+sudo $(cabal list-bin -fexample acme-not-a-joke-warp-example) example.dicioccio.fr certmaster@dicioccio.fr ./state+```++Add `tls-alpn-01` after the state directory to use TLS-ALPN-01 challenges and+no port 80. It uses the staging environment of Let's Encrypt.++## limits++- HTTP-01 or TLS-ALPN-01 only: no wildcard certificates (they need DNS-01).+- TLS-ALPN-01 challenges are answered over TLS 1.3 only.+- One certificate per domain rather than one certificate for several names+  (the dance of `acme-not-a-joke` validates a single authorization per order).+- Certificate keys are RSA, and the key is reused across renewals.+- The names in a stored certificate are not checked against the domain of its+  directory.+- No OCSP stapling, no revocation, no on-demand certificates for names which+  are not listed.+- One process per state directory: nothing coordinates several instances+  behind a load balancer.

@@ -0,0 +1,105 @@+cabal-version:      2.4+name:               acme-not-a-joke-warp+version:            0.1.0.0++-- A short (one-line) description of the package.+synopsis: automatic HTTPS for warp: obtains, stores, renews and serves ACME certificates++-- A longer description of the package.+description: runs a wai application over HTTPS with certificates obtained from an ACME provider such as Let's Encrypt (rfc-8555, HTTP-01 challenges, or TLS-ALPN-01 challenges of rfc-8737 which need no port 80), in the spirit of Caddy. A certificate manager obtains the certificates when the server starts, stores them on disk, renews them before they expire and hands them to the running warp-tls server without a restart. Built on the acme-not-a-joke and acme-not-a-joke-wai libraries.++-- 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-warp++flag example+    description: build the example program (a warp server with automatic HTTPS)+    default: False+    manual: True++library+    hs-source-dirs: src+    ghc-options: -Wall+    default-language: Haskell2010+    default-extensions: OverloadedStrings OverloadedRecordDot+    exposed-modules:+      Acme.NotAJoke.Warp+      Acme.NotAJoke.Warp.CertificateManager+    build-depends:+      acme-not-a-joke >= 0.2 && < 0.3,+      acme-not-a-joke-wai >= 0.1 && < 0.2,+      async >= 2.2.4 && < 2.3,+      base >= 4.19.1 && < 5,+      bytestring >= 0.12.1 && < 0.13,+      containers >= 0.6.8 && < 0.8,+      directory >= 1.3.8 && < 1.4,+      filepath >= 1.4.200 && < 1.6,+      text >= 2.1.1 && < 2.2,+      time >= 1.12.2 && < 1.13,+      time-hourglass >= 0.2.12 && < 0.4,+      transformers >= 0.6.1 && < 0.7,+      http-types >= 0.12.4 && < 0.13,+      wai >= 3.2.4 && < 3.3,+      warp >= 3.4 && < 3.5,+      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-warp-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-warp,+      base,+      http-types,+      text,+      wai,++test-suite certificate-manager+    type: exitcode-stdio-1.0+    hs-source-dirs: test+    main-is: Main.hs+    ghc-options: -Wall -threaded+    default-language: Haskell2010+    default-extensions: OverloadedStrings OverloadedRecordDot+    build-depends:+      acme-not-a-joke,+      acme-not-a-joke-wai,+      acme-not-a-joke-warp,+      base,+      bytestring,+      crypton,+      crypton-asn1-types,+      crypton-x509,+      directory,+      filepath,+      http-types,+      network,+      text,+      time,+      time-hourglass,+      tls,+      wai,+      warp,

@@ -0,0 +1,46 @@+{- | A warp server with automatic HTTPS.++> acme-not-a-joke-warp-example DOMAIN CONTACT-EMAIL STATE-DIRECTORY [tls-alpn-01]++The machine must be reachable from the Internet as DOMAIN, on ports 80 and+443. With @tls-alpn-01@, the certificate is obtained with TLS-ALPN-01+challenges answered on port 443, and no HTTP server runs on port 80. 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+* @DOMAIN\/key.pem@: the private key of the certificate, created on the first run+* @DOMAIN\/certificate.pem@: the certificate chain, written at each renewal++The program can be stopped and started again: it serves the stored certificate+and only asks for a new one when it is due for renewal.+-}+module Main (main) where++import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Text as Text+import Network.HTTP.Types (status200)+import Network.Wai (Application, responseLBS)+import System.Environment (getArgs)+import System.IO (hPutStrLn, stderr)++import Acme.NotAJoke.LetsEncrypt (staging_letsencryptv2)+import Acme.NotAJoke.Warp (AutoHttps (..), ChallengeMethod (..), defaultAutoHttps, runAutoHttps)++main :: IO ()+main = do+    args <- getArgs+    case args of+        [domain, email, dir] ->+            runAutoHttps (settings domain email dir) application+        [domain, email, dir, "tls-alpn-01"] ->+            runAutoHttps (settings domain email dir){challengeMethod = TlsAlpn01, serveHttp = False} application+        _ -> hPutStrLn stderr "usage: acme-not-a-joke-warp-example DOMAIN CONTACT-EMAIL STATE-DIRECTORY [tls-alpn-01]"+  where+    settings domain email dir =+        defaultAutoHttps staging_letsencryptv2 (Text.pack domain :| []) [Text.pack ("mailto:" <> email)] dir++application :: Application+application _ respond = respond $ responseLBS status200 [] "hello\n"

@@ -0,0 +1,242 @@+{- | Automatic HTTPS for warp, in the spirit of Caddy.++> main :: IO ()+> main =+>     runAutoHttps+>         (defaultAutoHttps letsencryptv2 ("example.com" :| []) ["mailto:certmaster@example.com"] "state")+>         application++'runAutoHttps' runs two servers and a certificate manager:++* an HTTPS server (port 443) running your application, with certificates read+  at each TLS handshake from a 'CertificateStore'. It also answers the+  TLS-ALPN-01 challenges of the ACME server (see 'challengeMethod');+* an HTTP server (port 80) answering the HTTP-01 challenges of the ACME+  server, and redirecting everything else to HTTPS (or running an application+  of yours, see 'httpApplication'). It can be left out with TLS-ALPN-01+  challenges (see 'serveHttp');+* a "Acme.NotAJoke.Warp.CertificateManager" which obtains the certificates+  when the program starts, stores them on disk, renews them before they+  expire, and puts them in the 'CertificateStore': the running HTTPS server+  presents a new certificate to the next connection, without a restart.++The machine must be reachable from the Internet under each domain name, on+port 80 (for the ACME server, with HTTP-01 challenges, the default) or on+port 443 (with TLS-ALPN-01 challenges), and on the HTTPS port.++Until a first certificate is obtained (a few seconds when all goes well), TLS+handshakes fail: the HTTPS server has nothing to present. A failure to get a+certificate does not stop the servers: it is reported (on stderr unless+'Acme.NotAJoke.Warp.CertificateManager.onEvent' says otherwise) and the+manager tries again later.++To run the servers yourself (e.g., several applications, or another port 80+server), assemble the same parts: 'newChallengeStore' and 'http01Middleware'+(or 'newTlsAlpn01Store' and 'withTlsAlpn01'), 'newCertificateStore' and+'liveTlsSettings', 'newCertificateManager' with an 'acmeIssuer' (or an+'acmeTlsAlpn01Issuer') and 'runCertificateManager'. The source of+'runAutoHttpsWith' is a couple dozen lines.+-}+module Acme.NotAJoke.Warp (+    -- * automatic HTTPS+    AutoHttps (..),+    ChallengeMethod (..),+    defaultAutoHttps,+    runAutoHttps,+    runAutoHttpsWith,+    Challenges (..),+    newChallenges,++    -- * port 80+    redirectToHttps,++    -- * parts+    module Acme.NotAJoke.Warp.CertificateManager,+    ChallengeStore,+    newChallengeStore,+    http01Middleware,+    TlsAlpn01Store,+    newTlsAlpn01Store,+    withTlsAlpn01,+    CertificateStore,+    newCertificateStore,+    liveTlsSettings,+) where++import Control.Concurrent.Async (Async, waitAny, withAsync)+import Control.Exception (throwIO)+import Control.Monad (void)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as Char8+import Data.Char (isAlphaNum, isAscii)+import Data.List.NonEmpty (NonEmpty)+import Data.Maybe (fromMaybe)+import Network.HTTP.Types (hContentType, hLocation, status308, status400)+import Network.Wai (Application, rawPathInfo, rawQueryString, requestHeaderHost, responseLBS)+import Network.Wai.Handler.Warp (Port, Settings, defaultSettings, getPort, runSettings, setPort)+import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS)+import System.FilePath ((</>))++import Acme.NotAJoke.Api.Account (Contact)+import Acme.NotAJoke.Api.Endpoint (BaseUrl)+import Acme.NotAJoke.Wai.Http01 (ChallengeStore, http01Middleware, newChallengeStore)+import Acme.NotAJoke.Wai.TlsAlpn01 (TlsAlpn01Store, newTlsAlpn01Store, withTlsAlpn01)+import Acme.NotAJoke.Wai.WarpTLS (CertificateStore, liveTlsSettings, newCertificateStore)+import Acme.NotAJoke.Warp.CertificateManager++-- | What 'runAutoHttps' runs.+data AutoHttps = AutoHttps+    { acmeSettings :: AcmeSettings+    -- ^ the ACME server and account+    , managerSettings :: ManagerSettings+    -- ^ the domains, where certificates are stored and when they are renewed+    , challengeMethod :: ChallengeMethod+    {- ^ how the ACME server validates that the machine answers for the+    domains, defaults to 'Http01'+    -}+    , serveHttp :: Bool+    {- ^ whether to run the HTTP server, defaults to 'True'. HTTP-01+    challenges need it, TLS-ALPN-01 challenges do not.+    -}+    , httpSettings :: Settings+    {- ^ warp settings of the HTTP server, defaults to port 80. The ACME+    server only connects to port 80: change the port when something forwards+    port 80 to it.+    -}+    , httpsSettings :: Settings+    {- ^ warp settings of the HTTPS server, defaults to port 443. With+    TLS-ALPN-01 challenges, the ACME server only connects to port 443: change+    the port when something forwards port 443 to it (without terminating TLS).+    -}+    , tweakTls :: TLSSettings -> TLSSettings+    {- ^ changes the warp-tls settings, which are the default ones reading+    certificates from the store (see 'liveTlsSettings'). Defaults to 'id'.+    The settings are then wrapped to answer TLS-ALPN-01 challenges (see+    'withTlsAlpn01'), which takes over the choice of the protocol (ALPN):+    when HTTP/2 is disabled in 'httpsSettings', set a+    'Network.TLS.onALPNClientSuggest' hook choosing @http/1.1@ here.+    -}+    , httpApplication :: Maybe Application+    {- ^ what the HTTP server runs besides answering challenges, defaults to+    'Nothing': redirect to HTTPS (see 'redirectToHttps')+    -}+    }++-- | How the ACME server validates that the machine answers for a domain.+data ChallengeMethod+    = {- | HTTP-01 challenges (RFC-8555): the ACME server fetches a file from+      the HTTP server, on port 80+      -}+      Http01+    | {- | TLS-ALPN-01 challenges (RFC-8737): the ACME server opens a TLS+      connection to the HTTPS server, on port 443, with the @acme-tls/1@+      protocol. Needs the TLS 1.3 support of warp-tls (enabled by default).+      -}+      TlsAlpn01+    deriving (Show, Eq)++{- | Automatic HTTPS for some domains with the certificates of an ACME server+(e.g. 'Acme.NotAJoke.LetsEncrypt.letsencryptv2'), an account with some+contacts (e.g. @["mailto:certmaster\@example.com"]@), and a directory to store+the account key (@account.jwk@), the keys and the certificates.++Using an ACME server means agreeing to its terms of service.+-}+defaultAutoHttps :: BaseUrl -> NonEmpty Domain -> [Contact] -> FilePath -> AutoHttps+defaultAutoHttps url names contactUrls dir =+    AutoHttps+        { acmeSettings = defaultAcmeSettings url (dir </> "account.jwk") contactUrls+        , managerSettings = defaultManagerSettings names dir+        , challengeMethod = Http01+        , serveHttp = True+        , httpSettings = setPort 80 defaultSettings+        , httpsSettings = setPort 443 defaultSettings+        , tweakTls = id+        , httpApplication = Nothing+        }++{- | Runs an application over HTTPS, with certificates obtained and renewed+from an ACME server.++Runs until one of the two servers stops. Throws what warp throws (e.g., when a+port cannot be bound), and an 'IOError' when a domain is not a plain host+name.+-}+runAutoHttps :: AutoHttps -> Application -> IO ()+runAutoHttps cfg = runAutoHttpsWith issuer cfg+  where+    issuer :: Challenges -> Issuer+    issuer challenges =+        case cfg.challengeMethod of+            Http01 -> acmeIssuer cfg.acmeSettings challenges.http01+            TlsAlpn01 -> acmeTlsAlpn01Issuer cfg.acmeSettings challenges.tlsAlpn01++{- | The stores of the challenges answered by the servers of+'runAutoHttpsWith'.+-}+data Challenges = Challenges+    { http01 :: ChallengeStore+    -- ^ HTTP-01 challenges, answered by the HTTP server+    , tlsAlpn01 :: TlsAlpn01Store+    -- ^ TLS-ALPN-01 challenges, answered by the HTTPS server+    }++-- | Creates empty stores.+newChallenges :: IO Challenges+newChallenges = Challenges <$> newChallengeStore <*> newTlsAlpn01Store++{- | Same as 'runAutoHttps' with certificates from another issuer, which is+given the stores of the challenges answered by the servers. The+'acmeSettings' and the 'challengeMethod' are ignored.+-}+runAutoHttpsWith :: (Challenges -> Issuer) -> AutoHttps -> Application -> IO ()+runAutoHttpsWith mkIssuer cfg application = do+    challenges <- newChallenges+    certificates <- newCertificateStore+    created <- newCertificateManager cfg.managerSettings (mkIssuer challenges) certificates+    certManager <- either (throwIO . userError) pure created+    let plain = fromMaybe (redirectToHttps (getPort cfg.httpsSettings)) cfg.httpApplication+    let http = runSettings cfg.httpSettings (http01Middleware challenges.http01 plain)+    let tls = withTlsAlpn01 challenges.tlsAlpn01 (cfg.tweakTls (liveTlsSettings certificates))+    let https = runTLS tls cfg.httpsSettings application+    withOptional cfg.serveHttp http $ \httpServer ->+        withAsync https $ \httpsServer ->+            withAsync (runCertificateManager certManager) $ \renewer ->+                void $ waitAny (httpServer <> [httpsServer, renewer])+  where+    withOptional :: Bool -> IO () -> ([Async ()] -> IO b) -> IO b+    withOptional False _ k = k []+    withOptional True action k = withAsync action (k . pure)++{- | Redirects (308) every request to the same host, path and query over+HTTPS, on the given port.++The host comes from the @Host@ header: requests without one, or with one+which is not a host name or an IP address, get a 400.+-}+redirectToHttps :: Port -> Application+redirectToHttps port req respond =+    case hostName =<< requestHeaderHost req of+        Nothing ->+            respond $ responseLBS status400 [(hContentType, "text/plain")] "bad or missing Host header\n"+        Just host ->+            respond $ responseLBS status308 [(hLocation, location host)] ""+  where+    location host =+        "https://" <> host <> portSuffix <> rawPathInfo req <> rawQueryString req++    portSuffix+        | port == 443 = ""+        | otherwise = Char8.pack (':' : show port)++    -- the host without its port+    hostName hostPort+        | ByteString.null name || not (Char8.all validChar name) = Nothing+        | otherwise = Just name+      where+        name = case Char8.uncons hostPort of+            -- an IPv6 address+            Just ('[', rest) -> "[" <> Char8.takeWhile (/= ']') rest <> "]"+            _ -> Char8.takeWhile (/= ':') hostPort++    validChar c = isAscii c && (isAlphaNum c || c `elem` ("-.:[]" :: String))

@@ -0,0 +1,534 @@+{- | Keeps the certificates of a TLS server valid, unattended.++A 'CertificateManager' looks after one certificate per domain name. For each+domain it:++* loads the certificate stored on disk by a previous run, if there is one;+* asks an 'Issuer' for a certificate when there is none, or when the stored one+  is due for renewal (see 'renewAt');+* writes the new certificate on disk, and hands it to a+  'Acme.NotAJoke.Wai.WarpTLS.CertificateStore' so that a running warp-tls+  server presents it to the next connection, without a restart;+* tries again later, with increasing delays, when the 'Issuer' fails (see+  'retryDelay').++'runCertificateManager' is the loop doing so forever, 'checkCertificates' is+a single pass of this loop.++The manager never throws for a failed issuance: errors of the 'Issuer',+whether returned or thrown (e.g., the @HttpException@ of a network failure),+and errors while reading or writing files are reported to 'onEvent' and the+certificate is tried again later. Meanwhile, the server keeps presenting the+certificate it has.++= Where things are stored++Everything is under the 'stateDirectory':++* @{domain}\/key.pem@: the private key of the certificate, created on the+  first run (see 'generateKey') and reused for renewals+* @{domain}\/certificate.pem@: the certificate chain, leaf certificate first++These are the formats that warp-tls, nginx, haproxy etc. read. Files are+replaced atomically (written aside, then renamed). The directory holds private+keys: restrict who can read it.++The ACME account key of 'acmeIssuer' is stored where 'accountKeyPath' says.+-}+module Acme.NotAJoke.Warp.CertificateManager (+    -- * manager+    CertificateManager,+    newCertificateManager,+    runCertificateManager,+    checkCertificates,++    -- * settings+    Domain,+    ManagerSettings (..),+    defaultManagerSettings,+    keyPath,+    certificatePath,++    -- * renewal+    Validity (..),+    renewAfterTwoThirds,+    renewBefore,+    exponentialRetry,++    -- * events+    Event (..),+    showEvent,+    logEvent,++    -- * issuers+    Issuer,+    AcmeSettings (..),+    defaultAcmeSettings,+    acmeIssuer,+    acmeTlsAlpn01Issuer,+) where++import Control.Concurrent (threadDelay)+import Control.Exception (Exception, SomeAsyncException (..), SomeException, catch, displayException, fromException, throwIO)+import Control.Monad (forever, unless, void, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT)+import qualified Crypto.PubKey.RSA as RSA+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LByteString+import Data.Char (isAsciiLower, isDigit)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime)+import qualified Data.X509 as X509+import Network.TLS (Credential)+import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile)+import System.FilePath (takeDirectory, (<.>), (</>))+import System.IO (hPutStrLn, stderr)+import qualified Time.Types as Hourglass++import Acme.NotAJoke.Api.Account (Contact, fetchAccount1)+import Acme.NotAJoke.Api.Certificate (PEM (..), readPEM)+import Acme.NotAJoke.Api.Endpoint (AcmeError, BaseUrl, problemDetail, readProblem)+import Acme.NotAJoke.Api.Order (OrderIdentifier (..), OrderType (..), createOrder)+import Acme.NotAJoke.CertManagement (createCSR, decodeCertificateChain)+import Acme.NotAJoke.Dancer (AcmeDancer (..), DanceStep (..))+import Acme.NotAJoke.KeyManagement (encodeRSAKeyPEM, genRSAKey4096, loadOrCreateJWKFile, loadRSAKeyPEM)+import Acme.NotAJoke.Wai.Http01 (ChallengeStore, runAcmeDance_http01_wai)+import Acme.NotAJoke.Wai.TlsAlpn01 (TlsAlpn01Store, runAcmeDance_tlsalpn01_wai)+import Acme.NotAJoke.Wai.WarpTLS (CertificateStore, setCredential, setCredentialFor)++{- | A DNS name, in ASCII form (i.e., punycode-encoded for internationalized+names). Wildcards are not supported.+-}+type Domain = Text++{- | Gets a certificate for a domain and the private key of the certificate.++Returns the content of a PEM file: the certificate chain, leaf certificate+first. See 'acmeIssuer' for the ACME one.+-}+type Issuer = Domain -> RSA.PrivateKey -> IO (Either String ByteString)++-- | The period during which a certificate is valid.+data Validity = Validity+    { notBefore :: UTCTime+    , notAfter :: UTCTime+    }+    deriving (Show, Eq)++-- | What a manager does and when.+data ManagerSettings = ManagerSettings+    { domains :: NonEmpty Domain+    {- ^ the names to get a certificate for: one certificate per name. The+    certificate of the first name also is the default one, presented to+    clients asking for another name (or for none).+    -}+    , stateDirectory :: FilePath+    -- ^ where keys and certificates are stored, created if missing+    , renewAt :: Validity -> UTCTime+    -- ^ when to renew a certificate, defaults to 'renewAfterTwoThirds'+    , retryDelay :: Int -> NominalDiffTime+    {- ^ how long to wait after the n-th failure in a row (starting at 1),+    defaults to 'exponentialRetry'+    -}+    , checkInterval :: NominalDiffTime+    {- ^ the longest 'runCertificateManager' sleeps between two looks at the+    clock, defaults to one hour+    -}+    , generateKey :: IO RSA.PrivateKey+    {- ^ generates the private key of a certificate, defaults to+    'genRSAKey4096'+    -}+    , onEvent :: Event -> IO ()+    -- ^ called for each 'Event', defaults to 'logEvent'+    , getTime :: IO UTCTime+    -- ^ the clock, defaults to 'getCurrentTime'+    }++-- | Settings with the defaults documented in 'ManagerSettings'.+defaultManagerSettings :: NonEmpty Domain -> FilePath -> ManagerSettings+defaultManagerSettings names dir =+    ManagerSettings+        { domains = names+        , stateDirectory = dir+        , renewAt = renewAfterTwoThirds+        , retryDelay = exponentialRetry+        , checkInterval = 3600+        , generateKey = genRSAKey4096+        , onEvent = logEvent+        , getTime = getCurrentTime+        }++{- | Renews when two thirds of the validity period have elapsed (e.g., 30 days+before the end for a certificate valid for 90 days).+-}+renewAfterTwoThirds :: Validity -> UTCTime+renewAfterTwoThirds validity =+    addUTCTime (2 * diffUTCTime validity.notAfter validity.notBefore / 3) validity.notBefore++-- | Renews a fixed duration before the end of the validity period.+renewBefore :: NominalDiffTime -> Validity -> UTCTime+renewBefore margin validity = addUTCTime (negate margin) validity.notAfter++{- | Two minutes after the first failure, then twice as long after each+failure, up to six hours.++ACME providers limit the number of failed validations (e.g., five per hour+and per name at Let's Encrypt): do not retry much faster.+-}+exponentialRetry :: Int -> NominalDiffTime+exponentialRetry n = min (6 * 3600) (120 * 2 ^ (max 0 (min 16 (n - 1))))++-- | What happens to the certificates of a manager.+data Event+    = -- | a certificate stored by a previous run is served+      CertificateLoaded Domain Validity+    | -- | the stored key or certificate cannot be used, with the reason: a new certificate is requested+      StoredCertificateUnusable Domain String+    | -- | the issuer is asked for a certificate+      CertificateRequested Domain+    | -- | a new certificate is stored and served+      CertificateObtained Domain Validity+    | -- | no certificate, with the reason and the time of the next attempt+      CertificateFailed Domain String UTCTime+    deriving (Show, Eq)++-- | A line of log for an event.+showEvent :: Event -> String+showEvent event =+    case event of+        CertificateLoaded domain validity ->+            line domain ("serving the stored certificate, valid until " <> show validity.notAfter)+        StoredCertificateUnusable domain reason ->+            line domain ("cannot use the stored certificate: " <> reason)+        CertificateRequested domain ->+            line domain "requesting a certificate"+        CertificateObtained domain validity ->+            line domain ("serving a new certificate, valid until " <> show validity.notAfter)+        CertificateFailed domain reason next ->+            line domain ("no certificate, next attempt at " <> show next <> ": " <> reason)+  where+    line domain msg = "acme-not-a-joke-warp: " <> Text.unpack domain <> ": " <> msg++-- | Prints the event on stderr.+logEvent :: Event -> IO ()+logEvent = hPutStrLn stderr . showEvent++-- | Path of the private key of the certificate of a domain.+keyPath :: ManagerSettings -> Domain -> FilePath+keyPath cfg domain = cfg.stateDirectory </> Text.unpack domain </> "key.pem"++-- | Path of the certificate chain of a domain.+certificatePath :: ManagerSettings -> Domain -> FilePath+certificatePath cfg domain = cfg.stateDirectory </> Text.unpack domain </> "certificate.pem"++data DomainState = DomainState+    { due :: UTCTime+    -- ^ nothing to do before this time+    , failures :: Int+    -- ^ failures in a row+    }++-- | See 'newCertificateManager'.+data CertificateManager = CertificateManager+    { settings :: ManagerSettings+    , issuer :: Issuer+    , store :: CertificateStore+    , states :: IORef (Map Domain DomainState)+    }++{- | Creates a manager getting its certificates from an issuer and handing+them to a store.++Nothing happens until 'runCertificateManager' or 'checkCertificates' is+called. The store is the one given to+'Acme.NotAJoke.Wai.WarpTLS.liveTlsSettings'.++Domain names are lower-cased. Fails on names which are not plain host names+(they are used as directory names, and wildcards cannot be validated with+HTTP-01 or TLS-ALPN-01).+-}+newCertificateManager :: ManagerSettings -> Issuer -> CertificateStore -> IO (Either String CertificateManager)+newCertificateManager cfg getCertificate certificates =+    case traverse hostName (NonEmpty.nub (NonEmpty.map Text.toLower cfg.domains)) of+        Left err -> pure (Left err)+        Right names -> do+            ref <- newIORef Map.empty+            pure $ Right $ CertificateManager cfg{domains = names} getCertificate certificates ref+  where+    hostName :: Domain -> Either String Domain+    hostName name+        | validDomain name = Right name+        | otherwise = Left ("not a host name: " <> show name)++validDomain :: Domain -> Bool+validDomain name =+    not (Text.null name)+        && Text.length name <= 253+        && all validLabel (Text.splitOn "." name)+  where+    validLabel label =+        not (Text.null label)+            && Text.all (\c -> isAsciiLower c || isDigit c || c == '-') label++{- | Checks the certificates forever: sleeps until the next certificate is due+(for renewal, or for another attempt after a failure), up to 'checkInterval'.++Run it in its own thread, next to the servers.+-}+runCertificateManager :: CertificateManager -> IO a+runCertificateManager manager = forever $ do+    next <- checkCertificates manager+    now <- manager.settings.getTime+    let wait = max 1 (min manager.settings.checkInterval (diffUTCTime next now))+    threadDelay (ceiling (wait * 1000000))++{- | Checks every domain once: loads, obtains or renews the certificates which+are due, and leaves the other ones alone.++Returns when to call it again: the earliest time at which a certificate is due.+Failures are reported to 'onEvent' rather than thrown.+-}+checkCertificates :: CertificateManager -> IO UTCTime+checkCertificates manager = do+    let first :| others = manager.settings.domains+    dues <- (:|) <$> checkDomain manager True first <*> traverse (checkDomain manager False) others+    pure (minimum dues)++checkDomain :: CertificateManager -> Bool -> Domain -> IO UTCTime+checkDomain manager isDefault domain = do+    now <- manager.settings.getTime+    known <- Map.lookup domain <$> readIORef manager.states+    case known of+        Just st | st.due > now -> pure st.due+        _ -> do+            outcome <- guarded (ensureCertificate manager isDefault domain now)+            let st = nextState now (maybe 0 (.failures) known) outcome+            atomicModifyIORef' manager.states (\m -> (Map.insert domain st m, ()))+            case outcome of+                Left reason -> emit manager (CertificateFailed domain reason st.due)+                Right _ -> pure ()+            pure st.due+  where+    nextState :: UTCTime -> Int -> Either String Validity -> DomainState+    nextState now failed outcome =+        case outcome of+            Left _ -> DomainState (addUTCTime (retryAfter (failed + 1)) now) (failed + 1)+            -- a certificate which already is due for renewal is not requested+            -- again right away+            Right validity -> DomainState (max (manager.settings.renewAt validity) (addUTCTime (retryAfter 1) now)) 0++    retryAfter :: Int -> NominalDiffTime+    retryAfter = max 1 . manager.settings.retryDelay++{- | Serves a certificate which is not due for renewal: the stored one, or a+new one from the issuer.+-}+ensureCertificate :: CertificateManager -> Bool -> Domain -> UTCTime -> IO (Either String Validity)+ensureCertificate manager isDefault domain now = runExceptT $ do+    liftIO $ createDirectoryIfMissing True (takeDirectory keyFile)+    key <- ExceptT $ loadOrCreateKey manager.settings.generateKey keyFile+    stored <- liftIO $ loadStored key certFile+    case stored of+        Right (Just (cred, validity))+            | now < manager.settings.renewAt validity -> liftIO $ do+                install cred+                emit manager (CertificateLoaded domain validity)+                pure validity+            | now < validity.notAfter -> do+                -- still good to serve while the new one is requested+                liftIO $ install cred+                request key+        Right _ -> request key+        Left reason -> do+            liftIO $ emit manager (StoredCertificateUnusable domain reason)+            request key+  where+    keyFile = keyPath manager.settings domain+    certFile = certificatePath manager.settings domain++    install :: Credential -> IO ()+    install cred = do+        setCredentialFor manager.store (Text.unpack domain) cred+        when isDefault $ setCredential manager.store cred++    request :: RSA.PrivateKey -> ExceptT String IO Validity+    request key = do+        liftIO $ emit manager (CertificateRequested domain)+        pem <- ExceptT $ manager.issuer domain key+        (cred, validity) <- ExceptT $ pure $ readCredential key pem+        liftIO $ do+            writeFileAtomic certFile pem+            install cred+            emit manager (CertificateObtained domain validity)+        pure validity++loadOrCreateKey :: IO RSA.PrivateKey -> FilePath -> IO (Either String RSA.PrivateKey)+loadOrCreateKey generate path = do+    exists <- doesFileExist path+    if exists+        then loadRSAKeyPEM path+        else do+            key <- generate+            writeFileAtomic path (encodeRSAKeyPEM key)+            pure (Right key)++-- | The stored certificate, if there is one.+loadStored :: RSA.PrivateKey -> FilePath -> IO (Either String (Maybe (Credential, Validity)))+loadStored key path = do+    exists <- doesFileExist path+    if exists+        then fmap Just . readCredential key <$> ByteString.readFile path+        else pure (Right Nothing)++-- | Reads a certificate chain (PEM), which must be for the given key.+readCredential :: RSA.PrivateKey -> ByteString -> Either String (Credential, Validity)+readCredential key pem = do+    chain <- decodeCertificateChain pem+    case chain of+        [] -> Left "no certificate in the PEM content"+        (leaf : _) -> do+            let cert = X509.getCertificate leaf+            unless (X509.certPubKey cert == X509.PubKeyRSA (RSA.private_pub key)) $+                Left "the certificate is not for the stored key"+            let (start, end) = X509.certValidity cert+            pure ((X509.CertificateChain chain, X509.PrivKeyRSA key), Validity (toUTCTime start) (toUTCTime end))++toUTCTime :: Hourglass.DateTime -> UTCTime+toUTCTime (Hourglass.DateTime (Hourglass.Date year month day) (Hourglass.TimeOfDay hours minutes seconds _)) =+    UTCTime+        (fromGregorian (fromIntegral year) (fromEnum month + 1) day)+        (fromIntegral hours * 3600 + fromIntegral minutes * 60 + fromIntegral seconds)++-- | Writes aside then renames, so that readers never see half a file.+writeFileAtomic :: FilePath -> ByteString -> IO ()+writeFileAtomic path bytes = do+    let tmp = path <.> "tmp"+    ByteString.writeFile tmp bytes+    renameFile tmp path++-- | Calls the event handler, which must not break the manager.+emit :: CertificateManager -> Event -> IO ()+emit manager event =+    void $ guarded (Right <$> manager.settings.onEvent event)++{- | Turns synchronous exceptions into errors. Asynchronous ones (e.g., the+thread being killed) are thrown again.+-}+guarded :: IO (Either String a) -> IO (Either String a)+guarded action = action `catch` handler+  where+    handler :: SomeException -> IO (Either String a)+    handler e =+        case fromException e of+            Just (SomeAsyncException _) -> throwIO e+            Nothing -> pure (Left (displayException e))++-- | How to get certificates from an ACME server.+data AcmeSettings = AcmeSettings+    { acmeUrl :: BaseUrl+    -- ^ the ACME server, e.g. 'Acme.NotAJoke.LetsEncrypt.letsencryptv2'+    , accountKeyPath :: FilePath+    {- ^ where the account key (a JWK) is stored. The key is created on the+    first run, and so is the account.+    -}+    , contacts :: [Contact]+    -- ^ contacts of the account, e.g. @["mailto:certmaster\@example.com"]@+    , pollDelay :: Int -> Int+    {- ^ how long to wait (in microseconds) before the n-th poll of an order+    (starting at 0), defaults to n seconds capped at ten seconds+    -}+    , maxPolls :: Int+    -- ^ how many times an order is polled before giving up, defaults to 60+    }++{- | Settings with the defaults documented in 'AcmeSettings'.++Using an ACME server means agreeing to its terms of service: 'acmeIssuer'+says so when it creates the account.+-}+defaultAcmeSettings :: BaseUrl -> FilePath -> [Contact] -> AcmeSettings+defaultAcmeSettings url path contactUrls =+    AcmeSettings+        { acmeUrl = url+        , accountKeyPath = path+        , contacts = contactUrls+        , pollDelay = \n -> 1000000 * min 10 n+        , maxPolls = 60+        }++{- | Gets certificates from an ACME server with HTTP-01 challenges.++The challenges are served from the store by+'Acme.NotAJoke.Wai.Http01.http01Middleware', which must be running on port 80+of the domain and reachable by the ACME server.++Each call is a whole ACME dance, with a new CSR built in memory.+-}+acmeIssuer :: AcmeSettings -> ChallengeStore -> Issuer+acmeIssuer acme challenges = acmeIssuerWith (runAcmeDance_http01_wai challenges) acme++{- | Gets certificates from an ACME server with TLS-ALPN-01 challenges+(RFC-8737), which need no port 80.++The challenges are answered from the store by the HTTPS server, whose TLS+settings must be wrapped with 'Acme.NotAJoke.Wai.TlsAlpn01.withTlsAlpn01',+running on port 443 of the domain and reachable by the ACME server.++Each call is a whole ACME dance, with a new CSR built in memory. The+challenge certificate has a throw-away RSA-2048 key.+-}+acmeTlsAlpn01Issuer :: AcmeSettings -> TlsAlpn01Store -> Issuer+acmeTlsAlpn01Issuer acme challenges = acmeIssuerWith (runAcmeDance_tlsalpn01_wai challenges) acme++-- | An issuer running a dance.+acmeIssuerWith :: (AcmeDancer -> IO ()) -> AcmeSettings -> Issuer+acmeIssuerWith dance acme domain key = runExceptT $ do+    liftIO $ createDirectoryIfMissing True (takeDirectory acme.accountKeyPath)+    accountKey <- ExceptT $ loadOrCreateJWKFile acme.accountKeyPath+    request <- ExceptT $ createCSR key (domain :| [])+    result <- liftIO $ newIORef (Left "the ACME dance stopped without a certificate")+    let handle step =+            case step of+                WaitingForValidation n+                    | n >= acme.maxPolls -> writeIORef result (Left "the order still is pending") >> throwIO PollingTimeout+                    | otherwise -> threadDelay (acme.pollDelay n)+                Done _ cert -> writeIORef result (Right (pemBytes (readPEM cert)))+                InvalidOrder _ -> writeIORef result (Left "the ACME server could not validate the challenge")+                OtherError err -> writeIORef result (Left (Text.unpack err))+                AcmeFailure err -> writeIORef result (Left (showAcmeError err))+                _ -> pure ()+    let dancer =+            AcmeDancer+                { baseUrl = acme.acmeUrl+                , accountJwk = accountKey+                , -- creates the account when the key has none yet+                  account = fetchAccount1 True False acme.contacts+                , csr = request+                , order = createOrder (Nothing, Nothing) [OrderIdentifier DNSOrder domain]+                , handleStep = handle+                }+    liftIO $ dance dancer `catch` \PollingTimeout -> pure ()+    ExceptT $ readIORef result+  where+    pemBytes (PEM bytes) = LByteString.toStrict bytes++-- | Stops a dance whose order never leaves the pending state.+data PollingTimeout = PollingTimeout+    deriving (Show)++instance Exception PollingTimeout++showAcmeError :: AcmeError -> String+showAcmeError err =+    case problemDetail =<< readProblem err of+        Just detail -> "the ACME server rejected a request: " <> Text.unpack detail+        Nothing -> show err

@@ -0,0 +1,516 @@+{-# LANGUAGE TupleSections #-}++module Main (main) where++import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Exception (SomeException, bracket, throwIO, 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.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as Char8+import Data.Either (isLeft)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Text as Text+import Data.Time.Calendar (fromGregorian, toGregorian)+import Data.Time.Clock (UTCTime (..), addUTCTime)+import Data.Time.Clock.POSIX (getPOSIXTime)+import qualified Data.X509 as X509+import Network.HTTP.Types (Status, hHost, hLocation, status200, status308, status400)+import qualified Network.Socket as Socket+import qualified Network.Socket.ByteString as SocketBS+import qualified Network.TLS as TLS+import Network.Wai (Application, Request, defaultRequest, rawPathInfo, rawQueryString, requestHeaderHost, requestHeaders, responseHeaders, responseLBS, responseStatus)+import Network.Wai.Handler.Warp (Port, defaultSettings, openFreePort, setOnException, setPort)+import System.Directory (createDirectoryIfMissing, doesFileExist, getTemporaryDirectory, removePathForcibly)+import System.Exit (exitFailure)+import System.FilePath ((</>))+import System.Timeout (timeout)+import Time.Types (Date (..), DateTime (..), TimeOfDay (..))++import Acme.NotAJoke.Api.Challenge (Token (..))+import Acme.NotAJoke.Api.Validation (KeyAuthorization (..))+import Acme.NotAJoke.CertManagement (acmeTLSALPNProtocol, decodeCertificateChain, encodeCertificateChain)+import Acme.NotAJoke.KeyManagement (genRSAKey, writeRSAKeyPEM)+import Acme.NotAJoke.Wai.Http01 (deleteChallenge, insertChallenge)+import Acme.NotAJoke.Wai.TlsAlpn01 (challengeCredential, deleteTlsAlpn01, insertTlsAlpn01)+import Acme.NotAJoke.Wai.WarpTLS (lookupCredential)+import Acme.NotAJoke.Warp++main :: IO ()+main = do+    renewalTimes+    domainsAreChecked+    withStateDirectory certificateIsObtainedStoredAndRenewed+    withStateDirectory failuresAreRetried+    withStateDirectory unusableFilesAreReplaced+    withStateDirectory eachDomainHasItsCertificate+    redirectsToHttps+    withStateDirectory serversGetTheirCertificate+    withStateDirectory httpsServerAnswersTlsAlpn01+    putStrLn "ok"++-- | Midnight, some days after the start of the test clock.+day :: Integer -> UTCTime+day n = UTCTime (fromGregorian 2030 1 1) 0 `plusDays` n++plusDays :: UTCTime -> Integer -> UTCTime+plusDays t n = addUTCTime (fromInteger n * 86400) t++renewalTimes :: IO ()+renewalTimes = do+    let validity = Validity (day 0) (day 90)+    check "renews after two thirds of the validity" (renewAfterTwoThirds validity == day 60)+    check "renews a fixed duration before the end" (renewBefore (10 * 86400) validity == day 80)+    check "first retry is after two minutes" (exponentialRetry 1 == 120)+    check "retry delays double" (map exponentialRetry [2, 3, 4] == [240, 480, 960])+    check "retry delays are capped" (exponentialRetry 1000 == 6 * 3600)++domainsAreChecked :: IO ()+domainsAreChecked = do+    check "a path is not a domain" . isLeft =<< create ("../etc" :| [])+    check "a wildcard is not a domain" . isLeft =<< create ("*.a.test" :| [])+    check "an empty name is not a domain" . isLeft =<< create ("a.test" :| [""])+    check "host names are domains" . not . isLeft =<< create ("a.test" :| ["B.Test", "xn--bcher-kva.test"])+  where+    create names = do+        certificates <- newCertificateStore+        fmap (const ()) <$> newCertificateManager (defaultManagerSettings names "unused") (\_ _ -> pure (Left "unused")) certificates++-- | A clock, an issuer and the events of a manager under test.+data Harness = Harness+    { clock :: IORef UTCTime+    , issued :: IORef Int+    -- ^ number of certificates issued so far+    , failing :: IORef (Maybe (IO (Either String ByteString)))+    -- ^ what the issuer does instead of issuing+    , events :: IORef [Event]+    , store :: CertificateStore+    , dir :: FilePath+    }++newHarness :: FilePath -> IO Harness+newHarness path =+    Harness+        <$> newIORef (day 0)+        <*> newIORef 0+        <*> newIORef Nothing+        <*> newIORef []+        <*> newCertificateStore+        <*> pure path++settingsOf :: Harness -> NonEmpty Domain -> ManagerSettings+settingsOf h names =+    (defaultManagerSettings names h.dir)+        { generateKey = genRSAKey 2048+        , onEvent = \e -> modifyIORef' h.events (e :)+        , getTime = readIORef h.clock+        }++-- | Self-signed certificates valid for 90 days from the time of the clock.+issuerOf :: Harness -> Issuer+issuerOf h domain key = do+    instead <- readIORef h.failing+    case instead of+        Just action -> action+        Nothing -> do+            serial <- atomicModifyIORef' h.issued (\n -> (n + 1, n + 1))+            now <- readIORef h.clock+            X509.CertificateChain certs <- selfSignedChain key (toInteger serial) (Text.unpack domain) (now, now `plusDays` 90)+            pure (Right (encodeCertificateChain certs))++managerOf :: Harness -> NonEmpty Domain -> IO CertificateManager+managerOf h names =+    either fail pure =<< newCertificateManager (settingsOf h names) (issuerOf h) h.store++-- | The events since the last call.+takeEvents :: Harness -> IO [Event]+takeEvents h = reverse <$> atomicModifyIORef' h.events ([],)++-- | Serial number of the certificate presented for a server name.+servedSerial :: CertificateStore -> Maybe TLS.HostName -> IO (Maybe Integer)+servedSerial certificates name =+    fmap (serialOf . fst) <$> lookupCredential certificates name++serialOf :: X509.CertificateChain -> Integer+serialOf (X509.CertificateChain certs) =+    case certs of+        (leaf : _) -> X509.certSerial (X509.getCertificate leaf)+        [] -> 0++certificateIsObtainedStoredAndRenewed :: FilePath -> IO ()+certificateIsObtainedStoredAndRenewed path = do+    h <- newHarness path+    mgr <- managerOf h ("a.test" :| [])+    let validity0 = Validity (day 0) (day 90)++    next <- checkCertificates mgr+    count <- readIORef h.issued+    check "a certificate is requested when there is none" (count == 1)+    check "the next check is when the certificate is due for renewal" (next == day 60)+    evs <- takeEvents h+    check "request and success are reported" (evs == [CertificateRequested "a.test", CertificateObtained "a.test" validity0])+    served <- servedSerial h.store (Just "a.test")+    check "the certificate is served for its name" (served == Just 1)+    fallback <- servedSerial h.store Nothing+    check "the certificate is served by default" (fallback == Just 1)+    hasKey <- doesFileExist (path </> "a.test" </> "key.pem")+    check "the key is stored" hasKey+    stored <- decodeCertificateChain <$> ByteString.readFile (path </> "a.test" </> "certificate.pem")+    check "the certificate is stored" (fmap (serialOf . X509.CertificateChain) stored == Right 1)++    writeIORef h.clock (day 59)+    early <- checkCertificates mgr+    count1 <- readIORef h.issued+    check "nothing is requested before the renewal time" (count1 == 1 && early == day 60)++    -- a new run, with an empty store+    restarted <- newHarness path+    writeIORef restarted.clock (day 59)+    manager1 <- managerOf restarted ("a.test" :| [])+    next1 <- checkCertificates manager1+    count2 <- readIORef restarted.issued+    check "the stored certificate is not requested again" (count2 == 0 && next1 == day 60)+    evs1 <- takeEvents restarted+    check "loading is reported" (evs1 == [CertificateLoaded "a.test" validity0])+    served1 <- servedSerial restarted.store (Just "a.test")+    check "the stored certificate is served after a restart" (served1 == Just 1)++    writeIORef h.clock (day 61)+    next2 <- checkCertificates mgr+    count3 <- readIORef h.issued+    check "the certificate is renewed when due" (count3 == 2 && next2 == day 121)+    served2 <- servedSerial h.store (Just "a.test")+    check "the renewed certificate is served" (served2 == Just 2)+    stored2 <- decodeCertificateChain <$> ByteString.readFile (path </> "a.test" </> "certificate.pem")+    check "the renewed certificate is stored" (fmap (serialOf . X509.CertificateChain) stored2 == Right 2)++    -- a new run during the renewal period of the stored certificate+    late <- newHarness path+    writeIORef late.clock (day 125)+    writeIORef late.failing (Just (pure (Left "down")))+    manager2 <- managerOf late ("a.test" :| [])+    _ <- checkCertificates manager2+    served3 <- servedSerial late.store (Just "a.test")+    check "a stored certificate due for renewal is served meanwhile" (served3 == Just 2)++    -- a new run after the end of the stored certificate+    expired <- newHarness path+    writeIORef expired.clock (day 400)+    writeIORef expired.failing (Just (pure (Left "down")))+    manager3 <- managerOf expired ("a.test" :| [])+    _ <- checkCertificates manager3+    served4 <- servedSerial expired.store (Just "a.test")+    check "an expired stored certificate is not served" (served4 == Nothing)++failuresAreRetried :: FilePath -> IO ()+failuresAreRetried path = do+    h <- newHarness path+    mgr <- managerOf h ("a.test" :| [])+    let at seconds = addUTCTime seconds (day 0)++    writeIORef h.failing (Just (pure (Left "no route")))+    next <- checkCertificates mgr+    check "a failure is retried after the first delay" (next == at 120)+    evs <- takeEvents h+    check "the failure is reported" (evs == [CertificateRequested "a.test", CertificateFailed "a.test" "no route" (at 120)])++    writeIORef h.clock (at 60)+    _ <- checkCertificates mgr+    evs1 <- takeEvents h+    check "nothing is requested before the retry time" (null evs1)++    writeIORef h.clock (at 120)+    writeIORef h.failing (Just (throwIO (userError "boom")))+    next1 <- checkCertificates mgr+    check "an exception of the issuer is a failure, retried after a longer delay" (next1 == at (120 + 240))+    evs2 <- takeEvents h+    check "the exception is reported" (map isFailure evs2 == [False, True])++    writeIORef h.clock (at 360)+    writeIORef h.failing (Just (pure (Right "not a certificate")))+    next2 <- checkCertificates mgr+    check "a response without certificate is a failure" (next2 == at (360 + 480))+    hasCert <- doesFileExist (path </> "a.test" </> "certificate.pem")+    check "a response without certificate is not stored" (not hasCert)++    writeIORef h.clock (at 840)+    writeIORef h.failing Nothing+    next3 <- checkCertificates mgr+    served <- servedSerial h.store (Just "a.test")+    check "the certificate is obtained once the issuer works" (served == Just 1 && next3 == day 60)++    -- failures of a renewal+    writeIORef h.clock (day 70)+    writeIORef h.failing (Just (pure (Left "no route")))+    next4 <- checkCertificates mgr+    check "delays start over after a success" (next4 == addUTCTime 120 (day 70))+    served1 <- servedSerial h.store (Just "a.test")+    check "the previous certificate is served while renewals fail" (served1 == Just 1)++    -- a broken event handler+    broken <- newHarness path+    writeIORef broken.clock (day 70)+    let settings = (settingsOf broken ("a.test" :| [])){onEvent = \_ -> throwIO (userError "handler")}+    manager1 <- either fail pure =<< newCertificateManager settings (issuerOf broken) broken.store+    res <- try (checkCertificates manager1)+    check "an exception of the event handler is ignored" (either (\e -> const False (e :: SomeException)) (const True) res)+    count <- readIORef broken.issued+    check "the certificate is renewed despite the event handler" (count == 1)+  where+    isFailure e = case e of+        CertificateFailed _ _ _ -> True+        _ -> False++unusableFilesAreReplaced :: FilePath -> IO ()+unusableFilesAreReplaced path = do+    h <- newHarness path+    mgr <- managerOf h ("a.test" :| [])+    _ <- checkCertificates mgr+    _ <- takeEvents h++    -- the key is replaced behind the back of the manager+    other <- genRSAKey 2048+    writeRSAKeyPEM other (path </> "a.test" </> "key.pem")+    restarted <- newHarness path+    manager1 <- managerOf restarted ("a.test" :| [])+    _ <- checkCertificates manager1+    evs <- takeEvents restarted+    check "a certificate for another key is reported" (take 1 evs == [StoredCertificateUnusable "a.test" "the certificate is not for the stored key"])+    served <- lookupCredential restarted.store (Just "a.test")+    check "a certificate for another key is replaced" (fmap snd served == Just (X509.PrivKeyRSA other))++    ByteString.writeFile (path </> "a.test" </> "key.pem") "not a key"+    broken <- newHarness path+    manager2 <- managerOf broken ("a.test" :| [])+    next <- checkCertificates manager2+    count <- readIORef broken.issued+    check "an unreadable key is a failure, left for the operator" (count == 0 && next == addUTCTime 120 (day 0))+    kept <- ByteString.readFile (path </> "a.test" </> "key.pem")+    check "an unreadable key is not overwritten" (kept == "not a key")++eachDomainHasItsCertificate :: FilePath -> IO ()+eachDomainHasItsCertificate path = do+    h <- newHarness path+    mgr <- managerOf h ("a.test" :| ["B.test"])+    _ <- checkCertificates mgr+    a <- servedSerial h.store (Just "a.test")+    b <- servedSerial h.store (Just "b.test")+    other <- servedSerial h.store (Just "other.test")+    check "each domain gets its certificate" (a == Just 1 && b == Just 2)+    check "the certificate of the first domain is the default one" (other == Just 1)+    hasB <- doesFileExist (path </> "b.test" </> "certificate.pem")+    check "domains are stored in lower case" hasB++redirectsToHttps :: IO ()+redirectsToHttps = do+    let request host = defaultRequest{requestHeaderHost = Just host, requestHeaders = [(hHost, host)], rawPathInfo = "/some/path", rawQueryString = "?q=1"}+    plain <- run (redirectToHttps 443) (request "a.test")+    check "redirects to the same host, path and query" (plain == (status308, Just "https://a.test/some/path?q=1"))+    ported <- run (redirectToHttps 8443) (request "a.test:8080")+    check "redirects to the HTTPS port" (ported == (status308, Just "https://a.test:8443/some/path?q=1"))+    v6 <- run (redirectToHttps 443) (request "[::1]:80")+    check "redirects IPv6 hosts" (v6 == (status308, Just "https://[::1]/some/path?q=1"))+    missing <- run (redirectToHttps 443) defaultRequest+    check "refuses requests without host" (missing == (status400, Nothing))+    weird <- run (redirectToHttps 443) (request "a.test/@evil")+    check "refuses odd hosts" (weird == (status400, Nothing))+  where+    run :: Application -> Request -> IO (Status, Maybe ByteString)+    run app req = do+        result <- newIORef Nothing+        _ <- app req $ \rsp -> do+            writeIORef result (Just (responseStatus rsp, lookup hLocation (responseHeaders rsp)))+            pure (error "unused ResponseReceived")+        maybe (fail "no response") pure =<< readIORef result++{- | Runs 'runAutoHttpsWith' on local ports: the HTTP server answers the+challenges and redirects, the HTTPS server presents the certificates as the+manager gets them.+-}+serversGetTheirCertificate :: FilePath -> IO ()+serversGetTheirCertificate path = do+    h <- newHarness path+    httpPort <- freePort+    httpsPort <- freePort+    challengeSeen <- newIORef Nothing+    let app _ respond = respond $ responseLBS status200 [] "hello"+    let quiet = setOnException (\_ _ -> pure ()) defaultSettings+    let cfg =+            (defaultAutoHttps "http://unused.test/" ("a.test" :| []) [] path)+                { managerSettings = (settingsOf h ("a.test" :| [])){checkInterval = 0.2, getTime = readIORef h.clock}+                , httpSettings = setPort httpPort quiet+                , httpsSettings = setPort httpsPort quiet+                }+    -- an issuer which, as an ACME server does, fetches a challenge first+    let issuer :: Challenges -> Issuer+        issuer challenges domain key = do+            insertChallenge challenges.http01 (Token "tok") (KeyAuthorization "tok.thumbprint")+            fetched <- httpGet httpPort "/.well-known/acme-challenge/tok"+            deleteChallenge challenges.http01 (Token "tok")+            writeIORef challengeSeen (Just fetched)+            issuerOf h domain key+    bracket (forkIO $ runAutoHttpsWith issuer cfg app) killThread $ \_ -> do+        first <- eventually (fmap serialOf <$> presented httpsPort "a.test") (== Just 1)+        check "the HTTPS server presents the certificate obtained at startup" first+        seen <- readIORef challengeSeen+        check "the HTTP server answers the challenge" (maybe False (ByteString.isSuffixOf "tok.thumbprint") seen)+        redirected <- httpGet httpPort "/page"+        check "the HTTP server redirects to HTTPS" (("Location: https://a.test:" <> Char8.pack (show httpsPort) <> "/page") `ByteString.isInfixOf` redirected)++        writeIORef h.clock (day 61)+        renewed <- eventually (fmap serialOf <$> presented httpsPort "a.test") (== Just 2)+        check "the running HTTPS server presents the renewed certificate" renewed++{- | Runs 'runAutoHttpsWith' without the HTTP server: the HTTPS server answers+the TLS-ALPN-01 challenges, then presents the certificates.+-}+httpsServerAnswersTlsAlpn01 :: FilePath -> IO ()+httpsServerAnswersTlsAlpn01 path = do+    h <- newHarness path+    httpsPort <- freePort+    challengeSeen <- newIORef Nothing+    let app _ respond = respond $ responseLBS status200 [] "hello"+    let quiet = setOnException (\_ _ -> pure ()) defaultSettings+    let cfg =+            (defaultAutoHttps "http://unused.test/" ("a.test" :| []) [] path)+                { managerSettings = (settingsOf h ("a.test" :| [])){checkInterval = 0.2, getTime = readIORef h.clock}+                , challengeMethod = TlsAlpn01+                , serveHttp = False+                , httpsSettings = setPort httpsPort quiet+                }+    -- an issuer which, as an ACME server does, checks the challenge first+    let issuer :: Challenges -> Issuer+        issuer challenges domain key = do+            challengeKey <- genRSAKey 2048+            Right cred <- challengeCredential challengeKey (Text.unpack domain) (KeyAuthorization "tok.thumbprint")+            insertTlsAlpn01 challenges.tlsAlpn01 (Text.unpack domain) cred+            seen <- presentedWith [acmeTLSALPNProtocol] httpsPort (Text.unpack domain)+            deleteTlsAlpn01 challenges.tlsAlpn01 (Text.unpack domain)+            writeIORef challengeSeen (Just (seen == Just (fst cred)))+            issuerOf h domain key+    bracket (forkIO $ runAutoHttpsWith issuer cfg app) killThread $ \_ -> do+        first <- eventually (fmap serialOf <$> presented httpsPort "a.test") (== Just 1)+        check "the HTTPS server presents the certificate obtained with TLS-ALPN-01" first+        seen <- readIORef challengeSeen+        check "the HTTPS server answers the TLS-ALPN-01 challenge" (seen == Just True)+        h2 <- presentedWith ["h2", "http/1.1"] httpsPort "a.test"+        check "clients asking for h2 get the certificate" ((serialOf <$> h2) == Just 1)++freePort :: IO Port+freePort = do+    (port, sock) <- openFreePort+    Socket.close sock+    pure port++-- | Polls for up to ten seconds.+eventually :: IO a -> (a -> Bool) -> IO Bool+eventually action ok = go (100 :: Int)+  where+    go 0 = pure False+    go n = do+        x <- action+        if ok x then pure True else threadDelay 100000 >> go (n - 1)++-- | The raw response to a GET on localhost, for the host @a.test@.+httpGet :: Port -> ByteString -> IO ByteString+httpGet port path = do+    res <- timeout 5000000 $ bracket (connect port) Socket.close $ \sock -> do+        SocketBS.sendAll sock ("GET " <> path <> " HTTP/1.0\r\nHost: a.test\r\n\r\n")+        let recvAll acc = do+                chunk <- SocketBS.recv sock 4096+                if ByteString.null chunk then pure acc else recvAll (acc <> chunk)+        recvAll ""+    maybe (fail "no HTTP response") pure res++{- | 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 = presentedWith []++-- | Same as 'presented' for a client asking for some protocols (ALPN).+presentedWith :: [ByteString] -> Port -> TLS.HostName -> IO (Maybe X509.CertificateChain)+presentedWith protocols port name = 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 (if null protocols then Nothing else Just protocols)+                }+    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++selfSignedChain :: RSA.PrivateKey -> Integer -> String -> (UTCTime, UTCTime) -> IO X509.CertificateChain+selfSignedChain key serial name (start, end) = 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)]++    -- test times are at midnight+    midnight :: UTCTime -> DateTime+    midnight (UTCTime d _) =+        let (y, m, dd) = toGregorian d+         in DateTime (Date (fromInteger y) (toEnum (m - 1)) dd) (TimeOfDay 0 0 0 0)++    certificate :: X509.Certificate+    certificate =+        X509.Certificate+            { X509.certVersion = 2+            , X509.certSerial = serial+            , X509.certSignatureAlg = alg+            , X509.certIssuerDN = dn+            , X509.certValidity = (midnight start, midnight end)+            , X509.certSubjectDN = dn+            , X509.certPubKey = X509.PubKeyRSA (RSA.private_pub key)+            , X509.certExtensions = X509.Extensions Nothing+            }++withStateDirectory :: (FilePath -> IO a) -> IO a+withStateDirectory action = do+    tmp <- getTemporaryDirectory+    stamp <- getPOSIXTime+    let path = tmp </> ("acme-not-a-joke-warp-test-" <> show (fromEnum stamp))+    bracket (removePathForcibly path >> createDirectoryIfMissing True path >> pure path) removePathForcibly action++check :: String -> Bool -> IO ()+check name ok = do+    putStrLn $ (if ok then "pass: " else "FAIL: ") <> name+    unless ok exitFailure