diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Lucas DiCioccio (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,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). diff --git a/acme-not-a-joke.cabal b/acme-not-a-joke.cabal --- a/acme-not-a-joke.cabal +++ b/acme-not-a-joke.cabal @@ -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, diff --git a/src/Acme/NotAJoke/Api/Account.hs b/src/Acme/NotAJoke/Api/Account.hs --- a/src/Acme/NotAJoke/Api/Account.hs +++ b/src/Acme/NotAJoke/Api/Account.hs @@ -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 diff --git a/src/Acme/NotAJoke/Api/Authorization.hs b/src/Acme/NotAJoke/Api/Authorization.hs --- a/src/Acme/NotAJoke/Api/Authorization.hs +++ b/src/Acme/NotAJoke/Api/Authorization.hs @@ -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 diff --git a/src/Acme/NotAJoke/Api/CSR.hs b/src/Acme/NotAJoke/Api/CSR.hs --- a/src/Acme/NotAJoke/Api/CSR.hs +++ b/src/Acme/NotAJoke/Api/CSR.hs @@ -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) diff --git a/src/Acme/NotAJoke/Api/Certificate.hs b/src/Acme/NotAJoke/Api/Certificate.hs --- a/src/Acme/NotAJoke/Api/Certificate.hs +++ b/src/Acme/NotAJoke/Api/Certificate.hs @@ -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 diff --git a/src/Acme/NotAJoke/Api/Challenge.hs b/src/Acme/NotAJoke/Api/Challenge.hs --- a/src/Acme/NotAJoke/Api/Challenge.hs +++ b/src/Acme/NotAJoke/Api/Challenge.hs @@ -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) diff --git a/src/Acme/NotAJoke/Api/Directory.hs b/src/Acme/NotAJoke/Api/Directory.hs --- a/src/Acme/NotAJoke/Api/Directory.hs +++ b/src/Acme/NotAJoke/Api/Directory.hs @@ -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 diff --git a/src/Acme/NotAJoke/Api/Endpoint.hs b/src/Acme/NotAJoke/Api/Endpoint.hs --- a/src/Acme/NotAJoke/Api/Endpoint.hs +++ b/src/Acme/NotAJoke/Api/Endpoint.hs @@ -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) diff --git a/src/Acme/NotAJoke/Api/Field.hs b/src/Acme/NotAJoke/Api/Field.hs --- a/src/Acme/NotAJoke/Api/Field.hs +++ b/src/Acme/NotAJoke/Api/Field.hs @@ -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 diff --git a/src/Acme/NotAJoke/Api/JWS.hs b/src/Acme/NotAJoke/Api/JWS.hs --- a/src/Acme/NotAJoke/Api/JWS.hs +++ b/src/Acme/NotAJoke/Api/JWS.hs @@ -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 diff --git a/src/Acme/NotAJoke/Api/KeyChange.hs b/src/Acme/NotAJoke/Api/KeyChange.hs new file mode 100644 --- /dev/null +++ b/src/Acme/NotAJoke/Api/KeyChange.hs @@ -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 diff --git a/src/Acme/NotAJoke/Api/Meta.hs b/src/Acme/NotAJoke/Api/Meta.hs --- a/src/Acme/NotAJoke/Api/Meta.hs +++ b/src/Acme/NotAJoke/Api/Meta.hs @@ -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. diff --git a/src/Acme/NotAJoke/Api/Nonce.hs b/src/Acme/NotAJoke/Api/Nonce.hs --- a/src/Acme/NotAJoke/Api/Nonce.hs +++ b/src/Acme/NotAJoke/Api/Nonce.hs @@ -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 diff --git a/src/Acme/NotAJoke/Api/Order.hs b/src/Acme/NotAJoke/Api/Order.hs --- a/src/Acme/NotAJoke/Api/Order.hs +++ b/src/Acme/NotAJoke/Api/Order.hs @@ -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 diff --git a/src/Acme/NotAJoke/Api/Revocation.hs b/src/Acme/NotAJoke/Api/Revocation.hs new file mode 100644 --- /dev/null +++ b/src/Acme/NotAJoke/Api/Revocation.hs @@ -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 diff --git a/src/Acme/NotAJoke/Api/Validation.hs b/src/Acme/NotAJoke/Api/Validation.hs --- a/src/Acme/NotAJoke/Api/Validation.hs +++ b/src/Acme/NotAJoke/Api/Validation.hs @@ -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 $ diff --git a/src/Acme/NotAJoke/CertManagement.hs b/src/Acme/NotAJoke/CertManagement.hs --- a/src/Acme/NotAJoke/CertManagement.hs +++ b/src/Acme/NotAJoke/CertManagement.hs @@ -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 + ) diff --git a/src/Acme/NotAJoke/Client.hs b/src/Acme/NotAJoke/Client.hs --- a/src/Acme/NotAJoke/Client.hs +++ b/src/Acme/NotAJoke/Client.hs @@ -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 diff --git a/src/Acme/NotAJoke/Dancer.hs b/src/Acme/NotAJoke/Dancer.hs --- a/src/Acme/NotAJoke/Dancer.hs +++ b/src/Acme/NotAJoke/Dancer.hs @@ -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 diff --git a/src/Acme/NotAJoke/KeyManagement.hs b/src/Acme/NotAJoke/KeyManagement.hs --- a/src/Acme/NotAJoke/KeyManagement.hs +++ b/src/Acme/NotAJoke/KeyManagement.hs @@ -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) diff --git a/src/Acme/NotAJoke/LetsEncrypt.hs b/src/Acme/NotAJoke/LetsEncrypt.hs --- a/src/Acme/NotAJoke/LetsEncrypt.hs +++ b/src/Acme/NotAJoke/LetsEncrypt.hs @@ -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/" diff --git a/test/KeyChange.hs b/test/KeyChange.hs new file mode 100644 --- /dev/null +++ b/test/KeyChange.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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\ + \"