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