diff options
Diffstat (limited to 'vkraus/services/guix-wot-system.scm')
| -rw-r--r-- | vkraus/services/guix-wot-system.scm | 174 |
1 files changed, 174 insertions, 0 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.")))) |