(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 home services)
  #:use-module (gnu home services shells)
  #: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 (gnu packages gnome)
  #: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

   <guix-home-wot-configuration>
   make-guix-home-wot-configuration
   guix-home-wot-configuration?
   guix-home-wot-configuration-fingerprints

   guix-home-wot-bash
   guix-home-wot-zsh
   guix-home-wot-home-files
   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)
     (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."))))

(define-record-type <guix-home-wot-configuration>
  (make-guix-home-wot-configuration fingerprints)
  guix-home-wot-configuration?
  (fingerprints guix-home-wot-configuration-fingerprints))

(define %.profile
  (computed-file
   "run-gpg-agent-.profile"
   #~(call-with-output-file #$output
       (lambda (port)
         (let ((gpgconf
                #$(file-append gnupg "/bin/gpgconf"))
               (gpg-agent
                #$(file-append gnupg "/bin/gpg-agent")))
           (format port
                   "\
eval $(~a --daemon --enable-ssh-support)
export SSH_AUTH_SOCK=$(~a --list-dirs agent-ssh-socket --sh)
"
                   gpg-agent
                   gpgconf))))))

(define guix-home-wot-bash
  (match-lambda
    (($ <guix-home-wot-configuration> fingerprints)
     (home-bash-extension
      (bash-profile
       (list %.profile))))))

(define guix-home-wot-zsh
  (match-lambda
    (($ <guix-home-wot-configuration> fingerprints)
     (home-zsh-extension
      (zprofile
       (list %.profile))))))

(define guix-home-wot-home-files
  (match-lambda
    (($ <guix-home-wot-configuration> fingerprints)
     `(("gnupg/sshcontrol"
        ,(computed-file
          "sshcontrol"
          #~(call-with-output-file #$output
              (lambda (port)
                (for-each
                 (lambda (fingerprint)
                   (format port "~a\n" fingerprint))
                 '(#$@fingerprints))))))
       ("gnupg/gpg-agent.conf"
        ,(computed-file
          "gpg-agent.conf"
          #~(call-with-output-file #$output
              (lambda (port)
                (format port
                        "\
debug-level basic
pinentry-program ~a
enable-ssh-support
"
                        #$(file-append pinentry-gnome3 "/bin/pinentry"))))))
       ("config/autostart/gnome-keyring-ssh.desktop"
        ,(computed-file
          "gnome-keyring-ssh.desktop"
          #~(begin
              (use-modules (ice-9 textual-ports))
              (call-with-output-file #$output
                (lambda (port)
                  (format port "\
~a
X-GNOME-Autostart-enabled=false
"
                          (call-with-input-file
                              #$(file-append gnome-keyring
                                             "/etc/xdg/autostart/gnome-keyring-ssh.desktop")
                              get-string-all
                              #:encoding "ISO-8859-1")))
                #:encoding "ISO-8859-1"))))))))

(define guix-home-wot-service-type
  (service-type
   (name 'guix-home-wot)
   (extensions
    (list
     (service-extension home-bash-service-type guix-home-wot-bash)
     (service-extension home-zsh-service-type guix-home-wot-zsh)
     (service-extension home-files-service-type guix-home-wot-home-files)))
   (compose
    (lambda (extensions)
      (apply append extensions)))
   (extend
    (lambda (base-configuration other-fingerprints)
      (make-guix-home-wot-configuration
       (append (guix-home-wot-configuration-fingerprints base-configuration)
               other-fingerprints))))
   (description
    (format #f "Use the GPG agent to connect to SSH."))))