;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services backup)
  #:use-module (gnu packages backup)
  #:use-module (gnu services)
  #:use-module (gnu services configuration)
  #:use-module (gnu services mcron)
  #:use-module (guix build-system copy)
  #:use-module (guix gexp)
  #:use-module ((guix licenses)
                #:prefix license:)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (srfi srfi-1)
  #:export (restic-backup-job
            restic-backup-job?
            restic-backup-job-fields
            restic-backup-job-restic
            restic-backup-job-user
            restic-backup-job-name
            restic-backup-job-repository
            restic-backup-job-password-file
            restic-backup-job-schedule
            restic-backup-job-files
            restic-backup-job-verbose?
            restic-backup-job-extra-flags

            restic-backup-configuration
            restic-backup-configuration?
            restic-backup-configuration-fields
            restic-backup-configuration-jobs

            restic-action-program
            restic-backup-job->mcron-job
            restic-guix
            restic-guix-wrapper-package
            restic-backup-service-profile
            restic-backup-service-type))

(define (gexp-or-string? value)
  (or (gexp? value)
      (string? value)))

(define (lowerable? value)
  (or (file-like? value)
      (gexp-or-string? value)))

(define list-of-lowerables?
  (list-of lowerable?))

(define-configuration/no-serialization restic-backup-job
  (restic
   (package restic)
   "The restic package to be used for the current job.")
  (user
   (string "root")
   "The user used for running the current job.")
  (name
   (string)
   "A string denoting a name for this job.")
  (repository
   (string)
   "The restic repository target of this job.")
  (password-file
   (string)
   "Name of the password file, readable by the configured @code{user}, that
will be used to set the @code{RESTIC_PASSWORD} environment variable for the
current job.")
  (schedule
   (gexp-or-string)
   "A string or a gexp that will be passed as time specification in the mcron
job specification (@pxref{Syntax, mcron job specifications,, mcron,
GNU@tie{}mcron}).")
  (files
   (list-of-lowerables '())
   "The list of files or directories to be backed up.  It must be a list of
values that can be lowered to strings.")
  (verbose?
   (boolean #f)
   "Whether to enable verbose output for the current backup job.")
  (extra-flags
   (list-of-lowerables '())
   "A list of values that are lowered to strings.  These will be passed as
command-line arguments to the current @command{restic} invokation."))

(define list-of-restic-backup-jobs?
  (list-of restic-backup-job?))

(define-configuration/no-serialization restic-backup-configuration
  (jobs
   (list-of-restic-backup-jobs '())
   "The list of backup jobs for the current system."))

(define %restic-guix-supported-actions
  '("backup" "mount" "prune" "restore" "run" "snapshots" "unlock"))

(define* (restic-action-program config action)
  (define (format name)
    ;; Remove from NAME characters that cannot be used in the store.
    (string-map (lambda (chr)
                  (if (and (char-set-contains? char-set:ascii chr)
                           (char-set-contains? char-set:graphic chr)
                           (not (memv chr '(#\. #\/ #\space))))
                      chr
                      #\-))
                name))
  (let ((restic
         (file-append (restic-backup-job-restic config) "/bin/restic"))
        (name
         (restic-backup-job-name config))
        (repository
         (restic-backup-job-repository config))
        (password-file
         (restic-backup-job-password-file config))
        (extra-flags
         (restic-backup-job-extra-flags config))
        (verbose
         (if (restic-backup-job-verbose? config)
             '("--verbose")
             '())))
    (program-file
     (string-append "restic-" action "-" (format name) "-program.scm")
     #~(begin
         (use-modules (ice-9 popen)
                      (ice-9 rdelim)
                      (srfi srfi-1))

         (define cli-arguments
           (let* ((cl (command-line))
                  (argc (length cl)))
             (if (> argc 1)
                 (take-right cl (- argc 1))
                 '())))

         (setenv "RESTIC_PASSWORD"
                 (with-input-from-file #$password-file read-line))

         (apply execlp `(#$restic #$restic #$@verbose
                         "-r" #$repository
                         #$@extra-flags
                         #$action ,@cli-arguments))))))

(define* (restic-guix jobs #:key (supported-actions
                                  %restic-guix-supported-actions))
  (define action-table
    (map
     (lambda (action)
       (list action
             (map (lambda (job)
                    (list (restic-backup-job-name job)
                          (restic-action-program job action)))
                  jobs)))
     ;; run is an alias for backup
     (filter (lambda (a) (not (string=? a "run"))) supported-actions)))

  (program-file
   "restic-guix"
   #~(begin
       (use-modules (ice-9 match)
                    (srfi srfi-1))

       (define action-table '#$action-table)
       (define (assoc-table key table)
         (first
          (filter-map
           (match-lambda
             ((k v)
              (and (string=? key k) v)))
           table)))
       (define names '#$(map restic-backup-job-name jobs))
       (define backup-files
         '#$(map restic-backup-job-files jobs))

       (define (get-program action name)
         (assoc-table name (assoc-table action action-table)))

       (define (get-backup-files name)
         (define idx
           (list-index (lambda (n) (string=? n name)) names))
         (list-ref backup-files idx))

       (define (validate-args args)
         (unless (>= (length args) 2)
           (error (string-append "Usage: " (basename (first args))
                                 " ACTION [ARGS]\n\nSupported actions are: "
                                 #$(string-join supported-actions ", ") ".")))
         (unless (member (second args) '#$supported-actions)
           (error (string-append "Unknown action: " (second args) ". Supported"
                                 "actions are: "
                                 #$(string-join supported-actions ", ") "."))))

       (define (validate-action-args action args)
         (define argc (length args))
         (when (not (>= argc 3))
           (error (string-append "Usage: " (basename (first args))
                                 " " action " JOB_NAME [ARGS]\n\nPossible job "
                                 "names are: " (string-join names ", ") ".")))
         (define job-name (third args))
         (unless (member job-name names)
           (error (string-append "Unknown job name: " job-name ". Possible job "
                                 "names are: " (string-join names ", ") ".")))
         (let ((program
                (get-program
                 ;; run is just backup called with restic-backup-job-files
                 (if (string=? action "run") "backup" action)
                 job-name))
               (rest (if (> argc 3)
                         (take-right args (- argc 3))
                         '())))
           (values program
                   (if (string=? action "run")
                       (append rest (get-backup-files job-name))
                       rest))))

       (define (main args)
         (validate-args args)
         (define action (second args))
         (define-values (program action-args) (validate-action-args action args))
         (apply execlp (append (list program program) action-args)))

       (main (command-line)))))

(define (restic-backup-job->mcron-job config)
  (let ((user
         (restic-backup-job-user config))
        (schedule
         (restic-backup-job-schedule config))
        (name
         (restic-backup-job-name config)))
    #~(job #$schedule
           #$(string-append "restic-guix run " name)
           #:user #$user)))

(define (restic-guix-wrapper-package jobs)
  (package
    (name "restic-backup-service-wrapper")
    (version "0.0.0")
    (source (restic-guix jobs))
    (build-system copy-build-system)
    (arguments
     (list #:install-plan #~'(("./" "/bin"))))
    (home-page "https://restic.net")
    (synopsis
     "Easily interact from the CLI with Guix configured backups")
    (description
     "This package provides a simple wrapper around @code{restic}, handled
by the @code{restic-backup-service-type}.  It allows for easily interacting
with Guix configured backup jobs, for example for manually triggering a backup
without waiting for the scheduled job to run.")
    (license license:gpl3+)))

(define restic-backup-service-profile
  (lambda (config)
    (define jobs (restic-backup-configuration-jobs config))
    (if (> (length jobs) 0)
        (list
         (restic-guix-wrapper-package jobs))
        '())))

(define restic-backup-service-type
  (service-type (name 'restic-backup)
                (extensions
                 (list
                  (service-extension profile-service-type
                                     restic-backup-service-profile)
                  (service-extension mcron-service-type
                                     (lambda (config)
                                       (map restic-backup-job->mcron-job
                                            (restic-backup-configuration-jobs
                                             config))))))
                (compose concatenate)
                (extend
                 (lambda (config jobs)
                   (restic-backup-configuration
                    (inherit config)
                    (jobs (append (restic-backup-configuration-jobs config)
                                  jobs)))))
                (default-value (restic-backup-configuration))
                (description
                 "This service configures @code{mcron} jobs for running backups
with @code{restic}.")))