gnu/installer/steps.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2020 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 (gnu installer utils)
  24   #:use-module (ice-9 match)
  25   #:use-module (ice-9 pretty-print)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-34)
  28   #:use-module (srfi srfi-35)
  29   #:use-module (rnrs io ports)
  30   #:export (&installer-step-abort
  31             installer-step-abort?
  32
  33             &installer-step-break
  34             installer-step-break?
  35
  36             <installer-step>
  37             installer-step
  38             make-installer-step
  39             installer-step?
  40             installer-step-id
  41             installer-step-description
  42             installer-step-compute
  43             installer-step-configuration-formatter
  44
  45             run-installer-steps
  46             find-step-by-id
  47             result->step-ids
  48             result-step
  49             result-step-done?
  50
  51             %installer-configuration-file
  52             %installer-target-dir
  53             %configuration-file-width
  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 sequencially. 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 (define %configuration-file-width (make-parameter 79))
 222
 223 (define (format-configuration steps results)
 224   "Return the list resulting from the application of the procedure defined in
 225 CONFIGURATION-FORMATTER field of <installer-step> on the associated result
 226 found in RESULTS."
 227   (let ((configuration
 228          (append-map
 229           (lambda (step)
 230             (let* ((step-id (installer-step-id step))
 231                    (conf-formatter
 232                     (installer-step-configuration-formatter step))
 233                    (result-step (result-step results step-id)))
 234               (if (and result-step conf-formatter)
 235                   (conf-formatter result-step)
 236                   '())))
 237           steps))
 238         (modules '((use-modules (gnu))
 239                    (use-service-modules desktop networking ssh xorg))))
 240     `(,@modules
 241       ()
 242       (operating-system ,@configuration))))
 243
 244 (define* (configuration->file configuration
 245                               #:key (filename (%installer-configuration-file)))
 246   "Write the given CONFIGURATION to FILENAME."
 247   (mkdir-p (dirname filename))
 248   (call-with-output-file filename
 249     (lambda (port)
 250       (format port ";; This is an operating system configuration generated~%")
 251       (format port ";; by the graphical installer.~%")
 252       (newline port)
 253       (for-each (lambda (part)
 254                   (if (null? part)
 255                       (newline port)
 256                       (pretty-print part port)))
 257                 configuration)
 258       (flush-output-port port))))
 259
 260 ;;; Local Variables:
 261 ;;; eval: (put 'with-server-socket 'scheme-indent-function 0)
 262 ;;; End: