acme: Add ACME service.

* guix/forge/acme.scm: Import shadow from (gnu packages admin),
nss-certs from (gnu packages certs), (gnu services), (gnu services
mcron), (gnu system shadow), (guix diagnostics), (guix i18n), (guix
profiles), (guix records), (srfi srfi-1) and (ice-9 match).
(%letsencrypt-production-url, %letsencrypt-staging-url): New
variables.
(<acme-configuration>, <acme-rsa-key>, <acme-ecdsa-key>,
<acme-certificate>): New record types.
(acme-http-01-webroot-authorization-hook,
acme-http-01-webroot-cleanup-hook): New public functions.
(acme-key-length, uacme-hook, acme-activation, acme-renew,
acme-helper, acme-helper-sudo-wrapper, acme-special-files,
acme-cron-job, raise-to-top): New functions.
(%acme-accounts, acme-service-type): New variables.
* doc/forge.skb (Services)[ACME service]: New section.

1 files changed, 431 insertions, 1 deletions

diff --git a/guix/forge/acme.scm b/guix/forge/acme.scm
index ee715ae..690f1e4 100644
--- a/guix/forge/acme.scm
+++ b/guix/forge/acme.scm
@@ -18,16 +18,57 @@
 ;;; <https://www.gnu.org/licenses/>.
 
 (define-module (forge acme)
+  #:use-module ((gnu packages admin) #:select (shadow))
   #:use-module ((gnu packages autotools) #:select (autoconf automake))
+  #:use-module ((gnu packages certs) #:select (nss-certs))
   #:use-module ((gnu packages curl) #:select (curl))
   #:use-module ((gnu packages documentation) #:select (asciidoc))
   #:use-module ((gnu packages pkg-config) #:select (pkg-config))
   #:use-module ((gnu packages tls) #:select (gnutls))
+  #:use-module (gnu services)
+  #:use-module (gnu services mcron)
+  #:use-module (gnu system shadow)
   #:use-module (guix build-system gnu)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
   #:use-module (guix git-download)
+  #:use-module (guix i18n)
   #:use-module ((guix licenses) #:prefix license:)
-  #:use-module (guix packages))
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix records)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (acme-service-type
+            <acme-configuration>
+            acme-configuration
+            acme-configuration?
+            acme-configuration-uacme
+            acme-configuration-email
+            acme-configuration-acme-url
+            acme-configuration-state-directory
+            acme-configuration-http-01-challenge-directory
+            acme-configuration-http-01-authorization-hook
+            acme-configuration-http-01-cleanup-hook
+            acme-configuration-key
+            acme-configuration-certificates
+            %letsencrypt-production-url
+            %letsencrypt-staging-url
+            acme-http-01-webroot-authorization-hook
+            acme-http-01-webroot-cleanup-hook
+            <acme-rsa-key>
+            acme-rsa-key
+            acme-rsa-key?
+            acme-rsa-key-length
+            <acme-ecdsa-key>
+            acme-ecdsa-key
+            acme-ecdsa-key?
+            acme-ecdsa-key-length
+            <acme-certificate>
+            acme-certificate
+            acme-certificate?
+            acme-certificate-domains
+            acme-certificate-deploy-hook))
 
 (define-public uacme
   (package
@@ -77,3 +118,392 @@ challenge environment to the user or hook.
 uacme also includes ualpn, a lightweight proxying tls-alpn-01
 challenge responder compliant with RFC8737 and RFC8738.")
     (license license:gpl3+)))
