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> |
f675f8de KH |
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) | |
1d548569 | 25 | #:use-module (guix store) |
87e7faa2 | 26 | #:use-module (guix status) |
69db2993 LC |
27 | #:use-module ((guix git) |
28 | #:select (with-git-error-handling)) | |
87e7faa2 LC |
29 | #:use-module ((guix utils) |
30 | #:select (%current-system)) | |
d17e012d | 31 | #:use-module ((guix scripts pull) |
69db2993 | 32 | #:select (channel-list)) |
87e7faa2 LC |
33 | #:use-module ((guix scripts build) |
34 | #:select (%standard-build-options | |
35 | show-build-options-help | |
36 | set-build-options-from-command-line)) | |
f675f8de KH |
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")) | |
838ac881 LC |
60 | (display (G_ " |
61 | --disable-authentication | |
62 | disable channel authentication")) | |
87e7faa2 LC |
63 | (newline) |
64 | (show-build-options-help) | |
65 | (newline) | |
f675f8de KH |
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. | |
87e7faa2 LC |
75 | (cons* (option '(#\C "channels") #t #f |
76 | (lambda (opt name arg result) | |
77 | (alist-cons 'channel-file arg result))) | |
f675f8de KH |
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))) | |
838ac881 LC |
88 | (option '("disable-authentication") #f #f |
89 | (lambda (opt name arg result) | |
90 | (alist-cons 'authenticate-channels? #f result))) | |
87e7faa2 LC |
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) | |
7f44ab48 | 105 | (offload? . #t) |
87e7faa2 LC |
106 | (print-build-trace? . #t) |
107 | (print-extended-build-trace? . #t) | |
108 | (multiplexed-build-output? . #t) | |
838ac881 | 109 | (authenticate-channels? . #t) |
87e7faa2 LC |
110 | (graft? . #t) |
111 | (debug . 0) | |
112 | (verbosity . 1))) | |
f675f8de KH |
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))) | |
87e7faa2 LC |
119 | (let ((opts (parse-command-line args %options |
120 | (list %default-options)))) | |
f675f8de KH |
121 | (match command |
122 | (() opts) | |
123 | (("--") opts) | |
124 | (("--" command ...) (alist-cons 'exec command opts)))))) | |
125 | ||
126 | \f | |
127 | ;;; | |
128 | ;;; Entry point. | |
129 | ;;; | |
130 | ||
3794ce93 LC |
131 | (define-command (guix-time-machine . args) |
132 | (synopsis "run commands from a different revision") | |
133 | ||
f675f8de | 134 | (with-error-handling |
d17e012d LC |
135 | (with-git-error-handling |
136 | (let* ((opts (parse-args args)) | |
137 | (channels (channel-list opts)) | |
838ac881 LC |
138 | (command-line (assoc-ref opts 'exec)) |
139 | (authenticate? (assoc-ref opts 'authenticate-channels?))) | |
d17e012d | 140 | (when command-line |
87e7faa2 LC |
141 | (let* ((directory |
142 | (with-store store | |
143 | (with-status-verbosity (assoc-ref opts 'verbosity) | |
144 | (set-build-options-from-command-line store opts) | |
838ac881 LC |
145 | (cached-channel-instance store channels |
146 | #:authenticate? authenticate?)))) | |
d17e012d LC |
147 | (executable (string-append directory "/bin/guix"))) |
148 | (apply execl (cons* executable executable command-line)))))))) |