summaryrefslogtreecommitdiff
path: root/vkraus/services/guix-wot.scm
blob: a6996a8e9f4538170f51807b7d5710b8578f6384 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
(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
   ))

;; 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)
     (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")))
              (with-exception-handler
                  (lambda (exn)
                    (format (current-error-port) "Warning: no SSH key exported for ~a ~a: ~a.\n" user fingerprint exn))
                (lambda ()
                  (invoke (run-with-store (open-connection) (package-file gnupg "/bin/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."))))