guix/scripts/time-machine.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 Konrad Hinsen <konrad.hinsen@fastmail.net>
   3 ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix scripts time-machine)
  21   #:use-module (guix ui)
  22   #:use-module (guix scripts)
  23   #:use-module (guix inferior)
  24   #:use-module (guix channels)
  25   #:use-module (guix store)
  26   #:use-module (guix status)
  27   #:use-module ((guix git)
  28                 #:select (with-git-error-handling))
  29   #:use-module ((guix utils)
  30                 #:select (%current-system))
  31   #:use-module ((guix scripts pull)
  32                 #:select (channel-list))
  33   #:use-module ((guix scripts build)
  34                 #:select (%standard-build-options
  35                           show-build-options-help
  36                           set-build-options-from-command-line))
  37   #:use-module (ice-9 match)
  38   #:use-module (srfi srfi-1)
  39   #:use-module (srfi srfi-11)
  40   #:use-module (srfi srfi-26)
  41   #:use-module (srfi srfi-37)
  42   #:export (guix-time-machine))
  43
  44 \f
  45 ;;;
  46 ;;; Command-line options.
  47 ;;;
  48
  49 (define (show-help)
  50   (display (G_ "Usage: guix time-machine [OPTION] -- COMMAND ARGS...
  51 Execute COMMAND ARGS... in an older version of Guix.\n"))
  52   (display (G_ "
  53   -C, --channels=FILE    deploy the channels defined in FILE"))
  54   (display (G_ "
  55       --url=URL          use the Git repository at URL"))
  56   (display (G_ "
  57       --commit=COMMIT    use the specified COMMIT"))
  58   (display (G_ "
  59       --branch=BRANCH    use the tip of the specified BRANCH"))
  60   (display (G_ "
  61       --disable-authentication
  62                          disable channel authentication"))
  63   (newline)
  64   (show-build-options-help)
  65   (newline)
  66   (display (G_ "
  67   -h, --help             display this help and exit"))
  68   (display (G_ "
  69   -V, --version          display version information and exit"))
  70   (newline)
  71   (show-bug-report-information))
  72
  73 (define %options
  74   ;; Specifications of the command-line options.
  75   (cons* (option '(#\C "channels") #t #f
  76                  (lambda (opt name arg result)
  77                    (alist-cons 'channel-file arg result)))
  78          (option '("url") #t #f
  79                  (lambda (opt name arg result)
  80                    (alist-cons 'repository-url arg
  81                                (alist-delete 'repository-url result))))
  82          (option '("commit") #t #f
  83                  (lambda (opt name arg result)
  84                    (alist-cons 'ref `(commit . ,arg) result)))
  85          (option '("branch") #t #f
  86                  (lambda (opt name arg result)
  87                    (alist-cons 'ref `(branch . ,arg) result)))
  88          (option '("disable-authentication") #f #f
  89                  (lambda (opt name arg result)
  90                    (alist-cons 'authenticate-channels? #f result)))
  91          (option '(#\h "help") #f #f
  92                  (lambda args
  93                    (show-help)
  94                    (exit 0)))
  95          (option '(#\V "version") #f #f
  96                  (lambda args
  97                    (show-version-and-exit "guix time-machine")))
  98
  99          %standard-build-options))
 100
 101 (define %default-options
 102   ;; Alist of default option values.
 103   `((system . ,(%current-system))
 104     (substitutes? . #t)
 105     (offload? . #t)
 106     (print-build-trace? . #t)
 107     (print-extended-build-trace? . #t)
 108     (multiplexed-build-output? . #t)
 109     (authenticate-channels? . #t)
 110     (graft? . #t)
 111     (debug . 0)
 112     (verbosity . 1)))
 113
 114 (define (parse-args args)
 115   "Parse the list of command line arguments ARGS."
 116   ;; The '--' token is used to separate the command to run from the rest of
 117   ;; the operands.
 118   (let-values (((args command) (break (cut string=? "--" <>) args)))
 119     (let ((opts (parse-command-line args %options
 120                                     (list %default-options))))
 121       (match command
 122         (() opts)
 123         (("--") opts)
 124         (("--" command ...) (alist-cons 'exec command opts))))))
 125
 126 \f
 127 ;;;
 128 ;;; Entry point.
 129 ;;;
 130
 131 (define-command (guix-time-machine . args)
 132   (synopsis "run commands from a different revision")
 133
 134   (with-error-handling
 135     (with-git-error-handling
 136      (let* ((opts         (parse-args args))
 137             (channels     (channel-list opts))
 138             (command-line (assoc-ref opts 'exec))
 139             (authenticate? (assoc-ref opts 'authenticate-channels?)))
 140        (when command-line
 141          (let* ((directory
 142                  (with-store store
 143                    (with-status-verbosity (assoc-ref opts 'verbosity)
 144                      (set-build-options-from-command-line store opts)
 145                      (cached-channel-instance store channels
 146                                               #:authenticate? authenticate?))))
 147                 (executable (string-append directory "/bin/guix")))
 148            (apply execl (cons* executable executable command-line))))))))