From 754a7660a1716998b557aedeb805ee9040afdcdf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 19 Nov 2022 17:23:04 +0100 Subject: records: 'match-record' checks fields at macro-expansion time. This allows 'match-record' to be more efficient (field offsets are computed at compilation time) and to report unknown fields at macro-expansion time. * guix/records.scm (map-fields): New macro. (define-record-type*)[rtd-identifier]: New procedure. Define TYPE as a macro and use a separate identifier for the RTD. (lookup-field, match-record-inner): New macros. (match-record): Rewrite in terms of 'match-error-inner'. * tests/records.scm ("match-record, simple") ("match-record, unknown field"): New tests. * gnu/services/cuirass.scm (cuirass-shepherd-service): Rename 'log-file' local variable to 'main-log-file'. * gnu/services/getmail.scm (serialize-getmail-configuration-file): Move after definition. --- guix/records.scm | 87 +++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 76 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index ed94c83dac..13463647c8 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2012-2022 Ludovic Courtès ;;; Copyright © 2018 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -104,6 +104,10 @@ (define (report-duplicate-field-specifier name ctor) (() #t))))))) +(define-syntax map-fields + (lambda (x) + (syntax-violation 'map-fields "bad use of syntactic keyword" x x))) + (define-syntax-parameter this-record (lambda (s) "Return the record being defined. This macro may only be used in the @@ -325,6 +329,15 @@ (define-record-type* thing make-thing field and its 'loc' field---the latter is marked as \"innate\", so it is not inherited." + (define (rtd-identifier type) + ;; Return an identifier derived from TYPE to name its record type + ;; descriptor (RTD). + (let ((type-name (syntax->datum type))) + (datum->syntax + type + (string->symbol + (string-append "% " (symbol->string type-name) " rtd"))))) + (define (field-default-value s) (syntax-case s (default) ((field (default val) _ ...) @@ -428,10 +441,31 @@ (define (compute-abi-cookie field-specs) field))) field-spec))) #`(begin - (define-record-type type + (define-record-type #,(rtd-identifier #'type) (ctor field ...) pred field-spec* ...) + + ;; Rectify the vtable type name... + (set-struct-vtable-name! #,(rtd-identifier #'type) 'type) + (cond-expand + (guile-3 + ;; ... and the record type name. + (struct-set! #,(rtd-identifier #'type) vtable-offset-user + 'type)) + (else #f)) + + (define-syntax type + (lambda (s) + "This macro lets us query record type info at +macro-expansion time." + (syntax-case s (map-fields) + ((_ map-fields macro) + #'(macro (field ...))) + (id + (identifier? #'id) + #'#,(rtd-identifier #'type))))) + (define #,(current-abi-identifier #'type) #,cookie) @@ -535,19 +569,50 @@ (define (recutils->alist port) (else (error "unmatched line" line)))))))) + +;;; +;;; Pattern matching. +;;; + +(define-syntax lookup-field + (lambda (s) + "Look up FIELD in the given list and return an expression that represents +its offset in the record. Raise a syntax violation when the field is not +found." + (syntax-case s () + ((_ field offset ()) + (syntax-violation 'lookup-field "unknown record type field" + s #'field)) + ((_ field offset (head tail ...)) + (free-identifier=? #'field #'head) + #'offset) + ((_ field offset (_ tail ...)) + #'(lookup-field field (+ 1 offset) (tail ...)))))) + +(define-syntax match-record-inner + (lambda (s) + (syntax-case s () + ((_ record type (field rest ...) body ...) + #`(let-syntax ((field-offset (syntax-rules () + ((_ f) + (lookup-field field 0 f))))) + (let* ((offset (type map-fields field-offset)) + (field (struct-ref record offset))) + (match-record-inner record type (rest ...) body ...)))) + ((_ record type () body ...) + #'(begin body ...))))) + (define-syntax match-record (syntax-rules () "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name. +The order in which fields appear does not matter. A syntax error is raised if +an unknown field is queried. + The current implementation does not support thunked and delayed fields." - ((_ record type (field fields ...) body ...) + ;; TODO support thunked and delayed fields + ((_ record type (fields ...) body ...) (if (eq? (struct-vtable record) type) - ;; TODO compute indices and report wrong-field-name errors at - ;; expansion time - ;; TODO support thunked and delayed fields - (let ((field ((record-accessor type 'field) record))) - (match-record record type (fields ...) body ...)) - (throw 'wrong-type-arg record))) - ((_ record type () body ...) - (begin body ...)))) + (match-record-inner record type (fields ...) body ...) + (throw 'wrong-type-arg record))))) ;;; records.scm ends here -- cgit v1.2.3 From 0406df0b9b1bf39caa39eba50f918c897ea204e6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 Dec 2022 16:30:52 +0100 Subject: environment: '-C' doesn't throw when the NSS is dysfunctional. Previously, if the name service switch was dysfunctional, as can happen on foreign distros lacking nscd, "guix shell -C" would crash with a backtrace on the uncaught 'getpwuid' exception. To address that, catch the exception and deal with it gracefully. Reported by remsd1 on #guix. * guix/scripts/environment.scm (launch-environment/container): Wrap 'getpwuid' call in 'false-if-exception'. --- guix/scripts/environment.scm | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 64597f6e9f..ab11b35335 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -728,14 +728,21 @@ (define fhs-mappings (home (getenv "HOME")) (uid (if user 1000 (getuid))) (gid (if user 1000 (getgid))) - (passwd (let ((pwd (getpwuid (getuid)))) + + ;; On a foreign distro, the name service switch might be + ;; dysfunctional and 'getpwuid' throws. Don't let that hamper + ;; operations. + (passwd (let ((pwd (false-if-exception (getpwuid (getuid))))) (password-entry - (name (or user (passwd:name pwd))) - (real-name (if user + (name (or user + (and=> pwd passwd:name) + (getenv "USER") + "charlie")) + (real-name (if (or user (not pwd)) "" (passwd:gecos pwd))) (uid uid) (gid gid) (shell bash) - (directory (if user + (directory (if (or user (not pwd)) (string-append "/home/" user) (passwd:dir pwd)))))) (groups (list (group-entry (name "users") (gid gid)) -- cgit v1.2.3 From b129026e2e242e9068158ae6e6fcd8d7c5ea092e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 Dec 2022 10:56:48 +0100 Subject: deduplicate: Use 'sendfile' for small file copies. * guix/store/deduplication.scm (dump-file/deduplicate): Use 'sendfile' instead of 'dump-port'. * tests/store-deduplication.scm ("copy-file/deduplicate, below %deduplication-minimum-size"): New test. --- guix/store/deduplication.scm | 4 ++-- tests/store-deduplication.scm | 17 ++++++++++++++++- 2 files changed, 18 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index ab982e3b3d..9953675319 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Caleb Ristvedt -;;; Copyright © 2018-2021 Ludovic Courtès +;;; Copyright © 2018-2022 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -262,7 +262,7 @@ (define (dump-and-compute-hash) (deduplicate file (dump-and-compute-hash) #:store store) (call-with-output-file file (lambda (output) - (dump-port input output size))))) + (sendfile output input size 0))))) (define* (copy-file/deduplicate source target #:key (store (%store-directory))) diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm index 2950fbc1a3..f1845035d8 100644 --- a/tests/store-deduplication.scm +++ b/tests/store-deduplication.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2020-2021 Ludovic Courtès +;;; Copyright © 2018, 2020-2022 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -136,6 +136,21 @@ (define-module (test-store-deduplication) (cons (apply = (map (compose stat:ino stat) identical)) (map (compose stat:nlink stat) identical)))))) +(test-assert "copy-file/deduplicate, below %deduplication-minimum-size" + (call-with-temporary-directory + (lambda (store) + (let ((source (string-append store "/input"))) + (call-with-output-file source + (lambda (port) + (display "Hello!\n" port))) + (copy-file/deduplicate source + (string-append store "/a") + #:store store) + (and (not (directory-exists? (string-append store "/.links"))) + (file=? source (string-append store "/a")) + (not (= (stat:ino (stat (string-append store "/a"))) + (stat:ino (stat source))))))))) + (test-assert "copy-file/deduplicate" (call-with-temporary-directory (lambda (store) -- cgit v1.2.3 From 7866294e32f1e758d06fce4e1b1035eca3a7d772 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 Dec 2022 18:12:59 +0100 Subject: deduplicate: Use 'sendfile' only with file ports. Fixes a regression introduced in b129026e2e242e9068158ae6e6fcd8d7c5ea092e. * guix/store/deduplication.scm (dump-file/deduplicate): Use 'sendfile' only when INPUT' is a file port. --- guix/store/deduplication.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 9953675319..acb6ffcc4a 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -262,7 +262,10 @@ (define (dump-and-compute-hash) (deduplicate file (dump-and-compute-hash) #:store store) (call-with-output-file file (lambda (output) - (sendfile output input size 0))))) + (if (file-port? input) + (sendfile output input size 0) + (dump-port input output size + #:buffer-size %deduplication-minimum-size)))))) (define* (copy-file/deduplicate source target #:key (store (%store-directory))) -- cgit v1.2.3