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