| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com> |
| 3 | ;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.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 (gnu installer steps) |
| 21 | #:use-module (guix records) |
| 22 | #:use-module (guix build utils) |
| 23 | #:use-module (guix i18n) |
| 24 | #:use-module (gnu installer utils) |
| 25 | #:use-module (ice-9 match) |
| 26 | #:use-module (ice-9 pretty-print) |
| 27 | #:use-module (srfi srfi-1) |
| 28 | #:use-module (srfi srfi-34) |
| 29 | #:use-module (srfi srfi-35) |
| 30 | #:use-module (rnrs io ports) |
| 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 |
| 44 | installer-step-configuration-formatter |
| 45 | |
| 46 | run-installer-steps |
| 47 | find-step-by-id |
| 48 | result->step-ids |
| 49 | result-step |
| 50 | result-step-done? |
| 51 | |
| 52 | %installer-configuration-file |
| 53 | %installer-target-dir |
| 54 | format-configuration |
| 55 | configuration->file)) |
| 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? |
| 74 | (id installer-step-id) ;symbol |
| 75 | (description installer-step-description ;string |
| 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)) |
| 82 | (compute installer-step-compute) ;procedure |
| 83 | (configuration-formatter installer-step-configuration-formatter ;procedure |
| 84 | (default #f))) |
| 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 |
| 91 | sequentially. If the &installer-step-abort condition is raised, fallback to a |
| 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) |
| 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? |
| 129 | (run result |
| 130 | #:todo-steps todo-steps |
| 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))))))))) |
| 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))) |
| 182 | (syslog "running step '~a'~%" (installer-step-id step)) |
| 183 | (let* ((id (installer-step-id step)) |
| 184 | (compute (installer-step-compute step)) |
| 185 | (res (compute result done-steps))) |
| 186 | (run (alist-cons id res result) |
| 187 | #:todo-steps rest-steps |
| 188 | #:done-steps (append done-steps (list step)))))))) |
| 189 | |
| 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))))) |
| 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)) |
| 218 | |
| 219 | (define %installer-configuration-file (make-parameter "/mnt/etc/config.scm")) |
| 220 | (define %installer-target-dir (make-parameter "/mnt")) |
| 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)) |
| 238 | (use-service-modules desktop networking ssh xorg)))) |
| 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) |
| 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) |
| 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)))) |
| 263 | |
| 264 | ;;; Local Variables: |
| 265 | ;;; eval: (put 'with-server-socket 'scheme-indent-function 0) |
| 266 | ;;; End: |