projects/guix·blob java-team · refs

401 lines · 13.2 KiB

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