acme-not-a-joke 0.1.0.0 → 0.2.0.0

raw patch · 26 files changed

+2764/−250 lines, 26 filesdep +acme-not-a-jokedep +cryptondep +crypton-asn1-encodingdep −wreqdep ~aesondep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: acme-not-a-joke, crypton, crypton-asn1-encoding, crypton-asn1-types, crypton-pem, crypton-x509, directory, http-client, http-client-tls, http-types, mtl, time-hourglass, transformers

Dependencies removed: wreq

Dependency ranges changed: aeson, base, bytestring, filepath, jose, lens, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +113/−2
• LICENSE +30/−0
• README.md +443/−0
• acme-not-a-joke.cabal +64/−11
• src/Acme/NotAJoke/Api/Account.hs +77/−19
• src/Acme/NotAJoke/Api/Authorization.hs +24/−14
• src/Acme/NotAJoke/Api/CSR.hs +9/−0
• src/Acme/NotAJoke/Api/Certificate.hs +18/−15
• src/Acme/NotAJoke/Api/Challenge.hs +50/−17
• src/Acme/NotAJoke/Api/Directory.hs +18/−6
• src/Acme/NotAJoke/Api/Endpoint.hs +115/−9
• src/Acme/NotAJoke/Api/Field.hs +64/−0
• src/Acme/NotAJoke/Api/JWS.hs +86/−7
• src/Acme/NotAJoke/Api/KeyChange.hs +148/−0
• src/Acme/NotAJoke/Api/Meta.hs +2/−0
• src/Acme/NotAJoke/Api/Nonce.hs +35/−21
• src/Acme/NotAJoke/Api/Order.hs +62/−31
• src/Acme/NotAJoke/Api/Revocation.hs +123/−0
• src/Acme/NotAJoke/Api/Validation.hs +16/−1
• src/Acme/NotAJoke/CertManagement.hs +300/−4
• src/Acme/NotAJoke/Client.hs +257/−58
• src/Acme/NotAJoke/Dancer.hs +155/−29
• src/Acme/NotAJoke/KeyManagement.hs +198/−4
• src/Acme/NotAJoke/LetsEncrypt.hs +9/−2
• test/KeyChange.hs +87/−0
• test/Main.hs +261/−0

@@ -1,5 +1,116 @@-# Revision history for microdns+# Revision history for acme-not-a-joke -## 0.1.0.0 -- YYYY-mm-dd+## 0.2.0.0 -- 2026-10-23++The first release since 0.1.0.0. It also contains the changes listed under+0.1.1.0 below, which never was released on its own.++* TLS-ALPN-01 challenges (RFC-8737): `isTLSALPN01` (in+  `Acme.NotAJoke.Api.Challenge`), `runAcmeDance_tlsalpn01` (in+  `Acme.NotAJoke.Dancer`), and `createTLSALPN01Certificate`,+  `acmeIdentifierDigest`, `acmeIdentifierOID` and `acmeTLSALPNProtocol` (in+  `Acme.NotAJoke.CertManagement`) to build the self-signed certificate with+  the `acmeIdentifier` extension. New dependency: `time-hourglass`.++ACME errors are now returned as values rather than thrown (or printed), which+changes the type of most API calls.++* Replace `wreq` with `http-client` and `http-client-tls`: non-2xx responses+  are no longer thrown as exceptions. Network-level failures still are raised+  as `HttpException` (from `http-client`).+* Add `AcmeError` (in `Acme.NotAJoke.Api.Endpoint`) with `SigningFailed`,+  `ServerRejected` and `UnexpectedResponse`, and the helpers `errorResponse`,+  `readProblem`, `problemType` and `problemDetail` to read the RFC-7807+  problem document of a rejected request.+* Breaking: the `post*` API calls, `getNonce`, the `Nonce.Fetcher` fields,+  `saveNonce` and `AcmePrim` use `Either AcmeError a` where they had `Maybe a`.+  Signing errors are returned (as `SigningFailed`) instead of printed on stdout.+* Breaking: `fetchDirectory` and `Endpoint.get` return an `Either AcmeError`.+* Breaking: `prepareAcmeOrder` returns an `Either AcmeError AcmeSingle` instead+  of failing with a pattern-match error when a step fails.+* Breaking: `DanceStep` has a new `AcmeFailure` constructor, `runAcmeDance`+  reports failed API calls with it instead of crashing.+* Breaking: the response newtypes (`AccountCreated`, `OrderCreated`,+  `Certificate` etc.) wrap an `Endpoint.Response` (an `http-client` response)+  rather than a `wreq` one.+* Breaking: remove `wrequrl`, `responseNonceWreq` and `responseNonceWreqBS`;+  add `rawResponseNonce`, `responseHeader`, `call`, `head_`, `postJose`,+  `postJoseWith` and `checkResponse`.+* Nonces from error responses are saved for the next request as well.+* Requests carry a `User-Agent` header, as required by RFC-8555.+* Add `isHTTP01` (in `Acme.NotAJoke.Api.Challenge`) and `runAcmeDance_http01`+  (in `Acme.NotAJoke.Dancer`) to validate orders with HTTP-01 challenges. The+  new `acme-not-a-joke-wai` package serves these challenges from a wai+  application, and hands the certificates to a running warp-tls server.++* Wildcard certificates: orders with several identifiers, such as+  `*.example.com` together with `example.com`, are validated with one challenge+  per authorization (wildcard authorizations need DNS-01). Add+  `dns01RecordName`, `wildcardBase`, `isWildcardDomain` and `pickChallenges`+  (in `Acme.NotAJoke.Client`).+* Breaking: `AcmeSingle` has a `pendingAuthorizations :: [AcmeAuthorization]`+  field in place of `fetchAuthorization`, `proof`, `replyChallenge` and+  `pollChallenge`, which moved to `AcmeAuthorization` (along with the+  identifier and wildcard flag of the authorization). `prepareAcmeOrder`+  inspects every authorization of the order (emitting one `GotAuthorization`+  each) instead of the first one only, and skips the valid ones.+* Breaking: `DanceStep` has a new `Authorizing` constructor, emitted before the+  `Validation` step of each authorization; `runAcmeDance` emits all the+  `Validation` steps before telling the server to check the challenges.+* Account key rollover (RFC-8555 section 7.3.5): add+  `Acme.NotAJoke.Api.KeyChange` with `KeyChange`, `KeyChangeHeader` (the+  protected header of the inner JWS, with the new key and no nonce),+  `keyChangeInnerSign`, `keyChangeSign` and `postKeyChange`, and+  `changeAccountKey` (in `Acme.NotAJoke.Client`), which fetches the directory,+  nonce and account before changing its key.+* Certificate revocation (RFC-8555 section 7.6): add+  `Acme.NotAJoke.Api.Revocation` with `Revocation`, `RevocationReason`,+  `revocation`, `revocationDER`, `postRevokeCertificate` (signed with the+  account key) and `postRevokeCertificateWithCertKey` (signed with the key of+  the certificate), and `revokeCertificate` and `revokeCertificateWithCertKey`+  (in `Acme.NotAJoke.Client`), which fetch the directory, nonce and account.+* JWS algorithms beyond RS256: `jwkSign` and `kidSign` sign with the algorithm+  that fits the key (`RS256` for RSA, `ES256`/`ES384`/`ES512`/`ES256K` for EC,+  `EdDSA` for Ed25519/Ed448), or with the algorithm pinned in the `alg`+  parameter of the JWK. Symmetric keys and the `none`/MAC algorithms are+  refused (a `SigningFailed`). Add `acmeJWSAlg`, `acmeProtectedHeader` and+  `setAcmeJWSAlg` (in `Acme.NotAJoke.Api.JWS`) and `genJWKecP256`,+  `genJWKecP384` and `genJWKed25519` (in `Acme.NotAJoke.KeyManagement`). RSA+  keys without a pinned algorithm still sign with `RS256`. New dependency:+  `mtl`.+* Account deactivation (RFC-8555 section 7.3.6): add `postDeactivateAccount`,+  `deactivateAccountPayload` and `AccountDeactivationResponse` (in+  `Acme.NotAJoke.Api.Account`), and `deactivateAccount` (in+  `Acme.NotAJoke.Client`), which fetches the directory, nonce and account+  before deactivating it.++## 0.1.1.0 -- never released (shipped in 0.2.0.0)++Helpers to create, load and write the PKI formats involved in getting a+certificate, so that `openssl` and `scripts/gen-csr.sh` no longer are required.+Existing functions keep their types.++* `Acme.NotAJoke.KeyManagement`: add `genRSAKey` and `genRSAKey4096` to+  generate the key of a certificate; `encodeRSAKeyPEM`, `decodeRSAKeyPEM`,+  `encodeRSAKeyDER`, `decodeRSAKeyDER`, `loadRSAKeyPEM` and `writeRSAKeyPEM` to+  read and write RSA keys (PKCS#1 is written, PKCS#1 and unencrypted PKCS#8 are+  read); `jwkFromRSAKey` and `jwkToRSAKey` to convert between RSA keys and+  JWKs; `loadOrCreateJWKFile` and `loadOrCreateRSAKeyPEM` to generate a key on+  the first run.+* `Acme.NotAJoke.CertManagement`: add `createCSR` and `createCSRWith` to build+  and sign (RSA with SHA-256) a CSR with its subject alternative names;+  `loadCSR` (PEM or DER files), `writeCSRDER`, `writeCSRPEM`, `csrFromDER`,+  `csrToDER`, `encodeCSRPEM` and `decodeCSRPEM` to read and write CSRs;+  `certificateChain`, `decodeCertificateChain`, `encodeCertificateChain`,+  `loadCertificateChain` and `writeCertificateChain` to parse and write the+  certificates returned by the ACME server.+* Both modules now have an explicit export list (all the functions they had+  still are exported).+* New dependencies: `crypton`, `crypton-x509`, `crypton-asn1-encoding`,+  `crypton-asn1-types`, `crypton-pem` and `directory`. The `crypton` packages+  already were transitive dependencies (via `jose`).+* Add a `pki-formats` test-suite.++## 0.1.0.0 -- 2023  * First version. Released on an unsuspecting world.

@@ -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,443 @@+# ACME-not-a-joke++A library of primitives to perform ACME authentication certifications [RFC-8555](https://datatracker.ietf.org/doc/html/rfc8555).++## status of this library++Incomplete and subject to changes. But the happy path will work.++What I'd like to change with low appetite:+- support more features (e.g., key changes and account deactivation)++Errors are returned as values: API calls return an `Either AcmeError a`, where+an `AcmeError` tells whether the request could not be signed, whether the+server rejected the request (in which case `readProblem` gives the+[RFC-7807](https://datatracker.ietf.org/doc/html/rfc7807) problem document sent+by the ACME server), or whether the response was not the expected one. Only+network-level failures (no connection, TLS errors) are raised as exceptions (the+`HttpException` from `http-client`).++Design-wise, the library uses a TypeFamily pattern to specify/modulate which+fields are available for ACME resources in various APIs/states (e.g., an+`Account` in the `"account-create"` message has no "orders" fields).++## what about the name of the library++We use ACME-not-a-joke as a package name because `acme-` packages on Hackage+typically are "joke" packages.++## how a certificate is obtained++An ACME server hands out a certificate once you prove that you control the+names it is for. With this library, the whole flow goes:++1. **the account key**: a JWK which signs every request (see+   `Acme.NotAJoke.KeyManagement`). The server knows your account by this key,+   keep it.+2. **the account**: created once with `postCreateAccount` (which also finds+   the account when it already exists), then looked up with `fetchAccount`.+3. **the certificate key and the CSR**: an RSA key, which must differ from the+   account key, and a CSR for the names, signed with it (see+   `Acme.NotAJoke.CertManagement`, or `scripts/gen-csr.sh`). Your TLS server+   needs this key along with the certificate.+4. **the order**: `createOrder` with one `OrderIdentifier` per name.+5. **the dance** (`Acme.NotAJoke.Dancer`): fetches the directory and the+   account, creates the order, gives you one proof per name, tells the server+   to check the proofs, polls the order, finalizes it with the CSR, and+   downloads the certificate.++What the caller provides is an `AcmeDancer`: the server (its base URL, see+`Acme.NotAJoke.LetsEncrypt`), the account key, the account, the CSR, the order+and a step handler. The dance calls the step handler at each step and waits+for it to return before going on. The step handler is where:++- the proofs are published, on `Validation` (for DNS-01: a TXT record at the+  `dns01RecordName` of the identifier of the preceding `Authorizing` step,+  through the API of your DNS provider; the library does not talk to DNS+  providers),+- the dance waits between two polls of the order, on `WaitingForValidation n`+  (the dance does not sleep on its own),+- the certificate is kept, on `Done`,+- errors are reported, on `InvalidOrder`, `OtherError` and `AcmeFailure`,+  after which the dance stops.++Nothing runs in the background and nothing is written to disk but what your+code writes. A complete program, with a DNS-01 challenge:++```hs+import Acme.NotAJoke.Api.Account+import Acme.NotAJoke.Api.Certificate (storeCert)+import Acme.NotAJoke.Api.Directory+import Acme.NotAJoke.Api.Endpoint (readProblem)+import Acme.NotAJoke.Api.Nonce+import Acme.NotAJoke.Api.Order+import Acme.NotAJoke.Api.Validation (ValidationProof (..))+import Acme.NotAJoke.CertManagement+import Acme.NotAJoke.Client+import Acme.NotAJoke.Dancer+import Acme.NotAJoke.KeyManagement+import Acme.NotAJoke.LetsEncrypt+import Control.Concurrent (threadDelay)+import Data.IORef+import Data.List.NonEmpty (NonEmpty (..))++main :: IO ()+main = do+    let server = staging_letsencryptv2+        contacts = ["mailto:certmaster@example.com"]++    -- the account key, and the account (created on the first run, found afterwards)+    Right jwk <- loadOrCreateJWKFile "state/account.jwk"+    Right dir <- fetchDirectory (directory server)+    Right nonce <- getNonce dir.newNonce+    Right _ <- postCreateAccount jwk dir.newAccount nonce (createAccount contacts)++    -- the certificate key (not the account key) and a CSR for the names+    Right key <- loadOrCreateRSAKeyPEM "state/key.pem"+    Right csr <- createCSR key ("example.com" :| [])++    let order = createOrder (Nothing, Nothing) [OrderIdentifier DNSOrder "example.com"]++    -- the step handler: publish the proofs, wait between polls, keep the certificate+    current <- newIORef Nothing+    let handle step = case step of+            Authorizing authz -> writeIORef current (Just (dns01RecordName authz.authIdentifier))+            Validation (_, _, ValidationProof txt) -> do+                Just name <- readIORef current+                addTxtRecord name txt -- your DNS provider, then wait for propagation+            WaitingForValidation n -> threadDelay (n * 1000000)+            Done _ cert -> storeCert "state/certificate.pem" cert+            InvalidOrder o -> print o+            OtherError txt -> print txt+            AcmeFailure err -> print (readProblem err)+            _ -> pure ()++    runAcmeDance_dns01 (AcmeDancer server jwk (fetchAccount contacts) csr order handle)+```++(with the `OverloadedStrings`, `DataKinds` and `OverloadedRecordDot`+extensions, and `addTxtRecord` yours to write). The `state` directory must+exist. Once the certificate is obtained, the TXT records can go.++### the TypeFamily pattern++An ACME resource does not have the same fields in every message: an account+being created has contacts but no status yet, an order returned by the server+has authorizations and a finalize URL that the client does not send, and the+certificate URL of an order only appears once the order is valid. Instead of+one record per message, there is one record per resource with every field,+each field type going through the `Field` type family+(`Acme.NotAJoke.Api.Field`), and the record takes the name of a state:++```hs+data Account a = Account+    { status :: Field a "status" AccountStatus+    , contact :: Field a "contact" [Contact]+    , ...+    }++type instance Field "account-create" "contact" x = x  -- present+type instance Field "account-create" "status" x = ()  -- absent+```++In a state, a field holds its value (`x`), nothing (`()`), or maybe a value+(`Maybe x`). The functions take or return the record in the state matching+the message: `postCreateAccount` takes an `Account "account-create"` (built+with `createAccount`), the `AcmeDancer` an `Account "account-fetch"` (built+with `fetchAccount`), `readOrderCreated` returns an `Order "order-created"`,+and `readOrderInspected` an `Order "order-inspected"` whose `certificate` is a+`Maybe`. The states of each resource are listed in the documentation of+`Acme.NotAJoke.Api.Field`.++## example++```console+bash scripts/gen-csr.sh staging example dicioccio.fr+```++create a new account++```hs+import Acme.NotAJoke.Api.Account+import Acme.NotAJoke.Api.Directory+import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.Nonce+import Acme.NotAJoke.KeyManagement+import Acme.NotAJoke.LetsEncrypt+import Data.Maybe++loadedjwk <- loadJWKFile "staging/key.jwk"+let jwk = fromJust loadedjwk+let contacts = ["mailto:certmaster@dicioccio.fr"]++Right leDir <- fetchDirectory (directory staging_letsencryptv2)+Right nonce0 <- getNonce leDir.newNonce+created <- postCreateAccount jwk leDir.newAccount nonce0 (createAccount contacts)+```++inspect what the server complained about, if anything++```hs+either (\err -> print (readProblem err)) print created+```++create a new cert++```hs+import Acme.NotAJoke.CertManagement+import Acme.NotAJoke.Client+import Acme.NotAJoke.Dancer+import Acme.NotAJoke.KeyManagement+import Acme.NotAJoke.Api.Directory+import Acme.NotAJoke.Api.CSR+import Acme.NotAJoke.Api.Order+import Acme.NotAJoke.LetsEncrypt+import Data.Maybe++jwk <- fromJust <$> loadJWKFile "staging/key.jwk"+der <- loadDER "staging-example/certificate.csr.der"++let o = createOrder (Nothing, Nothing) [ OrderIdentifier DNSOrder "example.dicioccio.fr" ]+runAcmeDance_dns01 (AcmeDancer staging_letsencryptv2 jwk (fetchAccount ["mailto:certmaster@dicioccio.fr"]) (CSR der) o (ghciDance "staging-example/certificate.pem"))+```++### wildcard certificates with dns-01++A wildcard such as `*.example.com` is an identifier of the order like any other+(RFC-8555 sections 7.1.3 and 7.1.4), and it must be validated with a DNS-01+challenge. The server gives an authorization for `example.com` (without the+`*.`, with `wildcard: true`), so the TXT record holding the proof goes at+`_acme-challenge.example.com`: `dns01RecordName` (in `Acme.NotAJoke.Client`)+gives that name.++An order can mix a wildcard with its apex. There is one authorization per+identifier, so the dance emits one `Authorizing` step (which identifier, whether+it is the wildcard) followed by one `Validation` step (the proof) per+authorization, and tells the server to check the challenges only after the last+one. For `*.example.com` and `example.com` that means two TXT records at the+same name, which must be present at the same time: add records, do not replace+them. Authorizations the server already considers valid (e.g. reused from an+earlier order) are skipped.++```hs+import Acme.NotAJoke.Api.Validation (ValidationProof (..))+import Data.IORef+import Data.List.NonEmpty (NonEmpty (..))++Right key <- loadOrCreateRSAKeyPEM "staging-wildcard/key.pem"+Right csr <- createCSR key ("example.dicioccio.fr" :| ["*.example.dicioccio.fr"])++let o = createOrder (Nothing, Nothing) [ OrderIdentifier DNSOrder "example.dicioccio.fr", OrderIdentifier DNSOrder "*.example.dicioccio.fr" ]+current <- newIORef Nothing+let handle step = case step of+      Authorizing authz -> writeIORef current (Just (dns01RecordName (authIdentifier authz)))+      Validation (_, _, ValidationProof txt) -> do+        Just name <- readIORef current+        addTxtRecord name txt -- your DNS provider, then wait for propagation+      WaitingForValidation n -> threadDelay (n * 1000000)+      Done _ cert -> storeCert "staging-wildcard/certificate.pem" cert+      _ -> pure ()+runAcmeDance_dns01 (AcmeDancer staging_letsencryptv2 jwk (fetchAccount ["mailto:certmaster@dicioccio.fr"]) csr o handle)+```++### http-01 challenges with wai++The example above uses a DNS-01 challenge. The `acme-not-a-joke-wai` package+(in the `acme-not-a-joke-wai` directory) serves HTTP-01 challenges from a+wai application: a middleware answers the+`GET /.well-known/acme-challenge/{token}` requests of the ACME server, and the+dance fills and clears the store of challenges read by the middleware.++```hs+import Acme.NotAJoke.Wai.Http01+import Control.Concurrent (forkIO, threadDelay)+import Network.Wai.Handler.Warp (run)++store <- newChallengeStore+-- the ACME server connects on port 80+_ <- forkIO $ run 80 (http01Middleware store myApplication)++let handle step = case step of+      WaitingForValidation n -> threadDelay (n * 1000000)+      Done _ cert -> storeCert "staging-example/certificate.pem" cert+      _ -> pure ()+runAcmeDance_http01_wai store (AcmeDancer staging_letsencryptv2 jwk (fetchAccount ["mailto:certmaster@dicioccio.fr"]) (CSR der) o handle)+```++HTTP-01 challenges cannot validate wildcard identifiers, which require a DNS-01+challenge.++The same package answers TLS-ALPN-01 challenges (RFC-8737) from the HTTPS+server itself, without port 80: `runAcmeDance_tlsalpn01_wai` with a+`TlsAlpn01Store`, and `withTlsAlpn01` on the warp-tls settings (see+`Acme.NotAJoke.Wai.TlsAlpn01`).++Your program starts the dance (nothing runs in the background) and the only+incoming request is the one the ACME server sends to port 80. The library+writes no file on its own: keys, CSR and certificate go where the functions you+call put them (above, only `storeCert` writes something). See+[acme-not-a-joke-wai/README.md](acme-not-a-joke-wai/README.md) for who+initiates what, which files are involved, and a complete example.++The same package has `Acme.NotAJoke.Wai.WarpTLS`: a certificate store read by+a warp-tls server at each TLS handshake, so that the certificate you just+obtained (or renewed) is served without restarting.++```hs+import Acme.NotAJoke.Wai.WarpTLS+import Network.Wai.Handler.Warp (defaultSettings, setPort)+import Network.Wai.Handler.WarpTLS (runTLS)++certificates <- newCertificateStore+_ <- forkIO $ runTLS (liveTlsSettings certificates) (setPort 443 defaultSettings) myApplication++-- in the step handler, with the key that signed the CSR+--   Done _ cert -> installCertificate certificates key cert+```++### automatic HTTPS with warp++The `acme-not-a-joke-warp` package (in the `acme-not-a-joke-warp` directory)+puts the above together, in the spirit of Caddy: it runs your wai application+over HTTPS, gets the certificates with HTTP-01 challenges (or TLS-ALPN-01+challenges, without port 80) when the program+starts, stores them on disk, renews them before they expire and serves the new+ones without restarting.++```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")+    myApplication+```++See [acme-not-a-joke-warp/README.md](acme-not-a-joke-warp/README.md) for what+runs, what is stored, and when certificates are renewed.++### changing the account key++`Acme.NotAJoke.Api.KeyChange` builds account key rollovers (RFC-8555 section+7.3.5): an inner JWS signed with the new key, wrapped in a request signed with+the old key. `changeAccountKey` (in `Acme.NotAJoke.Client`) fetches the+directory, nonce and account and sends it. Once it succeeds, the old key no+longer works for the account: write the new key down before calling it.++```hs+import Acme.NotAJoke.Api.Account+import Acme.NotAJoke.Client+import Acme.NotAJoke.KeyManagement+import Acme.NotAJoke.LetsEncrypt++Just oldJwk <- loadJWKFile "staging/key.jwk"+newJwk <- genJWKrsa4096+writeJWKFile newJwk "staging/key.new.jwk"++changeAccountKey staging_letsencryptv2 oldJwk newJwk (fetchAccount ["mailto:certmaster@dicioccio.fr"])+```++### keys and CSRs without openssl++The `scripts/gen-csr.sh` script above calls `openssl` to generate the key of+the certificate and the CSR. You can stay in Haskell instead:+`Acme.NotAJoke.KeyManagement` and `Acme.NotAJoke.CertManagement` have helpers+to create, load and write account keys (JWK), RSA keys (PEM, DER), CSRs (PEM,+DER) and certificate chains (PEM).++```hs+import Acme.NotAJoke.CertManagement+import Acme.NotAJoke.KeyManagement+import Data.List.NonEmpty (NonEmpty (..))++-- the account key, created on the first run (directories must exist)+Right jwk <- loadOrCreateJWKFile "staging/key.jwk"++-- the key of the certificate (which must differ from the account key)+Right key <- loadOrCreateRSAKeyPEM "staging-example/key.pem"++-- a CSR for the names of the order, to pass to the AcmeDancer+Right csr <- createCSR key ("example.dicioccio.fr" :| [])++-- optionally, keep a copy that `openssl req -in ... -text` can read+writeCSRPEM csr "staging-example/certificate.csr"++-- once the dance is over, inspect what the server returned+Right chain <- loadCertificateChain "staging-example/certificate.pem"+```++Existing files made with `openssl` load as well: see `loadRSAKeyPEM` and+`loadCSR`.++### account keys and JWS algorithms++The account key need not be an RSA key: requests are signed with the JWS+algorithm that fits the key (see `acmeJWSAlg` in `Acme.NotAJoke.Api.JWS`),+`RS256` for RSA keys, `ES256`/`ES384`/`ES512` for EC keys on the P-256/P-384/P-521+curves and `EdDSA` for Ed25519 keys. Let's Encrypt accepts `RS256`, `ES256`+and `ES384`. To use another algorithm the server accepts (e.g. `PS256` with+an RSA key), pin it in the key with `setAcmeJWSAlg`: it is stored in the JWK+file.++```hs+import Acme.NotAJoke.KeyManagement++-- a smaller and faster account key, signing with ES256+jwk <- genJWKecP256+writeJWKFile jwk "staging/key.jwk"+```++The key of the certificate is unaffected (it is an RSA key, see above).++### revoking a certificate++`Acme.NotAJoke.Api.Revocation` builds revocation requests (RFC-8555 section+7.6) with an optional reason, and `Acme.NotAJoke.Client` sends them. Sign with+the account key, or with the key of the certificate when the account key is+lost (no account is needed then).++```hs+import Acme.NotAJoke.Api.Revocation+import Acme.NotAJoke.CertManagement+import Acme.NotAJoke.Client+import Acme.NotAJoke.KeyManagement++Right (cert : _) <- loadCertificateChain "staging-example/certificate.pem"+let rev = revocation (Just Superseded) cert++-- with the account key+revokeCertificate staging_letsencryptv2 jwk (fetchAccount ["mailto:certmaster@dicioccio.fr"]) rev++-- or with the key of the certificate+Right key <- loadRSAKeyPEM "staging-example/key.pem"+revokeCertificateWithCertKey staging_letsencryptv2 (jwkFromRSAKey key) rev+```++### deactivating an account++`deactivateAccount` (in `Acme.NotAJoke.Client`) fetches the directory, nonce+and account, then deactivates the account (RFC-8555 section 7.3.6). This+cannot be undone: the server rejects every later request signed with the key+of the account. `postDeactivateAccount` (in `Acme.NotAJoke.Api.Account`) is+the single API call, for when you already know the KID of the account.++```hs+import Acme.NotAJoke.Api.Account+import Acme.NotAJoke.Client+import Acme.NotAJoke.KeyManagement+import Acme.NotAJoke.LetsEncrypt++Just jwk <- loadJWKFile "staging/key.jwk"++deactivateAccount staging_letsencryptv2 jwk (fetchAccount ["mailto:certmaster@dicioccio.fr"])+```++## website++The site at https://lucasdicioccio.github.io/acme-not-a-joke/ is a+[Kitchen-Sink](https://kitchensink-tech.github.io/) site. Its sources are in+`website/src/` and the published output is in `docs/`, see+[website/README.md](website/README.md).

