gnu/installer/tests.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
   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 tests)
  21   #:use-module (srfi srfi-1)
  22   #:use-module (srfi srfi-34)
  23   #:use-module (srfi srfi-35)
  24   #:use-module (ice-9 match)
  25   #:use-module (ice-9 regex)
  26   #:use-module (ice-9 pretty-print)
  27   #:export (&pattern-not-matched
  28             pattern-not-matched?
  29
  30             %installer-socket-file
  31             open-installer-socket
  32
  33             converse
  34             conversation-log-port
  35
  36             choose-locale+keyboard
  37             enter-host-name+passwords
  38             choose-services
  39             choose-partitioning
  40             conclude-installation
  41
  42             edit-configuration-file))
  43
  44 ;;; Commentary:
  45 ;;;
  46 ;;; This module provides tools to test the guided "graphical" installer in a
  47 ;;; non-interactive fashion.  The core of it is 'converse': it allows you to
  48 ;;; state Expect-style dialogues, which happen over the Unix-domain socket the
  49 ;;; installer listens to.  Higher-level procedures such as
  50 ;;; 'choose-locale+keyboard' are provided to perform specific parts of the
  51 ;;; dialogue.
  52 ;;;
  53 ;;; Code:
  54
  55 (define %installer-socket-file
  56   ;; Socket the installer listens to.
  57   "/var/guix/installer-socket")
  58
  59 (define* (open-installer-socket #:optional (file %installer-socket-file))
  60   "Return a socket connected to the installer."
  61   (let ((sock (socket AF_UNIX SOCK_STREAM 0)))
  62     (connect sock AF_UNIX file)
  63     sock))
  64
  65 (define-condition-type &pattern-not-matched &error
  66   pattern-not-matched?
  67   (pattern pattern-not-matched-pattern)
  68   (sexp    pattern-not-matched-sexp))
  69
  70 (define (pattern-error pattern sexp)
  71   (raise (condition
  72           (&pattern-not-matched
  73            (pattern pattern) (sexp sexp)))))
  74
  75 (define conversation-log-port
  76   ;; Port where debugging info is logged
  77   (make-parameter (current-error-port)))
  78
  79 (define (converse-debug pattern)
  80   (format (conversation-log-port)
  81           "conversation expecting pattern ~s~%"
  82           pattern))
  83
  84 (define-syntax converse
  85   (lambda (s)
  86     "Convert over PORT: read sexps from there, match them against each
  87 PATTERN, and send the corresponding REPLY.  Raise to '&pattern-not-matched'
  88 when one of the PATTERNs is not matched."
  89
  90     ;; XXX: Strings that appear in PATTERNs must be in the language the
  91     ;; installer is running in.  In the future, we should add support to allow
  92     ;; writing English strings in PATTERNs and have the pattern matcher
  93     ;; automatically translate them.
  94
  95     ;; Here we emulate 'pmatch' syntax on top of 'match'.  This is ridiculous
  96     ;; but that's because 'pmatch' compares objects with 'eq?', making it
  97     ;; pretty useless, and it doesn't support ellipses and such.
  98
  99     (define (quote-pattern s)
 100       ;; Rewrite the pattern S from pmatch style (a ,b) to match style like
 101       ;; ('a b).
 102       (with-ellipsis :::
 103         (syntax-case s (unquote _ ...)
 104           ((unquote id) #'id)
 105           (_ #'_)
 106           (... #'...)
 107           (id
 108            (identifier? #'id)
 109            #''id)
 110           ((lst :::) (map quote-pattern #'(lst :::)))
 111           (pattern #'pattern))))
 112
 113     (define (match-pattern s)
 114       ;; Match one pattern without a guard.
 115       (syntax-case s ()
 116         ((port (pattern reply) continuation)
 117          (with-syntax ((pattern (quote-pattern #'pattern)))
 118            #'(let ((pat 'pattern))
 119                (converse-debug pat)
 120                (match (read port)
 121                  (pattern
 122                   (let ((data (call-with-values (lambda () reply)
 123                                 list)))
 124                     (for-each (lambda (obj)
 125                                 (write obj port)
 126                                 (newline port))
 127                               data)
 128                     (force-output port)
 129                     (continuation port)))
 130                  (sexp
 131                   (pattern-error pat sexp))))))))
 132
 133     (syntax-case s ()
 134       ((_ port (pattern reply) rest ...)
 135        (match-pattern #'(port (pattern reply)
 136                               (lambda (port)
 137                                 (converse port rest ...)))))
 138       ((_ port (pattern guard reply) rest ...)
 139        #`(let ((skip? (not guard))
 140                (next  (lambda (p)
 141                         (converse p rest ...))))
 142            (if skip?
 143                (next port)
 144                #,(match-pattern #'(port (pattern reply) next)))))
 145       ((_ port)
 146        #t))))
 147
 148 (define* (choose-locale+keyboard port
 149                                  #:key
 150                                  (language "English")
 151                                  (location "Hong Kong")
 152                                  (timezone '("Europe" "Zagreb"))
 153                                  (keyboard
 154                                   '("English (US)"
 155                                     "English (intl., with AltGr dead keys)")))
 156   "Converse over PORT with the guided installer to choose the specified
 157 LANGUAGE, LOCATION, TIMEZONE, and KEYBOARD."
 158   (converse port
 159     ((list-selection (title "Locale language")
 160                      (multiple-choices? #f)
 161                      (items _))
 162      language)
 163     ((list-selection (title "Locale location")
 164                      (multiple-choices? #f)
 165                      (items _))
 166      location)
 167     ((menu (title "GNU Guix install")
 168            (text _)
 169            (items (,guided _ ...)))           ;"Guided graphical installation"
 170      guided)
 171     ((list-selection (title "Timezone")
 172                      (multiple-choices? #f)
 173                      (items _))
 174      (first timezone))
 175     ((list-selection (title "Timezone")
 176                      (multiple-choices? #f)
 177                      (items _))
 178      (second timezone))
 179     ((list-selection (title "Layout")
 180                      (multiple-choices? #f)
 181                      (items _))
 182      (first keyboard))
 183     ((list-selection (title "Variant")
 184                      (multiple-choices? #f)
 185                      (items _))
 186      (second keyboard))))
 187
 188 (define* (enter-host-name+passwords port
 189                                     #:key
 190                                     (host-name "guix")
 191                                     (root-password "foo")
 192                                     (users '(("alice" "pass1")
 193                                              ("bob" "pass2")
 194                                              ("charlie" "pass3"))))
 195   "Converse over PORT with the guided installer to choose HOST-NAME,
 196 ROOT-PASSWORD, and USERS."
 197   (converse port
 198     ((input (title "Hostname") (text _) (default _))
 199      host-name)
 200     ((input (title "System administrator password") (text _) (default _))
 201      root-password)
 202     ((input (title "Password confirmation required") (text _) (default _))
 203      root-password)
 204     ((add-users)
 205      (match users
 206        (((names passwords) ...)
 207         (map (lambda (name password)
 208                `(user (name ,name) (real-name ,(string-titlecase name))
 209                       (home-directory ,(string-append "/home/" name))
 210                       (password ,password)))
 211              names passwords))))))
 212
 213 (define* (choose-services port
 214                           #:key
 215                           (choose-desktop-environment? (const #f))
 216                           (choose-network-service?
 217                            (lambda (service)
 218                              (or (string-contains service "SSH")
 219                                  (string-contains service "NSS"))))
 220                           (choose-network-management-tool?
 221                            (lambda (service)
 222                              (string-contains service "DHCP"))))
 223   "Converse over PORT to choose networking services."
 224   (define desktop-environments '())
 225
 226   (converse port
 227     ((checkbox-list (title "Desktop environment") (text _)
 228                     (items ,services))
 229      (let ((desktops (filter choose-desktop-environment? services)))
 230        (set! desktop-environments desktops)
 231        desktops))
 232     ((checkbox-list (title "Network service") (text _)
 233                     (items ,services))
 234      (filter choose-network-service? services))
 235
 236     ;; The "Network management" dialog shows up only when no desktop
 237     ;; environments have been selected, hence the guard.
 238     ((list-selection (title "Network management")
 239                      (multiple-choices? #f)
 240                      (items ,services))
 241      (null? desktop-environments)
 242      (find choose-network-management-tool? services))))
 243
 244 (define (edit-configuration-file file)
 245   "Edit FILE, an operating system configuration file generated by the
 246 installer, by adding a marionette service such that the installed OS is
 247 instrumented for further testing."
 248   (define (read-expressions port)
 249     (let loop ((result '()))
 250       (match (read port)
 251         ((? eof-object?)
 252          (reverse result))
 253         (exp
 254          (loop (cons exp result))))))
 255
 256   (define (edit exp)
 257     (match exp
 258       (('operating-system _ ...)
 259        `(marionette-operating-system ,exp
 260                                      #:imported-modules
 261                                      '((gnu services herd)
 262                                        (guix build utils)
 263                                        (guix combinators))))
 264       (_
 265        exp)))
 266
 267   (let ((content (call-with-input-file file read-expressions)))
 268     (call-with-output-file file
 269       (lambda (port)
 270         (format port "\
 271 ;; Operating system configuration edited for automated testing.~%~%")
 272
 273         (pretty-print '(use-modules (gnu tests)) port)
 274         (for-each (lambda (exp)
 275                     (pretty-print (edit exp) port)
 276                     (newline port))
 277                   content)))
 278
 279     #t))
 280
 281 (define* (choose-partitioning port
 282                               #:key
 283                               (encrypted? #t)
 284                               (passphrase "thepassphrase")
 285                               (edit-configuration-file
 286                                edit-configuration-file))
 287   "Converse over PORT to choose the partitioning method.  When ENCRYPTED? is
 288 true, choose full-disk encryption with PASSPHRASE as the LUKS passphrase.
 289 This conversation goes past the final dialog box that shows the configuration
 290 file, actually starting the installation process."
 291   (converse port
 292     ((list-selection (title "Partitioning method")
 293                      (multiple-choices? #f)
 294                      (items (,not-encrypted ,encrypted _ ...)))
 295      (if encrypted?
 296          encrypted
 297          not-encrypted))
 298     ((list-selection (title "Disk") (multiple-choices? #f)
 299                      (items (,disks ...)))
 300      ;; When running the installation from an ISO image, the CD/DVD drive
 301      ;; shows up in the list.  Avoid it.
 302      (find (lambda (disk)
 303              (not (or (string-contains disk "DVD")
 304                       (string-contains disk "CD-ROM"))))
 305            disks))
 306
 307     ;; The "Partition table" dialog pops up only if there's not already a
 308     ;; partition table.
 309     ((list-selection (title "Partition table")
 310                      (multiple-choices? #f)
 311                      (items _))
 312      "gpt")
 313     ((list-selection (title "Partition scheme")
 314                      (multiple-choices? #f)
 315                      (items (,one-partition _ ...)))
 316      one-partition)
 317     ((list-selection (title "Guided partitioning")
 318                      (multiple-choices? #f)
 319                      (items (,disk _ ...)))
 320      disk)
 321     ((input (title "Password required")
 322             (text _) (default #f))
 323      encrypted?                                   ;only when ENCRYPTED?
 324      passphrase)
 325     ((input (title "Password confirmation required")
 326             (text _) (default #f))
 327      encrypted?
 328      passphrase)
 329     ((confirmation (title "Format disk?") (text _))
 330      #t)
 331     ((info (title "Preparing partitions") _ ...)
 332      (values))                                    ;nothing to return
 333     ((file-dialog (title "Configuration file")
 334                   (text _)
 335                   (file ,configuration-file))
 336      (edit-configuration-file configuration-file))))
 337
 338 (define (conclude-installation port)
 339   "Conclude the installation by checking over PORT that we get the final
 340 messages once the 'guix system init' process has completed."
 341   (converse port
 342     ((pause)                                      ;"Press Enter to continue."
 343      #t)
 344     ((installation-complete)                      ;congratulations!
 345      (values))))
 346
 347 ;;; Local Variables:
 348 ;;; eval: (put 'converse 'scheme-indent-function 1)
 349 ;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)
 350 ;;; End: