Commit | Line | Data |
---|---|---|
5cbb832f JK |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2019 David Thompson <davet@gnu.org> | |
3 | ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.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 deploy) | |
21 | #:use-module (gnu machine) | |
55e238f2 | 22 | #:use-module (guix discovery) |
5cbb832f JK |
23 | #:use-module (guix scripts) |
24 | #:use-module (guix scripts build) | |
25 | #:use-module (guix store) | |
26 | #:use-module (guix ui) | |
3c618b98 | 27 | #:use-module (guix utils) |
2fa23d8f | 28 | #:use-module (guix grafts) |
b69ce8a8 | 29 | #:use-module (guix status) |
5cbb832f JK |
30 | #:use-module (ice-9 format) |
31 | #:use-module (srfi srfi-1) | |
9c70c460 JK |
32 | #:use-module (srfi srfi-34) |
33 | #:use-module (srfi srfi-35) | |
5cbb832f JK |
34 | #:use-module (srfi srfi-37) |
35 | #:export (guix-deploy)) | |
36 | ||
37 | ;;; Commentary: | |
38 | ;;; | |
39 | ;;; This program provides a command-line interface to (gnu machine), allowing | |
40 | ;;; users to perform remote deployments through specification files. | |
41 | ;;; | |
42 | ;;; Code: | |
43 | ||
44 | \f | |
45 | ||
46 | (define (show-help) | |
47 | (display (G_ "Usage: guix deploy [OPTION] FILE... | |
48 | Perform the deployment specified by FILE.\n")) | |
49 | (show-build-options-help) | |
50 | (newline) | |
51 | (display (G_ " | |
52 | -h, --help display this help and exit")) | |
53 | (display (G_ " | |
54 | -V, --version display version information and exit")) | |
55 | (newline) | |
b69ce8a8 LC |
56 | (display (G_ " |
57 | -v, --verbosity=LEVEL use the given verbosity LEVEL")) | |
5cbb832f JK |
58 | (show-bug-report-information)) |
59 | ||
60 | (define %options | |
61 | (cons* (option '(#\h "help") #f #f | |
62 | (lambda args | |
63 | (show-help) | |
64 | (exit 0))) | |
1bdb63e7 LC |
65 | (option '(#\V "version") #f #f |
66 | (lambda args | |
67 | (show-version-and-exit "guix deploy"))) | |
68 | ||
3c618b98 SB |
69 | (option '(#\s "system") #t #f |
70 | (lambda (opt name arg result) | |
71 | (alist-cons 'system arg | |
72 | (alist-delete 'system result eq?)))) | |
b69ce8a8 LC |
73 | (option '(#\v "verbosity") #t #f |
74 | (lambda (opt name arg result) | |
75 | (let ((level (string->number* arg))) | |
76 | (alist-cons 'verbosity level | |
77 | (alist-delete 'verbosity result))))) | |
78 | ||
5cbb832f JK |
79 | %standard-build-options)) |
80 | ||
81 | (define %default-options | |
91300526 LC |
82 | ;; Alist of default option values. |
83 | `((verbosity . 1) | |
5cbb832f | 84 | (debug . 0) |
91300526 LC |
85 | (graft? . #t) |
86 | (substitutes? . #t) | |
7f44ab48 | 87 | (offload? . #t) |
91300526 LC |
88 | (print-build-trace? . #t) |
89 | (print-extended-build-trace? . #t) | |
90 | (multiplexed-build-output? . #t))) | |
5cbb832f JK |
91 | |
92 | (define (load-source-file file) | |
93 | "Load FILE as a user module." | |
55e238f2 JK |
94 | (let* ((guix-path (dirname (search-path %load-path "guix.scm"))) |
95 | (environment-modules (scheme-modules* guix-path "gnu/machine")) | |
96 | (module (make-user-module (append '((gnu) (gnu machine)) | |
97 | environment-modules)))) | |
5cbb832f JK |
98 | (load* file module))) |
99 | ||
100 | (define (guix-deploy . args) | |
101 | (define (handle-argument arg result) | |
102 | (alist-cons 'file arg result)) | |
b69ce8a8 | 103 | |
5cbb832f JK |
104 | (let* ((opts (parse-command-line args %options (list %default-options) |
105 | #:argument-handler handle-argument)) | |
106 | (file (assq-ref opts 'file)) | |
107 | (machines (or (and file (load-source-file file)) '()))) | |
b69ce8a8 LC |
108 | (with-status-verbosity (assoc-ref opts 'verbosity) |
109 | (with-store store | |
110 | (set-build-options-from-command-line store opts) | |
111 | (for-each (lambda (machine) | |
112 | (info (G_ "deploying to ~a...~%") | |
113 | (machine-display-name machine)) | |
114 | (parameterize ((%graft? (assq-ref opts 'graft?))) | |
115 | (guard (c ((message-condition? c) | |
116 | (report-error (G_ "failed to deploy ~a: ~a~%") | |
117 | (machine-display-name machine) | |
118 | (condition-message c))) | |
119 | ((deploy-error? c) | |
120 | (when (deploy-error-should-roll-back c) | |
121 | (info (G_ "rolling back ~a...~%") | |
122 | (machine-display-name machine)) | |
123 | (run-with-store store (roll-back-machine machine))) | |
124 | (apply throw (deploy-error-captured-args c)))) | |
125 | (run-with-store store (deploy-machine machine))))) | |
126 | machines))))) |