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) | |
8361817b | 21 | #:use-module (gnu services herd) |
3ad8f775 | 22 | #:use-module (guix utils) |
96bb00d2 | 23 | #:use-module ((guix build syscalls) #:select (openpty login-tty)) |
3ad8f775 | 24 | #:use-module (guix build utils) |
9529f785 | 25 | #:use-module (guix i18n) |
63b8c089 | 26 | #:use-module (srfi srfi-1) |
4814ec28 JP |
27 | #:use-module (srfi srfi-9) |
28 | #:use-module (srfi srfi-9 gnu) | |
3d3ffb30 | 29 | #:use-module (srfi srfi-19) |
9529f785 | 30 | #:use-module (srfi srfi-34) |
408427a3 | 31 | #:use-module (srfi srfi-35) |
0b9fbbb4 | 32 | #:use-module (ice-9 control) |
63b8c089 | 33 | #:use-module (ice-9 match) |
0b9fbbb4 | 34 | #:use-module (ice-9 popen) |
d0f3a672 | 35 | #:use-module (ice-9 rdelim) |
3ad8f775 | 36 | #:use-module (ice-9 regex) |
2cf65e1d | 37 | #:use-module (ice-9 format) |
d0f3a672 | 38 | #:use-module (ice-9 textual-ports) |
4814ec28 JP |
39 | #:export (<secret> |
40 | secret? | |
41 | make-secret | |
42 | secret-content | |
43 | ||
44 | read-lines | |
3ad8f775 MO |
45 | read-all |
46 | nearest-exact-integer | |
47 | read-percentage | |
0b9fbbb4 | 48 | run-external-command-with-handler |
96bb00d2 | 49 | run-external-command-with-handler/tty |
0b9fbbb4 | 50 | run-external-command-with-line-hooks |
8a4b11c6 | 51 | run-command |
408427a3 | 52 | run-command-in-installer |
2cf65e1d LC |
53 | |
54 | syslog-port | |
7251b15d | 55 | %syslog-line-hook |
7251b15d JP |
56 | installer-log-port |
57 | %installer-log-line-hook | |
58 | %default-installer-line-hooks | |
59 | installer-log-line | |
3d3ffb30 MO |
60 | call-with-time |
61 | let/time | |
63b8c089 LC |
62 | |
63 | with-server-socket | |
64 | current-server-socket | |
65 | current-clients | |
8361817b MO |
66 | send-to-clients |
67 | ||
68 | with-silent-shepherd)) | |
d0f3a672 | 69 | |
4814ec28 JP |
70 | (define-record-type <secret> |
71 | (make-secret content) | |
72 | secret? | |
73 | (content secret-content)) | |
74 | ||
75 | (set-record-type-printer! | |
76 | <secret> | |
77 | (lambda (secret port) | |
78 | (format port "<secret>"))) | |
79 | ||
d0f3a672 MO |
80 | (define* (read-lines #:optional (port (current-input-port))) |
81 | "Read lines from PORT and return them as a list." | |
82 | (let loop ((line (read-line port)) | |
83 | (lines '())) | |
84 | (if (eof-object? line) | |
85 | (reverse lines) | |
86 | (loop (read-line port) | |
87 | (cons line lines))))) | |
88 | ||
89 | (define (read-all file) | |
90 | "Return the content of the given FILE as a string." | |
91 | (call-with-input-file file | |
92 | get-string-all)) | |
3ad8f775 MO |
93 | |
94 | (define (nearest-exact-integer x) | |
95 | "Given a real number X, return the nearest exact integer, with ties going to | |
96 | the nearest exact even integer." | |
97 | (inexact->exact (round x))) | |
98 | ||
99 | (define (read-percentage percentage) | |
100 | "Read PERCENTAGE string and return the corresponding percentage as a | |
101 | number. If no percentage is found, return #f" | |
102 | (let ((result (string-match "^([0-9]+)%$" percentage))) | |
103 | (and result | |
104 | (string->number (match:substring result 1))))) | |
105 | ||
0b9fbbb4 JP |
106 | (define* (run-external-command-with-handler handler command) |
107 | "Run command specified by the list COMMAND in a child with output handler | |
108 | HANDLER. HANDLER is a procedure taking an input port, to which the command | |
109 | will write its standard output and error. Returns the integer status value of | |
110 | the child process as returned by waitpid." | |
111 | (match-let (((input . output) (pipe))) | |
112 | ;; Hack to work around Guile bug 52835 | |
113 | (define dup-output (duplicate-port output "w")) | |
114 | ;; Void pipe, but holds the pid for close-pipe. | |
115 | (define dummy-pipe | |
116 | (with-input-from-file "/dev/null" | |
117 | (lambda () | |
118 | (with-output-to-port output | |
119 | (lambda () | |
120 | (with-error-to-port dup-output | |
121 | (lambda () | |
122 | (apply open-pipe* (cons "" command))))))))) | |
123 | (close-port output) | |
124 | (close-port dup-output) | |
125 | (handler input) | |
126 | (close-port input) | |
127 | (close-pipe dummy-pipe))) | |
128 | ||
96bb00d2 MO |
129 | (define (run-external-command-with-handler/tty handler command) |
130 | "Run command specified by the list COMMAND in a child operating in a | |
131 | pseudoterminal with output handler HANDLER. HANDLER is a procedure taking an | |
132 | input port, to which the command will write its standard output and error. | |
133 | Returns the integer status value of the child process as returned by waitpid." | |
134 | (define-values (controller inferior) | |
135 | (openpty)) | |
136 | ||
137 | (match (primitive-fork) | |
138 | (0 | |
139 | (catch #t | |
140 | (lambda () | |
141 | (close-fdes controller) | |
142 | (login-tty inferior) | |
143 | (apply execlp (car command) command)) | |
144 | (lambda _ | |
145 | (primitive-exit 127)))) | |
146 | (pid | |
147 | (close-fdes inferior) | |
148 | (let* ((port (fdopen controller "r0")) | |
149 | (result (false-if-exception | |
150 | (handler port)))) | |
151 | (close-port port) | |
152 | (cdr (waitpid pid)))))) | |
153 | ||
154 | (define* (run-external-command-with-line-hooks line-hooks command | |
155 | #:key (tty? #false)) | |
0b9fbbb4 | 156 | "Run command specified by the list COMMAND in a child, processing each |
96bb00d2 MO |
157 | output line with the procedures in LINE-HOOKS. If TTY is set to #true, the |
158 | COMMAND will be run in a pseudoterminal. Returns the integer status value of | |
159 | the child process as returned by waitpid." | |
0b9fbbb4 JP |
160 | (define (handler input) |
161 | (and | |
162 | (and=> (get-line input) | |
163 | (lambda (line) | |
164 | (if (eof-object? line) | |
165 | #f | |
166 | (begin (for-each (lambda (f) (f line)) | |
167 | (append line-hooks | |
96bb00d2 | 168 | %default-installer-line-hooks)) |
0b9fbbb4 JP |
169 | #t)))) |
170 | (handler input))) | |
96bb00d2 MO |
171 | (if tty? |
172 | (run-external-command-with-handler/tty handler command) | |
173 | (run-external-command-with-handler handler command))) | |
0b9fbbb4 | 174 | |
96bb00d2 | 175 | (define* (run-command command #:key (tty? #f)) |
0c9693d8 | 176 | "Run COMMAND, a list of strings. Return true if COMMAND exited |
96bb00d2 MO |
177 | successfully, #f otherwise. If TTY is set to #true, the COMMAND will be run |
178 | in a pseudoterminal." | |
5f7c4416 MO |
179 | (define (pause) |
180 | (format #t (G_ "Press Enter to continue.~%")) | |
181 | (send-to-clients '(pause)) | |
5f7c4416 MO |
182 | (match (select (cons (current-input-port) (current-clients)) |
183 | '() '()) | |
184 | (((port _ ...) _ _) | |
185 | (read-line port)))) | |
186 | ||
0b9fbbb4 JP |
187 | (installer-log-line "running command ~s" command) |
188 | (define result (run-external-command-with-line-hooks | |
96bb00d2 MO |
189 | (list %display-line-hook) command |
190 | #:tty? tty?)) | |
0b9fbbb4 JP |
191 | (define exit-val (status:exit-val result)) |
192 | (define term-sig (status:term-sig result)) | |
193 | (define stop-sig (status:stop-sig result)) | |
194 | (define succeeded? | |
195 | (cond | |
196 | ((and exit-val (not (zero? exit-val))) | |
197 | (installer-log-line "command ~s exited with value ~a" | |
198 | command exit-val) | |
199 | (format #t (G_ "Command ~s exited with value ~a") | |
200 | command exit-val) | |
201 | #f) | |
202 | (term-sig | |
203 | (installer-log-line "command ~s killed by signal ~a" | |
204 | command term-sig) | |
205 | (format #t (G_ "Command ~s killed by signal ~a") | |
206 | command term-sig) | |
207 | #f) | |
208 | (stop-sig | |
209 | (installer-log-line "command ~s stopped by signal ~a" | |
210 | command stop-sig) | |
211 | (format #t (G_ "Command ~s stopped by signal ~a") | |
212 | command stop-sig) | |
213 | #f) | |
214 | (else | |
215 | (installer-log-line "command ~s succeeded" command) | |
216 | (format #t (G_ "Command ~s succeeded") command) | |
217 | #t))) | |
218 | (newline) | |
219 | (pause) | |
220 | succeeded?) | |
5f7c4416 | 221 | |
408427a3 JP |
222 | (define run-command-in-installer |
223 | (make-parameter | |
224 | (lambda (. args) | |
225 | (raise | |
226 | (condition | |
227 | (&serious) | |
228 | (&message (message "run-command-in-installer not set"))))))) | |
229 | ||
2cf65e1d LC |
230 | \f |
231 | ;;; | |
232 | ;;; Logging. | |
233 | ;;; | |
234 | ||
3d3ffb30 MO |
235 | (define (call-with-time thunk kont) |
236 | "Call THUNK and pass KONT the elapsed time followed by THUNK's return | |
237 | values." | |
238 | (let* ((start (current-time time-monotonic)) | |
239 | (result (call-with-values thunk list)) | |
240 | (end (current-time time-monotonic))) | |
241 | (apply kont (time-difference end start) result))) | |
242 | ||
243 | (define-syntax-rule (let/time ((time result exp)) body ...) | |
244 | (call-with-time (lambda () exp) (lambda (time result) body ...))) | |
245 | ||
2cf65e1d LC |
246 | (define (open-syslog-port) |
247 | "Return an open port (a socket) to /dev/log or #f if that wasn't possible." | |
248 | (let ((sock (socket AF_UNIX SOCK_DGRAM 0))) | |
249 | (catch 'system-error | |
250 | (lambda () | |
251 | (connect sock AF_UNIX "/dev/log") | |
252 | (setvbuf sock 'line) | |
253 | sock) | |
254 | (lambda args | |
255 | (close-port sock) | |
256 | #f)))) | |
257 | ||
258 | (define syslog-port | |
259 | (let ((port #f)) | |
260 | (lambda () | |
261 | "Return an output port to syslog." | |
262 | (unless port | |
263 | (set! port (open-syslog-port))) | |
264 | (or port (%make-void-port "w"))))) | |
265 | ||
7251b15d JP |
266 | (define (%syslog-line-hook line) |
267 | (format (syslog-port) "installer[~d]: ~a~%" (getpid) line)) | |
268 | ||
2cf65e1d LC |
269 | (define-syntax syslog |
270 | (lambda (s) | |
271 | "Like 'format', but write to syslog." | |
272 | (syntax-case s () | |
273 | ((_ fmt args ...) | |
274 | (string? (syntax->datum #'fmt)) | |
275 | (with-syntax ((fmt (string-append "installer[~d]: " | |
276 | (syntax->datum #'fmt)))) | |
277 | #'(format (syslog-port) fmt (getpid) args ...)))))) | |
63b8c089 | 278 | |
7251b15d JP |
279 | (define (open-new-log-port) |
280 | (define now (localtime (time-second (current-time)))) | |
281 | (define filename | |
282 | (format #f "/tmp/installer.~a.log" | |
283 | (strftime "%F.%T" now))) | |
284 | (open filename (logior O_RDWR | |
285 | O_CREAT))) | |
286 | ||
287 | (define installer-log-port | |
288 | (let ((port #f)) | |
289 | (lambda () | |
290 | "Return an input and output port to the installer log." | |
291 | (unless port | |
292 | (set! port (open-new-log-port))) | |
293 | port))) | |
294 | ||
295 | (define (%installer-log-line-hook line) | |
296 | (format (installer-log-port) "~a~%" line)) | |
297 | ||
298 | (define (%display-line-hook line) | |
299 | (display line) | |
300 | (newline)) | |
301 | ||
302 | (define %default-installer-line-hooks | |
303 | (list %syslog-line-hook | |
304 | %installer-log-line-hook)) | |
305 | ||
306 | (define-syntax installer-log-line | |
307 | (lambda (s) | |
308 | "Like 'format', but uses the default line hooks, and only formats one line." | |
309 | (syntax-case s () | |
310 | ((_ fmt args ...) | |
311 | (string? (syntax->datum #'fmt)) | |
312 | #'(let ((formatted (format #f fmt args ...))) | |
313 | (for-each (lambda (f) (f formatted)) | |
314 | %default-installer-line-hooks)))))) | |
315 | ||
63b8c089 LC |
316 | \f |
317 | ;;; | |
318 | ;;; Client protocol. | |
319 | ;;; | |
320 | ||
321 | (define %client-socket-file | |
322 | ;; Unix-domain socket where the installer accepts connections. | |
323 | "/var/guix/installer-socket") | |
324 | ||
325 | (define current-server-socket | |
326 | ;; Socket on which the installer is currently accepting connections, or #f. | |
327 | (make-parameter #f)) | |
328 | ||
329 | (define current-clients | |
330 | ;; List of currently connected clients. | |
331 | (make-parameter '())) | |
332 | ||
333 | (define* (open-server-socket | |
334 | #:optional (socket-file %client-socket-file)) | |
335 | "Open SOCKET-FILE as a Unix-domain socket to accept incoming connections and | |
336 | return it." | |
337 | (mkdir-p (dirname socket-file)) | |
338 | (when (file-exists? socket-file) | |
339 | (delete-file socket-file)) | |
340 | (let ((sock (socket AF_UNIX SOCK_STREAM 0))) | |
341 | (bind sock AF_UNIX socket-file) | |
342 | (listen sock 0) | |
343 | sock)) | |
344 | ||
345 | (define (call-with-server-socket thunk) | |
346 | (if (current-server-socket) | |
347 | (thunk) | |
348 | (let ((socket (open-server-socket))) | |
349 | (dynamic-wind | |
350 | (const #t) | |
351 | (lambda () | |
352 | (parameterize ((current-server-socket socket)) | |
353 | (thunk))) | |
354 | (lambda () | |
355 | (close-port socket)))))) | |
356 | ||
357 | (define-syntax-rule (with-server-socket exp ...) | |
358 | "Evaluate EXP with 'current-server-socket' parameterized to a currently | |
359 | accepting socket." | |
360 | (call-with-server-socket (lambda () exp ...))) | |
361 | ||
362 | (define* (send-to-clients exp) | |
363 | "Send EXP to all the current clients." | |
364 | (define remainder | |
365 | (fold (lambda (client remainder) | |
366 | (catch 'system-error | |
367 | (lambda () | |
368 | (write exp client) | |
369 | (newline client) | |
370 | (force-output client) | |
371 | (cons client remainder)) | |
372 | (lambda args | |
373 | ;; We might get EPIPE if the client disconnects; when that | |
374 | ;; happens, remove CLIENT from the set of available clients. | |
375 | (let ((errno (system-error-errno args))) | |
376 | (if (memv errno (list EPIPE ECONNRESET ECONNABORTED)) | |
377 | (begin | |
4f2fd33b JP |
378 | (installer-log-line |
379 | "removing client ~s due to ~s while replying" | |
380 | (fileno client) (strerror errno)) | |
63b8c089 LC |
381 | (false-if-exception (close-port client)) |
382 | remainder) | |
383 | (cons client remainder)))))) | |
384 | '() | |
385 | (current-clients))) | |
386 | ||
387 | (current-clients (reverse remainder)) | |
388 | exp) | |
8361817b MO |
389 | |
390 | (define-syntax-rule (with-silent-shepherd exp ...) | |
391 | "Evaluate EXP while discarding shepherd messages." | |
392 | (parameterize ((shepherd-message-port | |
393 | (%make-void-port "w"))) | |
394 | exp ...)) |