@@ -1,26 +1,50 @@ cabal-version:      2.4 name:               acme-not-a-joke-version:            0.1.0.0+version:            0.2.0.0  -- A short (one-line) description of the package. synopsis: implements ACME clients (rfc-8555)  -- A longer description of the package.-description: a library to get TLS certificate by communicating to a ACME-provider such as Lets'Encrypt. Hence: no, the acme prefix is not a marker for a joke.---- A URL where users can report bugs.--- bug-reports:+description: a library to get TLS certificates by communicating with an ACME provider such as Let's Encrypt (rfc-8555). It creates accounts and orders, validates them with HTTP-01, DNS-01 or TLS-ALPN-01 (rfc-8737) challenges, downloads certificates, and handles account key rollover, account deactivation and certificate revocation. It also generates and reads the keys, CSRs and certificates involved. Hence: no, the acme prefix is not a marker for a joke. See acme-not-a-joke-wai and acme-not-a-joke-warp to serve challenges and certificates from a wai/warp application.  -- 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+copyright: Lucas DiCioccio 2023-2026 category: Security-extra-source-files: CHANGELOG.md+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++test-suite pki-formats+    type: exitcode-stdio-1.0+    hs-source-dirs: test+    main-is: Main.hs+    ghc-options: -Wall+    default-language: Haskell2010+    default-extensions: OverloadedStrings+    build-depends:+      acme-not-a-joke,+      aeson,+      base,+      bytestring,+      directory,+      filepath,+      crypton-x509,+      jose,+      lens,+      text,+ library     hs-source-dirs: src     ghc-options: -Wall -Wwarn=missing-home-modules@@ -36,9 +60,11 @@       Acme.NotAJoke.Api.Endpoint       Acme.NotAJoke.Api.Field       Acme.NotAJoke.Api.JWS+      Acme.NotAJoke.Api.KeyChange       Acme.NotAJoke.Api.Meta       Acme.NotAJoke.Api.Nonce       Acme.NotAJoke.Api.Order+      Acme.NotAJoke.Api.Revocation       Acme.NotAJoke.Api.Validation       Acme.NotAJoke.Client       Acme.NotAJoke.Dancer@@ -47,13 +73,40 @@       Acme.NotAJoke.CertManagement     build-depends:       aeson >= 2.2.1 && < 2.3,-      base >= 4.19.1 && < 4.20,+      base >= 4.19.1 && < 5,       bytestring >= 0.12.1 && < 0.13,-      filepath >= 1.4.200 && < 1.5,+      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,       base16-bytestring >= 1.0.2 && < 1.1,+      directory >= 1.3.8 && < 1.4,       cryptohash-sha256 >= 0.11.102 && < 0.12,+      crypton >= 1.0 && < 1.1,+      crypton-asn1-encoding >= 0.10 && < 0.11,+      crypton-asn1-types >= 0.4 && < 0.5,+      crypton-pem >= 0.3 && < 0.4,+      crypton-x509 >= 1.8 && < 1.9,       jose >= 0.11 && < 0.12,-      lens >= 5.2.3 && < 5.3,-      wreq >= 0.5.4 && < 0.6,+      lens >= 5.2.3 && < 5.4,+      mtl >= 2.3.1 && < 2.4,+      http-client >= 0.7.17 && < 0.8,+      http-client-tls >= 0.3.6 && < 0.4,+      http-types >= 0.12.4 && < 0.13,+      transformers >= 0.6.1 && < 0.7,++test-suite key-change+    type: exitcode-stdio-1.0+    hs-source-dirs: test+    main-is: KeyChange.hs+    ghc-options: -Wall+    default-language: Haskell2010+    default-extensions: OverloadedStrings+    build-depends:+      acme-not-a-joke,+      aeson,+      base,+      bytestring,+      jose,+      lens,+      text,

