Commit | Line | Data |
---|---|---|
5cbb832f JK |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2019 David Thompson <davet@gnu.org> | |
e8134442 | 3 | ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> |
1bb248d0 | 4 | ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> |
5cbb832f JK |
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 deploy) | |
22 | #:use-module (gnu machine) | |
55e238f2 | 23 | #:use-module (guix discovery) |
5cbb832f JK |
24 | #:use-module (guix scripts) |
25 | #:use-module (guix scripts build) | |
26 | #:use-module (guix store) | |
27 | #:use-module (guix ui) | |
3c618b98 | 28 | #:use-module (guix utils) |
2fa23d8f | 29 | #:use-module (guix grafts) |
b69ce8a8 | 30 | #:use-module (guix status) |
5cbb832f JK |
31 | #:use-module (ice-9 format) |
32 | #:use-module (srfi srfi-1) | |
d089b233 | 33 | #:use-module (srfi srfi-26) |
9c70c460 JK |
34 | #:use-module (srfi srfi-34) |
35 | #:use-module (srfi srfi-35) | |
5cbb832f JK |
36 | #:use-module (srfi srfi-37) |
37 | #:export (guix-deploy)) | |
38 | ||
39 | ;;; Commentary: | |
40 | ;;; | |
41 | ;;; This program provides a command-line interface to (gnu machine), allowing | |
42 | ;;; users to perform remote deployments through specification files. | |
43 | ;;; | |
44 | ;;; Code: | |
45 | ||
46 | \f | |
47 | ||
48 | (define (show-help) | |
49 | (display (G_ "Usage: guix deploy [OPTION] FILE... | |
50 | Perform the deployment specified by FILE.\n")) | |
51 | (show-build-options-help) | |
52 | (newline) | |
53 | (display (G_ " | |
54 | -h, --help display this help and exit")) | |
55 | (display (G_ " | |
56 | -V, --version display version information and exit")) | |
57 | (newline) | |
b69ce8a8 LC |
58 | (display (G_ " |
59 | -v, --verbosity=LEVEL use the given verbosity LEVEL")) | |
5cbb832f JK |
60 | (show-bug-report-information)) |
61 | ||
62 | (define %options | |
63 | (cons* (option '(#\h "help") #f #f | |
64 | (lambda args | |
65 | (show-help) | |
66 | (exit 0))) | |
1bdb63e7 LC |
67 | (option '(#\V "version") #f #f |
68 | (lambda args | |
69 | (show-version-and-exit "guix deploy"))) | |
70 | ||
3c618b98 SB |
71 | (option '(#\s "system") #t #f |
72 | (lambda (opt name arg result) | |
73 | (alist-cons 'system arg | |
74 | (alist-delete 'system result eq?)))) | |
b69ce8a8 LC |
75 | (option '(#\v "verbosity") #t #f |
76 | (lambda (opt name arg result) | |
77 | (let ((level (string->number* arg))) | |
78 | (alist-cons 'verbosity level | |
79 | (alist-delete 'verbosity result))))) | |
80 | ||
5cbb832f JK |
81 | %standard-build-options)) |
82 | ||
83 | (define %default-options | |
91300526 LC |
84 | ;; Alist of default option values. |
85 | `((verbosity . 1) | |
5cbb832f | 86 | (debug . 0) |
91300526 LC |
87 | (graft? . #t) |
88 | (substitutes? . #t) | |
7f44ab48 | 89 | (offload? . #t) |
91300526 LC |
90 | (print-build-trace? . #t) |
91 | (print-extended-build-trace? . #t) | |
92 | (multiplexed-build-output? . #t))) | |
5cbb832f JK |
93 | |
94 | (define (load-source-file file) | |
95 | "Load FILE as a user module." | |
55e238f2 JK |
96 | (let* ((guix-path (dirname (search-path %load-path "guix.scm"))) |
97 | (environment-modules (scheme-modules* guix-path "gnu/machine")) | |
98 | (module (make-user-module (append '((gnu) (gnu machine)) | |
99 | environment-modules)))) | |
5cbb832f JK |
100 | (load* file module))) |
101 | ||
1bb248d0 LC |
102 | (define (show-what-to-deploy machines) |
103 | "Show the list of machines to deploy, MACHINES." | |
104 | (let ((count (length machines))) | |
105 | (format (current-error-port) | |
388b432c | 106 | (N_ "The following ~d machine will be deployed:~%" |
1bb248d0 LC |
107 | "The following ~d machines will be deployed:~%" |
108 | count) | |
109 | count) | |
110 | (display (indented-string | |
111 | (fill-paragraph (string-join (map machine-display-name machines) | |
112 | ", ") | |
113 | (- (%text-width) 2) 2) | |
114 | 2) | |
115 | (current-error-port)) | |
116 | (display "\n\n" (current-error-port)))) | |
117 | ||
d089b233 LC |
118 | (define (deploy-machine* store machine) |
119 | "Deploy MACHINE, taking care of error handling." | |
120 | (info (G_ "deploying to ~a...~%") | |
121 | (machine-display-name machine)) | |
122 | ||
123 | (guard (c ((message-condition? c) | |
124 | (report-error (G_ "failed to deploy ~a: ~a~%") | |
125 | (machine-display-name machine) | |
126 | (condition-message c))) | |
127 | ((deploy-error? c) | |
128 | (when (deploy-error-should-roll-back c) | |
129 | (info (G_ "rolling back ~a...~%") | |
130 | (machine-display-name machine)) | |
131 | (run-with-store store (roll-back-machine machine))) | |
132 | (apply throw (deploy-error-captured-args c)))) | |
133 | (run-with-store store (deploy-machine machine)) | |
134 | ||
135 | (info (G_ "successfully deployed ~a~%") | |
136 | (machine-display-name machine)))) | |
137 | ||
138 | \f | |
3794ce93 LC |
139 | (define-command (guix-deploy . args) |
140 | (synopsis "deploy operating systems on a set of machines") | |
5cbb832f JK |
141 | (define (handle-argument arg result) |
142 | (alist-cons 'file arg result)) | |
b69ce8a8 | 143 | |
c9c8c633 LC |
144 | (with-error-handling |
145 | (let* ((opts (parse-command-line args %options (list %default-options) | |
146 | #:argument-handler handle-argument)) | |
147 | (file (assq-ref opts 'file)) | |
148 | (machines (or (and file (load-source-file file)) '()))) | |
149 | (show-what-to-deploy machines) | |
150 | ||
151 | (with-status-verbosity (assoc-ref opts 'verbosity) | |
152 | (with-store store | |
153 | (set-build-options-from-command-line store opts) | |
154 | (with-build-handler (build-notifier #:use-substitutes? | |
898e6d0a LC |
155 | (assoc-ref opts 'substitutes?) |
156 | #:verbosity | |
157 | (assoc-ref opts 'verbosity)) | |
c9c8c633 LC |
158 | (parameterize ((%graft? (assq-ref opts 'graft?))) |
159 | (map/accumulate-builds store | |
160 | (cut deploy-machine* store <>) | |
161 | machines)))))))) |