diff options
author | Vivien <vivien@pruneau.lan> | 2021-11-07 15:41:34 +0100 |
---|---|---|
committer | Vivien <vivien@pruneau.lan> | 2021-11-07 21:46:35 +0100 |
commit | ae9265b80a20498b85b72ce4b58d41db86503864 (patch) | |
tree | 308cb8d5710d35f311657682d9051aa65aa20d5e /vkraus | |
parent | 3b4427522e01e8f537a7b3a922854167a70e1ecd (diff) |
Diffstat (limited to 'vkraus')
-rw-r--r-- | vkraus/services/guix-wot-system.scm | 174 | ||||
-rw-r--r-- | vkraus/services/guix-wot.scm | 86 |
2 files changed, 183 insertions, 77 deletions
diff --git a/vkraus/services/guix-wot-system.scm b/vkraus/services/guix-wot-system.scm new file mode 100644 index 0000000..45c408f --- /dev/null +++ b/vkraus/services/guix-wot-system.scm @@ -0,0 +1,174 @@ +(define-module (vkraus services guix-wot-system) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu services ssh) + #:use-module (gnu services mcron) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix packages) + #:use-module (guix build utils) + #: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 (ice-9 receive) + #:use-module (oop goops) + #:declarative? #t + #:export + ( + <guix-system-wot-configuration> + users key-servers + guix-system-wot-service-type + )) + +;; 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 gpg-program + (file-append gnupg "/bin/gpg")) + +(define-class <guix-system-wot-configuration> () + (users + #:init-keyword #:users + #:accessor users + #:init-value '()) + (public-keys-file + #:init-keyword #:public-keys-file + #:accessor public-keys-file + #:init-value "/var/lib/user-keys.gpg") + (key-servers + #:init-keyword #:key-servers + #:accessor key-servers + #:init-value '())) + +(define-method (+ (main <guix-system-wot-configuration>) + (other <guix-system-wot-configuration>)) + (let ((ret (shallow-clone main))) + (set! (users ret) + (append (users main) (users other))) + (unless (public-keys-file ret) + (set! (public-keys-file ret) + (public-keys-file other))) + (set! (key-servers ret) + (append (key-servers main) (key-servers other))) + ret)) + +(define (sync-script configuration) + (program-file + "update-keys" + (with-imported-modules + (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (guix build utils)) + (let ((gpg #$gpg-program) + (all-public-keys + (list + #$@(apply append + (map (match-lambda + (((? string?) . (? string? fingerprint)) + (list fingerprint)) + (((? string?) (? string? fingerprint) ...) + fingerprint)) + (users configuration))))) + (file #$(public-keys-file configuration))) + (mkdir-p ".tmp-gnupg-home") + (setenv "GNUPGHOME" (string-append (getcwd) "/.tmp-gnupg-home")) + (catch #t + (lambda () + (invoke gpg "--import" file)) + (lambda _ #t)) + (apply invoke gpg + #$@(apply append + (map (cute list "--keyserver" <>) + (key-servers configuration))) + "--recv-key" + all-public-keys) + (catch #t + (lambda () + (delete-file (string-append file "~"))) + (lambda _ #t)) + (apply invoke gpg "--export" "-o" (string-append file "~") all-public-keys) + (catch #t + (lambda () + (delete-file (string-append (getcwd) "/.tmp-gnupg-home"))) + (lambda _ #t)) + (rename-file (string-append file "~") file)))))) + +(define (guix-system-wot-mcron-service configuration) + (let ((script (sync-script configuration))) + (list + (with-imported-modules + (source-module-closure + '((guix build utils))) + #~(job '(next-hour) + (lambda () + #$script)))))) + +(define (guix-system-wot-openssh-service configuration) + (let ((script (sync-script configuration))) + (map + (lambda (record) + (receive (user fingerprints) + (match record + ((user . fingerprint) + (values user (list fingerprint))) + ((user fingerprint ...) + (values user fingerprint))) + (let ((fingerprint-files + (map + (lambda (fingerprint) + (computed-file + (format #f "ssh-key-for-~a" user) + (with-imported-modules + (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (guix build utils)) + (format (current-error-port) "To synchronize the keys, please run ~a.\n" + #$script) + (let ((gpg #$gpg-program) + (repository + #$(catch #t + (lambda () + (local-file (public-keys-file configuration))) + (lambda exn + (let ((message + (format #f "Error: no keys have been downloaded yet. Please run ~a and reconfigure.\n" + script))) + (display message) + (apply throw exn)))))) + (setenv "GNUPGHOME" (getcwd)) + (invoke gpg "--import" repository) + (mkdir-p (dirname #$output)) + (invoke gpg "-o" #$output "--export-ssh-key" #$fingerprint)))))) + fingerprints))) + `(,user + ,@fingerprint-files)))) + (users configuration)))) + +(define guix-system-wot-service-type + (service-type + (name 'guix-system-wot) + (extensions + (list + (service-extension mcron-service-type guix-system-wot-mcron-service) + (service-extension openssh-service-type guix-system-wot-openssh-service))) + (compose + (lambda (extensions) + (apply append extensions))) + (extend + (lambda (base-configuration other-configurations) + (let fold-configurations ((cfgs other-configurations) + (total base-configuration)) + (match cfgs + (() total) + ((next cfgs ...) + (fold-configurations cfgs (+ total next))))))) + (description + (format #f "Add every available authentication keys for each user +as an auhorized SSH key.")))) diff --git a/vkraus/services/guix-wot.scm b/vkraus/services/guix-wot.scm index 5b53f9c..17880f6 100644 --- a/vkraus/services/guix-wot.scm +++ b/vkraus/services/guix-wot.scm @@ -1,8 +1,10 @@ (define-module (vkraus services guix-wot) + #:use-module (vkraus services guix-wot-system) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services ssh) #:use-module (gnu services admin) + #:use-module (gnu services mcron) #:use-module (gnu home services) #:use-module (gnu home services shells) #:use-module (gnu system shadow) @@ -26,20 +28,19 @@ #:use-module (ice-9 optargs) #:use-module (ice-9 threads) #:use-module (ice-9 textual-ports) + #:use-module (ice-9 receive) #:use-module ((guix licenses) #:prefix license:) + #:use-module (oop goops) #:declarative? #t #:duplicates (merge-generics) - #:export + #:re-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 + users key-servers guix-system-wot-service-type - + ) + #:export + ( <guix-home-wot-configuration> make-guix-home-wot-configuration guix-home-wot-configuration? @@ -51,75 +52,6 @@ guix-home-wot-service-type )) -;; 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 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) - (run-with-store - (open-connection) - (mlet %store-monad ((gpg (package-file gnupg "/bin/gpg"))) - (apply invoke - `(,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"))) - (with-exception-handler - (lambda (exn) - (format (current-error-port) "Warning: no SSH key exported for ~a ~a: ~a.\n" user fingerprint exn)) - (lambda () - (run-with-store - (open-connection) - (mlet %store-monad ((gpg (package-file gnupg "/bin/gpg"))) - (invoke gpg - "-o" (port-filename port) - "--export-ssh-key" fingerprint)))) - #:unwind? #t) - (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.")))) - (define-record-type <guix-home-wot-configuration> (make-guix-home-wot-configuration fingerprints) guix-home-wot-configuration? |