@@ -1,11 +1,30 @@+{- | ACME accounts (RFC-8555 section 7.3).++Every request but the ones fetching the directory and a nonce is signed by an+account key (a JWK, see "Acme.NotAJoke.KeyManagement"). The server knows the+account by its public key: the first request, to the @newAccount@ endpoint of+the 'Acme.NotAJoke.Api.Directory.Directory', creates the account (or finds the+existing one) and returns its URL in the @Location@ header (see 'readKID').+Later requests are signed with that URL as a @kid@ (see+'Acme.NotAJoke.Api.JWS.kidSign').++'Account' has two states (see "Acme.NotAJoke.Api.Field"):++* @Account \"account-create\"@ ('createAccount', 'postCreateAccount') creates+  the account if needed+* @Account \"account-fetch\"@ ('fetchAccount', 'postFetchAccount') only finds an+  existing account: the server rejects the request when the key has no+  account; this is the state 'Acme.NotAJoke.Dancer.AcmeDancer' and the+  functions of "Acme.NotAJoke.Client" take++Hence a program first creates its account once (e.g., when it creates the+account key), then fetches it.+-} module Acme.NotAJoke.Api.Account where -import Control.Lens hiding ((.=))-import Data.Aeson (encode, object, (.=))-import Data.ByteString.Lazy (ByteString)+import Data.Aeson (Value, encode, object, (.=)) import Data.Text (Text) import qualified Data.Text.Encoding as Encoding-import qualified Network.Wreq as Wreq  import qualified Crypto.JOSE.JWS as JWS @@ -24,7 +43,9 @@     | AccountRevoked     deriving (Show, Eq) --- | A structure holding various Account field.+{- | A structure holding various Account field, the set of fields depending on+the state @a@ (@\"account-create\"@ or @\"account-fetch\"@).+-} data Account a     = Account     { status :: Field a "status" AccountStatus@@ -49,41 +70,51 @@ type instance Field "account-fetch" "agreement" x = () type instance Field "account-fetch" "onlyReturnExisting" x = x -newtype AccountCreated = AccountCreated (Wreq.Response ByteString)+{- | The response of the server to 'postCreateAccount' or 'postFetchAccount',+whose @Location@ header gives the KID of the account (see 'readKID').+-}+newtype AccountCreated = AccountCreated Response     deriving (Show)  -- | Initializes an account structure, assuming we have read the terms-of-service. createAccount :: [Contact] -> Account "account-create" createAccount = createAccount1 True +-- | Whether you agree to the terms of service of the ACME server (see 'Acme.NotAJoke.Api.Meta.termsOfService'). type HasReadTermsOfService = Bool  -- | Initializes an account structure. createAccount1 :: HasReadTermsOfService -> [Contact] -> Account "account-create" createAccount1 tos contacts = Account () () () tos contacts () +{- | Initializes a structure to look up an existing account (agreeing to the+terms-of-service and setting @onlyReturnExisting@). The server ignores the+contacts of a lookup (an existing account keeps its contacts).+-} fetchAccount :: [Contact] -> Account "account-fetch" fetchAccount = fetchAccount1 True True +{- | Initializes a structure to look up an account, with whether you agree to+the terms-of-service and whether the server must only return an existing+account (with @False@, the server creates the account when missing).+-} fetchAccount1 :: Bool -> Bool -> [Contact] -> Account "account-fetch" fetchAccount1 tos onlyfetch contacts = Account () () () tos contacts onlyfetch  -- | Lookup a Key Identifier for the account. readKID :: AccountCreated -> Maybe KID-readKID (AccountCreated rsp) = rsp ^? Wreq.responseHeader "location" . to (KID . Encoding.decodeUtf8)+readKID (AccountCreated rsp) = KID . Encoding.decodeUtf8 <$> responseHeader "location" rsp  -- | Fetches or create an account (a single API call).-postCreateAccount :: JWS.JWK -> Endpoint "newAccount" -> Nonce -> Account "account-create" -> IO (Maybe AccountCreated)+postCreateAccount :: JWS.JWK -> Endpoint "newAccount" -> Nonce -> Account "account-create" -> IO (Either AcmeError AccountCreated) postCreateAccount jwk ep nonce acc = do-    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]     ebody <- (jwkSign jwk ep nonce $ encode $ serialized)     case ebody of         Right body -> do-            e <- Wreq.postWith opts (wrequrl ep) $ encode body-            pure $ Just $ AccountCreated e+            e <- postJose ep $ encode body+            pure $ fmap AccountCreated e         Left err -> do-            print err-            pure Nothing+            pure $ Left $ SigningFailed err   where     serialized =         object@@ -92,17 +123,15 @@             ]  -- | Only fetches an account (i.e., does not create the account if missing).-postFetchAccount :: JWS.JWK -> Endpoint "newAccount" -> Nonce -> Account "account-fetch" -> IO (Maybe AccountCreated)+postFetchAccount :: JWS.JWK -> Endpoint "newAccount" -> Nonce -> Account "account-fetch" -> IO (Either AcmeError AccountCreated) postFetchAccount jwk ep nonce acc = do-    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]     ebody <- (jwkSign jwk ep nonce $ encode $ serialized)     case ebody of         Right body -> do-            e <- Wreq.postWith opts (wrequrl ep) $ encode body-            pure $ Just $ AccountCreated e+            e <- postJose ep $ encode body+            pure $ fmap AccountCreated e         Left err -> do-            print err-            pure Nothing+            pure $ Left $ SigningFailed err   where     serialized =         object@@ -110,3 +139,32 @@             , "contact" .= acc.contact             , "onlyReturnExisting" .= acc.onlyReturnExisting             ]++newtype AccountDeactivationResponse = AccountDeactivationResponse Response+    deriving (Show)++{- | Payload of an account deactivation request (RFC-8555 section 7.3.6):+@{"status": "deactivated"}@.+-}+deactivateAccountPayload :: Value+deactivateAccountPayload = object ["status" .= ("deactivated" :: Text)]++{- | Deactivates an account (a single API call), see RFC-8555 section 7.3.6.++The request is posted to the URL of the account (its 'KID', see 'readKID'),+signed with the key of the account. Once this succeeds the account is gone for+good: the server rejects every later request signed with its key (and+'postFetchAccount' no longer finds it).+-}+postDeactivateAccount :: JWS.JWK -> KID -> Nonce -> IO (Either AcmeError AccountDeactivationResponse)+postDeactivateAccount jwk kid@(KID accountUrl) nonce = do+    ebody <- (kidSign jwk ep kid nonce $ encode deactivateAccountPayload)+    case ebody of+        Right body -> do+            e <- postJose ep $ encode body+            pure $ fmap AccountDeactivationResponse e+        Left err -> do+            pure $ Left $ SigningFailed err+  where+    ep :: Endpoint "account"+    ep = Endpoint accountUrl

@@ -1,12 +1,21 @@+{- | ACME authorizations (RFC-8555 section 7.1.4).++An order has one authorization per identifier: the client proves it controls+the identifier by completing one of the challenges of the authorization (see+"Acme.NotAJoke.Api.Challenge"). For a wildcard identifier such as+@*.example.com@, the authorization is for @example.com@ with @wildcard@ set,+and only DNS-01 challenges are offered.++An authorization already validated (e.g., for an earlier order of the same+account) can be @valid@ from the start, with nothing left to do.+-} module Acme.NotAJoke.Api.Authorization where -import Control.Lens hiding ((.=)) import Data.Aeson (FromJSON (..), ToJSON (..), decode, encode, object, pairs, withObject, withText, (.:), (.:?), (.=))-import Data.ByteString.Lazy (ByteString) import Data.Coerce (coerce) import Data.Text (Text) import Data.Time.Clock (UTCTime)-import qualified Network.Wreq as Wreq+import qualified Network.HTTP.Client as HTTP  import qualified Crypto.JOSE.JWS as JWS @@ -16,7 +25,7 @@ import Acme.NotAJoke.Api.JWS import Acme.NotAJoke.Api.Nonce --- RFC-defined authorization statuses.+-- | RFC-defined authorization statuses. data AuthorizationStatus     = AuthorizationPending     | AuthorizationValid@@ -37,7 +46,7 @@             "revoked" -> pure AuthorizationRevoked             _ -> fail $ "invalid authorization status:" <> show txt --- RFC-defined authorization types (only the subset supported in this library).+-- | RFC-defined authorization types (only the subset supported in this library). data AuthorizationType     = DNSAuthorization     deriving (Show, Eq, Ord)@@ -68,7 +77,9 @@             <$> o .: "type"             <*> o .: "value" --- | RFC-defined authorization resource.+{- | RFC-defined authorization resource, the set of fields depending on the+state @a@ (only @\"authorization-inspected\"@ for now).+-} data Authorization a     = Authorization     { status :: Field a "status" AuthorizationStatus@@ -78,7 +89,8 @@     , wildcard :: Field a "wildcard" (Maybe Bool)     } -newtype AuthorizationInspected = AuthorizationInspected (Wreq.Response ByteString)+-- | The response of the server to 'postGetAuthorization'.+newtype AuthorizationInspected = AuthorizationInspected Response     deriving (Show)  type instance Field "authorization-inspected" "status" x = x@@ -98,20 +110,18 @@  -- | Lookup an Authorization. readAuthorization :: AuthorizationInspected -> Maybe (Authorization "authorization-inspected")-readAuthorization (AuthorizationInspected rsp) = decode $ rsp ^. Wreq.responseBody+readAuthorization (AuthorizationInspected rsp) = decode $ HTTP.responseBody rsp  -- | Inspects an authorization from its URL.-postGetAuthorization :: JWS.JWK -> KID -> Url "authorization" -> Nonce -> IO (Maybe AuthorizationInspected)+postGetAuthorization :: JWS.JWK -> KID -> Url "authorization" -> Nonce -> IO (Either AcmeError AuthorizationInspected) postGetAuthorization jwk kid authUrl nonce = do-    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]     ebody <- (kidSign jwk ep kid nonce "")     case ebody of         Right body -> do-            e <- Wreq.postWith opts (wrequrl ep) $ encode body-            pure $ Just $ AuthorizationInspected e+            e <- postJose ep $ encode body+            pure $ fmap AuthorizationInspected e         Left err -> do-            print err-            pure Nothing+            pure $ Left $ SigningFailed err   where     ep :: Endpoint "authorization"     ep = coerce authUrl

@@ -1,12 +1,21 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{- | Certificate Signing Requests as the ACME API carries them. To create,+load or write them, see "Acme.NotAJoke.CertManagement".+-} module Acme.NotAJoke.Api.CSR where  import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Text (Text) +-- | The base64url encoding (without padding) of some DER-encoded data. newtype Base64DER = Base64DER Text     deriving (Show, FromJSON, ToJSON) +{- | A Certificate Signing Request, as sent to finalize an order.++Build one with 'Acme.NotAJoke.CertManagement.createCSR', or load one with+'Acme.NotAJoke.CertManagement.loadCSR'.+-} newtype CSR = CSR Base64DER     deriving (Show, FromJSON, ToJSON)

@@ -1,11 +1,12 @@+{- | Downloading the certificate of a valid order (RFC-8555 section 7.4.2).+-} module Acme.NotAJoke.Api.Certificate where -import Control.Lens hiding ((.=)) import Data.Aeson (encode) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as ByteString import Data.Coerce (coerce)-import qualified Network.Wreq as Wreq+import qualified Network.HTTP.Client as HTTP  import qualified Crypto.JOSE.JWS as JWS @@ -18,34 +19,36 @@ You should be able to figure out most of the ACME flow by looking how you build a Certificate and pulling all the dependencies. -}-newtype Certificate = Certificate (Wreq.Response ByteString)+newtype Certificate = Certificate Response     deriving (Show) --- | A PEM-file representation of a certificate.+{- | A PEM-file representation of a certificate: the certificate followed by+the intermediate certificates of the chain (see+'Acme.NotAJoke.CertManagement.decodeCertificateChain').+-} newtype PEM = PEM ByteString +-- | Writes the certificate chain to a PEM file (overwriting the file). storeCert :: FilePath -> Certificate -> IO () storeCert path cert = ByteString.writeFile path (coerce $ readPEM cert)  -- | Lookup a PEM from a certificate. readPEM :: Certificate -> PEM-readPEM (Certificate rsp) = PEM $ rsp ^. Wreq.responseBody+readPEM (Certificate rsp) = PEM $ HTTP.responseBody rsp --- | Retrieves a certificate from an URL.-postGetCertificate :: JWS.JWK -> KID -> Url "certificate" -> Nonce -> IO (Maybe Certificate)+{- | Retrieves a certificate from an URL (see+'Acme.NotAJoke.Api.Order.readCertificateUrl').+-}+postGetCertificate :: JWS.JWK -> KID -> Url "certificate" -> Nonce -> IO (Either AcmeError Certificate) postGetCertificate jwk kid certificateUrl nonce = do-    let opts =-            Wreq.defaults-                & Wreq.header "Content-Type" .~ ["application/jose+json"]-                & Wreq.header "Accept" .~ ["application/pem-certificate-chain"]+    let headers = [("Accept", "application/pem-certificate-chain")]     ebody <- (kidSign jwk ep kid nonce "")     case ebody of         Right body -> do-            e <- Wreq.postWith opts (wrequrl ep) $ encode body-            pure $ Just $ Certificate e+            e <- postJoseWith headers ep $ encode body+            pure $ fmap Certificate e         Left err -> do-            print err-            pure Nothing+            pure $ Left $ SigningFailed err   where     ep :: Endpoint "certificate"     ep = coerce certificateUrl

@@ -1,15 +1,30 @@+{- | ACME challenges (RFC-8555 sections 7.5 and 8, RFC-8737).++An authorization offers several challenges, each a way to prove control of+the identifier; the client completes one of them:++1. pick a challenge (e.g., with 'isDNS01', 'isHTTP01' or 'isTLSALPN01')+2. compute the proof from its 'Token' and the account key (see+   "Acme.NotAJoke.Api.Validation"), and publish it: a TXT record for DNS-01,+   a file served over HTTP for HTTP-01, a certificate served over TLS for+   TLS-ALPN-01+3. tell the server the proof is in place ('postReplyChallenge'), the server+   then checks it+4. poll the challenge ('postGetChallenge'), or the order, until it is valid+   (or invalid)++"Acme.NotAJoke.Dancer" runs these steps for all the authorizations of an+order, calling your code at step 2.+-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Acme.NotAJoke.Api.Challenge where -import Control.Lens hiding ((.=)) import Data.Aeson (FromJSON (..), Value (..), encode, withObject, withText, (.:), (.:?))-import Data.ByteString.Lazy (ByteString) import Data.Coerce (coerce) import Data.Text (Text) import Data.Time.Clock (UTCTime)-import qualified Network.Wreq as Wreq  import qualified Crypto.JOSE.JWS as JWS @@ -55,7 +70,12 @@             "invalid" -> pure ChallengeInvalid             _ -> fail $ "invalid challenge status:" <> show txt --- | RFC-defined Challenge resources.+{- | RFC-defined Challenge resources, the @token@ depending on the state @a@+(only @\"challenge-unspecified\"@ for now, where the token is present).++The original JSON object is kept in '_sourceObject', for the fields of+challenge types this library does not know about.+-} data Challenge a     = Challenge     { type_ :: ChallengeType@@ -77,6 +97,22 @@ isDNS01 :: Challenge "challenge-unspecified" -> Bool isDNS01 challenge = challenge.type_ == ChallengeDNS01 +{- | Predicate useful to locate HTTP-01 challenges when multiple challenges can+validate an Authorization.++Note that HTTP-01 challenges cannot validate wildcard identifiers.+-}+isHTTP01 :: Challenge "challenge-unspecified" -> Bool+isHTTP01 challenge = challenge.type_ == ChallengeHTTP01++{- | Predicate useful to locate TLS-ALPN-01 challenges (RFC-8737) when multiple+challenges can validate an Authorization.++Note that TLS-ALPN-01 challenges cannot validate wildcard identifiers.+-}+isTLSALPN01 :: Challenge "challenge-unspecified" -> Bool+isTLSALPN01 challenge = challenge.type_ == ChallengeTLSALPN01+ instance FromJSON (Challenge "challenge-unspecified") where     parseJSON = withObject "Challenge(unspecified)" $ \v ->         Challenge@@ -94,40 +130,37 @@ newtype Token = Token Text     deriving (Eq, Ord, FromJSON) -newtype ChallengeAttempted = ChallengeAttempted (Wreq.Response ByteString)+-- | The response of the server to 'postReplyChallenge' or 'postGetChallenge'.+newtype ChallengeAttempted = ChallengeAttempted Response     deriving (Show)  {- | Notify the ACME server that you are ready to reply a challenge.  For instance, after installing the required DNS-records. -}-postReplyChallenge :: JWS.JWK -> KID -> Challenge a -> Nonce -> IO (Maybe ChallengeAttempted)+postReplyChallenge :: JWS.JWK -> KID -> Challenge a -> Nonce -> IO (Either AcmeError ChallengeAttempted) postReplyChallenge jwk kid challenge nonce = do-    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]     ebody <- (kidSign jwk ep kid nonce $ encode emptyObject)     case ebody of         Right body -> do-            e <- Wreq.postWith opts (wrequrl ep) $ encode body-            pure $ Just $ ChallengeAttempted e+            e <- postJose ep $ encode body+            pure $ fmap ChallengeAttempted e         Left err -> do-            print err-            pure Nothing+            pure $ Left $ SigningFailed err   where     ep :: Endpoint "authorization"     ep = coerce (challenge.url)  -- | Query the ACME server about the status of a given challenge.-postGetChallenge :: JWS.JWK -> KID -> Challenge a -> Nonce -> IO (Maybe ChallengeAttempted)+postGetChallenge :: JWS.JWK -> KID -> Challenge a -> Nonce -> IO (Either AcmeError ChallengeAttempted) postGetChallenge jwk kid challenge nonce = do-    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]     ebody <- (kidSign jwk ep kid nonce "")     case ebody of         Right body -> do-            e <- Wreq.postWith opts (wrequrl ep) $ encode body-            pure $ Just $ ChallengeAttempted e+            e <- postJose ep $ encode body+            pure $ fmap ChallengeAttempted e         Left err -> do-            print err-            pure Nothing+            pure $ Left $ SigningFailed err   where     ep :: Endpoint "authorization"     ep = coerce (challenge.url)

@@ -1,12 +1,18 @@ {-# LANGUAGE DeriveGeneric #-} +{- | The directory of an ACME server (RFC-8555 section 7.1.1): the first thing+a client fetches, which lists the URLs of the other endpoints.++Only the directory URL is configured: it is 'directory' applied to the base+URL of the server (see "Acme.NotAJoke.LetsEncrypt").+-} module Acme.NotAJoke.Api.Directory where -import Control.Lens hiding ((.=))-import Data.Aeson (FromJSON (..))+import Data.Aeson (FromJSON (..), eitherDecode) import Data.Coerce (coerce)+import qualified Data.Text as Text import GHC.Generics (Generic)-import qualified Network.Wreq as Wreq+import qualified Network.HTTP.Client as HTTP  import Acme.NotAJoke.Api.Endpoint import Acme.NotAJoke.Api.Meta@@ -29,11 +35,17 @@  instance FromJSON Directory +-- | The directory endpoint of a server, given its base URL (which ends with a @/@). directory :: BaseUrl -> Endpoint "directory" directory baseUrl = coerce $ baseUrl <> "directory"  -- | Fetches the server's directory.-fetchDirectory :: Endpoint "directory" -> IO Directory+fetchDirectory :: Endpoint "directory" -> IO (Either AcmeError Directory) fetchDirectory ep = do-    r <- Wreq.asJSON =<< get ep-    pure $ r ^. Wreq.responseBody+    r <- get ep+    pure $ readDirectory =<< r+  where+    readDirectory rsp =+        case eitherDecode (HTTP.responseBody rsp) of+            Right dir -> Right dir+            Left err -> Left $ UnexpectedResponse (Text.pack err) rsp

@@ -1,42 +1,148 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{- | URLs, HTTP calls and errors.++URLs are tagged with a type-level string telling what they point to (e.g.,+@Endpoint \"newOrder\"@, @Url \"certificate\"@), so that the type of each API+call says which URL it expects, and where to find it (the directory, a+response header, a field of another resource).++API calls return an @Either 'AcmeError' a@: whether the request could not be+signed, the server rejected it ('readProblem' gives the RFC-7807 problem+document explaining why), or the response was not the expected one.+Network-level failures are raised as 'HTTP.HttpException'.+-} module Acme.NotAJoke.Api.Endpoint where -import Data.Aeson (FromJSON (..), ToJSON (..), Value)+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), decode)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString as Strict import Data.ByteString.Lazy (ByteString) import Data.Coerce (coerce) import Data.Text (Text) import qualified Data.Text as Text import GHC.TypeLits-import qualified Network.Wreq as Wreq+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.TLS as TLS+import Network.HTTP.Types.Header (Header, HeaderName)+import Network.HTTP.Types.Method (Method)+import Network.HTTP.Types.Status (statusIsSuccessful) +import qualified Crypto.JOSE.Error as JOSE+ {- | A newtype helper to introduce unambiguous URL. This newtype helps following the logical flow of ACME's dance. -} newtype Endpoint (purpose :: Symbol) = Endpoint Text     deriving (Show, FromJSON) --- | An undtyped URL.+-- | An untyped URL. type RawEndpoint = Text -{- | Same ad Endpoint but for full URLs (e.g., certificates have URLs but the+{- | Same as Endpoint but for full URLs (e.g., certificates have URLs but the ACME server has normalized endpoints). -} newtype Url (purpose :: Symbol) = Url Text     deriving (Show, FromJSON, ToJSON) +{- | The base URL of an ACME server, ending with a @/@ (see+"Acme.NotAJoke.LetsEncrypt"), to which @directory@ is appended.+-} type BaseUrl = Text -get :: Endpoint a -> IO (Wreq.Response ByteString)-get ep = Wreq.get (wrequrl ep)-+-- | Forgets the purpose of an endpoint. raw :: Endpoint a -> RawEndpoint raw = coerce -wrequrl :: Endpoint a -> String-wrequrl = Text.unpack . coerce+-- | An HTTP response from the ACME server, with its whole body.+type Response = HTTP.Response ByteString  {- | Problem object for rich errors. The ACME RFCs uses the Problem RFC https://datatracker.ietf.org/doc/html/rfc7807 however we keep the object as an opaque Value as this library treat any error as an opaque error. -} type Problem = Value++{- | The "type" of a Problem (e.g., `urn:ietf:params:acme:error:badNonce`).+See https://datatracker.ietf.org/doc/html/rfc8555#section-6.7 for the ACME ones.+-}+problemType :: Problem -> Maybe Text+problemType = problemText "type"++-- | The human-readable "detail" of a Problem.+problemDetail :: Problem -> Maybe Text+problemDetail = problemText "detail"++-- | Lookup a textual field of a Problem.+problemText :: Text -> Problem -> Maybe Text+problemText key (Object o) =+    case KeyMap.lookup (Key.fromText key) o of+        Just (String txt) -> Just txt+        _ -> Nothing+problemText _ _ = Nothing++{- | What can go wrong in an ACME API call.++Network-level failures (no connection, TLS errors, invalid URLs) are not+covered here: they still are raised as 'HTTP.HttpException'.+-}+data AcmeError+    = -- | we could not sign the request, nothing has been sent+      SigningFailed JOSE.Error+    | -- | the server replied with a non-2xx status, see 'readProblem'+      ServerRejected Response+    | -- | the server replied with a 2xx status but we could not read what we were looking for+      UnexpectedResponse Text Response+    deriving (Show)++-- | Lookup the response of a server in an error (if any).+errorResponse :: AcmeError -> Maybe Response+errorResponse (SigningFailed _) = Nothing+errorResponse (ServerRejected rsp) = Just rsp+errorResponse (UnexpectedResponse _ rsp) = Just rsp++-- | Lookup the Problem document that ACME servers attach to their errors.+readProblem :: AcmeError -> Maybe Problem+readProblem (ServerRejected rsp) = decode $ HTTP.responseBody rsp+readProblem _ = Nothing++-- | Lookup a response header.+responseHeader :: HeaderName -> Response -> Maybe Strict.ByteString+responseHeader name rsp = lookup name (HTTP.responseHeaders rsp)++-- | Sorts out responses between successes and server errors.+checkResponse :: Response -> Either AcmeError Response+checkResponse rsp+    | statusIsSuccessful (HTTP.responseStatus rsp) = Right rsp+    | otherwise = Left (ServerRejected rsp)++{- | Performs an HTTP call.+Unlike a number of HTTP-libraries defaults, non-2xx responses are returned (as a 'ServerRejected') rather than thrown.+-}+call :: Method -> [Header] -> Endpoint a -> ByteString -> IO (Either AcmeError Response)+call method headers ep body = do+    manager <- TLS.getGlobalManager+    req <- HTTP.parseRequest (Text.unpack $ raw ep)+    let req' =+            req+                { HTTP.method = method+                , HTTP.requestHeaders = ("User-Agent", "haskell acme-not-a-joke") : headers+                , HTTP.requestBody = HTTP.RequestBodyLBS body+                }+    checkResponse <$> HTTP.httpLbs req' manager++-- | Performs a GET request.+get :: Endpoint a -> IO (Either AcmeError Response)+get ep = call "GET" [] ep ""++-- | Performs a HEAD request.+head_ :: Endpoint a -> IO (Either AcmeError Response)+head_ ep = call "HEAD" [] ep ""++-- | Posts a (serialized) JWS object.+postJose :: Endpoint a -> ByteString -> IO (Either AcmeError Response)+postJose = postJoseWith []++-- | Same as postJose but with extra headers.+postJoseWith :: [Header] -> Endpoint a -> ByteString -> IO (Either AcmeError Response)+postJoseWith headers = call "POST" (("Content-Type", "application/jose+json") : headers)

@@ -1,3 +1,63 @@+{- | The 'Field' type family, which shapes the records of ACME resources+according to the message or state they are used in.++An ACME resource does not carry the same fields in every message. An account+sent to create the account has a @contact@ but no @status@ (the server has not+decided it yet); an order the server returns has @authorizations@ and a+@finalize@ URL that the client does not send; the @certificate@ URL of an+order only shows up once the order is valid.++Rather than one record per message, the library has one record per resource,+holding every field the resource can have, where each field type goes through+'Field'. The record takes a type-level string (a 'Symbol') naming the state,+and each state picks, field by field, what the field holds:++* @x@: the field is present, with its value+* @()@: the field is absent in this state (there is nothing to read, and+  @()@ is the only thing to put when building the record)+* @Maybe x@: the field may or may not be present (e.g., the @certificate@ of+  an inspected order)++For instance, 'Acme.NotAJoke.Api.Order.Order' has (among others) these+states:++* @Order "order-create"@: what the client sends, built with+  'Acme.NotAJoke.Api.Order.createOrder'; the identifiers and validity+  dates are present, the fields set by the server are @()@+* @Order "order-created"@: what the server replies to a new order (see+  'Acme.NotAJoke.Api.Order.readOrderCreated'), with its status,+  authorizations and finalize URL+* @Order "order-inspected"@: what the server replies when the client polls+  an order (see 'Acme.NotAJoke.Api.Order.readOrderInspected'), where+  @certificate@ is a @Maybe@++The instances live next to the record, one per state and field:++@+data Account a = Account+    { status :: Field a \"status\" AccountStatus+    , contact :: Field a \"contact\" [Contact]+    , ...+    }++type instance Field \"account-create\" \"contact\" x = x+type instance Field \"account-create\" \"status\" x = ()+@++Hence @(createAccount contacts).status :: ()@: the type tells you which+fields make sense in which message, and the functions sending or reading a+message take or return the record in the matching state (e.g.,+'Acme.NotAJoke.Api.Account.postCreateAccount' takes an+@Account \"account-create\"@). The JSON (de)serialization of each state is+written by hand, next to the instances.++States in use: @\"account-create\"@ and @\"account-fetch\"@ for+'Acme.NotAJoke.Api.Account.Account'; @\"order-create\"@,+@\"order-created\"@ and @\"order-inspected\"@ for+'Acme.NotAJoke.Api.Order.Order'; @\"authorization-inspected\"@ for+'Acme.NotAJoke.Api.Authorization.Authorization'; and+@\"challenge-unspecified\"@ for 'Acme.NotAJoke.Api.Challenge.Challenge'.+-} module Acme.NotAJoke.Api.Field where  import GHC.TypeLits (Symbol)@@ -7,5 +67,9 @@  Allows to define a large product type of all possible fields of a REST resource on one hand. And specialize the structure based on the state.++@Field state key valuetype@ is the type of the field named @key@, whose value+has type @valuetype@ when present, in the given @state@ (see the module+documentation). -} type family Field (state :: Symbol) (key :: Symbol) valuetype

@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ---- | Helpers to work with JSON Web Signatures for ACME.+-- | Helpers to work with JSON Web Signatures for ACME. -- Indeed, almost all ACME API calls are signed with a KID or a JWK and -- transferred using the JWS format. Thus, some internal helpers are welcome. module Acme.NotAJoke.Api.JWS where@@ -8,23 +8,32 @@ import Control.Applicative ((<|>)) import Control.Exception (Exception, throwIO) import Control.Lens hiding ((.=))+import Control.Monad.Error.Lens (throwing)+import Control.Monad.Except (MonadError) import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.=)) import Data.ByteString.Lazy (ByteString) import Data.Coerce (coerce) import Data.Text (Text) +import qualified Crypto.JOSE.JWA.JWK as JWA import qualified Crypto.JOSE.JWK as JWK import qualified Crypto.JOSE.JWS as JWS  import Acme.NotAJoke.Api.Endpoint import Acme.NotAJoke.Api.Nonce +-- | The public part of a JWK, as sent in the @jwk@ header of a request. newtype PublicJWK = PublicJWK JWK.JWK     deriving (Show, FromJSON, ToJSON) +-- | The public part of a JWK (if it has one, e.g. not a symmetric key). publicJWK :: JWK.JWK -> Maybe PublicJWK publicJWK = coerce . view JWK.asPublicKey +{- | The key identifier of an account, i.e. its URL (see+'Acme.NotAJoke.Api.Account.readKID'), as sent in the @kid@ header of the+requests made once the account exists.+-} newtype KID = KID Text     deriving (Show, FromJSON, ToJSON) @@ -77,20 +86,90 @@     deriving (Show) instance Exception NoPublicKeyInJWK +{- | The JWS algorithm used to sign ACME requests with a given key.++If the key pins an algorithm (its @alg@ parameter, see 'setAcmeJWSAlg'), that+algorithm is used. Otherwise the algorithm follows from the key material:++* RSA keys sign with @RS256@ (the one algorithm all ACME servers must accept,+  RFC-8555 section 6.2),+* EC keys sign with @ES256@ (P-256), @ES384@ (P-384), @ES512@ (P-521) or+  @ES256K@ (secp256k1),+* OKP keys (Ed25519 and Ed448) sign with @EdDSA@.++Symmetric keys, as well as the @none@ and MAC algorithms, are refused: ACME+servers must reject them. X25519 and X448 keys cannot sign at all. Which of+the other algorithms are accepted is up to the ACME server (Let's Encrypt+accepts @RS256@, @ES256@ and @ES384@).++Call this function (or 'acmeProtectedHeader') to build any JWS for ACME,+including those without an 'AcmeHeader' (e.g., the inner JWS of a key change).+-}+acmeJWSAlg :: (MonadError e m, JWS.AsError e) => JWK.JWK -> m JWS.Alg+acmeJWSAlg jwk =+    case view JWK.jwkAlg jwk of+        Just (JWK.JWSAlg alg)+            | alg `elem` [JWS.None, JWS.HS256, JWS.HS384, JWS.HS512] ->+                throwing JWS._AlgorithmMismatch ("ACME refuses the JWS algorithm " <> show alg)+            | otherwise -> pure alg+        Just (JWK.JWEAlg _) ->+            throwing JWS._AlgorithmMismatch "this JWK is an encryption key"+        Nothing ->+            case view JWK.jwkMaterial jwk of+                JWA.RSAKeyMaterial _ -> pure JWS.RS256+                JWA.ECKeyMaterial k -> pure $ case view JWA.ecCrv k of+                    JWA.P_256 -> JWS.ES256+                    JWA.P_384 -> JWS.ES384+                    JWA.P_521 -> JWS.ES512+                    JWA.Secp256k1 -> JWS.ES256K+                JWA.OKPKeyMaterial (JWA.Ed25519Key _ _) -> pure JWS.EdDSA+                JWA.OKPKeyMaterial (JWA.Ed448Key _ _) -> pure JWS.EdDSA+                JWA.OKPKeyMaterial _ ->+                    throwing JWS._KeyMismatch "X25519 and X448 keys cannot sign"+                JWA.OctKeyMaterial _ ->+                    throwing JWS._AlgorithmMismatch "ACME refuses MAC-based (symmetric) signatures"++{- | Pins the JWS algorithm with which a key signs ACME requests (see+'acmeJWSAlg'), e.g., @PS256@ for an RSA key if your ACME server accepts it.++The algorithm is stored in the @alg@ parameter of the JWK, hence it is kept+when the key is written with 'Acme.NotAJoke.KeyManagement.writeJWKFile'.+Signing fails if the algorithm does not fit the key.+-}+setAcmeJWSAlg :: JWS.Alg -> JWK.JWK -> JWK.JWK+setAcmeJWSAlg alg = Control.Lens.set JWK.jwkAlg (Just (JWK.JWSAlg alg))++{- | A protected JWS header signed with the algorithm of 'acmeJWSAlg', the+starting point of the header of any ACME request.+-}+acmeProtectedHeader :: (MonadError e m, JWS.AsError e) => JWK.JWK -> m (JWS.JWSHeader JWS.Protection)+acmeProtectedHeader jwk = do+    alg <- acmeJWSAlg jwk+    pure $ JWS.newJWSHeader (JWS.Protected, alg)++{- | Signs a request with a key and carries its public key (in a @jwk@+header).++Used to create or fetch an account, and to revoke a certificate with the key+of the certificate. The algorithm follows from the key, see 'acmeJWSAlg'.+-} jwkSign :: JWS.JWK -> Endpoint a -> Nonce -> ByteString -> IO (Either JWS.Error (JWS.FlattenedJWS AcmeHeader)) jwkSign jwk ep nonce payload = do     jwk2 <- maybe (throwIO NoPublicKeyInJWK) pure $ publicJWK jwk     JWS.runJOSE $ do-        -- alg <- JWS.bestJWSAlg jwk-        let alg = JWS.RS256-        let header = AcmeHeader (JWS.newJWSHeader (JWS.Protected, alg)) (raw ep) nonce (Left jwk2)+        hdr <- acmeProtectedHeader jwk+        let header = AcmeHeader hdr (raw ep) nonce (Left jwk2)         JWS.signJWS payload (pure (header, jwk)) +{- | Signs a request with the key of an account and names the account (in a+@kid@ header).++The algorithm follows from the key, see 'acmeJWSAlg'.+-} kidSign :: JWS.JWK -> Endpoint a -> KID -> Nonce -> ByteString -> IO (Either JWS.Error (JWS.FlattenedJWS AcmeHeader)) kidSign jwk ep kid nonce payload = JWS.runJOSE $ do-    -- alg <- JWS.bestJWSAlg jwk-    let alg = JWS.RS256-    let header = AcmeHeader (JWS.newJWSHeader (JWS.Protected, alg)) (raw ep) nonce (Right kid)+    hdr <- acmeProtectedHeader jwk+    let header = AcmeHeader hdr (raw ep) nonce (Right kid)     JWS.signJWS payload (pure (header, jwk))  newtype EmptyObject = EmptyObject Value

@@ -0,0 +1,148 @@+{- | Account key rollover (RFC-8555 section 7.3.5).++Changing the key of an account takes a nested JWS posted to the @keyChange@+endpoint of the 'Acme.NotAJoke.Api.Directory.Directory':++* the inner JWS is signed with the new key, carries the new (public) key in a+  @jwk@ header and has no nonce; its payload names the account and its old+  (public) key,+* the outer JWS is a regular ACME request signed with the old key (with the+  @kid@ of the account and a nonce), whose payload is the inner JWS.++Once the server has accepted the request, the account is only reachable with+the new key (the KID of the account does not change).+-}+module Acme.NotAJoke.Api.KeyChange where++import Control.Exception (throwIO)+import Control.Lens hiding ((.=))+import Data.Aeson (ToJSON (..), encode, object, (.=))++import qualified Crypto.JOSE.JWS as JWS++import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.JWS+import Acme.NotAJoke.Api.Nonce++{- | Protected header of the inner JWS of a key change: like an 'AcmeHeader'+with a @jwk@ (the new key) but without a nonce.+-}+data KeyChangeHeader p+    = KeyChangeHeader+    { _keyChangeJwsHeader :: JWS.JWSHeader p+    , _keyChangeURL :: RawEndpoint+    , _keyChangeNewKey :: PublicJWK+    }++keyChangeJwsHeader :: Lens' (KeyChangeHeader p) (JWS.JWSHeader p)+keyChangeJwsHeader f s@(KeyChangeHeader{_keyChangeJwsHeader = a}) =+    fmap (\a' -> s{_keyChangeJwsHeader = a'}) (f a)++keyChangeURL :: Lens' (KeyChangeHeader p) RawEndpoint+keyChangeURL f s@(KeyChangeHeader{_keyChangeURL = a}) =+    fmap (\a' -> s{_keyChangeURL = a'}) (f a)++keyChangeNewKey :: Lens' (KeyChangeHeader p) PublicJWK+keyChangeNewKey f s@(KeyChangeHeader{_keyChangeNewKey = a}) =+    fmap (\a' -> s{_keyChangeNewKey = a'}) (f a)++instance JWS.HasJWSHeader KeyChangeHeader where+    jwsHeader = keyChangeJwsHeader++instance JWS.HasParams KeyChangeHeader where+    parseParamsFor proxy hp hu =+        KeyChangeHeader+            <$> JWS.parseParamsFor proxy hp hu+            <*> JWS.headerRequiredProtected "url" hp hu+            <*> JWS.headerRequiredProtected "jwk" hp hu+    params h =+        [ (True, "url" .= view keyChangeURL h)+        , (True, "jwk" .= view keyChangeNewKey h)+        ]+            <> JWS.params (view keyChangeJwsHeader h)+    extensions = const ["url", "jwk"]++-- | Payload of the inner JWS of a key change.+data KeyChange+    = KeyChange+    { account :: KID+    -- ^ the account whose key changes (its KID, i.e., its URL)+    , oldKey :: PublicJWK+    -- ^ the current key of the account+    }+    deriving (Show)++instance ToJSON KeyChange where+    toJSON kc =+        object+            [ "account" .= kc.account+            , "oldKey" .= kc.oldKey+            ]++newtype KeyChanged = KeyChanged Response+    deriving (Show)++{- | Signs the inner JWS of a key change with the new key.++Throws 'NoPublicKeyInJWK' if a public key cannot be derived from the old or+the new key (as 'jwkSign' does).+-}+keyChangeInnerSign ::+    -- | old key of the account+    JWS.JWK ->+    -- | new key of the account+    JWS.JWK ->+    KID ->+    Endpoint "keyChange" ->+    IO (Either JWS.Error (JWS.FlattenedJWS KeyChangeHeader))+keyChangeInnerSign oldJwk newJwk kid ep = do+    oldPub <- maybe (throwIO NoPublicKeyInJWK) pure $ publicJWK oldJwk+    newPub <- maybe (throwIO NoPublicKeyInJWK) pure $ publicJWK newJwk+    let payload = encode $ KeyChange kid oldPub+    JWS.runJOSE $ do+        -- alg <- JWS.bestJWSAlg newJwk+        let alg = JWS.RS256+        let header = KeyChangeHeader (JWS.newJWSHeader (JWS.Protected, alg)) (raw ep) newPub+        JWS.signJWS payload (pure (header, newJwk))++{- | Builds the whole (nested) key-change request: the inner JWS signed with+the new key, wrapped in an outer JWS signed with the old key.+-}+keyChangeSign ::+    -- | old key of the account+    JWS.JWK ->+    -- | new key of the account+    JWS.JWK ->+    KID ->+    Endpoint "keyChange" ->+    Nonce ->+    IO (Either JWS.Error (JWS.FlattenedJWS AcmeHeader))+keyChangeSign oldJwk newJwk kid ep nonce = do+    einner <- keyChangeInnerSign oldJwk newJwk kid ep+    case einner of+        Left err -> pure $ Left err+        Right inner -> kidSign oldJwk ep kid nonce (encode inner)++{- | Changes the key of an account (a single API call).++The server replies with a 409 Conflict (a 'ServerRejected', whose @location@+header is the account using it) when the new key is already used by another+account.+-}+postKeyChange ::+    -- | old key of the account+    JWS.JWK ->+    -- | new key of the account+    JWS.JWK ->+    KID ->+    Endpoint "keyChange" ->+    Nonce ->+    IO (Either AcmeError KeyChanged)+postKeyChange oldJwk newJwk kid ep nonce = do+    ebody <- keyChangeSign oldJwk newJwk kid ep nonce+    case ebody of+        Right body -> do+            e <- postJose ep $ encode body+            pure $ fmap KeyChanged e+        Left err -> do+            pure $ Left $ SigningFailed err

@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} +-- | The @meta@ field of the directory of an ACME server (RFC-8555 section 7.1.1). module Acme.NotAJoke.Api.Meta where  import Data.Aeson (FromJSON (..))@@ -8,6 +9,7 @@  import Acme.NotAJoke.Api.Endpoint (Url) +-- | A domain name that CAA records can use to designate the ACME server. type CAAIdentity = Text  -- | RFC-defined ACME server metadata.

@@ -10,43 +10,51 @@ -} module Acme.NotAJoke.Api.Nonce where -import Control.Lens hiding ((.=)) import Data.Aeson (FromJSON (..), ToJSON (..))-import Data.ByteString.Lazy (ByteString) import Data.Coerce (Coercible, coerce) import Data.IORef (atomicModifyIORef, newIORef, writeIORef) import Data.Text (Text) import qualified Data.Text.Encoding as Encoding-import qualified Network.Wreq as Wreq  import Acme.NotAJoke.Api.Endpoint +-- | An anti-replay nonce, valid for one request. newtype Nonce = Nonce Text     deriving (Show, FromJSON, ToJSON) -getNonce :: Endpoint "newNonce" -> IO (Maybe Nonce)+-- | Asks the server for a fresh nonce (at the @newNonce@ endpoint of the directory).+getNonce :: Endpoint "newNonce" -> IO (Either AcmeError Nonce) getNonce ep = do-    r <- Wreq.head_ (wrequrl ep)-    pure $ responseNonceWreq r+    r <- head_ ep+    pure $ readNonce =<< r   where--responseNonceWreq :: forall a. Wreq.Response a -> Maybe Nonce-responseNonceWreq r =-    r ^? Wreq.responseHeader "replay-nonce" . to Encoding.decodeUtf8 . to Nonce+    readNonce rsp =+        maybe (Left $ UnexpectedResponse "no replay-nonce header" rsp) Right $+            rawResponseNonce rsp -responseNonceWreqBS :: Wreq.Response ByteString -> Maybe Nonce-responseNonceWreqBS = responseNonceWreq+-- | Lookup the nonce of a response, in its @Replay-Nonce@ header.+rawResponseNonce :: Response -> Maybe Nonce+rawResponseNonce rsp =+    Nonce . Encoding.decodeUtf8 <$> responseHeader "replay-nonce" rsp -responseNonce :: forall a. (Coercible a (Wreq.Response ByteString)) => a -> Maybe Nonce-responseNonce = responseNonceWreqBS . coerce+-- | Same as 'rawResponseNonce' for the newtypes wrapping a 'Response'.+responseNonce :: forall a. (Coercible a Response) => a -> Maybe Nonce+responseNonce = rawResponseNonce . coerce +{- | A source of nonces which keeps the last nonce returned by the server and+fetches a fresh one only when it has none.+-} data Fetcher = Fetcher-    { produce :: IO (Maybe Nonce)+    { produce :: IO (Either AcmeError Nonce)+    -- ^ returns the saved nonce (forgetting it), or fetches a fresh one     , set :: Nonce -> IO ()-    , fetchNewNonce :: IO (Maybe Nonce)+    -- ^ saves a nonce for the next call to 'produce'+    , fetchNewNonce :: IO (Either AcmeError Nonce)+    -- ^ fetches a fresh nonce, ignoring the saved one     } -fetcher :: IO (Maybe Nonce) -> IO Fetcher+-- | Builds a 'Fetcher' from a way to fetch fresh nonces (e.g., 'getNonce').+fetcher :: IO (Either AcmeError Nonce) -> IO Fetcher fetcher fetch = do     ref <- newIORef Nothing     pure $ Fetcher (go ref) (writeIORef ref . Just) fetch@@ -55,14 +63,20 @@         val <- atomicModifyIORef ref (\x -> (Nothing, x))         case val of             Nothing -> fetch-            (Just x) -> pure (Just x)+            (Just x) -> pure (Right x) -saveResponseNonce :: forall a. (Coercible a (Wreq.Response ByteString)) => Fetcher -> a -> IO ()+-- | Saves the nonce of a response (if any) in a 'Fetcher'.+saveResponseNonce :: forall a. (Coercible a Response) => Fetcher -> a -> IO () saveResponseNonce nonceFetcher rsp =     maybe (pure ()) (nonceFetcher.set) (responseNonce rsp) -saveNonce :: forall a. (Coercible a (Wreq.Response ByteString)) => Fetcher -> IO (Maybe a) -> IO (Maybe a)+{- | Saves the nonce found in the response of an API call.+Error responses from the server carry a fresh nonce as well, which we save too.+-}+saveNonce :: forall a. (Coercible a Response) => Fetcher -> IO (Either AcmeError a) -> IO (Either AcmeError a) saveNonce nonceFetcher apiCall = do     obj <- apiCall-    maybe (pure ()) (saveResponseNonce nonceFetcher) obj+    case obj of+        Right rsp -> saveResponseNonce nonceFetcher rsp+        Left err -> maybe (pure ()) (saveResponseNonce nonceFetcher) (errorResponse err)     pure obj

@@ -1,14 +1,34 @@+{- | ACME orders (RFC-8555 sections 7.1.3 and 7.4).++An order asks for a certificate for a list of identifiers (domain names,+possibly wildcards such as @*.example.com@). Its life goes:++1. the client creates it ('createOrder', 'postNewOrder'), the server replies+   with the order URL (see 'readOrderUrl') and one authorization URL per+   identifier (see 'readOrderCreated' and "Acme.NotAJoke.Api.Authorization")+2. the order is @pending@ until the client has validated all the+   authorizations (see "Acme.NotAJoke.Api.Challenge"), then @ready@+3. the client sends its CSR to the @finalize@ URL ('postFinalizeOrder'), the+   order goes @processing@ then @valid@+4. the order of 'postGetOrder' then has a @certificate@ URL (see+   'readCertificateUrl'), from which to download the certificate (see+   "Acme.NotAJoke.Api.Certificate")++An order which fails at any point goes @invalid@, with a problem document in+its @error@ field.++'Order' has three states (see "Acme.NotAJoke.Api.Field"):+@\"order-create\"@, @\"order-created\"@ and @\"order-inspected\"@.+-} module Acme.NotAJoke.Api.Order where -import Control.Lens hiding ((.=)) import Data.Aeson (FromJSON (..), ToJSON (..), decode, encode, object, pairs, withObject, withText, (.:), (.:?), (.=))-import Data.ByteString.Lazy (ByteString) import Data.Coerce (coerce) import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text.Encoding as Encoding import Data.Time.Clock (UTCTime)-import qualified Network.Wreq as Wreq+import qualified Network.HTTP.Client as HTTP  import qualified Crypto.JOSE.JWS as JWS @@ -69,7 +89,9 @@             <$> o .: "type"             <*> o .: "value" --- | RFC-defined order structure.+{- | RFC-defined order structure, the set of fields depending on the state @a@+(@\"order-create\"@, @\"order-created\"@ or @\"order-inspected\"@).+-} data Order a     = Order     { status :: Field a "status" OrderStatus@@ -93,7 +115,8 @@ type instance Field "order-create" "finalize" x = () type instance Field "order-create" "certificate" x = () -newtype OrderCreated = OrderCreated (Wreq.Response ByteString)+-- | The response of the server to 'postNewOrder'.+newtype OrderCreated = OrderCreated Response     deriving (Show)  type instance Field "order-created" "status" x = x@@ -119,29 +142,32 @@             <*> v .: "finalize"             <*> pure () --- | Prepare a new order.+{- | Prepare a new order, with optional @notBefore@ and @notAfter@ dates for+the certificate (servers such as Let's Encrypt do not support them, pass+@(Nothing, Nothing)@) and the identifiers the certificate is for.+-} createOrder :: (Maybe UTCTime, Maybe UTCTime) -> [OrderIdentifier] -> Order "order-create" createOrder (nbefore, nafter) ois =     Order () () ois nbefore nafter () () () () +-- | Lookup the URL of a new order (to poll it with 'postGetOrder'). readOrderUrl :: OrderCreated -> Maybe (Url "order")-readOrderUrl (OrderCreated rsp) = rsp ^? Wreq.responseHeader "location" . to (Url . Encoding.decodeUtf8)+readOrderUrl (OrderCreated rsp) = Url . Encoding.decodeUtf8 <$> responseHeader "location" rsp +-- | Lookup the order the server created. readOrderCreated :: OrderCreated -> Maybe (Order "order-created")-readOrderCreated (OrderCreated rsp) = decode $ rsp ^. Wreq.responseBody+readOrderCreated (OrderCreated rsp) = decode $ HTTP.responseBody rsp  -- | Requests a new order to the server.-postNewOrder :: JWS.JWK -> Endpoint "newOrder" -> KID -> Nonce -> Order "order-create" -> IO (Maybe OrderCreated)+postNewOrder :: JWS.JWK -> Endpoint "newOrder" -> KID -> Nonce -> Order "order-create" -> IO (Either AcmeError OrderCreated) postNewOrder jwk ep kid nonce ord = do-    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]     ebody <- (kidSign jwk ep kid nonce $ encode $ serialized)     case ebody of         Right body -> do-            e <- Wreq.postWith opts (wrequrl ep) $ encode body-            pure $ Just $ OrderCreated e+            e <- postJose ep $ encode body+            pure $ fmap OrderCreated e         Left err -> do-            print err-            pure Nothing+            pure $ Left $ SigningFailed err   where     serialized =         object $@@ -151,7 +177,8 @@                 , Just $ "identifiers" .= ord.identifiers                 ] -newtype OrderInspected = OrderInspected (Wreq.Response ByteString)+-- | The response of the server to 'postGetOrder'.+newtype OrderInspected = OrderInspected Response     deriving (Show)  type instance Field "order-inspected" "status" x = x@@ -177,25 +204,25 @@             <*> v .: "finalize"             <*> v .:? "certificate" +-- | Lookup the order in a response to 'postGetOrder'. readOrderInspected :: OrderInspected -> Maybe (Order "order-inspected")-readOrderInspected (OrderInspected rsp) = decode $ rsp ^. Wreq.responseBody+readOrderInspected (OrderInspected rsp) = decode $ HTTP.responseBody rsp +-- | Lookup the URL of the certificate of a valid order. readCertificateUrl :: OrderInspected -> Maybe (Url "certificate") readCertificateUrl order =     certificate =<< readOrderInspected order  -- | Fetches a known order to inspect its status.-postGetOrder :: JWS.JWK -> Url "order" -> KID -> Nonce -> IO (Maybe OrderInspected)+postGetOrder :: JWS.JWK -> Url "order" -> KID -> Nonce -> IO (Either AcmeError OrderInspected) postGetOrder jwk orderurl kid nonce = do-    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]     ebody <- (kidSign jwk ep kid nonce "")     case ebody of         Right body -> do-            e <- Wreq.postWith opts (wrequrl ep) $ encode body-            pure $ Just $ OrderInspected e+            e <- postJose ep $ encode body+            pure $ fmap OrderInspected e         Left err -> do-            print err-            pure Nothing+            pure $ Left $ SigningFailed err   where     ep :: Endpoint "order"     ep = coerce orderurl@@ -208,25 +235,29 @@     { csr :: CSR     } -newtype OrderFinalized = OrderFinalized (Wreq.Response ByteString)+-- | The response of the server to 'postFinalizeOrder'.+newtype OrderFinalized = OrderFinalized Response     deriving (Show)  -- todo: specialize status of a finalized order++-- | Lookup the order in a response to 'postFinalizeOrder'. readOrderFinalized :: OrderFinalized -> Maybe (Order "order-created")-readOrderFinalized (OrderFinalized rsp) = decode $ rsp ^. Wreq.responseBody+readOrderFinalized (OrderFinalized rsp) = decode $ HTTP.responseBody rsp --- | Finalize an order after completing a challenge.-postFinalizeOrder :: JWS.JWK -> KID -> Url "finalize-order" -> Finalize -> Nonce -> IO (Maybe OrderFinalized)+{- | Finalize an order after completing its challenges (i.e., once the order+is @ready@): sends the CSR, whose names must be the identifiers of the+order.+-}+postFinalizeOrder :: JWS.JWK -> KID -> Url "finalize-order" -> Finalize -> Nonce -> IO (Either AcmeError OrderFinalized) postFinalizeOrder jwk kid finalizeurl finalizeobj nonce = do-    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]     ebody <- (kidSign jwk ep kid nonce $ encode $ serialized)     case ebody of         Right body -> do-            e <- Wreq.postWith opts (wrequrl ep) $ encode body-            pure $ Just $ OrderFinalized e+            e <- postJose ep $ encode body+            pure $ fmap OrderFinalized e         Left err -> do-            print err-            pure Nothing+            pure $ Left $ SigningFailed err   where     ep :: Endpoint "finalize-order"     ep = coerce finalizeurl

@@ -0,0 +1,123 @@+{- | Certificate revocation (RFC-8555 section 7.6).++A revocation request carries the DER encoding of the certificate to revoke+and, optionally, a reason. It is sent to the 'revokeCert' endpoint of the+'Acme.NotAJoke.Api.Directory.Directory', signed either:++* with the account key, using the KID of the account which ordered the+  certificate (or of an account holding authorizations for all its names),+  see 'postRevokeCertificate'+* with the key of the certificate itself (the key which signed the CSR, see+  'Acme.NotAJoke.KeyManagement.jwkFromRSAKey'), which needs no account and is+  the way out when the account key is lost, see+  'postRevokeCertificateWithCertKey'++The server replies with an empty 200 response when the certificate is+revoked; an already revoked certificate is rejected with an+@urn:ietf:params:acme:error:alreadyRevoked@ problem (see 'readProblem').+-}+module Acme.NotAJoke.Api.Revocation where++import Control.Lens (review)+import Data.Aeson (encode, object, (.=))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text.Encoding as Encoding++import qualified Crypto.JOSE.JWK as JWK+import qualified Crypto.JOSE.JWS as JWS+import qualified Data.X509 as X509++import Acme.NotAJoke.Api.CSR (Base64DER (..))+import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.JWS+import Acme.NotAJoke.Api.Nonce++{- | Revocation reasons, from the CRLReason of RFC-5280 section 5.3.1.++ACME servers may accept only some of them: Let's Encrypt, for instance,+refuses 'CACompromise', 'CertificateHold', 'RemoveFromCRL' and 'AACompromise'.+-}+data RevocationReason+    = Unspecified+    | KeyCompromise+    | CACompromise+    | AffiliationChanged+    | Superseded+    | CessationOfOperation+    | CertificateHold+    | RemoveFromCRL+    | PrivilegeWithdrawn+    | AACompromise+    deriving (Show, Eq, Ord, Enum, Bounded)++-- | The code of a reason, as sent to the ACME server (7 is not used).+revocationReasonCode :: RevocationReason -> Int+revocationReasonCode reason =+    case reason of+        Unspecified -> 0+        KeyCompromise -> 1+        CACompromise -> 2+        AffiliationChanged -> 3+        Superseded -> 4+        CessationOfOperation -> 5+        CertificateHold -> 6+        RemoveFromCRL -> 8+        PrivilegeWithdrawn -> 9+        AACompromise -> 10++-- | A revocation request.+data Revocation+    = Revocation+    { revokedCertificate :: Base64DER+    -- ^ the certificate to revoke, DER-encoded in base64url+    , revocationReason :: Maybe RevocationReason+    -- ^ why the certificate is revoked, servers assume 'Unspecified' if missing+    }+    deriving (Show)++{- | A revocation request for a certificate (e.g., the first one of+'Acme.NotAJoke.CertManagement.certificateChain').+-}+revocation :: Maybe RevocationReason -> X509.SignedCertificate -> Revocation+revocation why = revocationDER why . X509.encodeSignedObject++-- | A revocation request for the DER encoding of a certificate.+revocationDER :: Maybe RevocationReason -> ByteString -> Revocation+revocationDER why der =+    Revocation (Base64DER $ Encoding.decodeUtf8 $ review JWK.base64url der) why++-- | The JSON payload of a revocation request.+serializeRevocation :: Revocation -> LBS.ByteString+serializeRevocation rev =+    encode $+        object $+            ("certificate" .= rev.revokedCertificate)+                : maybe [] (\r -> ["reason" .= revocationReasonCode r]) rev.revocationReason++-- | The (empty) response of a successful revocation.+newtype CertificateRevoked = CertificateRevoked Response+    deriving (Show)++{- | Revokes a certificate, signing the request with the account key and+the KID of the account.+-}+postRevokeCertificate :: JWS.JWK -> KID -> Endpoint "revokeCert" -> Nonce -> Revocation -> IO (Either AcmeError CertificateRevoked)+postRevokeCertificate jwk kid ep nonce rev =+    sendRevocation ep =<< kidSign jwk ep kid nonce (serializeRevocation rev)++{- | Revokes a certificate, signing the request with the key of the+certificate (as a JWK, see 'Acme.NotAJoke.KeyManagement.jwkFromRSAKey').++No account is needed: the JWS carries the public key, which the server+compares with the one of the certificate.+-}+postRevokeCertificateWithCertKey :: JWS.JWK -> Endpoint "revokeCert" -> Nonce -> Revocation -> IO (Either AcmeError CertificateRevoked)+postRevokeCertificateWithCertKey certJwk ep nonce rev =+    sendRevocation ep =<< jwkSign certJwk ep nonce (serializeRevocation rev)++sendRevocation :: Endpoint "revokeCert" -> Either JWS.Error (JWS.FlattenedJWS AcmeHeader) -> IO (Either AcmeError CertificateRevoked)+sendRevocation ep ebody =+    case ebody of+        Right body -> fmap CertificateRevoked <$> postJose ep (encode body)+        Left err -> pure $ Left $ SigningFailed err

@@ -1,4 +1,16 @@--- | Helper to build a ValidationProof out of some token+{- | Helpers to build the proofs that answer challenges (RFC-8555 section 8.1).++A challenge gives a 'Token'. The key authorization ('keyAuthorization') is+that token followed by the thumbprint of the account key, and what is+published depends on the challenge:++* HTTP-01: the key authorization itself, served at+  @http:\/\/{domain}\/.well-known\/acme-challenge\/{token}@+* DNS-01: its SHA-256 digest, base64url-encoded ('sha256digest'), in a TXT+  record at @_acme-challenge.{domain}@+* TLS-ALPN-01: its SHA-256 digest, in a certificate (see+  'Acme.NotAJoke.CertManagement.createTLSALPN01Certificate')+-} module Acme.NotAJoke.Api.Validation where  import Control.Lens hiding ((.=))@@ -14,6 +26,7 @@ newtype KeyAuthorization = KeyAuthorization Text     deriving (Eq, Ord) +-- | Computes the key authorization of a challenge token for an account key. keyAuthorization :: Token -> JWK.JWK -> KeyAuthorization keyAuthorization tok jwk =     KeyAuthorization txt@@ -26,9 +39,11 @@     tprint :: JWK.Digest JWK.SHA256     tprint = view JWK.thumbprint jwk +-- | The value to publish in the TXT record of a DNS-01 challenge. newtype ValidationProof = ValidationProof Text     deriving (Eq) +-- | The base64url-encoded SHA-256 digest of a key authorization. sha256digest :: KeyAuthorization -> ValidationProof sha256digest (KeyAuthorization kauth) =     ValidationProof $

@@ -1,16 +1,312 @@-{- | A series of helper to work with Certificate Signing Requests.+{- | A series of helper to work with Certificate Signing Requests and+certificates. -See the `openssl req` command to build CSR and DER files.+CSRs can be built with 'createCSR' from a key of+"Acme.NotAJoke.KeyManagement", or with the `openssl req` command and then+loaded with 'loadCSR'. -}-module Acme.NotAJoke.CertManagement where+module Acme.NotAJoke.CertManagement (+    -- * Create CSRs+    createCSR,+    createCSRWith, +    -- * Load and write CSRs+    loadDER,+    loadCSR,+    writeCSRDER,+    writeCSRPEM,+    csrFromDER,+    csrToDER,+    encodeCSRPEM,+    decodeCSRPEM,++    -- * Certificates+    certificateChain,+    decodeCertificateChain,+    encodeCertificateChain,+    loadCertificateChain,+    writeCertificateChain,++    -- * TLS-ALPN-01 challenges+    createTLSALPN01Certificate,+    acmeTLSALPNProtocol,+    acmeIdentifierOID,+    acmeIdentifierDigest,+) where+ import Acme.NotAJoke.Api.CSR-import Control.Lens hiding ((.=))+import qualified Acme.NotAJoke.Api.Certificate as Certificate+import Acme.NotAJoke.Api.Validation (KeyAuthorization (..))+import Control.Lens (preview, review)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import qualified Crypto.JOSE.JWK as JWK+import Data.Bifunctor (bimap, first)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LBS+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Text (Text)+import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding +import qualified Crypto.Hash.SHA256 as SHA256+import Crypto.Hash.Algorithms (SHA256 (..))+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as PKCS15+import Data.ASN1.BinaryEncoding (DER (..))+import Data.ASN1.BitArray (toBitArray)+import Data.ASN1.Encoding (decodeASN1', encodeASN1')+import Data.ASN1.Types+import qualified Data.PEM as PEM+import qualified Data.X509 as X509+import Data.Time.Calendar (toGregorian)+import Data.Time.Clock (UTCTime (..))+import qualified Time.Types as Hourglass++{- | Creates a CSR for a list of DNS names, signed (RSA with SHA-256) with the+key of the certificate.++The names all are requested as subject alternative names, the first one also+is the common name of the subject (unless it is too long to fit in a common+name). Names should be the ones in the identifiers of the order, in ASCII+form (i.e., punycode-encoded for internationalized names).++The key must not be the account key.+-}+createCSR :: RSA.PrivateKey -> NonEmpty Text -> IO (Either String CSR)+createCSR key names+    | not (all validName names) = pure (Left "DNS names must be non-empty ASCII strings")+    | otherwise = createCSRWith key subject altNames+  where+    validName :: Text -> Bool+    validName name = not (Text.null name) && Text.all (\c -> c > ' ' && c < '\DEL') name++    commonName :: Text+    commonName = NonEmpty.head names++    -- the upper bound of a common name, see RFC-5280+    subject :: X509.DistinguishedName+    subject+        | Text.length commonName <= 64 =+            X509.DistinguishedName+                [ (getObjectID X509.DnCommonName, ASN1CharacterString UTF8 (Encoding.encodeUtf8 commonName))+                ]+        | otherwise = X509.DistinguishedName []++    altNames :: [X509.AltName]+    altNames = X509.AltNameDNS . Text.unpack <$> NonEmpty.toList names++{- | Creates a CSR for a given subject and a given list of subject alternative+names, signed (RSA with SHA-256) with the key of the certificate.++The subject may be empty, ACME servers typically only care about the subject+alternative names.+-}+createCSRWith :: RSA.PrivateKey -> X509.DistinguishedName -> [X509.AltName] -> IO (Either String CSR)+createCSRWith key subject altNames = do+    signed <- PKCS15.signSafer (Just SHA256) key (encodeASN1' DER requestInfo)+    pure $ bimap show (csrFromDER . encodeASN1' DER . request) signed+  where+    -- CertificationRequestInfo of RFC-2986+    requestInfo :: [ASN1]+    requestInfo =+        asn1Container Sequence $+            IntVal 0+                : toASN1 subject (toASN1 (X509.PubKeyRSA (RSA.private_pub key)) attributes)++    -- an extensionRequest attribute (RFC-2985) carries the alternative names+    attributes :: [ASN1]+    attributes =+        asn1Container (Container Context 0) $+            case altNames of+                [] -> []+                _ ->+                    asn1Container Sequence $+                        OID [1, 2, 840, 113549, 1, 9, 14]+                            : asn1Container Set (toASN1 extensions [])++    extensions :: X509.Extensions+    extensions =+        X509.Extensions $+            Just [X509.extensionEncode False (X509.ExtSubjectAltName altNames)]++    -- CertificationRequest of RFC-2986+    request :: ByteString -> [ASN1]+    request signature =+        asn1Container Sequence $+            requestInfo+                <> toASN1 (X509.SignatureALG X509.HashSHA256 X509.PubKeyALG_RSA) []+                <> [BitString (toBitArray signature 0)]++-- | Wraps ASN.1 values in a container.+asn1Container :: ASN1ConstructionType -> [ASN1] -> [ASN1]+asn1Container ty l = [Start ty] <> l <> [End ty]+ -- | Loads a DER file in base64 format. loadDER :: FilePath -> IO Base64DER loadDER =     fmap (Base64DER . Encoding.decodeUtf8 . review JWK.base64url) . LBS.readFile++{- | Loads a CSR from a file, which is either a DER file or a PEM file (as+`openssl req -new` writes by default).+-}+loadCSR :: FilePath -> IO (Either String CSR)+loadCSR path = do+    bytes <- ByteString.readFile path+    pure $+        if "-----BEGIN" `ByteString.isInfixOf` bytes+            then decodeCSRPEM bytes+            else csrFromDER bytes <$ first show (decodeASN1' DER bytes)++-- | Writes a CSR to a DER file.+writeCSRDER :: CSR -> FilePath -> IO (Either String ())+writeCSRDER csr path = traverse (ByteString.writeFile path) (csrToDER csr)++-- | Writes a CSR to a PEM file.+writeCSRPEM :: CSR -> FilePath -> IO (Either String ())+writeCSRPEM csr path = traverse (ByteString.writeFile path) (encodeCSRPEM csr)++-- | Wraps the DER encoding of a CSR.+csrFromDER :: ByteString -> CSR+csrFromDER =+    CSR . Base64DER . Encoding.decodeUtf8 . review JWK.base64url++{- | Unwraps the DER encoding of a CSR.++Fails if the CSR does not hold base64url-encoded content.+-}+csrToDER :: CSR -> Either String ByteString+csrToDER (CSR (Base64DER txt)) =+    maybe (Left "invalid base64url content") Right $+        preview JWK.base64url (Encoding.encodeUtf8 txt)++-- | Encodes a CSR as a PEM file content.+encodeCSRPEM :: CSR -> Either String ByteString+encodeCSRPEM =+    fmap (PEM.pemWriteBS . PEM.PEM "CERTIFICATE REQUEST" []) . csrToDER++-- | Decodes the first CSR found in a PEM file content.+decodeCSRPEM :: ByteString -> Either String CSR+decodeCSRPEM bytes = do+    pems <- PEM.pemParseBS bytes+    case filter isCSR pems of+        [] -> Left "no certificate request in PEM content"+        (pem : _) -> Right (csrFromDER (PEM.pemContent pem))+  where+    isCSR pem = PEM.pemName pem `elem` ["CERTIFICATE REQUEST", "NEW CERTIFICATE REQUEST"]++{- | Parses the certificates of the PEM returned by the ACME server.++The first certificate is the one for the names you ordered, followed by the+certificates of the issuers.+-}+certificateChain :: Certificate.PEM -> Either String [X509.SignedCertificate]+certificateChain (Certificate.PEM bytes) = decodeCertificateChain (LBS.toStrict bytes)++-- | Parses all the certificates found in a PEM file content.+decodeCertificateChain :: ByteString -> Either String [X509.SignedCertificate]+decodeCertificateChain bytes = do+    pems <- PEM.pemParseBS bytes+    traverse (X509.decodeSignedCertificate . PEM.pemContent) (filter isCertificate pems)+  where+    isCertificate pem = PEM.pemName pem == "CERTIFICATE"++-- | Encodes certificates as a PEM file content.+encodeCertificateChain :: [X509.SignedCertificate] -> ByteString+encodeCertificateChain =+    foldMap (PEM.pemWriteBS . PEM.PEM "CERTIFICATE" [] . X509.encodeSignedObject)++-- | Loads all the certificates of a PEM file.+loadCertificateChain :: FilePath -> IO (Either String [X509.SignedCertificate])+loadCertificateChain = fmap decodeCertificateChain . ByteString.readFile++{- | Writes certificates to a PEM file.++Useful to store the certificate apart from the ones of its issuers.+-}+writeCertificateChain :: [X509.SignedCertificate] -> FilePath -> IO ()+writeCertificateChain certs path = ByteString.writeFile path (encodeCertificateChain certs)++{- | The ALPN protocol name (@acme-tls/1@) that an ACME server asks for when it+validates a TLS-ALPN-01 challenge (RFC-8737).+-}+acmeTLSALPNProtocol :: ByteString+acmeTLSALPNProtocol = "acme-tls/1"++-- | The OID of the @acmeIdentifier@ certificate extension (RFC-8737).+acmeIdentifierOID :: OID+acmeIdentifierOID = [1, 3, 6, 1, 5, 5, 7, 1, 31]++{- | The SHA-256 digest of a key authorization (32 bytes), which the+@acmeIdentifier@ extension of a TLS-ALPN-01 certificate carries.+-}+acmeIdentifierDigest :: KeyAuthorization -> ByteString+acmeIdentifierDigest (KeyAuthorization keyAuth) = SHA256.hash (Encoding.encodeUtf8 keyAuth)++{- | Creates the self-signed certificate answering a TLS-ALPN-01 challenge+(RFC-8737 section 3) for a DNS name, signed (RSA with SHA-256) with a key.++The certificate has the name as its only subject alternative name, and a+critical @acmeIdentifier@ extension holding the SHA-256 digest of the key+authorization of the challenge. The TLS server presents it, for this name, to+the clients negotiating the 'acmeTLSALPNProtocol' protocol.++The validity period is given by the caller: ACME servers do not check it, a+few days around the current time is customary. The key can be any RSA key,+except the account key.+-}+createTLSALPN01Certificate ::+    RSA.PrivateKey ->+    (UTCTime, UTCTime) ->+    Text ->+    KeyAuthorization ->+    IO (Either String X509.SignedCertificate)+createTLSALPN01Certificate key (start, end) name keyAuth+    | Text.null name || not (Text.all (\c -> c > ' ' && c < '\DEL') name) =+        pure (Left "the DNS name must be a non-empty ASCII string")+    | otherwise = runExceptT (X509.objectToSignedExactF sign certificate)+  where+    alg :: X509.SignatureALG+    alg = X509.SignatureALG X509.HashSHA256 X509.PubKeyALG_RSA++    sign :: ByteString -> ExceptT String IO (ByteString, X509.SignatureALG)+    sign bytes = ExceptT $ bimap show (\sig -> (sig, alg)) <$> PKCS15.signSafer (Just SHA256) key bytes++    dn :: X509.DistinguishedName+    dn+        | Text.length name <= 64 =+            X509.DistinguishedName+                [(getObjectID X509.DnCommonName, ASN1CharacterString UTF8 (Encoding.encodeUtf8 name))]+        | otherwise = X509.DistinguishedName []++    certificate :: X509.Certificate+    certificate =+        X509.Certificate+            { X509.certVersion = 2+            , X509.certSerial = 1+            , X509.certSignatureAlg = alg+            , X509.certIssuerDN = dn+            , X509.certValidity = (toDateTime start, toDateTime end)+            , X509.certSubjectDN = dn+            , X509.certPubKey = X509.PubKeyRSA (RSA.private_pub key)+            , X509.certExtensions =+                X509.Extensions $+                    Just+                        [ X509.extensionEncode False (X509.ExtSubjectAltName [X509.AltNameDNS (Text.unpack name)])+                        , X509.ExtensionRaw acmeIdentifierOID True (encodeASN1' DER [OctetString (acmeIdentifierDigest keyAuth)])+                        ]+            }++    toDateTime :: UTCTime -> Hourglass.DateTime+    toDateTime (UTCTime day time) =+        let (y, m, d) = toGregorian day+            secs = floor time :: Int+         in Hourglass.DateTime+                (Hourglass.Date (fromInteger y) (toEnum (m - 1)) d)+                ( Hourglass.TimeOfDay+                    (fromIntegral (secs `div` 3600))+                    (fromIntegral ((secs `div` 60) `mod` 60))+                    (fromIntegral (min 59 (secs `mod` 60)))+                    0+                )

@@ -1,9 +1,27 @@-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+{- | The ACME flow, composed out of the API calls of the @Acme.NotAJoke.Api.*@+modules. +'prepareAcmeOrder' runs the requests from the directory to the challenges of+an order (fetch the directory, find the account, create the order, inspect its+authorizations and pick a challenge for each) and returns an 'AcmeSingle':+the remaining calls, with the URLs, KID and nonces filled in. Most programs+do not call it directly but go through "Acme.NotAJoke.Dancer", which also+runs the remaining calls.++The other functions of this module wrap single operations (changing the+account key, revoking a certificate) the same way: given the base URL of the+server and the account key, they fetch the directory, a nonce and the account+before sending the request.+-} module Acme.NotAJoke.Client where +import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE)+import Data.Coerce (Coercible, coerce) import qualified Data.List as List-import Data.Maybe (fromJust)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text  import qualified Crypto.JOSE.JWK as JWK @@ -14,17 +32,20 @@ import Acme.NotAJoke.Api.Challenge import Acme.NotAJoke.Api.Directory import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.KeyChange import Acme.NotAJoke.Api.Nonce as Nonce import Acme.NotAJoke.Api.Order+import Acme.NotAJoke.Api.Revocation import Acme.NotAJoke.Api.Validation  {- | An IO-type for ACME primitives.+Errors from the ACME server are returned as values (see 'AcmeError'). As we iterate on this lib, this type may change to become a monad-stack/mtl-mashup. -}-type AcmePrim a = IO (Maybe a)+type AcmePrim a = IO (Either AcmeError a) -{- | An object carrying all functions to generate a single authorization from a-single order with a DNS challenge.+{- | An object carrying all functions to drive a single order to a certificate,+once the order is created and its authorizations are inspected. -} data AcmeSingle = AcmeSingle     { dir :: Directory@@ -33,35 +54,138 @@     -- ^ an object to generate new nonces for this ACME server, saving found nonces opportunistically     , pollOrder :: AcmePrim OrderInspected     -- ^ fetches the status of an order-    , fetchAuthorization :: AcmePrim AuthorizationInspected-    -- ^ fetches the authorization, this function is called by prepareAcmeOrder so you may not need to inspect authorization yourself+    , pendingAuthorizations :: [AcmeAuthorization]+    -- ^ the authorizations the client still has to validate, one per+    -- identifier of the order (authorizations the server already considers+    -- valid, e.g. reused from an earlier order, are left out)+    , finalizeOrder :: AcmePrim OrderFinalized+    -- ^ finalize the order (i.e, effectively sends the CSR to the server)+    , fetchCertificate :: Url "certificate" -> AcmePrim Certificate+    -- ^ fetch the signed certificate, the URL comes from a OrderInspected (see readOrderInspected)+    }++{- | An authorization of an order, with the challenge picked to validate it.++For a wildcard identifier such as @*.example.com@, the server gives an+authorization for @example.com@ with 'authWildcard' set (RFC-8555 section 7.1.3),+which only a DNS-01 challenge can validate. An order for both+@*.example.com@ and @example.com@ has two such authorizations for the same+@example.com@ value, hence two TXT records at the same name (see+'dns01RecordName'), which must be present at the same time.+-}+data AcmeAuthorization = AcmeAuthorization+    { authorizationUrl :: Url "authorization"+    -- ^ where the authorization lives+    , authIdentifier :: AuthorizationIdentifier+    -- ^ the identifier to prove control of (without the @*.@ of a wildcard)+    , authWildcard :: Bool+    -- ^ whether the authorization is for the wildcard of 'authIdentifier'     , proof :: (Token, KeyAuthorization, ValidationProof)     -- ^ the validation proof (i.e., the value to set in DNS records and so on)+    , fetchAuthorization :: AcmePrim AuthorizationInspected+    -- ^ fetches the authorization (e.g. to know why it failed)     , replyChallenge :: AcmePrim ChallengeAttempted-    -- ^ tells the server it can validates the challenge (i.e., after writing the proof in some DNS record)+    -- ^ tells the server it can validate the challenge (i.e., after writing the proof in some DNS record)     , pollChallenge :: AcmePrim ChallengeAttempted     -- ^ fetches the status of a challenge (mainly to know if the server has validated the challenge)-    , finalizeOrder :: AcmePrim OrderFinalized-    -- ^ finalize the order (i.e, effectively sends the CSR to the server)-    , fetchCertificate :: Url "certificate" -> AcmePrim Certificate-    -- ^ fetch the signed certificate, the URL comes from a OrderInspected (see readOrderInspected)     } +{- | The name of the TXT record holding the 'ValidationProof' of a DNS-01+challenge: @_acme-challenge.example.com@ for @example.com@ as well as for the+wildcard @*.example.com@ (RFC-8555 section 8.4).+-}+dns01RecordName :: AuthorizationIdentifier -> Text+dns01RecordName ident = "_acme-challenge." <> wildcardBase ident.value++{- | The domain a wildcard domain covers: @example.com@ for @*.example.com@,+other domains are returned as they are.+-}+wildcardBase :: Text -> Text+wildcardBase domain = fromMaybe domain (Text.stripPrefix "*." domain)++-- | Whether a domain is a wildcard such as @*.example.com@.+isWildcardDomain :: Text -> Bool+isWildcardDomain = Text.isPrefixOf "*."++{- | Changes the key of an account (RFC-8555 section 7.3.5), see+'Acme.NotAJoke.Api.KeyChange'.++Fetches the directory and the account with the old key (the account must+exist, see 'fetchAccount'), then asks the server to replace the old key with+the new one. Once this succeeds, only the new key can sign requests for the+account: save it before calling this function.+-}+changeAccountKey ::+    BaseUrl ->+    -- | old (current) key of the account+    JWK.JWK ->+    -- | new key of the account+    JWK.JWK ->+    Account "account-fetch" ->+    IO (Either AcmeError KeyChanged)+changeAccountKey baseurl oldJwk newJwk account = runExceptT $ do+    acmeDir <- ExceptT $ fetchDirectory (directory baseurl)+    nf <- liftIO $ fetcher (getNonce acmeDir.newNonce)+    let nonceify :: (Nonce -> AcmePrim a) -> AcmePrim a+        nonceify f = either (pure . Left) f =<< nf.produce+    accountCreated <- ExceptT $ saveNonce nf (nonceify $ \nonce -> postFetchAccount oldJwk acmeDir.newAccount nonce account)+    kid <- maybe (throwE $ UnexpectedResponse "no account location" (coerce accountCreated)) pure $ readKID accountCreated+    ExceptT $ nonceify $ postKeyChange oldJwk newJwk kid acmeDir.keyChange++-- | Progress of 'prepareAcmeOrder', reported to its step handler. data PrepareStep     = Starting-    | GotDirectory Directory-    | GettingNonce-    | GotAccount AccountCreated-    | GotOrder OrderCreated-    | GotAuthorization AuthorizationInspected+    | -- | the directory of the server is fetched+      GotDirectory Directory+    | -- | a fresh nonce is about to be fetched+      GettingNonce+    | -- | the account is found (see 'readKID')+      GotAccount AccountCreated+    | -- | the order is created+      GotOrder OrderCreated+    | -- | emitted once per authorization of the order+      GotAuthorization AuthorizationInspected +{- | Picks the type of challenge to validate authorizations with (e.g.,+'isDNS01').+-} type MatchChallenge = Challenge "challenge-unspecified" -> Bool --- TODO:+{- | Picks, among the authorizations of an order, the ones the client has to+validate, and the challenge to validate each of them with. The @tag@ is+carried along (e.g. the URL of the authorization). --- * step for errors+Valid authorizations are left out (the server may reuse an authorization+validated for an earlier order). Fails on the first authorization to validate+that has no matching challenge (e.g. a wildcard authorization with an HTTP-01+matcher), or which is neither pending nor valid, with its tag and a message.+-}+pickChallenges ::+    MatchChallenge ->+    [(tag, Authorization "authorization-inspected")] ->+    Either (tag, Text) [(tag, Authorization "authorization-inspected", Challenge "challenge-unspecified")]+pickChallenges matchChallenge = fmap concat . traverse pick+  where+    pick (tag, authz) =+        case authz.status of+            AuthorizationValid -> Right []+            AuthorizationPending ->+                case List.find matchChallenge authz.challenges of+                    Just challenge -> Right [(tag, authz, challenge)]+                    Nothing -> Left (tag, "no matching challenge in authorization for " <> describe authz)+            st -> Left (tag, "authorization for " <> describe authz <> " is " <> Text.pack (show st))+    describe :: Authorization "authorization-inspected" -> Text+    describe authz =+        (if authz.wildcard == Just True then "*." else "") <> authz.identifier.value --- * return shortcuts in handleStep function+{- | Runs the first steps of the ACME dance: up to the point where the client+has to prove it controls the identifiers in the order.++All the authorizations of the order are inspected, one challenge is picked+per authorization still to validate (see 'pickChallenges').++Stops at the first error, which is returned.+-} prepareAcmeOrder ::     BaseUrl ->     JWK.JWK ->@@ -70,57 +194,132 @@     Order "order-create" ->     MatchChallenge ->     (PrepareStep -> IO ()) ->-    IO AcmeSingle-prepareAcmeOrder baseurl jwk account csr1 order matchChallenge handleStep = do-    handleStep $ Starting+    IO (Either AcmeError AcmeSingle)+prepareAcmeOrder baseurl jwk account csr1 order matchChallenge handleStep = runExceptT $ do+    step $ Starting      -- unauthenticated info-    acmeDir <- fetchDirectory (directory baseurl)-    nf <- fetcher (handleStep GettingNonce >> getNonce acmeDir.newNonce)-    let mknonce = nf.produce-    let nonceify = fromJust <$> mknonce-    handleStep $ GotDirectory acmeDir+    acmeDir <- ExceptT $ fetchDirectory (directory baseurl)+    nf <- liftIO $ fetcher (handleStep GettingNonce >> getNonce acmeDir.newNonce)+    let nonceify :: (Nonce -> AcmePrim a) -> AcmePrim a+        nonceify f = either (pure . Left) f =<< nf.produce+    step $ GotDirectory acmeDir      -- fetch account-    nonce1 <- nonceify-    Just accountCreated <- saveNonce nf (postFetchAccount jwk acmeDir.newAccount nonce1 account)-    let (Just kid) = readKID accountCreated-    handleStep $ GotAccount accountCreated+    accountCreated <- ExceptT $ saveNonce nf (nonceify $ \nonce -> postFetchAccount jwk acmeDir.newAccount nonce account)+    kid <- expect "no account location" accountCreated $ readKID accountCreated+    step $ GotAccount accountCreated      -- prepare new order-    nonce2 <- nonceify-    Just orderCreated <- saveNonce nf (postNewOrder jwk acmeDir.newOrder kid nonce2 order)-    let Just authUrl = safeHead . authorizations =<< readOrderCreated orderCreated-    handleStep $ GotOrder orderCreated+    orderCreated <- ExceptT $ saveNonce nf (nonceify $ \nonce -> postNewOrder jwk acmeDir.newOrder kid nonce order)+    authUrls <- expect "no authorization in order" orderCreated $ nonEmpty . authorizations =<< readOrderCreated orderCreated+    step $ GotOrder orderCreated      -- poller for order-    let Just orderUrl = readOrderUrl orderCreated-    let fpollOrder = saveNonce nf (postGetOrder jwk orderUrl kid =<< nonceify)--    -- read authorization's dns challenge-    let ffetchAuthorization = saveNonce nf (postGetAuthorization jwk kid authUrl =<< nonceify)-    Just authorizationInspected <- ffetchAuthorization-    handleStep $ GotAuthorization authorizationInspected-    let Just challenge = List.find matchChallenge . challenges =<< readAuthorization authorizationInspected+    orderUrl <- expect "no order location" orderCreated $ readOrderUrl orderCreated+    let fpollOrder = saveNonce nf (nonceify $ postGetOrder jwk orderUrl kid) -    -- challenge validation proof-    let tok = challenge.token-    let keyAuth = keyAuthorization tok jwk-    let proofVal = sha256digest keyAuth+    -- inspect every authorization of the order+    let ffetchAuthorization authUrl = saveNonce nf (nonceify $ postGetAuthorization jwk kid authUrl)+    inspected <- traverse (inspectAuthorization ffetchAuthorization) authUrls+    picked <- case pickChallenges matchChallenge [((authUrl, rsp), authz) | (authUrl, rsp, authz) <- inspected] of+        Right xs -> pure xs+        Left ((_, rsp), what) -> throwE $ UnexpectedResponse what (coerce rsp) -    -- read authorization's dns challenge-    let freplyChallenge = saveNonce nf (postReplyChallenge jwk kid challenge =<< nonceify)-    let fpollChallenge = saveNonce nf (postGetChallenge jwk kid challenge =<< nonceify)+    let acmeAuthorization ((authUrl, _), authz, challenge) =+            let tok = challenge.token+                keyAuth = keyAuthorization tok jwk+             in AcmeAuthorization+                    { authorizationUrl = authUrl+                    , authIdentifier = authz.identifier+                    , authWildcard = authz.wildcard == Just True+                    , proof = (tok, keyAuth, sha256digest keyAuth)+                    , fetchAuthorization = ffetchAuthorization authUrl+                    , replyChallenge = saveNonce nf (nonceify $ postReplyChallenge jwk kid challenge)+                    , pollChallenge = saveNonce nf (nonceify $ postGetChallenge jwk kid challenge)+                    }      -- finalize order-    let Just finalizeOrderUrl = fmap finalize $ readOrderCreated orderCreated-    let ffinalizeOrder = saveNonce nf (postFinalizeOrder jwk kid finalizeOrderUrl (Finalize csr1) =<< nonceify)+    finalizeOrderUrl <- expect "no finalize url in order" orderCreated $ fmap finalize $ readOrderCreated orderCreated+    let ffinalizeOrder = saveNonce nf (nonceify $ postFinalizeOrder jwk kid finalizeOrderUrl (Finalize csr1))      -- fetch certificate (at last)-    let ffetchCertificate certificateUrl = saveNonce nf (postGetCertificate jwk kid certificateUrl =<< nonceify)+    let ffetchCertificate certificateUrl = saveNonce nf (nonceify $ postGetCertificate jwk kid certificateUrl) -    pure $ AcmeSingle acmeDir nf fpollOrder ffetchAuthorization (tok, keyAuth, proofVal) freplyChallenge fpollChallenge ffinalizeOrder ffetchCertificate+    pure $ AcmeSingle acmeDir nf fpollOrder (map acmeAuthorization picked) ffinalizeOrder ffetchCertificate   where-    safeHead :: [x] -> Maybe x-    safeHead [] = Nothing-    safeHead (x : _) = Just x+    step :: PrepareStep -> ExceptT AcmeError IO ()+    step = liftIO . handleStep++    inspectAuthorization fetchAuthz authUrl = do+        authorizationInspected <- ExceptT $ fetchAuthz authUrl+        step $ GotAuthorization authorizationInspected+        authz <- expect "could not read authorization" authorizationInspected $ readAuthorization authorizationInspected+        pure (authUrl, authorizationInspected, authz)++    -- turns a failed lookup in a (successful) response into an error+    expect :: (Coercible rsp Response) => Text -> rsp -> Maybe x -> ExceptT AcmeError IO x+    expect what rsp = maybe (throwE $ UnexpectedResponse what (coerce rsp)) pure++    nonEmpty :: [x] -> Maybe [x]+    nonEmpty [] = Nothing+    nonEmpty xs = Just xs++{- | Revokes a certificate with the account key (RFC-8555 section 7.6).++Fetches the directory and the account (which must exist, see 'fetchAccount'),+then sends the revocation signed with the KID of the account. The account must+be the one which ordered the certificate, or hold valid authorizations for all+its names.+-}+revokeCertificate ::+    BaseUrl ->+    JWK.JWK ->+    Account "account-fetch" ->+    Revocation ->+    IO (Either AcmeError CertificateRevoked)+revokeCertificate baseurl jwk account rev = runExceptT $ do+    acmeDir <- ExceptT $ fetchDirectory (directory baseurl)+    nf <- liftIO $ fetcher (getNonce acmeDir.newNonce)+    accountCreated <- ExceptT $ saveNonce nf (withNonce nf $ \nonce -> postFetchAccount jwk acmeDir.newAccount nonce account)+    kid <- maybe (throwE $ UnexpectedResponse "no account location" (coerce accountCreated)) pure $ readKID accountCreated+    ExceptT $ withNonce nf $ \nonce -> postRevokeCertificate jwk kid acmeDir.revokeCert nonce rev++{- | Revokes a certificate with its own key (RFC-8555 section 7.6), given as+a JWK (see 'Acme.NotAJoke.KeyManagement.jwkFromRSAKey').++No account is involved, which makes it the way to revoke a certificate whose+account key is lost, or whose key is compromised.+-}+revokeCertificateWithCertKey ::+    BaseUrl ->+    JWK.JWK ->+    Revocation ->+    IO (Either AcmeError CertificateRevoked)+revokeCertificateWithCertKey baseurl certJwk rev = runExceptT $ do+    acmeDir <- ExceptT $ fetchDirectory (directory baseurl)+    nonce <- ExceptT $ getNonce acmeDir.newNonce+    ExceptT $ postRevokeCertificateWithCertKey certJwk acmeDir.revokeCert nonce rev++-- | Runs an API call with a nonce from a fetcher.+withNonce :: Nonce.Fetcher -> (Nonce -> AcmePrim a) -> AcmePrim a+withNonce nf f = either (pure . Left) f =<< nf.produce++{- | Deactivates an account (RFC-8555 section 7.3.6).++Fetches the directory and the account (which must exist, see 'fetchAccount'),+then asks the server to deactivate it. This cannot be undone: once this+succeeds, the server rejects every request signed with the key of the account,+a new account (with another key) is needed to order certificates.+-}+deactivateAccount ::+    BaseUrl ->+    JWK.JWK ->+    Account "account-fetch" ->+    IO (Either AcmeError AccountDeactivationResponse)+deactivateAccount baseurl jwk account = runExceptT $ do+    acmeDir <- ExceptT $ fetchDirectory (directory baseurl)+    nf <- liftIO $ fetcher (getNonce acmeDir.newNonce)+    accountCreated <- ExceptT $ saveNonce nf (withNonce nf $ \nonce -> postFetchAccount jwk acmeDir.newAccount nonce account)+    kid <- maybe (throwE $ UnexpectedResponse "no account location" (coerce accountCreated)) pure $ readKID accountCreated+    ExceptT $ withNonce nf $ postDeactivateAccount jwk kid

@@ -1,46 +1,144 @@+{- | Runs the whole ACME flow (the \"dance\") for an order, from the directory+to the certificate, calling back your code at each step.++The caller provides an 'AcmeDancer': the server, the account key and account,+the CSR and the order, and a step handler. The step handler is where the+proofs of the challenges are published (DNS records, files, TLS+certificates): this library does not talk to DNS providers nor serve+anything on its own (see the @acme-not-a-joke-wai@ package for HTTP-01 and+TLS-ALPN-01).++@+jwk <- fromJust \<$\> loadJWKFile \"staging\/key.jwk\"+let o = createOrder (Nothing, Nothing) [OrderIdentifier DNSOrder \"example.com\"]+runAcmeDance_dns01 (AcmeDancer staging_letsencryptv2 jwk (fetchAccount [\"mailto:me\@example.com\"]) csr o (ghciDance \"certificate.pem\"))+@+-} module Acme.NotAJoke.Dancer where  import Control.Concurrent (threadDelay) import Control.Monad (void) import qualified Crypto.JOSE.JWK as JWK-import Data.Maybe (fromJust) import Data.Text (Text)  import Acme.NotAJoke.Api.Account import Acme.NotAJoke.Api.CSR import Acme.NotAJoke.Api.Certificate-import Acme.NotAJoke.Api.Challenge (Token (..), isDNS01)+import Acme.NotAJoke.Api.Challenge (Token (..), isDNS01, isHTTP01, isTLSALPN01) import Acme.NotAJoke.Api.Endpoint import Acme.NotAJoke.Api.Order import Acme.NotAJoke.Api.Validation import Acme.NotAJoke.Client +{- | What the caller provides to run the dance.++The account must exist (see 'Acme.NotAJoke.Api.Account.postCreateAccount'):+the dance only fetches it.+-} data AcmeDancer     = AcmeDancer     { baseUrl :: BaseUrl+    -- ^ the ACME server (e.g., 'Acme.NotAJoke.LetsEncrypt.staging_letsencryptv2')     , accountJwk :: JWK.JWK+    -- ^ the account key, which signs all the requests     , account :: Account "account-fetch"+    -- ^ the account to fetch (see 'fetchAccount')     , csr :: CSR+    -- ^ the CSR, for the identifiers of the order, signed with the+    -- certificate key (which differs from the account key)     , order :: Order "order-create"+    -- ^ the order (see 'createOrder')     , handleStep :: DanceStep -> IO ()+    -- ^ called at each step: this is where the proofs are published, where+    -- the dance waits between polls, and where the certificate is stored     } +{- | The steps of the dance, given in turn to the 'handleStep' of the+'AcmeDancer'.++The dance runs synchronously, in the thread calling 'runAcmeDance': it waits+for 'handleStep' to return before going on. A step handler must at least+publish the proofs on 'Validation', wait on 'WaitingForValidation' (the dance+does not sleep on its own between polls) and keep the certificate on 'Done'.+The dance ends after 'Done', 'InvalidOrder', 'OtherError' or 'AcmeFailure'.+-} data DanceStep-    = Validation (Token, KeyAuthorization, ValidationProof)-    | WaitingForValidation Int-    | OrderIsFinalized OrderFinalized-    | ValidOrder OrderInspected-    | InvalidOrder OrderInspected-    | OtherError Text-    | Done AcmeSingle Certificate-    | Prepare PrepareStep+    = {- | the client is about to validate this authorization, the next+      'Validation' step carries its proof (useful to know which identifier+      the proof is for, e.g. with 'dns01RecordName', when the order has more+      than one identifier)+      -}+      Authorizing AcmeAuthorization+    | {- | the proof must be answerable (e.g. the DNS record set, the+      token served) before the step handler returns; there is one+      'Validation' per authorization to validate, and the server is told to+      check the challenges only after the last one, so all proofs must be+      answerable at the same time+      -}+      Validation (Token, KeyAuthorization, ValidationProof)+    | -- | the dance is about to poll the order for the n-th time (starting+      -- at 0), the step handler should wait before returning (e.g., n seconds)+      WaitingForValidation Int+    | -- | the order is ready and the CSR was sent+      OrderIsFinalized OrderFinalized+    | -- | the order is valid, the certificate is about to be downloaded+      ValidOrder OrderInspected+    | -- | the order failed (e.g., a challenge failed), the dance stops+      InvalidOrder OrderInspected+    | -- | the server replied something unexpected, the dance stops+      OtherError Text+    | -- | an API call failed, the dance stops+      AcmeFailure AcmeError+    | -- | the certificate is downloaded, the dance is over+      Done AcmeSingle Certificate+    | -- | progress of the first requests (see 'prepareAcmeOrder')+      Prepare PrepareStep +{- | Runs the dance with DNS-01 challenges: the 'ValidationProof' given in each+'Validation' step must be published as a TXT record at the+'dns01RecordName' of the identifier given in the preceding 'Authorizing' step+before the step handler returns.++DNS-01 challenges can validate wildcard identifiers: an order for+@*.example.com@ needs a TXT record at @_acme-challenge.example.com@. An order+for both @*.example.com@ and @example.com@ needs two TXT records at that same+name, so a step handler must add records rather than replace them.+-} runAcmeDance_dns01 :: AcmeDancer -> IO () runAcmeDance_dns01 = runAcmeDance isDNS01 +{- | Runs the dance with an HTTP-01 challenge: the 'KeyAuthorization' given in+the 'Validation' step must be served at+@http:\/\/{domain}\/.well-known\/acme-challenge\/{token}@ (on port 80) before the+step handler returns.++HTTP-01 challenges cannot validate wildcard identifiers, use+'runAcmeDance_dns01' for these.+-}+runAcmeDance_http01 :: AcmeDancer -> IO ()+runAcmeDance_http01 = runAcmeDance isHTTP01++{- | Runs the dance with a TLS-ALPN-01 challenge (RFC-8737): before the step+handler returns from the 'Validation' step, the TLS server on port 443 of the+domain must answer handshakes negotiating the @acme-tls/1@ protocol (ALPN)+for this server name with a self-signed certificate carrying the SHA-256+digest of the 'KeyAuthorization' (see+'Acme.NotAJoke.CertManagement.createTLSALPN01Certificate').++TLS-ALPN-01 challenges cannot validate wildcard identifiers, use+'runAcmeDance_dns01' for these.+-}+runAcmeDance_tlsalpn01 :: AcmeDancer -> IO ()+runAcmeDance_tlsalpn01 = runAcmeDance isTLSALPN01++{- | Runs the whole dance for an order, validating authorizations with the+challenges picked by the 'MatchChallenge': fetch the directory and the+account, create the order, emit the proofs, tell the server to check them,+poll the order, finalize it with the CSR, and download the certificate.+-} runAcmeDance :: MatchChallenge -> AcmeDancer -> IO () runAcmeDance matchChallenge dancer = do-    acme <-+    prepared <-         prepareAcmeOrder             dancer.baseUrl             dancer.accountJwk@@ -49,34 +147,54 @@             dancer.order             matchChallenge             handleAcmeSingleStep-    go acme+    either failed go prepared   where     go acme = do-        dancer.handleStep $ Validation acme.proof-        _ <- acme.replyChallenge-        waitForValidOrder 0 acme+        mapM_ announce acme.pendingAuthorizations+        replyAll acme acme.pendingAuthorizations +    announce authz = do+        dancer.handleStep $ Authorizing authz+        dancer.handleStep $ Validation authz.proof++    replyAll acme [] = waitForValidOrder 0 acme+    replyAll acme (authz : rest) = do+        replied <- authz.replyChallenge+        case replied of+            Left err -> failed err+            Right _ -> replyAll acme rest+     handleAcmeSingleStep = dancer.handleStep . Prepare +    failed = dancer.handleStep . AcmeFailure+     waitForValidOrder n acme = do         dancer.handleStep (WaitingForValidation n)-        recentOrder <- fromJust <$> acme.pollOrder-        case Acme.NotAJoke.Api.Order.status <$> readOrderInspected recentOrder of-            Just OrderPending -> waitForValidOrder (succ n) acme-            Just OrderProcessing -> waitForValidOrder (succ n) acme-            Just OrderReady -> do-                x <- fromJust <$> acme.finalizeOrder-                dancer.handleStep $ OrderIsFinalized x-                waitForValidOrder (succ n) acme-            Just OrderValid -> handleValid acme recentOrder-            Just OrderInvalid -> dancer.handleStep $ InvalidOrder recentOrder-            _ -> dancer.handleStep $ OtherError "could not inspect order"+        polled <- acme.pollOrder+        case polled of+            Left err -> failed err+            Right recentOrder ->+                case Acme.NotAJoke.Api.Order.status <$> readOrderInspected recentOrder of+                    Just OrderPending -> waitForValidOrder (succ n) acme+                    Just OrderProcessing -> waitForValidOrder (succ n) acme+                    Just OrderReady -> do+                        finalized <- acme.finalizeOrder+                        case finalized of+                            Left err -> failed err+                            Right x -> do+                                dancer.handleStep $ OrderIsFinalized x+                                waitForValidOrder (succ n) acme+                    Just OrderValid -> handleValid acme recentOrder+                    Just OrderInvalid -> dancer.handleStep $ InvalidOrder recentOrder+                    _ -> dancer.handleStep $ OtherError "could not inspect order"      handleValid acme o = do         dancer.handleStep $ ValidOrder o-        let certUrl = certificate =<< (readOrderInspected o)-        certif <- acme.fetchCertificate (fromJust certUrl)-        dancer.handleStep $ Done acme (fromJust certif)+        case readCertificateUrl o of+            Nothing -> dancer.handleStep $ OtherError "valid order without certificate url"+            Just certUrl -> do+                certif <- acme.fetchCertificate certUrl+                either failed (dancer.handleStep . Done acme) certif  {- | A dance for running from within GHCI (i.e., printing and expecting you to press ENTER to continue).@@ -84,6 +202,9 @@ ghciDance :: FilePath -> DanceStep -> IO () ghciDance certPath x =     case x of+        Authorizing authz -> do+            print ("authorizing" :: Text, authz.authIdentifier, ("wildcard" :: Text, authz.authWildcard))+            print ("TXT record (dns01) is" :: Text, dns01RecordName authz.authIdentifier)         Validation (tok, keyAuth, sha) -> do             print ("token (http01) is" :: Text, showToken tok)             print ("key authorization (http01) is" :: Text, showKeyAuth keyAuth)@@ -104,6 +225,8 @@             print ("order invalid" :: Text, o)         OtherError txt -> do             print ("order invalid" :: Text, txt)+        AcmeFailure err -> do+            print ("acme failure" :: Text, readProblem err, err)         Prepare Starting -> do             print ("starting" :: Text)         Prepare GettingNonce -> do@@ -117,11 +240,14 @@         Prepare (GotAuthorization a) -> do             print ("got authorization" :: Text, a) +-- | The text of a token (the last path segment of the HTTP-01 URL). showToken :: Token -> Text showToken (Token x1) = x1 +-- | The text of a key authorization (the body served for HTTP-01). showKeyAuth :: KeyAuthorization -> Text showKeyAuth (KeyAuthorization x1) = x1 +-- | The text of a proof (the value of the TXT record for DNS-01). showProof :: ValidationProof -> Text showProof (ValidationProof x1) = x1

@@ -1,18 +1,212 @@-module Acme.NotAJoke.KeyManagement where+{- | A series of helpers to work with keys. -import Data.Aeson (decode, encode)+Two kinds of keys are involved when getting a certificate:++* the account key, a 'JWK.JWK' which signs the requests sent to the ACME server+  (an RSA, EC or Ed25519 key, the JWS algorithm follows from the key, see+  'Acme.NotAJoke.Api.JWS.acmeJWSAlg')+* the certificate key, an 'RSA.PrivateKey' which signs the CSR (see+  "Acme.NotAJoke.CertManagement") and that your TLS server needs to load++ACME servers refuse a CSR signed with the account key, hence you need one+key of each.+-}+module Acme.NotAJoke.KeyManagement (+    -- * JWK+    genJWKrsa4096,+    genJWKecP256,+    genJWKecP384,+    genJWKed25519,+    loadJWKFile,+    writeJWKFile,+    loadOrCreateJWKFile,++    -- * RSA keys+    genRSAKey,+    genRSAKey4096,+    jwkFromRSAKey,+    jwkToRSAKey,++    -- * PEM and DER formats for RSA keys+    encodeRSAKeyPEM,+    decodeRSAKeyPEM,+    encodeRSAKeyDER,+    decodeRSAKeyDER,+    loadRSAKeyPEM,+    writeRSAKeyPEM,+    loadOrCreateRSAKeyPEM,+) where++import Control.Lens (view)+import Data.Aeson (eitherDecode, encode)+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LBS+import Data.Maybe (isJust)+import System.Directory (doesFileExist) +import qualified Crypto.JOSE.JWA.JWK as JWA import qualified Crypto.JOSE.JWK as JWK+import Crypto.JOSE.Types (Base64Integer (..))+import qualified Crypto.PubKey.RSA as RSA+import Data.ASN1.BinaryEncoding (DER (..))+import Data.ASN1.Encoding (decodeASN1', encodeASN1')+import Data.ASN1.Types (fromASN1, toASN1)+import qualified Data.PEM as PEM+import qualified Data.X509 as X509  -- | Generates and RSA-4096 bits key. genJWKrsa4096 :: IO JWK.JWK genJWKrsa4096 = JWK.genJWK (JWK.RSAGenParam (4096 `div` 8)) +-- | Generates an EC key on the P-256 curve, which signs with @ES256@.+genJWKecP256 :: IO JWK.JWK+genJWKecP256 = JWK.genJWK (JWK.ECGenParam JWK.P_256)++-- | Generates an EC key on the P-384 curve, which signs with @ES384@.+genJWKecP384 :: IO JWK.JWK+genJWKecP384 = JWK.genJWK (JWK.ECGenParam JWK.P_384)++{- | Generates an Ed25519 key, which signs with @EdDSA@.++Mind that not all ACME servers accept @EdDSA@ (Let's Encrypt does not).+-}+genJWKed25519 :: IO JWK.JWK+genJWKed25519 = JWK.genJWK (JWK.OKPGenParam JWK.Ed25519)+ -- | Loads a JWK from a file. loadJWKFile :: FilePath -> IO (Maybe JWK.JWK)-loadJWKFile = fmap decode . LBS.readFile+loadJWKFile = fmap (either (const Nothing) Just) . readJWKFile --- | Loads a JWK from a file.+-- | Writes a JWK to a file. writeJWKFile :: JWK.JWK -> FilePath -> IO () writeJWKFile jwk path = LBS.writeFile path (encode jwk)++{- | Loads a JWK from a file, generating a RSA-4096 bits key and storing it at+this path if the file does not exist yet.++An existing file which is not a JWK is left untouched and reported as an+error.+-}+loadOrCreateJWKFile :: FilePath -> IO (Either String JWK.JWK)+loadOrCreateJWKFile path = do+    exists <- doesFileExist path+    if exists+        then readJWKFile path+        else do+            jwk <- genJWKrsa4096+            writeJWKFile jwk path+            pure (Right jwk)++readJWKFile :: FilePath -> IO (Either String JWK.JWK)+readJWKFile = fmap (eitherDecode . LBS.fromStrict) . ByteString.readFile++{- | Generates an RSA key of a given size in bits (with the usual 65537 public+exponent).+-}+genRSAKey :: Int -> IO RSA.PrivateKey+genRSAKey bits = snd <$> RSA.generate (bits `div` 8) 65537++-- | Generates and RSA-4096 bits key.+genRSAKey4096 :: IO RSA.PrivateKey+genRSAKey4096 = genRSAKey 4096++-- | Turns an RSA key into a JWK.+jwkFromRSAKey :: RSA.PrivateKey -> JWK.JWK+jwkFromRSAKey = JWK.fromRSA++{- | Extracts the RSA key of a JWK.++Fails for JWKs which are not RSA keys or which only hold a public key.+-}+jwkToRSAKey :: JWK.JWK -> Either String RSA.PrivateKey+jwkToRSAKey jwk =+    case view JWK.jwkMaterial jwk of+        JWA.RSAKeyMaterial params ->+            case view JWA.rsaPrivateKeyParameters params of+                Nothing -> Left "not a private key"+                -- JWKs may omit the primes, which the PEM and DER formats require+                Just (JWA.RSAPrivateKeyParameters _ Nothing) -> Left "RSA key without its prime factors"+                Just (JWA.RSAPrivateKeyParameters d (Just opt))+                    | isJust (JWA.rsaOth opt) -> Left "RSA key with more than two primes"+                    | otherwise ->+                        Right $+                            RSA.PrivateKey+                                (JWA.rsaPublicKey params)+                                (int d)+                                (int $ JWA.rsaP opt)+                                (int $ JWA.rsaQ opt)+                                (int $ JWA.rsaDp opt)+                                (int $ JWA.rsaDq opt)+                                (int $ JWA.rsaQi opt)+        _ -> Left "not an RSA key"+  where+    int :: Base64Integer -> Integer+    int (Base64Integer x) = x++{- | Encodes an RSA key as a PEM file content.++The output is the PKCS#1 format (@-----BEGIN RSA PRIVATE KEY-----@), which is+not encrypted.+-}+encodeRSAKeyPEM :: RSA.PrivateKey -> ByteString+encodeRSAKeyPEM key =+    PEM.pemWriteBS (PEM.PEM "RSA PRIVATE KEY" [] (encodeRSAKeyDER key))++{- | Decodes the first RSA key found in a PEM file content.++Supports unencrypted keys in PKCS#1 format (@-----BEGIN RSA PRIVATE KEY-----@,+what 'encodeRSAKeyPEM' and older versions of `openssl genrsa` write) and in+PKCS#8 format (@-----BEGIN PRIVATE KEY-----@, what newer versions of `openssl+genrsa` write).+-}+decodeRSAKeyPEM :: ByteString -> Either String RSA.PrivateKey+decodeRSAKeyPEM bytes = do+    pems <- PEM.pemParseBS bytes+    case filter isKey pems of+        [] -> Left "no private key in PEM content"+        (pem : _) -> decodeRSAKeyDER (PEM.pemContent pem)+  where+    isKey pem = PEM.pemName pem `elem` ["RSA PRIVATE KEY", "PRIVATE KEY"]++-- | Encodes an RSA key in DER (PKCS#1) format.+encodeRSAKeyDER :: RSA.PrivateKey -> ByteString+encodeRSAKeyDER key = encodeASN1' DER (toASN1 (X509.PrivKeyRSA key) [])++-- | Decodes an RSA key in DER format (either PKCS#1 or PKCS#8).+decodeRSAKeyDER :: ByteString -> Either String RSA.PrivateKey+decodeRSAKeyDER bytes = do+    asn1 <- first show (decodeASN1' DER bytes)+    (key, _) <- fromASN1 asn1+    case key of+        X509.PrivKeyRSA rsa -> Right rsa+        _ -> Left "not an RSA key"++-- | Loads an RSA key from a PEM file, see 'decodeRSAKeyPEM'.+loadRSAKeyPEM :: FilePath -> IO (Either String RSA.PrivateKey)+loadRSAKeyPEM = fmap decodeRSAKeyPEM . ByteString.readFile++{- | Writes an RSA key to a PEM file, see 'encodeRSAKeyPEM'.++The key is not encrypted and the file gets the default permissions of your+process: mind where you store it.+-}+writeRSAKeyPEM :: RSA.PrivateKey -> FilePath -> IO ()+writeRSAKeyPEM key path = ByteString.writeFile path (encodeRSAKeyPEM key)++{- | Loads an RSA key from a PEM file, generating a RSA-4096 bits key and+storing it at this path if the file does not exist yet.++An existing file which is not an RSA key is left untouched and reported as an+error.+-}+loadOrCreateRSAKeyPEM :: FilePath -> IO (Either String RSA.PrivateKey)+loadOrCreateRSAKeyPEM path = do+    exists <- doesFileExist path+    if exists+        then loadRSAKeyPEM path+        else do+            key <- genRSAKey4096+            writeRSAKeyPEM key path+            pure (Right key)

@@ -1,13 +1,20 @@ {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +{- | Base URLs of the Let's Encrypt ACME servers.++Use the staging server while developing: its certificates are not trusted by+browsers, but its rate limits are much higher. Any other ACME server works+the same, given its base URL (the URL of its directory without+@directory@).+-} module Acme.NotAJoke.LetsEncrypt where  import Acme.NotAJoke.Api.Endpoint --- Base URL for Let'sEncrypt staging.+-- | Base URL for Let'sEncrypt staging. staging_letsencryptv2 :: BaseUrl staging_letsencryptv2 = "https://acme-staging-v02.api.letsencrypt.org/" --- Base URL for Let'sEncrypt production.+-- | Base URL for Let'sEncrypt production. letsencryptv2 :: BaseUrl letsencryptv2 = "https://acme-v02.api.letsencrypt.org/"

@@ -0,0 +1,87 @@+{-# LANGUAGE DataKinds #-}++-- | The nested JWS of account key rollovers (RFC-8555 section 7.3.5).+module Main (main) where++import Control.Lens (toListOf, view)+import Control.Monad (unless)+import Data.Aeson (FromJSON, Value (..), decode, encode, object, (.=))+import qualified Data.ByteString.Lazy as LByteString+import System.Exit (exitFailure)++import qualified Crypto.JOSE.JWK as JWK+import qualified Crypto.JOSE.JWS as JWS++import Acme.NotAJoke.Api.Endpoint (Endpoint (..))+import Acme.NotAJoke.Api.JWS+import Acme.NotAJoke.Api.KeyChange+import Acme.NotAJoke.Api.Nonce (Nonce (..))+import Acme.NotAJoke.KeyManagement (genRSAKey, jwkFromRSAKey)++main :: IO ()+main = do+    oldJwk <- jwkFromRSAKey <$> genRSAKey 2048+    newJwk <- jwkFromRSAKey <$> genRSAKey 2048+    let ep = Endpoint "https://acme.test/acme/key-change" :: Endpoint "keyChange"+    let kid = KID "https://acme.test/acme/acct/42"++    Right outer <- keyChangeSign oldJwk newJwk kid ep (Nonce "a-nonce")++    -- outer JWS: a regular ACME request signed by the old key+    outerPayload <- verify oldJwk outer+    check "outer JWS, verified with the old key" $ isRight outerPayload+    newVerifiesOuter <- verify newJwk outer+    check "outer JWS, not verified with the new key" $ not (isRight newVerifiesOuter)+    check "outer JWS, url is the keyChange endpoint" $+        map (view acmeURL) (headers outer) == ["https://acme.test/acme/key-change"]+    check "outer JWS, signed with the kid of the account" $+        map (fmap encode . preview' . view acmeAuthBit) (headers outer) == [Just (encode kid)]++    -- inner JWS: the payload of the outer one, signed by the new key+    Right outerBytes <- pure outerPayload+    Just inner <- pure (decodeJWS outerBytes :: Maybe (JWS.FlattenedJWS KeyChangeHeader))+    innerPayload <- verify newJwk inner+    check "inner JWS, verified with the new key" $ isRight innerPayload+    oldVerifiesInner <- verify oldJwk inner+    check "inner JWS, not verified with the old key" $ not (isRight oldVerifiesInner)+    check "inner JWS, url is the keyChange endpoint" $+        map (view keyChangeURL) (headers inner) == ["https://acme.test/acme/key-change"]+    check "inner JWS, jwk is the new public key" $+        map (encode . view keyChangeNewKey) (headers inner) == [encode (publicJWK newJwk)]+    check "inner JWS, has no nonce" $+        isNothing (decodeJWS outerBytes :: Maybe (JWS.FlattenedJWS AcmeHeader))+    check "inner JWS, payload names the account and its old key" $+        fmap decodeValue innerPayload+            == Right+                ( Just $+                    object+                        [ "account" .= kid+                        , "oldKey" .= publicJWK oldJwk+                        ]+                )+  where+    verify :: (JWS.HasJWSHeader h, JWS.HasParams h) => JWK.JWK -> JWS.FlattenedJWS h -> IO (Either JWS.Error LByteString.ByteString)+    verify jwk jws = JWS.runJOSE (maybe (error "no public key") (\pub -> JWS.verifyJWS' pub jws) (view JWK.asPublicKey jwk))++    headers :: JWS.FlattenedJWS h -> [h JWS.Protection]+    headers = toListOf (JWS.signatures . JWS.header)++    decodeJWS :: (FromJSON a) => LByteString.ByteString -> Maybe a+    decodeJWS = decode++    decodeValue :: LByteString.ByteString -> Maybe Value+    decodeValue = decode++    preview' :: Either a b -> Maybe b+    preview' = either (const Nothing) Just++    isRight :: Either a b -> Bool+    isRight = either (const False) (const True)++    isNothing :: Maybe a -> Bool+    isNothing = maybe True (const False)++check :: String -> Bool -> IO ()+check name ok = do+    putStrLn $ (if ok then "ok   " else "FAIL ") <> name+    unless ok exitFailure

@@ -0,0 +1,261 @@+{-# LANGUAGE DataKinds #-}++-- | Round-trips of the PKI-formats helpers, and pure helpers of the dance.+module Main (main) where++import Control.Lens (preview, view)+import Control.Monad (forM_, unless)+import Data.Aeson (Value (..), decode, decodeStrict, encode, object, (.=))+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy as LByteString+import qualified Data.ByteString as ByteString+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Encoding+import System.Directory (getTemporaryDirectory, removeFile)+import System.Exit (exitFailure)+import System.FilePath ((</>))++import qualified Crypto.JOSE.JWK as JWK+import qualified Crypto.JOSE.JWS as JWS+import qualified Data.X509 as X509++import Acme.NotAJoke.Api.Account (deactivateAccountPayload)+import Acme.NotAJoke.Api.Authorization+import Acme.NotAJoke.Api.CSR+import Acme.NotAJoke.Api.Challenge (Challenge (..), Token (..), isDNS01, isHTTP01)+import Acme.NotAJoke.Api.Endpoint (Endpoint (..))+import Acme.NotAJoke.Api.JWS (AcmeHeader, KID (..), acmeJWSAlg, jwkSign, kidSign, setAcmeJWSAlg)+import Acme.NotAJoke.Api.Nonce (Nonce (..))+import Acme.NotAJoke.Api.Revocation+import Acme.NotAJoke.CertManagement+import Acme.NotAJoke.Client (dns01RecordName, isWildcardDomain, pickChallenges, wildcardBase)+import Acme.NotAJoke.KeyManagement++main :: IO ()+main = do+    tmp <- getTemporaryDirectory+    let keyPath = tmp </> "acme-not-a-joke-test.key.pem"+    let csrPath = tmp </> "acme-not-a-joke-test.csr"++    key <- genRSAKey 2048++    -- keys+    check "RSA key, DER round-trip" $+        decodeRSAKeyDER (encodeRSAKeyDER key) == Right key+    check "RSA key, PEM round-trip" $+        decodeRSAKeyPEM (encodeRSAKeyPEM key) == Right key+    check "RSA key, JWK round-trip" $+        jwkToRSAKey (jwkFromRSAKey key) == Right key+    check "RSA key, not a key" $+        isLeft (decodeRSAKeyPEM "garbage")+    writeRSAKeyPEM key keyPath+    loaded <- loadRSAKeyPEM keyPath+    check "RSA key, file round-trip" $+        loaded == Right key+    reloaded <- loadOrCreateRSAKeyPEM keyPath+    check "RSA key, existing file is kept" $+        reloaded == Right key+    removeFile keyPath++    -- CSRs+    Right csr <- createCSR key ("example.dicioccio.fr" :| ["*.example.dicioccio.fr"])+    check "CSR, PEM round-trip" $+        (encodeCSRPEM csr >>= decodeCSRPEM >>= csrToDER) == csrToDER csr+    Right () <- writeCSRPEM csr csrPath+    fromPEM <- loadCSR csrPath+    check "CSR, PEM file round-trip" $+        (fromPEM >>= csrToDER) == csrToDER csr+    Right () <- writeCSRDER csr csrPath+    fromDER <- loadCSR csrPath+    check "CSR, DER file round-trip" $+        (fromDER >>= csrToDER) == csrToDER csr+    legacy <- loadDER csrPath+    check "CSR, same as loadDER" $+        csrToDER (CSR legacy) == csrToDER csr+    removeFile csrPath+    invalid <- createCSR key ("exämple.dicioccio.fr" :| [])+    check "CSR, non-ASCII names are rejected" $+        isLeft (invalid >>= csrToDER)++    -- certificates+    check "certificates, PEM round-trip" $+        fmap encodeCertificateChain (decodeCertificateChain (certificate <> certificate))+            == Right (certificate <> certificate)+    check "certificates, not a certificate" $+        isLeft (decodeCertificateChain "-----BEGIN CERTIFICATE-----\nAAAA\n-----END CERTIFICATE-----\n")++    -- account deactivation+    check "account deactivation, payload" $+        decode "{\"status\":\"deactivated\"}" == Just deactivateAccountPayload++    -- wildcard orders+    check "wildcard, base domain" $+        wildcardBase "*.example.com" == "example.com" && wildcardBase "example.com" == "example.com"+    check "wildcard, detected" $+        isWildcardDomain "*.example.com" && not (isWildcardDomain "example.com")+    check "dns-01, record name of a domain" $+        dns01RecordName (AuthorizationIdentifier DNSAuthorization "example.com") == "_acme-challenge.example.com"+    check "dns-01, record name of a wildcard is the one of its base domain" $+        dns01RecordName (AuthorizationIdentifier DNSAuthorization "*.example.com") == "_acme-challenge.example.com"+    Just wildcardAuthz <- pure $ decodeAuthorization (authorizationJSON "pending" True)+    Just apexAuthz <- pure $ decodeAuthorization (authorizationJSON "pending" False)+    Just reusedAuthz <- pure $ decodeAuthorization (authorizationJSON "valid" False)+    Just expiredAuthz <- pure $ decodeAuthorization (authorizationJSON "expired" False)+    check "authorization, wildcard flag is read" $+        wildcard wildcardAuthz == Just True && wildcard apexAuthz == Nothing+    check "dns-01, wildcard and apex both get a challenge" $+        fmap (map (\(tag, _, _) -> tag)) (pickChallenges isDNS01 [(1 :: Int, wildcardAuthz), (2, apexAuthz)]) == Right [1, 2]+    check "dns-01, challenges of wildcard and apex have their own tokens" $+        fmap (map (\(_, _, c) -> challengeToken c)) (pickChallenges isDNS01 [(1 :: Int, wildcardAuthz), (2, apexAuthz)])+            == Right [Token "dns-token-wildcard", Token "dns-token-apex"]+    check "dns-01, valid authorizations are skipped" $+        fmap (map (\(tag, _, _) -> tag)) (pickChallenges isDNS01 [(1 :: Int, wildcardAuthz), (2, reusedAuthz)]) == Right [1]+    check "http-01, a wildcard cannot be validated" $+        either fst (const 0) (pickChallenges isHTTP01 [(1 :: Int, apexAuthz), (2, wildcardAuthz)]) == 2+    check "an expired authorization fails the order" $+        isLeft (pickChallenges isDNS01 [(1 :: Int, expiredAuthz)])++    -- revocations+    Right [cert] <- pure $ decodeCertificateChain certificate+    -- (a Base64DER holds base64url content, which csrToDER decodes)+    Right der <- pure $ csrToDER (CSR (revokedCertificate (revocation Nothing cert)))+    check "revocation, certificate is sent in base64url DER" $+        fmap (encodeCertificateChain . pure) (X509.decodeSignedCertificate der) == Right certificate+    check "revocation, payload without reason" $+        decode (serializeRevocation (revocation Nothing cert))+            == Just (object ["certificate" .= revokedCertificate (revocation Nothing cert)])+    check "revocation, payload with reason" $+        decode (serializeRevocation (revocation (Just KeyCompromise) cert))+            == Just (object ["certificate" .= revokedCertificate (revocation Nothing cert), "reason" .= (1 :: Int)])+    check "revocation, reason codes skip 7" $+        map revocationReasonCode [minBound .. maxBound] == [0, 1, 2, 3, 4, 5, 6, 8, 9, 10]+    let ep = Endpoint "https://acme.test/revoke-cert" :: Endpoint "revokeCert"+    let payload = serializeRevocation (revocation Nothing cert)+    byCertKey <- jwkSign (jwkFromRSAKey key) ep (Nonce "nonce") payload+    check "revocation, signed with the certificate key carries a jwk" $+        protectedHeaderHas "jwk" (encode <$> byCertKey) && not (protectedHeaderHas "kid" (encode <$> byCertKey))+    byAccount <- kidSign (jwkFromRSAKey key) ep (KID "https://acme.test/acct/1") (Nonce "nonce") payload+    check "revocation, signed with the account carries a kid" $+        protectedHeaderHas "kid" (encode <$> byAccount) && not (protectedHeaderHas "jwk" (encode <$> byAccount))++    -- JWS algorithms+    let rsa = jwkFromRSAKey key+    ecP256 <- genJWKecP256+    ecP384 <- genJWKecP384+    ed25519 <- genJWKed25519+    oct <- JWK.genJWK (JWK.OctGenParam 32)+    check "JWS alg, from the key" $+        (map acmeJWSAlg [rsa, ecP256, ecP384, ed25519] :: [Either JWS.Error JWS.Alg])+            == map Right [JWS.RS256, JWS.ES256, JWS.ES384, JWS.EdDSA]+    check "JWS alg, symmetric keys are refused" $+        isLeft (acmeJWSAlg oct :: Either JWS.Error JWS.Alg)+    check "JWS alg, pinned by the key" $+        acmeJWSAlg (setAcmeJWSAlg JWS.PS256 rsa) == (Right JWS.PS256 :: Either JWS.Error JWS.Alg)+    check "JWS alg, MAC algorithms cannot be pinned" $+        isLeft (acmeJWSAlg (setAcmeJWSAlg JWS.HS256 oct) :: Either JWS.Error JWS.Alg)+    let kid = KID "https://acme.test/acct/1"+    forM_ [("RS256", rsa), ("ES256", ecP256), ("ES384", ecP384), ("EdDSA", ed25519), ("PS256", setAcmeJWSAlg JWS.PS256 rsa)] $ \(alg, jwk) -> do+        byJwk <- jwkSign jwk ep (Nonce "nonce") payload+        check ("JWS alg, jwk signature with " <> alg) =<< verifiesWith jwk byJwk+        check ("JWS alg, jwk header announces " <> alg) $+            protectedHeaderParam "alg" (encode <$> byJwk) == Just (String (Text.pack alg))+        byKid <- kidSign jwk ep kid (Nonce "nonce") payload+        check ("JWS alg, kid signature with " <> alg) =<< verifiesWith jwk byKid+        check ("JWS alg, kid header announces " <> alg) $+            protectedHeaderParam "alg" (encode <$> byKid) == Just (String (Text.pack alg))+    mismatched <- kidSign (setAcmeJWSAlg JWS.ES256 rsa) ep kid (Nonce "nonce") payload+    check "JWS alg, an algorithm which does not fit the key fails" $+        isLeft mismatched+    byOct <- kidSign oct ep kid (Nonce "nonce") payload+    check "JWS alg, signing with a symmetric key fails" $+        isLeft byOct+  where+    isLeft :: Either a b -> Bool+    isLeft = either (const True) (const False)++{- | Whether the protected header of a (JSON-serialized, flattened) JWS has a+given parameter.+-}+protectedHeaderHas :: KeyMap.Key -> Either e LByteString.ByteString -> Bool+protectedHeaderHas param = maybe False (const True) . protectedHeaderParam param++{- | A parameter of the protected header of a (JSON-serialized, flattened)+JWS.+-}+protectedHeaderParam :: KeyMap.Key -> Either e LByteString.ByteString -> Maybe Value+protectedHeaderParam param (Right jws) =+    case decode jws of+        Just (Object o) | Just (String protected) <- KeyMap.lookup "protected" o ->+            case decodeStrict =<< preview JWK.base64url (Encoding.encodeUtf8 protected) of+                Just (Object hdr) -> KeyMap.lookup param hdr+                _ -> Nothing+        _ -> Nothing+protectedHeaderParam _ (Left _) = Nothing++-- | Whether a JWS was signed (successfully) by the public part of a key.+verifiesWith :: JWK.JWK -> Either JWS.Error (JWS.FlattenedJWS AcmeHeader) -> IO Bool+verifiesWith jwk (Right jws) =+    case view JWK.asPublicKey jwk of+        Nothing -> pure False+        Just pub -> do+            res <- JWS.runJOSE (JWS.verifyJWS' pub jws) :: IO (Either JWS.Error LByteString.ByteString)+            pure $ either (const False) (const True) res+verifiesWith _ (Left _) = pure False++decodeAuthorization :: LByteString.ByteString -> Maybe (Authorization "authorization-inspected")+decodeAuthorization = decode++challengeToken :: Challenge "challenge-unspecified" -> Token+challengeToken = token++{- | An authorization for example.com, in the shape Let's Encrypt gives:+wildcard authorizations only offer a DNS-01 challenge.+-}+authorizationJSON :: LByteString.ByteString -> Bool -> LByteString.ByteString+authorizationJSON st isWildcard =+    mconcat+        [ "{\"status\":\"" <> st <> "\""+        , ",\"identifier\":{\"type\":\"dns\",\"value\":\"example.com\"}"+        , ",\"expires\":\"2026-10-29T20:00:00Z\""+        , ",\"challenges\":["+        , if isWildcard+            then challengeJSON "dns-01" "dns-token-wildcard"+            else challengeJSON "http-01" "http-token-apex" <> "," <> challengeJSON "dns-01" "dns-token-apex"+        , "]"+        , if isWildcard then ",\"wildcard\":true" else ""+        , "}"+        ]+  where+    challengeJSON ty tok =+        "{\"type\":\"" <> ty <> "\",\"url\":\"https://acme.test/chall/" <> tok <> "\",\"status\":\"pending\",\"token\":\"" <> tok <> "\"}"++check :: String -> Bool -> IO ()+check name ok = do+    putStrLn $ (if ok then "ok   " else "FAIL ") <> name+    unless ok exitFailure++-- | A self-signed certificate from `openssl req -x509`.+certificate :: ByteString.ByteString+certificate =+    "\+    \-----BEGIN CERTIFICATE-----\n\+    \MIIDHzCCAgegAwIBAgIUe6GwrrJYtHXoUUvOfo+0k65J9b8wDQYJKoZIhvcNAQEL\n\+    \BQAwHzEdMBsGA1UEAwwUZXhhbXBsZS5kaWNpb2NjaW8uZnIwHhcNMjYxMDAzMjAw\n\+    \NTU4WhcNMzYwOTMwMjAwNTU4WjAfMR0wGwYDVQQDDBRleGFtcGxlLmRpY2lvY2Np\n\+    \by5mcjCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAI5pzazL8wVF1rLi\n\+    \yC+gf24C0p5bnC/7Qcis7778BEbhf/inyvSh4MIb478OB4HCMgxwACZPx5v4+G+i\n\+    \eJRC2+rfF6j8aP6Q6uLNviS6n3gzlY0HvUdd7RblwSvDJBsgXhaW244EM1V+eaDk\n\+    \pS89WlRgvS0loIIxS2c4qZO5JtLCVaeXuCXjRZRd7fzvPiGjRePr3+yNvm/ni0VN\n\+    \hYpg/6BIJ/fvWznnex8GNVL1/PH0EWW3p+GUn+64kHDlO0GhCnssP0DzU4DVKWVq\n\+    \FTjVjVq74gA7F3VcXxQRzNDnySJmnI7PlafF8E55Wi7kdHhbXD5WAFj8PdxqAfil\n\+    \GzMBJnkCAwEAAaNTMFEwHQYDVR0OBBYEFAtAWeP1+UJzfxKHf7gynaAtDYz3MB8G\n\+    \A1UdIwQYMBaAFAtAWeP1+UJzfxKHf7gynaAtDYz3MA8GA1UdEwEB/wQFMAMBAf8w\n\+    \DQYJKoZIhvcNAQELBQADggEBABqTTUXnNc//sjXn+PCjhUPZ5RBJ/W624pH7MwIT\n\+    \9xncI0zkkp5OMyLzwCIVwlkA//y/5Sv7zSRXAGwrUajKR8hmBGE1q8yE0fwv6Drj\n\+    \6LxXScSjpTbXtLdvuRU/CcV+xToc3ApfyyB37XOtugUxPizHHxeFQxF2aBSLToXZ\n\+    \15MQ9w+JIgLJP/cFrSKYHGgqrTdQOZ/ouSpGBpwu7jWioN5HaL4WLWyX0GTzX4SV\n\+    \foVtfxa84UV77PyoQ8m0VH2zilqvgRld2NKUIGABrSJeHiVvZ7++fLrDY5llzT2K\n\+    \4PixgIzdV81Bt88QEvMdDZcf3SSbRS018YfqTqNbs7ntG8k=\n\+    \-----END CERTIFICATE-----\n\+    \"