diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/profiles.scm | 7 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 114 | ||||
| -rw-r--r-- | guix/import/gnome.scm | 15 | ||||
| -rw-r--r-- | guix/platform.scm | 2 | ||||
| -rw-r--r-- | guix/read-print.scm | 59 | ||||
| -rw-r--r-- | guix/search-paths.scm | 20 | ||||
| -rw-r--r-- | guix/store.scm | 63 |
7 files changed, 162 insertions, 118 deletions
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 0c92f222b4..b19d93f971 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -179,9 +179,10 @@ search path specifications." (() (values (reverse inputs) (delete-duplicates - (cons $PATH - (map sexp->search-path-specification - (reverse search-paths))))))))))) + (cons* $PATH + $GUIX_EXTENSIONS_PATH + (map sexp->search-path-specification + (reverse search-paths))))))))))) (define* (build-profile output manifest #:key (extra-inputs '()) (symlink symlink)) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index eda487f52e..7842b0a9fc 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -549,50 +549,50 @@ the last argument of `mknod'." (define MNT_EXPIRE 4) (define UMOUNT_NOFOLLOW 8) -(define-as-needed (mount source target type - #:optional (flags 0) options - #:key (update-mtab? #f)) - "Mount device SOURCE on TARGET as a file system TYPE. -Optionally, FLAGS may be a bitwise-or of the MS_* <sys/mount.h> -constants, and OPTIONS may be a string. When FLAGS contains -MS_REMOUNT, SOURCE and TYPE are ignored. When UPDATE-MTAB? is true, -update /etc/mtab. Raise a 'system-error' exception on error." +(define-as-needed mount ;; XXX: '#:update-mtab?' is not implemented by core 'mount'. (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *)))) - (let-values (((ret err) - (proc (if source - (string->pointer source) - %null-pointer) - (string->pointer target) - (if type - (string->pointer type) - %null-pointer) - flags - (if options - (string->pointer options) - %null-pointer)))) - (unless (zero? ret) - (throw 'system-error "mount" "mount ~S on ~S: ~A" - (list source target (strerror err)) - (list err))) - (when update-mtab? - (augment-mtab source target type options))))) + (lambda* (source target type + #:optional (flags 0) options + #:key (update-mtab? #f)) + "Mount device SOURCE on TARGET as a file system TYPE. +Optionally, FLAGS may be a bitwise-or of the MS_* <sys/mount.h> constants, and +OPTIONS may be a string. When FLAGS contains MS_REMOUNT, SOURCE and TYPE are +ignored. When UPDATE-MTAB? is true, update /etc/mtab. Raise a 'system-error' +exception on error." + (let-values (((ret err) + (proc (if source + (string->pointer source) + %null-pointer) + (string->pointer target) + (if type + (string->pointer type) + %null-pointer) + flags + (if options + (string->pointer options) + %null-pointer)))) + (unless (zero? ret) + (throw 'system-error "mount" "mount ~S on ~S: ~A" + (list source target (strerror err)) + (list err))) + (when update-mtab? + (augment-mtab source target type options)))))) -(define-as-needed (umount target - #:optional (flags 0) - #:key (update-mtab? #f)) - "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* -constants from <sys/mount.h>." +(define-as-needed umount ;; XXX: '#:update-mtab?' is not implemented by core 'umount'. - (let ((proc (syscall->procedure int "umount2" `(* ,int)))) - (let-values (((ret err) - (proc (string->pointer target) flags))) - (unless (zero? ret) - (throw 'system-error "umount" "~S: ~A" - (list target (strerror err)) - (list err))) - (when update-mtab? - (remove-from-mtab target))))) + (let ((proc (syscall->procedure int "umount2" `(* ,int)))) ;XXX + (lambda* (target #:optional (flags 0) #:key (update-mtab? #f)) + "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* +constants from <sys/mount.h>." + (let-values (((ret err) + (proc (string->pointer target) flags))) + (unless (zero? ret) + (throw 'system-error "umount" "~S: ~A" + (list target (strerror err)) + (list err))) + (when update-mtab? + (remove-from-mtab target)))))) ;; Mount point information. (define-record-type <mount> @@ -732,25 +732,27 @@ current process." (define-as-needed RB_SW_SUSPEND #xd000fce2) (define-as-needed RB_KEXEC #x45584543) -(define-as-needed (reboot #:optional (cmd RB_AUTOBOOT)) +(define-as-needed reboot (let ((proc (syscall->procedure int "reboot" (list int)))) - (let-values (((ret err) (proc cmd))) - (unless (zero? ret) - (throw 'system-error "reboot" "~S: ~A" - (list cmd (strerror err)) - (list err)))))) + (lambda* (#:optional (cmd RB_AUTOBOOT)) + (let-values (((ret err) (proc cmd))) + (unless (zero? ret) + (throw 'system-error "reboot" "~S: ~A" + (list cmd (strerror err)) + (list err))))))) -(define-as-needed (load-linux-module data #:optional (options "")) +(define-as-needed load-linux-module (let ((proc (syscall->procedure int "init_module" (list '* unsigned-long '*)))) - (let-values (((ret err) - (proc (bytevector->pointer data) - (bytevector-length data) - (string->pointer options)))) - (unless (zero? ret) - (throw 'system-error "load-linux-module" "~A" - (list (strerror err)) - (list err)))))) + (lambda* (data #:optional (options "")) + (let-values (((ret err) + (proc (bytevector->pointer data) + (bytevector-length data) + (string->pointer options)))) + (unless (zero? ret) + (throw 'system-error "load-linux-module" "~A" + (list (strerror err)) + (list err))))))) (define (kernel? pid) "Return #t if PID designates a \"kernel thread\" rather than a normal diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm index 43966c1028..49ad7169fd 100644 --- a/guix/import/gnome.scm +++ b/guix/import/gnome.scm @@ -62,11 +62,16 @@ not be determined." (define (even-minor-version? version) (match (string-tokenize version %not-dot) - (((= string->number major) (= string->number minor) . rest) - (and minor (even? minor))) - (((= string->number major) . _) - ;; It should at last start with a digit. - major))) + (((= string->number major) (= string->number minor) (= string->number micro)) + ;; This is for things like GLib, with version strings like "2.72.3". + (and minor (even? minor) micro)) + (((= string->number major) (= string->number minor)) + ;; GNOME applications have version strings like "42.1" (only two + ;; integers) and are not subject to the odd/even policy. MAJOR and + ;; MINOR should be valid numbers though; "43.alpha" is rejected. + (and major minor)) + (_ + #f))) (define upstream-name ;; Some packages like "NetworkManager" have camel-case names. diff --git a/guix/platform.scm b/guix/platform.scm index 19d4527e29..f873913fe0 100644 --- a/guix/platform.scm +++ b/guix/platform.scm @@ -67,7 +67,7 @@ (target platform-target) (system platform-system) (linux-architecture platform-linux-architecture - (default #f)) + (default #false)) (glibc-dynamic-linker platform-glibc-dynamic-linker)) diff --git a/guix/read-print.scm b/guix/read-print.scm index 00dde870f4..a5a1b708bf 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -386,6 +386,21 @@ particular newlines, is left as is." str) #\"))) +(define %natural-whitespace-string-forms + ;; When a string has one of these forms as its parent, only double quotes + ;; and backslashes are escaped; newlines, tabs, etc. are left as-is. + '(synopsis description G_ N_)) + +(define (printed-string str context) + "Return the read syntax for STR depending on CONTEXT." + (match context + (() + (object->string str)) + ((head . _) + (if (memq head %natural-whitespace-string-forms) + (escaped-string str) + (object->string str))))) + (define (string-width str) "Return the \"width\" of STR--i.e., the width of the longest line of STR." (apply max (map string-length (string-split str #\newline)))) @@ -427,26 +442,40 @@ each line except the first one (they're assumed to be already there)." (display (make-string indent #\space) port) (loop tail))))) -(define %symbols-followed-by-octal-integers - ;; Symbols for which the following integer must be printed as octal. - '(chmod umask mkdir mkstemp)) - -(define %symbols-followed-by-hexadecimal-integers - ;; Likewise, for hexadecimal integers. - '(logand logior logxor lognot)) +(define %integer-forms + ;; Forms that take an integer as their argument, where said integer should + ;; be printed in base other than decimal base. + (letrec-syntax ((vhashq (syntax-rules () + ((_) vlist-null) + ((_ (key value) rest ...) + (vhash-consq key value (vhashq rest ...)))))) + (vhashq + ('chmod 8) + ('umask 8) + ('mkdir 8) + ('mkstemp 8) + ('logand 16) + ('logior 16) + ('logxor 16) + ('lognot 16)))) (define (integer->string integer context) "Render INTEGER as a string using a base suitable based on CONTEXT." + (define (form-base form) + (match (vhash-assq form %integer-forms) + (#f 10) + ((_ . base) base))) + + (define (octal? form) + (= 8 (form-base form))) + (define base (match context ((head . tail) - (cond ((memq head %symbols-followed-by-octal-integers) 8) - ((memq head %symbols-followed-by-hexadecimal-integers) - (if (any (cut memq <> %symbols-followed-by-octal-integers) - tail) - 8 - 16)) - (else 10))) + (match (form-base head) + (8 8) + (16 (if (any octal? tail) 8 16)) + (10 10))) (_ 10))) (string-append (match base @@ -691,7 +720,7 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." (+ column 1))))) (_ (let* ((str (cond ((string? obj) - (escaped-string obj)) + (printed-string obj context)) ((integer? obj) (integer->string obj context)) (else diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 6b13a98946..4a8f5131ed 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -33,6 +33,7 @@ search-path-specification-file-pattern $PATH + $GUIX_EXTENSIONS_PATH $SSL_CERT_DIR $SSL_CERT_FILE @@ -73,23 +74,32 @@ (variable "PATH") (files '("bin" "sbin")))) -;; Two variables for certificates (see (guix)X.509 Certificates), -;; respected by 'openssl', possibly GnuTLS in the future +(define $GUIX_EXTENSIONS_PATH + ;; 'GUIX_EXTENSIONS_PATH' is used by Guix to locate extension commands. + ;; Unlike 'PATH', it is attached to a package, Guix; however, it is + ;; convenient to define it by default because the 'guix' package is not + ;; supposed to be installed in a profile. + (search-path-specification + (variable "GUIX_EXTENSIONS_PATH") + (files '("share/guix/extensions")))) + +;; Two variables for certificates (info "(guix)X.509 Certificates"), +;; respected by OpenSSL and possibly GnuTLS in the future ;; (https://gitlab.com/gnutls/gnutls/-/merge_requests/1541) -;; and many of their dependents -- even some GnuTLS depepdents +;; and many of their dependents -- even some GnuTLS dependents ;; like Guile. As they are not tied to a single package, define ;; them here to avoid duplication. ;; ;; Additionally, the 'native-search-paths' field is not thunked, ;; so doing (package-native-search-paths openssl) ;; could cause import cycle issues. -(define-public $SSL_CERT_DIR +(define $SSL_CERT_DIR (search-path-specification (variable "SSL_CERT_DIR") (separator #f) ;single entry (files '("etc/ssl/certs")))) -(define-public $SSL_CERT_FILE +(define $SSL_CERT_FILE (search-path-specification (variable "SSL_CERT_FILE") (file-type 'regular) diff --git a/guix/store.scm b/guix/store.scm index 6bdd071b48..4d21c5ff1a 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -457,7 +457,7 @@ '&store-connection-error' upon error." (let ((s (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. - (socket PF_UNIX SOCK_STREAM 0))) + (socket PF_UNIX (logior SOCK_STREAM SOCK_CLOEXEC) 0))) (a (make-socket-address PF_UNIX file))) (system-error-to-connection-error file @@ -471,41 +471,38 @@ (define (open-inet-socket host port) "Connect to the Unix-domain socket at HOST:PORT and return it. Raise a '&store-connection-error' upon error." - (let ((sock (with-fluids ((%default-port-encoding #f)) - ;; This trick allows use of the `scm_c_read' optimization. - (socket PF_UNIX SOCK_STREAM 0)))) - (define addresses - (getaddrinfo host - (if (number? port) (number->string port) port) - (if (number? port) - (logior AI_ADDRCONFIG AI_NUMERICSERV) - AI_ADDRCONFIG) - 0 ;any address family - SOCK_STREAM)) ;TCP only + (define addresses + (getaddrinfo host + (if (number? port) (number->string port) port) + (if (number? port) + (logior AI_ADDRCONFIG AI_NUMERICSERV) + AI_ADDRCONFIG) + 0 ;any address family + SOCK_STREAM)) ;TCP only - (let loop ((addresses addresses)) - (match addresses - ((ai rest ...) - (let ((s (socket (addrinfo:fam ai) - ;; TCP/IP only - SOCK_STREAM IPPROTO_IP))) + (let loop ((addresses addresses)) + (match addresses + ((ai rest ...) + (let ((s (socket (addrinfo:fam ai) + ;; TCP/IP only + (logior SOCK_STREAM SOCK_CLOEXEC) IPPROTO_IP))) - (catch 'system-error - (lambda () - (connect s (addrinfo:addr ai)) + (catch 'system-error + (lambda () + (connect s (addrinfo:addr ai)) - ;; Setting this option makes a dramatic difference because it - ;; avoids the "ACK delay" on our RPC messages. - (setsockopt s IPPROTO_TCP TCP_NODELAY 1) - s) - (lambda args - ;; Connection failed, so try one of the other addresses. - (close s) - (if (null? rest) - (raise (condition (&store-connection-error - (file host) - (errno (system-error-errno args))))) - (loop rest)))))))))) + ;; Setting this option makes a dramatic difference because it + ;; avoids the "ACK delay" on our RPC messages. + (setsockopt s IPPROTO_TCP TCP_NODELAY 1) + s) + (lambda args + ;; Connection failed, so try one of the other addresses. + (close s) + (if (null? rest) + (raise (condition (&store-connection-error + (file host) + (errno (system-error-errno args))))) + (loop rest))))))))) (define (connect-to-daemon uri) "Connect to the daemon at URI, a string that may be an actual URI or a file |