gpg-agent.scm

gpg-agent.scm

(use-modules (ice-9 format) (ice-9 popen) (ice-9 rdelim) (ice-9 regex)
	     ((guix packages) #:select (package-file))
	     ((guix store) #:select (open-connection close-connection run-with-store))
	     ((gnu packages gnupg) #:select (gnupg pinentry-emacs)))


(define current-tty (ttyname (current-output-port)))

(define gpg-agent-description
  (format #f "GnuPG PGP and SSH agent on ~a" current-tty))

(define (package-command pkg cmd)
  (let*
      ((s (open-connection))
       (p (run-with-store s (package-file pkg cmd)))
       (c (close-connection s)))
    p))

(define gpg-agent-command (package-command gnupg "bin/gpg-agent"))
(define gpgconf-command (package-command gnupg "bin/gpgconf"))
(define pinentry-command (package-command pinentry-emacs "bin/pinentry-emacs"))

(define gpg-agent-daemon-command
  (list gpg-agent-command
	"--display" (format #f ":~a" (getenv "XDG_VTNR"))
	"--homedir" (string-append (getenv "HOME") "/.private/gnupg")
	"--pinentry-program" pinentry-command "--allow-emacs-pinentry"
	;; "--allow-preset-passphrase"
	"--max-cache-ttl" "14400"
	"--default-cache-ttl" "14400"
	"--max-cache-ttl-ssh" "14400"
	"--default-cache-ttl-ssh" "14400"
	"--enable-ssh-support"
	"--daemon"))

(define gpg-agent-kill-command
  (format #f "~a --kill gpg-agent" gpgconf-command))

(define* (gpg-agent-start #:optional . args)
  (let*
      ((port (apply open-pipe* OPEN_READ gpg-agent-daemon-command))
       (output (read-string port))
       (match-res (string-match "\\`SSH_AUTH_SOCK=([^;]*)" output)))
    (catch #t (lambda () (close-pipe port) (const 0)) (const 0))
    (when match-res (setenv "SSH_AUTH_SOCK" (match:substring match-res 1)))
    match-res))

(define* (gpg-agent-stop #:optional . args)
  (let*
      ((dtor (make-system-destructor gpg-agent-kill-command))
       (res (apply dtor args)))
    (unsetenv "SSH_AUTH_SOCK")
    res))

(define gpg-agent
  (make <service>
    #:provides '(gpg-agent ssh-agent)
    #:requires '()
    #:docstring gpg-agent-description
    #:start gpg-agent-start
    #:stop gpg-agent-stop
    #:respawn? #t))

(register-services gpg-agent)
(start gpg-agent)