From 8b3ad455be7e8ace35a2eaebf7fffbb611280852 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 10 Mar 2019 23:39:14 +0100
Subject: services: guix: Pre-compute the default ACL.

This makes the first boot slightly faster.

* gnu/services/base.scm (not-config?): New procedure.
(hydra-key-authorization): Rewrite to pre-compute the default ACL, and
pre-compute it using (guix pki) directly.
---
 gnu/services/base.scm | 69 +++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 51 insertions(+), 18 deletions(-)

(limited to 'gnu/services')

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index fffb7b301b..67df4d1379 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -43,6 +43,7 @@
                 #:select (canonical-package glibc glibc-utf8-locales))
   #:use-module (gnu packages bash)
   #:use-module (gnu packages package-management)
+  #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
   #:use-module (gnu packages linux)
   #:use-module (gnu packages terminals)
   #:use-module ((gnu build file-systems)
@@ -50,6 +51,7 @@
   #:use-module (guix gexp)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module ((guix self) #:select (make-config.scm))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -1502,27 +1504,58 @@ GID."
           1+
           1))
 
+(define not-config?
+  ;; Select (guix …) and (gnu …) modules, except (guix config).
+  (match-lambda
+    (('guix 'config) #f)
+    (('guix rest ...) #t)
+    (('gnu rest ...) #t)
+    (rest #f)))
+
 (define (hydra-key-authorization keys guix)
   "Return a gexp with code to register KEYS, a list of files containing 'guix
 archive' public keys, with GUIX."
-  #~(unless (file-exists? "/etc/guix/acl")
-      (for-each (lambda (key)
-                  (let ((pid (primitive-fork)))
-                    (case pid
-                      ((0)
-                       (let* ((port (open-file key "r0b")))
-                         (format #t "registering public key '~a'...~%" key)
-                         (close-port (current-input-port))
-                         (dup port 0)
-                         (execl #$(file-append guix "/bin/guix")
-                                "guix" "archive" "--authorize")
-                         (primitive-exit 1)))
-                      (else
-                       (let ((status (cdr (waitpid pid))))
-                         (unless (zero? status)
-                           (format (current-error-port) "warning: \
-failed to register public key '~a': ~a~%" key status)))))))
-                '(#$@keys))))
+  (define aaa
+    ;; XXX: Terrible hack to work around <https://bugs.gnu.org/15602>: this
+    ;; forces (guix config) and (guix utils) to be loaded upfront, so that
+    ;; their run-time symbols are defined.
+    (scheme-file "aaa.scm"
+                 #~(define-module (guix aaa)
+                     #:use-module (guix config)
+                     #:use-module (guix memoization))))
+
+  (define default-acl
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules `(((guix config) => ,(make-config.scm))
+                               ((guix aaa) => ,aaa)
+                               ,@(source-module-closure '((guix pki))
+                                                        #:select? not-config?))
+        (computed-file "acl"
+                       #~(begin
+                           (use-modules (guix pki)
+                                        (gcrypt pk-crypto)
+                                        (ice-9 rdelim))
+
+                           (define keys
+                             (map (lambda (file)
+                                    (call-with-input-file file
+                                      (compose string->canonical-sexp
+                                               read-string)))
+                                  '(#$@keys)))
+
+                           (call-with-output-file #$output
+                             (lambda (port)
+                               (write-acl (public-keys->acl keys)
+                                          port))))))))
+
+  (with-imported-modules '((guix build utils))
+    #~(begin
+        (use-modules (guix build utils))
+
+        (unless (file-exists? "/etc/guix/acl")
+          (mkdir-p "/etc/guix")
+          (copy-file #+default-acl "/etc/guix/acl")
+          (chmod "/etc/guix/acl" #o600)))))
 
 (define %default-authorized-guix-keys
   ;; List of authorized substitute keys.
-- 
cgit v1.2.3