Commit | Line | Data |
---|---|---|
d0f3a672 | 1 | ;;; GNU Guix --- Functional package management for GNU |
33023baa | 2 | ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com> |
70c2897e | 3 | ;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
d0f3a672 MO |
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 (gnu installer steps) | |
21 | #:use-module (guix records) | |
dc5f3275 | 22 | #:use-module (guix build utils) |
70c2897e | 23 | #:use-module (guix i18n) |
63b8c089 | 24 | #:use-module (gnu installer utils) |
d0f3a672 | 25 | #:use-module (ice-9 match) |
dc5f3275 | 26 | #:use-module (ice-9 pretty-print) |
d0f3a672 MO |
27 | #:use-module (srfi srfi-1) |
28 | #:use-module (srfi srfi-34) | |
29 | #:use-module (srfi srfi-35) | |
dc5f3275 | 30 | #:use-module (rnrs io ports) |
d0f3a672 MO |
31 | #:export (&installer-step-abort |
32 | installer-step-abort? | |
33 | ||
34 | &installer-step-break | |
35 | installer-step-break? | |
36 | ||
37 | <installer-step> | |
38 | installer-step | |
39 | make-installer-step | |
40 | installer-step? | |
41 | installer-step-id | |
42 | installer-step-description | |
43 | installer-step-compute | |
dc5f3275 | 44 | installer-step-configuration-formatter |
d0f3a672 MO |
45 | |
46 | run-installer-steps | |
47 | find-step-by-id | |
48 | result->step-ids | |
49 | result-step | |
dc5f3275 MO |
50 | result-step-done? |
51 | ||
52 | %installer-configuration-file | |
53 | %installer-target-dir | |
dc5f3275 MO |
54 | format-configuration |
55 | configuration->file)) | |
d0f3a672 MO |
56 | |
57 | ;; This condition may be raised to abort the current step. | |
58 | (define-condition-type &installer-step-abort &condition | |
59 | installer-step-abort?) | |
60 | ||
61 | ;; This condition may be raised to break out from the steps execution. | |
62 | (define-condition-type &installer-step-break &condition | |
63 | installer-step-break?) | |
64 | ||
65 | ;; An installer-step record is basically an id associated to a compute | |
66 | ;; procedure. The COMPUTE procedure takes exactly one argument, an association | |
67 | ;; list containing the results of previously executed installer-steps (see | |
68 | ;; RUN-INSTALLER-STEPS description). The value returned by the COMPUTE | |
69 | ;; procedure will be stored in the results list passed to the next | |
70 | ;; installer-step and so on. | |
71 | (define-record-type* <installer-step> | |
72 | installer-step make-installer-step | |
73 | installer-step? | |
dc5f3275 MO |
74 | (id installer-step-id) ;symbol |
75 | (description installer-step-description ;string | |
7ae9979c LC |
76 | (default #f) |
77 | ||
78 | ;; Make it thunked so that 'G_' is called at the | |
79 | ;; right time, as opposed to being called once | |
80 | ;; when the installer starts. | |
81 | (thunked)) | |
dc5f3275 MO |
82 | (compute installer-step-compute) ;procedure |
83 | (configuration-formatter installer-step-configuration-formatter ;procedure | |
84 | (default #f))) | |
d0f3a672 MO |
85 | |
86 | (define* (run-installer-steps #:key | |
87 | steps | |
88 | (rewind-strategy 'previous) | |
89 | (menu-proc (const #f))) | |
90 | "Run the COMPUTE procedure of all <installer-step> records in STEPS | |
e1f37889 | 91 | sequentially. If the &installer-step-abort condition is raised, fallback to a |
d0f3a672 MO |
92 | previous install-step, accordingly to the specified REWIND-STRATEGY. |
93 | ||
94 | REWIND-STRATEGY possible values are 'previous, 'menu and 'start. If 'previous | |
95 | is selected, the execution will resume at the previous installer-step. If | |
96 | 'menu is selected, the MENU-PROC procedure will be called. Its return value | |
97 | has to be an installer-step ID to jump to. The ID has to be the one of a | |
98 | previously executed step. It is impossible to jump forward. Finally if 'start | |
99 | is selected, the execution will resume at the first installer-step. | |
100 | ||
101 | The result of every COMPUTE procedures is stored in an association list, under | |
102 | the form: | |
103 | ||
104 | '((STEP-ID . COMPUTE-RESULT) ...) | |
105 | ||
106 | where STEP-ID is the ID field of the installer-step and COMPUTE-RESULT the | |
107 | result of the associated COMPUTE procedure. This result association list is | |
108 | passed as argument of every COMPUTE procedure. It is finally returned when the | |
109 | computation is over. | |
110 | ||
111 | If the &installer-step-break condition is raised, stop the computation and | |
112 | return the accumalated result so far." | |
113 | (define (pop-result list) | |
114 | (cdr list)) | |
115 | ||
116 | (define (first-step? steps step) | |
117 | (match steps | |
118 | ((first-step . rest-steps) | |
119 | (equal? first-step step)))) | |
120 | ||
121 | (define* (skip-to-step step result | |
122 | #:key todo-steps done-steps) | |
33023baa MO |
123 | (match todo-steps |
124 | ((todo . rest-todo) | |
125 | (let ((found? (eq? (installer-step-id todo) | |
126 | (installer-step-id step)))) | |
127 | (cond | |
128 | (found? | |
d0f3a672 MO |
129 | (run result |
130 | #:todo-steps todo-steps | |
33023baa MO |
131 | #:done-steps done-steps)) |
132 | ((and (not found?) | |
133 | (null? done-steps)) | |
134 | (error (format #f "Step ~a not found" (installer-step-id step)))) | |
135 | (else | |
136 | (match done-steps | |
137 | ((prev-done ... last-done) | |
138 | (skip-to-step step (pop-result result) | |
139 | #:todo-steps (cons last-done todo-steps) | |
140 | #:done-steps prev-done))))))))) | |
d0f3a672 MO |
141 | |
142 | (define* (run result #:key todo-steps done-steps) | |
143 | (match todo-steps | |
144 | (() (reverse result)) | |
145 | ((step . rest-steps) | |
146 | (guard (c ((installer-step-abort? c) | |
147 | (case rewind-strategy | |
148 | ((previous) | |
149 | (match done-steps | |
150 | (() | |
151 | ;; We cannot go previous the first step. So re-raise | |
152 | ;; the exception. It might be useful in the case of | |
153 | ;; nested run-installer-steps. Abort to 'raise-above | |
154 | ;; prompt to prevent the condition from being catched | |
155 | ;; by one of the previously installed guard. | |
156 | (abort-to-prompt 'raise-above c)) | |
157 | ((prev-done ... last-done) | |
158 | (run (pop-result result) | |
159 | #:todo-steps (cons last-done todo-steps) | |
160 | #:done-steps prev-done)))) | |
161 | ((menu) | |
162 | (let ((goto-step (menu-proc | |
163 | (append done-steps (list step))))) | |
164 | (if (eq? goto-step step) | |
165 | (run result | |
166 | #:todo-steps todo-steps | |
167 | #:done-steps done-steps) | |
168 | (skip-to-step goto-step result | |
169 | #:todo-steps todo-steps | |
170 | #:done-steps done-steps)))) | |
171 | ((start) | |
172 | (if (null? done-steps) | |
173 | ;; Same as above, it makes no sense to jump to start | |
174 | ;; when we are at the first installer-step. Abort to | |
175 | ;; 'raise-above prompt to re-raise the condition. | |
176 | (abort-to-prompt 'raise-above c) | |
177 | (run '() | |
178 | #:todo-steps steps | |
179 | #:done-steps '()))))) | |
180 | ((installer-step-break? c) | |
181 | (reverse result))) | |
5c04b00c | 182 | (syslog "running step '~a'~%" (installer-step-id step)) |
d0f3a672 MO |
183 | (let* ((id (installer-step-id step)) |
184 | (compute (installer-step-compute step)) | |
dc5f3275 | 185 | (res (compute result done-steps))) |
d0f3a672 MO |
186 | (run (alist-cons id res result) |
187 | #:todo-steps rest-steps | |
188 | #:done-steps (append done-steps (list step)))))))) | |
189 | ||
63b8c089 LC |
190 | ;; Ignore SIGPIPE so that we don't die if a client closes the connection |
191 | ;; prematurely. | |
192 | (sigaction SIGPIPE SIG_IGN) | |
193 | ||
194 | (with-server-socket | |
195 | (call-with-prompt 'raise-above | |
196 | (lambda () | |
197 | (run '() | |
198 | #:todo-steps steps | |
199 | #:done-steps '())) | |
200 | (lambda (k condition) | |
201 | (raise condition))))) | |
d0f3a672 MO |
202 | |
203 | (define (find-step-by-id steps id) | |
204 | "Find and return the step in STEPS whose id is equal to ID." | |
205 | (find (lambda (step) | |
206 | (eq? (installer-step-id step) id)) | |
207 | steps)) | |
208 | ||
209 | (define (result-step results step-id) | |
210 | "Return the result of the installer-step specified by STEP-ID in | |
211 | RESULTS." | |
212 | (assoc-ref results step-id)) | |
213 | ||
214 | (define (result-step-done? results step-id) | |
215 | "Return #t if the installer-step specified by STEP-ID has a COMPUTE value | |
216 | stored in RESULTS. Return #f otherwise." | |
217 | (and (assoc step-id results) #t)) | |
dc5f3275 MO |
218 | |
219 | (define %installer-configuration-file (make-parameter "/mnt/etc/config.scm")) | |
220 | (define %installer-target-dir (make-parameter "/mnt")) | |
dc5f3275 MO |
221 | |
222 | (define (format-configuration steps results) | |
223 | "Return the list resulting from the application of the procedure defined in | |
224 | CONFIGURATION-FORMATTER field of <installer-step> on the associated result | |
225 | found in RESULTS." | |
226 | (let ((configuration | |
227 | (append-map | |
228 | (lambda (step) | |
229 | (let* ((step-id (installer-step-id step)) | |
230 | (conf-formatter | |
231 | (installer-step-configuration-formatter step)) | |
232 | (result-step (result-step results step-id))) | |
233 | (if (and result-step conf-formatter) | |
234 | (conf-formatter result-step) | |
235 | '()))) | |
236 | steps)) | |
237 | (modules '((use-modules (gnu)) | |
469e56b4 | 238 | (use-service-modules desktop networking ssh xorg)))) |
dc5f3275 MO |
239 | `(,@modules |
240 | () | |
241 | (operating-system ,@configuration)))) | |
242 | ||
243 | (define* (configuration->file configuration | |
244 | #:key (filename (%installer-configuration-file))) | |
245 | "Write the given CONFIGURATION to FILENAME." | |
246 | (mkdir-p (dirname filename)) | |
247 | (call-with-output-file filename | |
248 | (lambda (port) | |
70c2897e LC |
249 | ;; TRANSLATORS: This is a comment within a Scheme file. Each line must |
250 | ;; start with ";; " (two semicolons and a space). Please keep line | |
251 | ;; length below 60 characters. | |
252 | (display (G_ "\ | |
253 | ;; This is an operating system configuration generated | |
254 | ;; by the graphical installer.\n") | |
255 | port) | |
dc5f3275 MO |
256 | (newline port) |
257 | (for-each (lambda (part) | |
258 | (if (null? part) | |
259 | (newline port) | |
260 | (pretty-print part port))) | |
261 | configuration) | |
262 | (flush-output-port port)))) | |
63b8c089 LC |
263 | |
264 | ;;; Local Variables: | |
265 | ;;; eval: (put 'with-server-socket 'scheme-indent-function 0) | |
266 | ;;; End: |