[bug#72803] [PATCH v2] services: restic-backup: Add more restic commands to the restic-guix package.

[Giacomo Leidi via Guix-patches via <guix-patches@gnu.org>]

This patch refactors the way restic commands can be added to the
restic-guix package with a more general approach.  This way new
subcommands for restic-guix can be added more easily.

* gnu/services/backup.scm (restic-backup-job-program): Generalize to
restic-action-program;
(restic-guix): allow for multiple actions.

* doc/guix.texi: Document it.

Change-Id: Ib2b5d74bebc51e35f1ae6e1aa32cedee0da59697
---
 doc/guix.texi           |  13 +++-
 gnu/services/backup.scm | 127 +++++++++++++++++++++++++++++-----------
 2 files changed, 104 insertions(+), 36 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index ac3a7adef0..f8a73abdce 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -41711,7 +41711,15 @@ Miscellaneous Services
 configuration, without waiting for the scheduled job:
 
 @example
-restic-guix backup remote-ftp
+restic-guix run remote-ftp
+@end example
+
+All arguments passed after the job name will be passed to the underlying
+@code{restic} command, together with the @code{extra-flags} field from the
+@code{restic-backup-job} record:
+
+@example
+restic-guix restore remote-ftp -t `pwd`/restored -i .config/guix/channels.scm latest
 @end example
 
 @c %start of fragment
@@ -41767,8 +41775,7 @@ Miscellaneous Services
 
 @item @code{extra-flags} (default: @code{'()}) (type: list-of-lowerables)
 A list of values that are lowered to strings.  These will be passed as
-command-line arguments to the current job @command{restic backup}
-invokation.
+command-line arguments to the current @command{restic} invokation.
 
 @end table
 
diff --git a/gnu/services/backup.scm b/gnu/services/backup.scm
index 555e9fc959..83d388143e 100644
--- a/gnu/services/backup.scm
+++ b/gnu/services/backup.scm
@@ -46,7 +46,7 @@ (define-module (gnu services backup)
             restic-backup-configuration-fields
             restic-backup-configuration-jobs
 
-            restic-backup-job-program
+            restic-action-program
             restic-backup-job->mcron-job
             restic-guix
             restic-guix-wrapper-package
@@ -97,7 +97,7 @@ (define-configuration/no-serialization restic-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 job @command{restic backup} invokation."))
+command-line arguments to the current @command{restic} invokation."))
 
 (define list-of-restic-backup-jobs?
   (list-of restic-backup-job?))
@@ -107,15 +107,27 @@ (define-configuration/no-serialization restic-backup-configuration
    (list-of-restic-backup-jobs '())
    "The list of backup jobs for the current system."))
 
-(define (restic-backup-job-program config)
+(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))
-        (files
-         (restic-backup-job-files config))
         (extra-flags
          (restic-backup-job-extra-flags config))
         (verbose
@@ -123,55 +135,104 @@ (define (restic-backup-job-program config)
              '("--verbose")
              '())))
     (program-file
-     "restic-backup-job.scm"
+     (string-append "restic-" action "-" (format name) "-program.scm")
      #~(begin
          (use-modules (ice-9 popen)
-                      (ice-9 rdelim))
+                      (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))
 
-         (execlp #$restic #$restic #$@verbose
-                 "-r" #$repository
-                 #$@extra-flags
-                 "backup" #$@files)))))
+         (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)))
 
-(define (restic-guix jobs)
   (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 programs '#$(map restic-backup-job-program 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-program name)
+       (define (get-backup-files name)
          (define idx
            (list-index (lambda (n) (string=? n name)) names))
-         (unless idx
-           (error (string-append "Unknown job name " name "\n\n"
-                                 "Possible job names are: "
-                                 (string-join names " "))))
-         (list-ref programs idx))
-
-       (define (backup args)
-         (define name (third args))
-         (define program (get-program name))
-         (execlp program program))
+         (list-ref backup-files idx))
 
        (define (validate-args args)
-         (when (not (>= (length args) 3))
-           (error (string-append "Usage: " (basename (car args))
-                                 " backup NAME"))))
+         (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))
-         (match action
-           ("backup"
-            (backup args))
-           (_
-            (error (string-append "Unknown action: " action)))))
+         (define-values (program action-args) (validate-action-args action args))
+         (apply execlp (append (list program program) action-args)))
 
        (main (command-line)))))
 
@@ -183,7 +244,7 @@ (define (restic-backup-job->mcron-job config)
         (name
          (restic-backup-job-name config)))
     #~(job #$schedule
-           #$(string-append "restic-guix backup " name)
+           #$(string-append "restic-guix run " name)
            #:user #$user)))
 
 (define (restic-guix-wrapper-package jobs)

base-commit: 5ab3c4c1e43ebb637551223791db0ea3519986e1
-- 
2.46.0