aboutsummaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
authorMaxim Cournoyer <maxim.cournoyer@gmail.com>2020-10-19 12:51:57 -0400
committerMaxim Cournoyer <maxim.cournoyer@gmail.com>2020-10-19 13:11:40 -0400
commit5e2140511c1ad9ccd731438b74d61b62111da1e6 (patch)
treea4ff748ad26e121b88469b5d921001ef1382be8f /gnu/build
parent9e3a5ee417ea7fe9721be8804ff047e80c4f22ed (diff)
parent353bdae32f72b720c7ddd706576ccc40e2b43f95 (diff)
downloadguix-5e2140511c1ad9ccd731438b74d61b62111da1e6.tar
guix-5e2140511c1ad9ccd731438b74d61b62111da1e6.tar.gz
Merge branch 'staging'
Conflicts: gnu/packages/admin.scm gnu/packages/commencement.scm gnu/packages/gdb.scm gnu/packages/llvm.scm gnu/packages/package-management.scm gnu/packages/tls.scm
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/bootloader.scm15
-rw-r--r--gnu/build/hurd-boot.scm5
-rw-r--r--gnu/build/image.scm16
-rw-r--r--gnu/build/linux-container.scm3
-rw-r--r--gnu/build/secret-service.scm121
-rw-r--r--gnu/build/shepherd.scm16
6 files changed, 127 insertions, 49 deletions
diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm
index 498022f6db..5ec839f902 100644
--- a/gnu/build/bootloader.scm
+++ b/gnu/build/bootloader.scm
@@ -22,6 +22,8 @@
#:use-module (guix utils)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 format)
+ #:use-module (rnrs io ports)
+ #:use-module (rnrs io simple)
#:export (write-file-on-device
install-efi-loader))
@@ -35,11 +37,14 @@
(call-with-input-file file
(lambda (input)
(let ((bv (get-bytevector-n input size)))
- (call-with-output-file device
- (lambda (output)
- (seek output offset SEEK_SET)
- (put-bytevector output bv))
- #:binary #t)))))
+ (call-with-port
+ (open-file-output-port device
+ (file-options no-truncate no-create)
+ (buffer-mode block)
+ (native-transcoder))
+ (lambda (output)
+ (seek output offset SEEK_SET)
+ (put-bytevector output bv)))))))
;;;
diff --git a/gnu/build/hurd-boot.scm b/gnu/build/hurd-boot.scm
index adc8b4ce16..e66d4d1ba8 100644
--- a/gnu/build/hurd-boot.scm
+++ b/gnu/build/hurd-boot.scm
@@ -211,6 +211,9 @@ set."
("dev/vcs" ("/hurd/console"))
("dev/tty" ("/hurd/magic" "tty") #o666)
+ ;; 'fd_to_filename' in libc expects it.
+ ("dev/fd" ("/hurd/magic" "--directory" "fd") #o555)
+
("dev/tty1" ("/hurd/term" "/dev/tty1" "hurdio" "/dev/vcs/1/console")
#o666)
("dev/tty2" ("/hurd/term" "/dev/tty2" "hurdio" "/dev/vcs/2/console")
@@ -240,10 +243,10 @@ set."
(for-each scope-set-translator devices)
(false-if-EEXIST (symlink "/dev/random" (scope "dev/urandom")))
- (mkdir* "dev/fd")
(false-if-EEXIST (symlink "/dev/fd/0" (scope "dev/stdin")))
(false-if-EEXIST (symlink "/dev/fd/1" (scope "dev/stdout")))
(false-if-EEXIST (symlink "/dev/fd/2" (scope "dev/stderr")))
+ (false-if-EEXIST (symlink "crash-dump-core" (scope "servers/crash")))
;; Make sure /etc/mtab is a symlink to /proc/mounts.
(false-if-exception (delete-file (scope "etc/mtab")))
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index b6bf259f1b..ff63039c16 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -37,6 +37,7 @@
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (make-partition-image
+ convert-disk-image
genimage
initialize-efi-partition
initialize-root-partition
@@ -120,13 +121,22 @@ ROOT directory to populate the image."
(format (current-error-port)
"Unsupported partition type~%.")))))
-(define* (genimage config target)
+(define (convert-disk-image image format output)
+ "Convert IMAGE to OUTPUT according to the given FORMAT."
+ (case format
+ ((compressed-qcow2)
+ (begin
+ (invoke "qemu-img" "convert" "-c" "-f" "raw"
+ "-O" "qcow2" image output)))
+ (else
+ (copy-file image output))))
+
+(define* (genimage config)
"Use genimage to generate in TARGET directory, the image described in the
given CONFIG file."
;; genimage needs a 'root' directory.
(mkdir "root")
- (invoke "genimage" "--config" config
- "--outputpath" target))
+ (invoke "genimage" "--config" config))
(define* (register-closure prefix closure
#:key
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 2d4de788df..4a8bed5a9a 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -170,7 +170,8 @@ for the process."
(pivot-root root put-old)
(chdir "/")
(umount "real-root" MNT_DETACH)
- (rmdir "real-root")))
+ (rmdir "real-root")
+ (chmod "/" #o755)))
(define* (initialize-user-namespace pid host-uids
#:key (guest-uid 0) (guest-gid 0))
diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm
index 781651e90d..46dcf1b9c3 100644
--- a/gnu/build/secret-service.scm
+++ b/gnu/build/secret-service.scm
@@ -35,44 +35,86 @@
;;;
;;; Code:
-(define* (secret-service-send-secrets port secret-root #:key (retry 60))
- "Copy all files under SECRET-ROOT using TCP to secret-service listening at
-local PORT. If connect fails, sleep 1s and retry RETRY times."
+(define-syntax log
+ (lambda (s)
+ "Log the given message."
+ (syntax-case s ()
+ ((_ fmt args ...)
+ (with-syntax ((fmt (string-append "secret service: "
+ (syntax->datum #'fmt))))
+ ;; Log to the current output port. That way, when
+ ;; 'secret-service-send-secrets' is called from shepherd, output goes
+ ;; to syslog.
+ #'(format (current-output-port) fmt args ...))))))
+(define* (secret-service-send-secrets port secret-root
+ #:key (retry 60)
+ (handshake-timeout 120))
+ "Copy all files under SECRET-ROOT using TCP to secret-service listening at
+local PORT. If connect fails, sleep 1s and retry RETRY times; once connected,
+wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete. Return
+#f on failure."
(define (file->file+size+mode file-name)
(let ((stat (stat file-name))
(target (substring file-name (string-length secret-root))))
(list target (stat:size stat) (stat:mode stat))))
- (format (current-error-port) "sending secrets to ~a~%" port)
+ (define (send-files sock)
+ (let* ((files (if secret-root (find-files secret-root) '()))
+ (files-sizes-modes (map file->file+size+mode files))
+ (secrets `(secrets
+ (version 0)
+ (files ,files-sizes-modes))))
+ (write secrets sock)
+ (for-each (lambda (file)
+ (call-with-input-file file
+ (lambda (input)
+ (dump-port input sock))))
+ files)))
+
+ (log "sending secrets to ~a~%" port)
(let ((sock (socket AF_INET SOCK_STREAM 0))
(addr (make-socket-address AF_INET INADDR_LOOPBACK port)))
- ;; connect to wait for port
+ ;; Connect to QEMU on the forwarded port. The 'connect' call succeeds as
+ ;; soon as QEMU is ready, even if there's no server listening on the
+ ;; forward port inside the guest.
(let loop ((retry retry))
(catch 'system-error
(cute connect sock addr)
(lambda (key . args)
(when (zero? retry)
(apply throw key args))
- (format (current-error-port) "retrying connection~%")
+ (log "retrying connection [~a attempts left]~%"
+ (- retry 1))
(sleep 1)
(loop (1- retry)))))
- (format (current-error-port) "connected! sending files in ~s %~"
- secret-root)
- (let* ((files (if secret-root (find-files secret-root) '()))
- (files-sizes-modes (map file->file+size+mode files))
- (secrets `(secrets
- (version 0)
- (files ,files-sizes-modes))))
- (write secrets sock)
- (for-each (compose (cute dump-port <> sock)
- (cute open-input-file <>))
- files))))
+ (log "connected; waiting for handshake...~%")
+
+ ;; Wait for "hello" message from the server. This is the only way to know
+ ;; that we're really connected to the server inside the guest.
+ (match (select (list sock) '() '() handshake-timeout)
+ (((_) () ())
+ (match (read sock)
+ (('secret-service-server ('version version ...))
+ (log "sending files from ~s...~%" secret-root)
+ (send-files sock)
+ (log "done sending files to port ~a~%" port)
+ (close-port sock)
+ secret-root)
+ (x
+ (log "invalid handshake ~s~%" x)
+ (close-port sock)
+ #f)))
+ ((() () ()) ;timeout
+ (log "timeout while sending files to ~a~%" port)
+ (close-port sock)
+ #f))))
(define (secret-service-receive-secrets port)
"Listen to local PORT and wait for a secret service client to send secrets.
-Write them to the file system."
+Write them to the file system. Return the list of files installed on success,
+and #f otherwise."
(define (wait-for-client port)
;; Wait for a TCP connection on PORT. Note: We cannot use the
@@ -81,16 +123,26 @@ Write them to the file system."
(let ((sock (socket AF_INET SOCK_STREAM 0)))
(bind sock AF_INET INADDR_ANY port)
(listen sock 1)
- (format (current-error-port)
- "waiting for secrets on port ~a...~%"
- port)
- (match (accept sock)
- ((client . address)
- (format (current-error-port) "client connection from ~a~%"
+ (log "waiting for secrets on port ~a...~%" port)
+ (match (select (list sock) '() '() 60)
+ (((_) () ())
+ (match (accept sock)
+ ((client . address)
+ (log "client connection from ~a~%"
(inet-ntop (sockaddr:fam address)
(sockaddr:addr address)))
+
+ ;; Send a "hello" message. This allows the client running on the
+ ;; host to know that it's now actually connected to server running
+ ;; in the guest.
+ (write '(secret-service-server (version 0)) client)
+ (force-output client)
+ (close-port sock)
+ client)))
+ ((() () ())
+ (log "did not receive any secrets; time out~%")
(close-port sock)
- client))))
+ #f))))
;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size'
;; parameter.
@@ -115,23 +167,24 @@ Write them to the file system."
(('secrets ('version 0)
('files ((files sizes modes) ...)))
(for-each (lambda (file size mode)
- (format (current-error-port)
- "installing file '~a' (~a bytes)...~%"
- file size)
+ (log "installing file '~a' (~a bytes)...~%"
+ file size)
(mkdir-p (dirname file))
(call-with-output-file file
(lambda (output)
(dump port output size)
(chmod file mode))))
- files sizes modes))
+ files sizes modes)
+ (log "received ~a secret files~%" (length files))
+ files)
(_
- (format (current-error-port)
- "invalid secrets received~%")
+ (log "invalid secrets received~%")
#f)))
- (let* ((port (wait-for-client port))
- (result (read-secrets port)))
- (close-port port)
+ (let* ((port (wait-for-client port))
+ (result (and=> port read-secrets)))
+ (when port
+ (close-port port))
result))
;;; secret-service.scm ends here
diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm
index 65141bd60f..91646288d5 100644
--- a/gnu/build/shepherd.scm
+++ b/gnu/build/shepherd.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -196,11 +197,16 @@ namespace, in addition to essential bind-mounts such /proc."
#:allow-other-keys
#:rest args)
"This is a variant of 'fork+exec-command' procedure, that joins the
-namespaces of process PID beforehand."
- (container-excursion* pid
- (lambda ()
- (apply fork+exec-command command
- (strip-keyword-arguments '(#:pid) args)))))
+namespaces of process PID beforehand. If there is no support for containers,
+on Hurd systems for instance, fallback to direct forking."
+ (let ((container-support?
+ (file-exists? "/proc/self/ns"))
+ (fork-proc (lambda ()
+ (apply fork+exec-command command
+ (strip-keyword-arguments '(#:pid) args)))))
+ (if container-support?
+ (container-excursion* pid fork-proc)
+ (fork-proc))))
;; Local Variables:
;; eval: (put 'container-excursion* 'scheme-indent-function 1)