From d87de0b58c6be0772c3f02bd53b067ee82533004 Mon Sep 17 00:00:00 2001
From: Vivien <vivien@pruneau.lan>
Date: Fri, 29 Oct 2021 14:36:15 +0200
Subject: Add a guix system service to convert GPG keys to SSH authorized keys

---
 vkraus/services/guix-wot.scm | 121 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 121 insertions(+)
 create mode 100644 vkraus/services/guix-wot.scm

diff --git a/vkraus/services/guix-wot.scm b/vkraus/services/guix-wot.scm
new file mode 100644
index 0000000..bb2fa5d
--- /dev/null
+++ b/vkraus/services/guix-wot.scm
@@ -0,0 +1,121 @@
+(define-module (vkraus services guix-wot)
+  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu services ssh)
+  #:use-module (gnu services admin)
+  #:use-module (gnu system shadow)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (guix records)
+  #:use-module (guix packages)
+  #:use-module (guix build-system minetest)
+  #:use-module (guix git-download)
+  #:use-module (guix build utils)
+  #:use-module (guix monads)
+  #:use-module (guix store)
+  #:use-module (gnu packages bash)
+  #:use-module (gnu packages minetest)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu packages gnupg)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 textual-ports)
+  #:use-module ((guix licenses) #:prefix license:)
+  #:declarative? #t
+  #:duplicates (merge-generics)
+  #:export
+  (
+   <guix-system-wot-configuration>
+   make-guix-system-wot-configuration
+   guix-system-wot-configuration?
+   guix-system-wot-configuration-users
+   guix-system-wot-configuration-key-servers
+
+   guix-system-wot-openssh
+   guix-system-wot-service-type
+
+   fetch-keys
+   ))
+
+;; This module defines a guix system service that converts GPG key
+;; fingerprints to authorized SSH keys. The public keys are pulled
+;; from key servers at reconfiguration time.
+
+(define-record-type <guix-system-wot-configuration>
+  (make-guix-system-wot-configuration users key-servers)
+  guix-system-wot-configuration?
+  (users guix-system-wot-configuration-users)
+  (key-servers guix-system-wot-configuration-key-servers))
+
+(define (fetch-keys fingerprints key-servers)
+  (with-imported-modules '((guix build utils))
+    (gexp->derivation
+        "gnupg-user-keys.gpg"
+      #~(begin
+          (use-modules (guix build utils))
+          (setenv "GNUPGHOME" (string-append (getcwd) "/gnupg"))
+          (invoke #$(file-append gnupg "/bin/gpg")
+                  "--import" "/var/cache/gnupg-user-keys.gpg")
+          (invoke #$(file-append gnupg "/bin/gpg")
+                  #$@(apply append
+                            (map
+                             (lambda (key-server)
+                               `("--keyserver" ,key-server))
+                             key-servers))
+                  "--recv-key"
+                  #$@fingerprints)
+          (invoke
+           #$(file-append gnupg "/bin/gpg")
+           "--export" "-a" "-o" #$output
+           #$@fingerprints)))))
+
+(define guix-system-wot-openssh
+  ;; This service will export all approved authentication keys for the
+  ;; openssh server to use.
+  (match-lambda
+    (($ <guix-system-wot-configuration> users key-servers)
+     (apply invoke
+            `(,(run-with-store (open-connection) (package-file gnupg "/bin/gpg"))
+              ,@(apply append
+                       (map
+                        (lambda (key-server)
+                          `("--keyserver" ,key-server))
+                        key-servers))
+              "--recv-key"
+              ,@(map cdr users)))
+     (par-map
+      (match-lambda
+        ((user . fingerprint)
+         `(,user
+           ,(let ((port (mkstemp "/tmp/user-key-file-XXXXXXXX")))
+              (invoke (run-with-store (open-connection) (package-file gnupg "/bin/gpg"))
+                      "-o" (port-filename port)
+                      "--export-ssh-key" fingerprint)
+              (let ((interned
+                     (plain-file (format #f "user-key-file-~a" fingerprint)
+                                 (get-string-all port))))
+                (delete-file (port-filename port))
+                interned)))))
+      users))))
+
+(define guix-system-wot-service-type
+  (service-type
+   (name 'guix-system-wot)
+   (extensions
+    (list
+     (service-extension openssh-service-type guix-system-wot-openssh)))
+   (compose
+    (lambda (extensions)
+      (apply append extensions)))
+   (extend
+    (lambda (base-configuration other-users)
+      (make-guix-system-wot-configuration
+       (append (guix-system-wot-configuration-users base-configuration)
+           other-users)
+       (guix-system-wot-configuration-key-servers base-configuration))))
+   (description
+    (format #f "Add every available authentication keys for each user
+as an auhorized SSH key."))))
-- 
cgit v1.2.3