;;; Whispers --- Stealth VPN and ssh tunneler
;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org>
;;;
;;; This file is part of Whispers.
;;;
;;; Whispers is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Whispers is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Whispers.  If not, see <http://www.gnu.org/licenses/>.

(define-module (whispers services ssh-agent)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services admin)
  #:use-module (gnu packages ssh)
  #:export (ssh-agent-configuration
            ssh-agent-configuration?
            ssh-agent-service-type))

(define-record-type* <ssh-agent-configuration>
  ssh-agent-configuration make-ssh-agent-configuration
  ssh-agent-configuration?
  this-ssh-agent-configuration
  ;; A file-like object
  (ssh-package          ssh-agent-configuration-ssh-package
                        (default openssh))
  ;; A string
  (socket-folder        ssh-agent-configuration-socket-folder
                        (default "/var/run/ssh-agent"))
  ;; A string
  (socket-file-name     ssh-agent-configuration-socket-file-name
                        (default "ssh-agent.sock"))
  ;; A string
  (log-folder           ssh-agent-configuration-log-folder
                        (default "/var/log"))
  ;; A string
  (log-file-name        ssh-agent-configuration-log-file-name
                        (default "ssh-agent.log"))
  ;; A list of strings
  (auto-added-keys      ssh-agent-configuration-auto-added-keys
                        (default '()))
  ;; A boolean value
  (%auto-start?         ssh-agent-configuration-auto-start?
                        (default #t)))

(define (socket-file-path config)
  "Returns a string specifying the path to the log file of an ssh agent
service configurable by CONFIG, a record of the
<ssh-agent-configuration> type."
  (string-append (ssh-agent-configuration-socket-folder config)
                 "/"
                 (ssh-agent-configuration-socket-file-name config)))

(define (log-file-path config)
  "Returns a string specifying the path to the log file of an ssh agent
service configurable by CONFIG, a record of the
<ssh-agent-configuration> type."
  (string-append (ssh-agent-configuration-log-folder config)
                 "/"
                 (ssh-agent-configuration-log-file-name config)))

(define (ssh-agent-log-rotation config)
  "Returns a list of log-rotation records specifying how to rotate the
logs of as ssh aggent service configurable by CONFIG, a record of
the <ssh-agent-configuration> type."
  (list (log-rotation (frequency 'daily)
                      (files `(,(log-file-path config))))))

(define (add-key-procedure config)
  "Returns a G-exp to a procedure adding a private key to a running ssh
agent daemon, configurable by CONFIG, a record of the
<ssh-agent-configuration> type."
  (let ((ssh-package (ssh-agent-configuration-ssh-package config)))
    #~(lambda (running key-path)
        ((make-system-constructor
          (string-append "SSH_AUTH_SOCK="
                         #$(socket-file-path config)
                         " "
                         #$(file-append ssh-package
                                        "/bin/ssh-add")
                         " "
                         key-path))))))

(define (constructor-gexp config)
  "Returns a G-exp to a procedure adding a private key to a running ssh
agent daemon, configurable by CONFIG, a record of the
<ssh-agent-configuration> type."
  (let ((ssh-package (ssh-agent-configuration-ssh-package config))
        (auto-added-keys (ssh-agent-configuration-auto-added-keys config))
        (socket-file-path (socket-file-path config))
        (log-file-path (log-file-path config)))
    #~(lambda whatever
        (let ((ret ((make-forkexec-constructor
                     (list #$(file-append ssh-package
                                          "/bin/ssh-agent")
                           "-d"
                           "-a"
                           #$socket-file-path)
                     #:log-file
                     #$log-file-path))))
          (map (lambda (key)
                 (action 'ssh-agent 'add-key key))
               '#$auto-added-keys)
          ret))))

(define (ssh-agent-shepherd-services config)
  "Returns a list of shepherd services handling an ssh agent daemon
configured by CONFIG, a record of the <ssh-agent-configuration>
type."
  (let ((auto-start? (ssh-agent-configuration-auto-start? config)))
    (list
     (shepherd-service
      (documentation (string-append "Ssh agent service, socket file can
be found at "
                                    (socket-file-path config)
                                    "."))
      (provision '(ssh-agent))
      (requirement '())
      (start (constructor-gexp config))
      (stop #~(make-kill-destructor))
      (actions
       (list
        (shepherd-action (name 'add-key)
                         (documentation "Add the private key found at at
the path KEY-PATH to a started ssh-agent daemon.")
                         (procedure (add-key-procedure config)))))
      (auto-start? auto-start?)))))

(define ssh-agent-service-type
  (service-type
   (name 'ssh-agent)
   (description "Ssh agent service")
   (extensions
    (list (service-extension shepherd-root-service-type
                             ssh-agent-shepherd-services)
          (service-extension rottlog-service-type
                             ssh-agent-log-rotation)
          (service-extension
           profile-service-type
           (lambda (config)
             (list
              (ssh-agent-configuration-ssh-package config))))))
   (default-value (ssh-agent-configuration))))