gnu/installer/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2019, 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 utils)
  21   #:use-module (guix utils)
  22   #:use-module (guix build utils)
  23   #:use-module (guix i18n)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-19)
  26   #:use-module (srfi srfi-34)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 rdelim)
  29   #:use-module (ice-9 regex)
  30   #:use-module (ice-9 format)
  31   #:use-module (ice-9 textual-ports)
  32   #:export (read-lines
  33             read-all
  34             nearest-exact-integer
  35             read-percentage
  36             run-command
  37
  38             syslog-port
  39             syslog
  40             call-with-time
  41             let/time
  42
  43             with-server-socket
  44             current-server-socket
  45             current-clients
  46             send-to-clients))
  47
  48 (define* (read-lines #:optional (port (current-input-port)))
  49   "Read lines from PORT and return them as a list."
  50   (let loop ((line (read-line port))
  51              (lines '()))
  52     (if (eof-object? line)
  53         (reverse lines)
  54         (loop (read-line port)
  55               (cons line lines)))))
  56
  57 (define (read-all file)
  58   "Return the content of the given FILE as a string."
  59   (call-with-input-file file
  60     get-string-all))
  61
  62 (define (nearest-exact-integer x)
  63   "Given a real number X, return the nearest exact integer, with ties going to
  64 the nearest exact even integer."
  65   (inexact->exact (round x)))
  66
  67 (define (read-percentage percentage)
  68   "Read PERCENTAGE string and return the corresponding percentage as a
  69 number. If no percentage is found, return #f"
  70   (let ((result (string-match "^([0-9]+)%$" percentage)))
  71     (and result
  72          (string->number (match:substring result 1)))))
  73
  74 (define* (run-command command #:key locale)
  75   "Run COMMAND, a list of strings, in the given LOCALE.  Return true if
  76 COMMAND exited successfully, #f otherwise."
  77   (define env (environ))
  78
  79   (define (pause)
  80     (format #t (G_ "Press Enter to continue.~%"))
  81     (send-to-clients '(pause))
  82     (environ env)                               ;restore environment variables
  83     (match (select (cons (current-input-port) (current-clients))
  84              '() '())
  85       (((port _ ...) _ _)
  86        (read-line port))))
  87
  88   (setenv "PATH" "/run/current-system/profile/bin")
  89
  90   (when locale
  91     (let ((supported? (false-if-exception
  92                        (setlocale LC_ALL locale))))
  93       ;; If LOCALE is not supported, then set LANGUAGE, which might at
  94       ;; least give us translated messages.
  95       (if supported?
  96           (setenv "LC_ALL" locale)
  97           (setenv "LANGUAGE"
  98                   (string-take locale
  99                                (or (string-index locale #\_)
 100                                    (string-length locale)))))))
 101
 102   (guard (c ((invoke-error? c)
 103              (newline)
 104              (format (current-error-port)
 105                      (G_ "Command failed with exit code ~a.~%")
 106                      (invoke-error-exit-status c))
 107              (syslog "command ~s failed with exit code ~a"
 108                      command (invoke-error-exit-status c))
 109              (pause)
 110              #f))
 111     (syslog "running command ~s~%" command)
 112     (apply invoke command)
 113     (syslog "command ~s succeeded~%" command)
 114     (newline)
 115     (pause)
 116     #t))
 117
 118 \f
 119 ;;;
 120 ;;; Logging.
 121 ;;;
 122
 123 (define (call-with-time thunk kont)
 124   "Call THUNK and pass KONT the elapsed time followed by THUNK's return
 125 values."
 126   (let* ((start  (current-time time-monotonic))
 127          (result (call-with-values thunk list))
 128          (end    (current-time time-monotonic)))
 129     (apply kont (time-difference end start) result)))
 130
 131 (define-syntax-rule (let/time ((time result exp)) body ...)
 132   (call-with-time (lambda () exp) (lambda (time result) body ...)))
 133
 134 (define (open-syslog-port)
 135   "Return an open port (a socket) to /dev/log or #f if that wasn't possible."
 136   (let ((sock (socket AF_UNIX SOCK_DGRAM 0)))
 137     (catch 'system-error
 138       (lambda ()
 139         (connect sock AF_UNIX "/dev/log")
 140         (setvbuf sock 'line)
 141         sock)
 142       (lambda args
 143         (close-port sock)
 144         #f))))
 145
 146 (define syslog-port
 147   (let ((port #f))
 148     (lambda ()
 149       "Return an output port to syslog."
 150       (unless port
 151         (set! port (open-syslog-port)))
 152       (or port (%make-void-port "w")))))
 153
 154 (define-syntax syslog
 155   (lambda (s)
 156     "Like 'format', but write to syslog."
 157     (syntax-case s ()
 158       ((_ fmt args ...)
 159        (string? (syntax->datum #'fmt))
 160        (with-syntax ((fmt (string-append "installer[~d]: "
 161                                          (syntax->datum #'fmt))))
 162          #'(format (syslog-port) fmt (getpid) args ...))))))
 163
 164 \f
 165 ;;;
 166 ;;; Client protocol.
 167 ;;;
 168
 169 (define %client-socket-file
 170   ;; Unix-domain socket where the installer accepts connections.
 171   "/var/guix/installer-socket")
 172
 173 (define current-server-socket
 174   ;; Socket on which the installer is currently accepting connections, or #f.
 175   (make-parameter #f))
 176
 177 (define current-clients
 178   ;; List of currently connected clients.
 179   (make-parameter '()))
 180
 181 (define* (open-server-socket
 182           #:optional (socket-file %client-socket-file))
 183   "Open SOCKET-FILE as a Unix-domain socket to accept incoming connections and
 184 return it."
 185   (mkdir-p (dirname socket-file))
 186   (when (file-exists? socket-file)
 187     (delete-file socket-file))
 188   (let ((sock (socket AF_UNIX SOCK_STREAM 0)))
 189     (bind sock AF_UNIX socket-file)
 190     (listen sock 0)
 191     sock))
 192
 193 (define (call-with-server-socket thunk)
 194   (if (current-server-socket)
 195       (thunk)
 196       (let ((socket (open-server-socket)))
 197         (dynamic-wind
 198           (const #t)
 199           (lambda ()
 200             (parameterize ((current-server-socket socket))
 201               (thunk)))
 202           (lambda ()
 203             (close-port socket))))))
 204
 205 (define-syntax-rule (with-server-socket exp ...)
 206   "Evaluate EXP with 'current-server-socket' parameterized to a currently
 207 accepting socket."
 208   (call-with-server-socket (lambda () exp ...)))
 209
 210 (define* (send-to-clients exp)
 211   "Send EXP to all the current clients."
 212   (define remainder
 213     (fold (lambda (client remainder)
 214             (catch 'system-error
 215               (lambda ()
 216                 (write exp client)
 217                 (newline client)
 218                 (force-output client)
 219                 (cons client remainder))
 220               (lambda args
 221                 ;; We might get EPIPE if the client disconnects; when that
 222                 ;; happens, remove CLIENT from the set of available clients.
 223                 (let ((errno (system-error-errno args)))
 224                   (if (memv errno (list EPIPE ECONNRESET ECONNABORTED))
 225                       (begin
 226                         (syslog "removing client ~s due to ~s while replying~%"
 227                                 (fileno client) (strerror errno))
 228                         (false-if-exception (close-port client))
 229                         remainder)
 230                       (cons client remainder))))))
 231           '()
 232           (current-clients)))
 233
 234   (current-clients (reverse remainder))
 235   exp)