+
+(define-record-type* <acme-rsa-key>
+  acme-rsa-key make-acme-rsa-key
+  acme-rsa-key?
+  (length acme-rsa-key-length
+          (default 2048)
+          (sanitize sanitize-acme-rsa-key-length)))
+
+(define (sanitize-acme-rsa-key-length length)
+  (if (and (zero? (remainder length 8))
+           (>= length 2048)
+           (<= length 8192))
+      length
+      (leave (G_ "RSA ACME key length ~a is invalid. It must be a multiple of 8 between 2048 and 8192.~%")
+             length)))
+
+(define-record-type* <acme-ecdsa-key>
+  acme-ecdsa-key make-acme-ecdsa-key
+  acme-ecdsa-key?
+  (length acme-ecdsa-key-length
+          (default 256)
+          (sanitize sanitize-acme-ecdsa-key-length)))
+
+(define (sanitize-acme-ecdsa-key-length length)
+  (if (memv length (list 256 384))
+      length
+      (leave (G_ "ECDSA ACME key length ~a is invalid. It must either be 256 or 384.~%")
+             length)))
+
+(define (acme-key-length key)
+  (cond
+   ((acme-rsa-key? key)
+    (acme-rsa-key-length key))
+   ((acme-ecdsa-key? key)
+    (acme-ecdsa-key-length key))))
+
+(define %letsencrypt-production-url
+  "https://acme-v02.api.letsencrypt.org/directory")
+
+(define %letsencrypt-staging-url
+  "https://acme-staging-v02.api.letsencrypt.org/directory")
+
+(define-record-type* <acme-configuration>
+  acme-configuration make-acme-configuration
+  acme-configuration?
+  this-acme-configuration
+  (uacme acme-configuration-uacme
+         (default uacme))
+  (email acme-configuration-email
+         (default #false))
+  (acme-url acme-configuration-acme-url
+            (default %letsencrypt-production-url))
+  (state-directory acme-configuration-state-directory
+                   (default "/var/lib/acme"))
+  (http-01-challenge-directory acme-configuration-http-01-challenge-directory
+                               (default "/var/run/acme/acme-challenge"))
+  (http-01-authorization-hook acme-configuration-http-01-authorization-hook
+                              (default (program-file "acme-http-01-authorization-hook"
+                                                     (acme-http-01-webroot-authorization-gexp this-acme-configuration)))
+                              (thunked))
+  (http-01-cleanup-hook acme-configuration-http-01-cleanup-hook
+                        (default (program-file "acme-http-01-cleanup-hook"
+                                               (acme-http-01-webroot-cleanup-gexp this-acme-configuration)))
+                        (thunked))
+  (key acme-configuration-key
+       (default (acme-ecdsa-key))
+       (sanitize sanitize-acme-key))
+  (certificates acme-configuration-certificates
+                (default '())))
+
+(define (sanitize-acme-key key)
+  (if (or (acme-rsa-key? key)
+          (acme-ecdsa-key? key))
+      key
+      (leave (G_ "Unsupported ACME key ~s~%")
+             key)))
+
+(define-record-type* <acme-certificate>
+  acme-certificate make-acme-certificate?
+  acme-certificate?
+  (domains acme-certificate-domains)
+  (deploy-hook acme-certificate-deploy-hook
+               (default #false)))
+
+(define (acme-http-01-webroot-authorization-gexp config)
+  "Return a HTTP-01 authorization G-expression for the ACME service
+described by @var{config}. The G-expression installs a challenge file
+in the configured challenge directory."
+  (match-record config <acme-configuration>
+    (http-01-challenge-directory)
+    #~(begin
+        (use-modules (srfi srfi-26)
+                     (ice-9 match))
+
+        (match (command-line)
+          ((_ identifier token auth)
+           (let ((challenge-file (string-append #$http-01-challenge-directory "/" token)))
+             (call-with-output-file challenge-file
+               (cut display auth <>))))))))
+
+(define (acme-http-01-webroot-cleanup-gexp config)
+  "Return a HTTP-01 cleanup G-expression for the ACME service described
+by @var{config}. The G-expression cleans up the challenge file
+installed by the authorization hook in the configured challenge
+directory."
+  (match-record config <acme-configuration>
+    (http-01-challenge-directory)
+    #~(begin
+        (use-modules (ice-9 match))
+
+        (match (command-line)
+          ((_ identifier token auth)
+           (delete-file (string-append #$http-01-challenge-directory "/" token)))))))
+
+(define (uacme-hook-gexp config)
+  "Put together authorization and cleanup hooks described in
+@var{config} into a hook suitable for passing to uacme."
+  (match-record config <acme-configuration>
+    (http-01-authorization-hook http-01-cleanup-hook)
+    (with-imported-modules '((guix build utils))
+      #~(begin
+          (use-modules (guix build utils)
+                       (ice-9 match))
+
+          (match (command-line)
+            ((_ "begin" "http-01" identifier token auth)
+             (invoke #$http-01-authorization-hook
+                     identifier token auth))
+            ((_ (or "done" "failed") "http-01" identifier token auth)
+             (invoke #$http-01-cleanup-hook
+                     identifier token auth))
+            ;; Decline other types of challenges.
+            (_ (exit #false)))))))
+
+(define %acme-accounts
+  (list (user-account
+         (name "acme")
+         (group "acme")
+         (system? #true)
+         (comment "ACME user")
+         (home-directory "/var/empty")
+         (shell (file-append shadow "/sbin/nologin")))
+        (user-group
+         (name "acme")
+         (system? #true))))
+
+(define acme-activation
+  (match-record-lambda <acme-configuration>
+      (state-directory http-01-challenge-directory key certificates)
+    (with-imported-modules '((guix build utils))
+      #~(begin
+          (use-modules (guix build utils)
+                       (ice-9 match)
+                       (srfi srfi-26))
+
+          ;; Create state directory.
+          (mkdir-p #$state-directory)
+
+          ;; Create keys and self-signed certificates if none exist so
+          ;; that services (such as nginx) that need the certificates
+          ;; don't fail to start.
+          (for-each (match-lambda
+                      ((identifier certificate-template-file)
+                       (let* ((key-file (string-append #$state-directory "/private/" identifier "/key.pem"))
+                              (certificate-file (string-append #$state-directory "/" identifier "/cert.pem")))
+                         (unless (and (file-exists? key-file)
+                                      (file-exists? certificate-file))
+                           (mkdir-p (dirname key-file))
+                           (invoke #$(file-append gnutls "/bin/certtool")
+                                   "--generate-privkey"
+                                   "--key-type" #$(cond
+                                                   ((acme-rsa-key? key) "rsa")
+                                                   ((acme-ecdsa-key? key) "ecdsa"))
+                                   "--bits" #$(number->string (acme-key-length key))
+                                   "--outfile" key-file)
+                           (chmod key-file #o400)
+                           (mkdir-p (dirname certificate-file))
+                           (invoke #$(file-append gnutls "/bin/certtool")
+                                   "--generate-self-signed"
+                                   "--template" certificate-template-file
+                                   "--load-privkey" key-file
+                                   "--outfile" certificate-file)))))
+                    '#$(map (match-record-lambda <acme-certificate>
+                                (domains)
+                              (let ((identifier (first domains)))
+                                (list identifier
+                                      (plain-file "certtool-template.cfg"
+                                                  (format #f
+                                                          "cn = \"~a\"
+expiration_days = 1
+~{dns_name = \"~a\"~%~}
+signing_key
+encryption_key
+tls_www_server
+"
+                                                          identifier
+                                                          domains)))))
+                            certificates))
+
+          ;; Set ownership of state directory and its contents.
+          (let ((user (getpw "acme")))
+            (for-each (cut chown <> (passwd:uid user) (passwd:gid user))
+                      (find-files #$state-directory #:directories? #t))
+
+            ;; Create challenge directory and make it world readable,
+            ;; but only writable by the acme user.
+            (mkdir-p #$http-01-challenge-directory)
+            (chown #$http-01-challenge-directory (passwd:uid user) (passwd:gid user))
+            (chmod #$http-01-challenge-directory #o755))
+
+          ;; Advise user about setup unless account key already
+          ;; exists.
+          (unless (file-exists? #$(string-append state-directory "/private/key.pem"))
+            (display "
+If this is the first time you are using the acme service, please
+register by running `/usr/bin/acme register' and initialize your
+certificates by running `/usr/bin/acme renew'
+
+"))))))
+
+(define* (acme-renew config #:key quiet?)
+  "Return a G-expression that renews certificates described in
+@var{config}. Unless @var{quiet?} is #true, be verbose."
+  (match-record config <acme-configuration>
+    (uacme email acme-url state-directory key certificates)
+    (with-imported-modules '((guix build utils))
+      #~(begin
+          (use-modules (guix build utils))
+
+          ;; Set path to TLS certificates for verification of HTTPS
+          ;; servers.
+          (setenv "SSL_CERT_FILE"
+                  #$(file-append (profile
+                                  (content (packages->manifest (list curl nss-certs))))
+                                 "/etc/ssl/certs/ca-certificates.crt"))
+
+          ;; Register ACME account if account does not already exist. We
+          ;; assume the presence of an account key implies the existence
+          ;; of an account.
+          (unless (file-exists? #$(string-append state-directory "/private/key.pem"))
+            (system* #$(file-append uacme "/bin/uacme")
+                     "--verbose"
+                     "--confdir" #$state-directory
+                     "--acme-url" #$acme-url
+                     "--yes"
+                     "new"
+                     #$@(if email
+                            (list email)
+                            (list))))
+
+          ;; Renew configured certificates.
+          (for-each (match-lambda
+                      ((domains deploy-hook)
+                       ;; uacme returns 0 on successful renewal, 1 when
+                       ;; there is no need to renew, and 2 on other
+                       ;; failures.
+                       (case (status:exit-val
+                              (apply system*
+                                     #$(file-append uacme "/bin/uacme")
+                                     "--confdir" #$state-directory
+                                     "--acme-url" #$acme-url
+                                     "--type" #$(cond
+                                                 ((acme-rsa-key? key) "RSA")
+                                                 ((acme-ecdsa-key? key) "EC"))
+                                     "--bits" #$(number->string (acme-key-length key))
+                                     "--hook" #$(program-file "uacme-hook"
+                                                              (uacme-hook-gexp config))
+                                     "issue"
+                                     #$@(if quiet?
+                                            (list)
+                                            (list "--verbose"))
+                                     domains))
+                         ((0) (invoke deploy-hook))
+                         ((2) (exit #false)))))
+                    '#$(map (match-record-lambda <acme-certificate>
+                                (domains deploy-hook)
+                              (list domains
+                                    deploy-hook))
+                            certificates))))))
+
+(define (acme-helper config)
+  "Return a G-expression for a interactive ACME helper tool. Bake in
+parameters described in @var{config}."
+  (match-record config <acme-configuration>
+    (uacme state-directory acme-url email)
+    #~(begin
+        (use-modules (ice-9 match))
+
+        (match (command-line)
+          ((command "renew")
+           #$(acme-renew config))
+          ((command _ ...)
+           (format (current-error-port)
+                   "Usage: ~a COMMAND
+
+Valid COMMANDs are
+
+renew: Issue or renew configured certificates
+
+"
+                   command)
+           (exit #false))))))
+
+(define (acme-helper-sudo-wrapper config)
+  #~(begin
+      (use-modules (ice-9 match))
+
+      (match (command-line)
+        ((_ arguments ...)
+         (apply system*
+                ;; We cannot refer to sudo in the store since that sudo
+                ;; does not have the setuid bit set. See "(guix) Setuid
+                ;; Programs".
+                "/run/setuid-programs/sudo"
+                "--user" "acme"
+                "--group" "acme"
+                #$(program-file "acme-helper" (acme-helper config))
+                arguments)))))
+
+(define (acme-special-files config)
+  `(("/usr/bin/acme" ,(program-file "acme"
+                                    (acme-helper-sudo-wrapper config)))))
+
+(define (acme-cron-job config)
+  ;; Attempt to renew certificates once a day, at a random minute
+  ;; within the day. This helps even out the load on the ACME
+  ;; server.
+  #~(job '(next-minute-from (next-hour '(0))
+                            (list (random (* 24 60))))
+         #$(program-file "acme-renew-cron"
+                         (acme-renew config #:quiet? #true))
+         #:user "acme"))
+
+(define (raise-to-top pred lst)
+  "Reorder @var{lst} so that the first element that satisfies @var{pred}
+is the first element. The order of the remaining elements is
+unspecified. If no element matching @var{pred} is found, return
+@code{#f}."
+  (and (find pred lst)
+       (append (find-tail pred lst)
+               (take-while (negate pred) lst))))
+
+(define acme-service-type
+  (service-type
+   (name 'acme)
+   (description "Automatically fetch and renew ACME certificates.")
+   (extensions (list (service-extension account-service-type
+                                        (const %acme-accounts))
+                     (service-extension activation-service-type
+                                        acme-activation)
+                     (service-extension special-files-service-type
+                                        acme-special-files)
+                     (service-extension mcron-service-type
+                                        (compose list acme-cron-job))))
+   (compose concatenate)
+   (extend (lambda (config certificates)
+             (acme-configuration
+              (inherit config)
+              (certificates
+               ;; Append new certificates onto existing ones. When any
+               ;; of the new certificates are for the same domains as
+               ;; existing certificates, combine them into a single
+               ;; certificate.
+               (fold (lambda (certificate previous-certificates)
+                       (cond
+                        ((raise-to-top (lambda (this-certificate)
+                                         (lset= string=?
+                                                (acme-certificate-domains this-certificate)
+                                                (acme-certificate-domains certificate)))
+                                       previous-certificates)
+                         => (match-lambda
+                              ((matched-certificate other-certificates ...)
+                               (cons (acme-certificate
+                                      (inherit certificate)
+                                      ;; Combine deploy hooks of the
+                                      ;; two certificates.
+                                      (deploy-hook
+                                       (with-imported-modules '((guix build utils))
+                                         #~(begin
+                                             (use-modules (guix build utils))
+
+                                             (invoke #$(acme-certificate-deploy-hook certificate))
+                                             (invoke #$(acme-certificate-deploy-hook matched-certificate))))))
+                                     other-certificates))))
+                        (else
+                         (cons certificate previous-certificates))))
+                     (acme-configuration-certificates config)
+                     certificates)))))
+   (default-value (acme-configuration))))