diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/acme-not-a-joke-warp.cabal b/acme-not-a-joke-warp.cabal new file mode 100644 --- /dev/null +++ b/acme-not-a-joke-warp.cabal @@ -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, diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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" diff --git a/src/Acme/NotAJoke/Warp.hs b/src/Acme/NotAJoke/Warp.hs new file mode 100644 --- /dev/null +++ b/src/Acme/NotAJoke/Warp.hs @@ -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)) diff --git a/src/Acme/NotAJoke/Warp/CertificateManager.hs b/src/Acme/NotAJoke/Warp/CertificateManager.hs new file mode 100644 --- /dev/null +++ b/src/Acme/NotAJoke/Warp/CertificateManager.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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