Commit | Line | Data |
---|---|---|
d0f3a672 | 1 | ;;; GNU Guix --- Functional package management for GNU |
1a24df44 | 2 | ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com> |
2cf65e1d | 3 | ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
d0f3a672 MO |
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) | |
3ad8f775 MO |
21 | #:use-module (guix utils) |
22 | #:use-module (guix build utils) | |
9529f785 | 23 | #:use-module (guix i18n) |
63b8c089 | 24 | #:use-module (srfi srfi-1) |
9529f785 | 25 | #:use-module (srfi srfi-34) |
63b8c089 | 26 | #:use-module (ice-9 match) |
d0f3a672 | 27 | #:use-module (ice-9 rdelim) |
3ad8f775 | 28 | #:use-module (ice-9 regex) |
2cf65e1d | 29 | #:use-module (ice-9 format) |
d0f3a672 MO |
30 | #:use-module (ice-9 textual-ports) |
31 | #:export (read-lines | |
3ad8f775 MO |
32 | read-all |
33 | nearest-exact-integer | |
34 | read-percentage | |
8a4b11c6 | 35 | run-command |
2cf65e1d LC |
36 | |
37 | syslog-port | |
63b8c089 LC |
38 | syslog |
39 | ||
40 | with-server-socket | |
41 | current-server-socket | |
42 | current-clients | |
43 | send-to-clients)) | |
d0f3a672 MO |
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)) | |
3ad8f775 MO |
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 | ||
5f7c4416 MO |
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 | ||
2cf65e1d LC |
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 ...)))))) | |
63b8c089 LC |
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) |