(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."))))