From 0ca3d5568676937d65674415d292820668fce6a7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Jul 2017 16:56:19 +0200 Subject: store: Account for 'add-to-store' in RPC statistics. * guix/store.scm (add-to-store): Add call to 'record-operation'. --- guix/store.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index a207d478e6..b15da54852 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -897,6 +897,7 @@ path." #:key (select? true)) ;; We don't use the 'operation' macro so we can pass SELECT? to ;; 'write-file'. + (record-operation 'add-to-store) (let ((port (nix-server-socket server))) (write-int (operation-id add-to-store) port) (write-string basename port) -- cgit v1.2.3 From 0bc6fe323d34aabc7f51fa80b8872a2c1770d32a Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Tue, 4 Jul 2017 02:56:02 +0200 Subject: syscalls: Add network-interface-running? * guix/build/syscalls.scm (network-interface-running?): New variable. Export it. * tests/syscalls.scm: Add test. Co-authored-by: John Darrington --- guix/build/syscalls.scm | 9 +++++++++ tests/syscalls.scm | 10 ++++++++++ 2 files changed, 19 insertions(+) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 549612fa3c..33a23edaac 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -92,6 +92,7 @@ all-network-interface-names network-interface-names network-interface-netmask + network-interface-running? loopback-network-interface? network-interface-address set-network-interface-netmask @@ -1156,6 +1157,7 @@ bytes." (define-as-needed IFF_UP #x1) ;Interface is up (define-as-needed IFF_BROADCAST #x2) ;Broadcast address valid. (define-as-needed IFF_LOOPBACK #x8) ;Is a loopback net. +(define-as-needed IFF_RUNNING #x40) ;interface RFC2863 OPER_UP (define IF_NAMESIZE 16) ;maximum interface name size @@ -1330,6 +1332,13 @@ interface NAME." (close-port sock) (not (zero? (logand flags IFF_LOOPBACK))))) +(define (network-interface-running? name) + "Return true if NAME designates a running network interface." + (let* ((sock (socket SOCK_STREAM AF_INET 0)) + (flags (network-interface-flags sock name))) + (close-port sock) + (not (zero? (logand flags IFF_RUNNING))))) + (define-as-needed (set-network-interface-flags socket name flags) "Set the flag of network interface NAME to FLAGS." (let ((req (make-bytevector ifreq-struct-size))) diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 8c048e6109..2b5c4c3be1 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -361,6 +361,16 @@ (lambda args (system-error-errno args))))) +(test-equal "loopback-network-interface-running?" + ENODEV + (and (network-interface-running? "lo") + (catch 'system-error + (lambda () + (network-interface-running? "nonexistent") + #f) + (lambda args + (system-error-errno args))))) + (test-skip (if (zero? (getuid)) 1 0)) (test-assert "set-network-interface-flags" (let ((sock (socket AF_INET SOCK_STREAM 0))) -- cgit v1.2.3 From 1ac3a488ad9724ecc45450c57eab2d360f274303 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 12 Jul 2017 12:04:55 +0200 Subject: environment: Rationalize calls to 'set-build-options'. Before this change '--substitute-urls' would be ignored. * guix/scripts/environment.scm (build-environment): Remove redundant call to 'set-build-options-from-command-line*'. (guix-environment): Move 'set-build-options-from-command-line' right after 'with-store'. --- guix/scripts/environment.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 0abc509a35..95ba199d97 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -313,9 +313,7 @@ in OPTS." #:dry-run? dry-run?) (if dry-run? (return #f) - (mbegin %store-monad - (set-build-options-from-command-line* opts) - (built-derivations derivations)))))) + (built-derivations derivations))))) (define (inputs->profile-derivation inputs system bootstrap?) "Return the derivation for a profile consisting of INPUTS for SYSTEM. @@ -580,6 +578,8 @@ message if any test fails." (when container? (assert-container-features)) (with-store store + (set-build-options-from-command-line store opts) + ;; Use the bootstrap Guile when requested. (parameterize ((%graft? (assoc-ref opts 'graft?)) (%guile-for-build @@ -588,7 +588,6 @@ message if any test fails." (if bootstrap? %bootstrap-guile (canonical-package guile-2.0))))) - (set-build-options-from-command-line store opts) (run-with-store store ;; Containers need a Bourne shell at /bin/sh. (mlet* %store-monad ((bash (environment-bash container? -- cgit v1.2.3 From a6c1fe824002d022ff3ba7c8b93987965db29641 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 12 Jul 2017 15:41:49 +0200 Subject: size: Add '--sort=KEY'. * guix/scripts/size.scm (profile-closure name1 self1 total1) + ($ name2 self2 total2)) + (< total1 total2)))) + +(define profile-self name1 self1 total1) + ($ name2 self2 total2)) + (< self1 self2)))) + +(define* (display-profile profile #:optional (port (current-output-port)) + #:key (profile name1 self1 total1) - ($ name2 self2 total2)) - (> total1 total2))))) + (sort profile (negate profilepage-map profile map-file) (return #t)) - (display-profile* profile))) + (display-profile* profile (current-output-port) + #:profile Date: Wed, 12 Jul 2017 21:40:57 +0200 Subject: substitute: Work around Guile 2.2 'time-monotonic' bug. Prior to this change, half of the cached narinfos would expire immediately since they contained the number of nanoseconds instead of the number of seconds as their date. * guix/scripts/substitute.scm (time-monotonic) : Define, as a workaround. --- guix/scripts/substitute.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 71f30030b6..9348599193 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -96,6 +96,13 @@ ;;; ;;; Code: +(cond-expand + (guile-2.2 + ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and + ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. + (define time-monotonic time-tai)) + (else #t)) + (define %narinfo-cache-directory ;; A local cache of narinfos, to avoid going to the network. Most of the ;; time, 'guix substitute' is called by guix-daemon as root and stores its -- cgit v1.2.3 From 578dfbe07bcd1bdef9129c6ce8529332a0abcba6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Jul 2017 23:21:55 +0200 Subject: gexp: 'ungexp-splicing' properly accounts for nested native inputs. Previously, (gexp-native-inputs #~#$@(list #~#+foo)) would return '(). This is a followup to 5b14a7902c58d9fb7923f9e16871f549fbe59b6e. * guix/gexp.scm (gexp-inputs)[add-reference-inputs]: In the list case, remove 'if' around 'fold-right'. In 'map' lambda, always inherit N?. * tests/gexp.scm ("gexp list splicing + ungexp-splicing"): New test. --- guix/gexp.scm | 20 +++++++++++--------- tests/gexp.scm | 8 ++++++++ 2 files changed, 19 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index d9c4cb461e..2094c495d6 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -706,15 +706,17 @@ references; otherwise, return only non-native references." (cons `(,thing ,output) result) result)) (($ (lst ...) output n?) - (if (eqv? native? n?) - (fold-right add-reference-inputs result - ;; XXX: For now, automatically convert LST to a list of - ;; gexp-inputs. - (map (match-lambda - ((? gexp-input? x) x) - (x (%gexp-input x "out" (or n? native?)))) - lst)) - result)) + (fold-right add-reference-inputs result + ;; XXX: For now, automatically convert LST to a list of + ;; gexp-inputs. Inherit N?. + (map (match-lambda + ((? gexp-input? x) + (%gexp-input (gexp-input-thing x) + (gexp-input-output x) + n?)) + (x + (%gexp-input x "out" n?))) + lst))) (_ ;; Ignore references to other kinds of objects. result))) diff --git a/tests/gexp.scm b/tests/gexp.scm index cf88a9db80..5873abdd41 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -355,6 +355,14 @@ (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) +(test-assert "gexp list splicing + ungexp-splicing" + (let* ((inner (gexp (ungexp-native glibc))) + (exp (gexp (list (ungexp-splicing (list inner)))))) + (and (equal? `((,glibc "out")) (gexp-native-inputs exp)) + (null? (gexp-inputs exp)) + (equal? (gexp->sexp* exp) ;native + (gexp->sexp* exp "mips64el-linux"))))) + (test-equal "output list" 2 (let ((exp (gexp (begin (mkdir (ungexp output)) -- cgit v1.2.3 From 5058bf56843baf3c0d82fbf0addbb30f00572428 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Jul 2017 21:39:56 +0200 Subject: guix system: Use "image.iso" as the name of ISO images. * guix/scripts/system.scm (system-derivation-for-action): Pass #:name to 'system-disk-image'. --- guix/scripts/system.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 65dd92e8b7..0fcb6a9b0f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -579,8 +579,12 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (* 70 (expt 2 20))) #:mappings mappings)) ((disk-image) - (system-disk-image os #:disk-image-size image-size - #:file-system-type file-system-type)))) + (system-disk-image os + #:name (match file-system-type + ("iso9660" "image.iso") + (_ "disk-image")) + #:disk-image-size image-size + #:file-system-type file-system-type)))) (define (maybe-suggest-running-guix-pull) "Suggest running 'guix pull' if this has never been done before." -- cgit v1.2.3 From 644e5f17dfd2f5b3bbf656580d6f1f84c52e668a Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Wed, 19 Jul 2017 01:42:08 +0200 Subject: download: Add OpenBSD mirrors. * guix/download.scm (%mirrors) : Add HTTPS OpenBSD mirrors. * gnu/packages/ntp.scm (openntpd)[source]: Use them. * gnu/packages/ssh.scm (openssh)[source]: Likewise. * gnu/packages/tls.scm (libressl)[source]: Likewise. --- gnu/packages/ntp.scm | 4 +--- gnu/packages/ssh.scm | 16 ++++++---------- gnu/packages/tls.scm | 16 +++++++--------- guix/download.scm | 51 ++++++++++++++++++++++++++++++++++++++++++++++++++- 4 files changed, 64 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/gnu/packages/ntp.scm b/gnu/packages/ntp.scm index 7befd491ac..959aa55a76 100644 --- a/gnu/packages/ntp.scm +++ b/gnu/packages/ntp.scm @@ -101,10 +101,8 @@ computers over a network.") (version "6.1p1") (source (origin (method url-fetch) - ;; XXX Use mirror://openbsd (uri (string-append - "http://ftp.openbsd.org/pub/OpenBSD/OpenNTPD/openntpd-" - version ".tar.gz")) + "mirror://openbsd/OpenNTPD/" name "-" version ".tar.gz")) (sha256 (base32 "1ykx9ga76k5m54h7k5x4ds2clxsyfniss5vmf88pxnrip5bx6if8")))) diff --git a/gnu/packages/ssh.scm b/gnu/packages/ssh.scm index 3cde6af5fe..89df37a636 100644 --- a/gnu/packages/ssh.scm +++ b/gnu/packages/ssh.scm @@ -130,16 +130,12 @@ a server that supports the SSH-2 protocol.") (name "openssh") (version "7.5p1") (source (origin - (method url-fetch) - (uri (let ((tail (string-append name "-" version ".tar.gz"))) - (list (string-append "http://openbsd.cs.fau.de/pub/OpenBSD/OpenSSH/portable/" - tail) - (string-append "http://ftp.fr.openbsd.org/pub/OpenBSD/OpenSSH/portable/" - tail) - (string-append "http://ftp2.fr.openbsd.org/pub/OpenBSD/OpenSSH/portable/" - tail)))) - (sha256 (base32 - "1w7rb5gbrikxdkp8w7zxnci4549gk4bw1lml01s59w5rzb2y6ilq")))) + (method url-fetch) + (uri (string-append "mirror://openbsd/OpenSSH/portable/" + name "-" version ".tar.gz")) + (sha256 + (base32 + "1w7rb5gbrikxdkp8w7zxnci4549gk4bw1lml01s59w5rzb2y6ilq")))) (build-system gnu-build-system) (native-inputs `(("groff" ,groff))) (inputs `(("openssl" ,openssl) diff --git a/gnu/packages/tls.scm b/gnu/packages/tls.scm index 2b317a84f1..0a81633aa7 100644 --- a/gnu/packages/tls.scm +++ b/gnu/packages/tls.scm @@ -456,15 +456,13 @@ required structures.") (package (name "libressl") (version "2.5.5") - (source - (origin - (method url-fetch) - (uri (string-append - "https://ftp.openbsd.org/pub/OpenBSD/LibreSSL/libressl-" - version ".tar.gz")) - (sha256 - (base32 - "1i77viqy1afvbr392npk9v54k9zhr9zq2vhv6pliza22b0ymwzz5")))) + (source (origin + (method url-fetch) + (uri (string-append "mirror://openbsd/LibreSSL/" + name "-" version ".tar.gz")) + (sha256 + (base32 + "1i77viqy1afvbr392npk9v54k9zhr9zq2vhv6pliza22b0ymwzz5")))) (build-system gnu-build-system) (arguments ;; Do as if 'getentropy' was missing since older Linux kernels lack it diff --git a/guix/download.scm b/guix/download.scm index c1da515477..d7590d4110 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -277,7 +277,56 @@ "http://kde.mirrors.tds.net/pub/kde/" ;; Oceania "http://ftp.kddlabs.co.jp/pub/X11/kde/" - "http://kde.mirror.uber.com.au/")))) + "http://kde.mirror.uber.com.au/") + (openbsd + "https://ftp.openbsd.org/pub/OpenBSD/" + ;; Anycast CDN redirecting to your friendly local mirror. + "https://mirrors.evowise.com/pub/OpenBSD/" + ;; Other HTTPS mirrors from https://www.openbsd.org/ftp.html + "https://mirror.aarnet.edu.au/pub/OpenBSD/" + "https://ftp2.eu.openbsd.org/pub/OpenBSD/" + "https://openbsd.c3sl.ufpr.br/pub/OpenBSD/" + "https://openbsd.ipacct.com/pub/OpenBSD/" + "https://ftp.OpenBSD.org/pub/OpenBSD/" + "https://openbsd.cs.toronto.edu/pub/OpenBSD/" + "https://openbsd.delfic.org/pub/OpenBSD/" + "https://openbsd.mirror.netelligent.ca/pub/OpenBSD/" + "https://mirrors.ucr.ac.cr/pub/OpenBSD/" + "https://mirrors.dotsrc.org/pub/OpenBSD/" + "https://mirror.one.com/pub/OpenBSD/" + "https://ftp.fr.openbsd.org/pub/OpenBSD/" + "https://ftp2.fr.openbsd.org/pub/OpenBSD/" + "https://mirrors.ircam.fr/pub/OpenBSD/" + "https://ftp.spline.de/pub/OpenBSD/" + "https://mirror.hs-esslingen.de/pub/OpenBSD/" + "https://ftp.halifax.rwth-aachen.de/openbsd/" + "https://ftp.hostserver.de/pub/OpenBSD/" + "https://ftp.fau.de/pub/OpenBSD/" + "https://ftp.cc.uoc.gr/pub/OpenBSD/" + "https://openbsd.hk/pub/OpenBSD/" + "https://ftp.heanet.ie/pub/OpenBSD/" + "https://openbsd.mirror.garr.it/pub/OpenBSD/" + "https://mirror.litnet.lt/pub/OpenBSD/" + "https://mirror.meerval.net/pub/OpenBSD/" + "https://ftp.nluug.nl/pub/OpenBSD/" + "https://ftp.bit.nl/pub/OpenBSD/" + "https://mirrors.dalenys.com/pub/OpenBSD/" + "https://ftp.icm.edu.pl/pub/OpenBSD/" + "https://ftp.rnl.tecnico.ulisboa.pt/pub/OpenBSD/" + "https://mirrors.pidginhost.com/pub/OpenBSD/" + "https://mirror.yandex.ru/pub/OpenBSD/" + "https://ftp.eu.openbsd.org/pub/OpenBSD/" + "https://ftp.yzu.edu.tw/pub/OpenBSD/" + "https://www.mirrorservice.org/pub/OpenBSD/" + "https://anorien.csc.warwick.ac.uk/pub/OpenBSD/" + "https://mirror.bytemark.co.uk/pub/OpenBSD/" + "https://mirrors.sonic.net/pub/OpenBSD/" + "https://ftp3.usa.openbsd.org/pub/OpenBSD/" + "https://mirrors.syringanetworks.net/pub/OpenBSD/" + "https://openbsd.mirror.constant.com/pub/OpenBSD/" + "https://ftp4.usa.openbsd.org/pub/OpenBSD/" + "https://ftp5.usa.openbsd.org/pub/OpenBSD/" + "https://mirror.esc7.net/pub/OpenBSD/")))) (define %mirror-file ;; Copy of the list of mirrors to a file. This allows us to keep a single -- cgit v1.2.3 From da036496406f60e591786f89e8a51ad75cb0e5c7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Jul 2017 11:44:12 +0200 Subject: profiles: Remove workaround for an old Guile 'scandir' bug. * guix/profiles.scm (generation-numbers)[scandir]: Remove. --- guix/profiles.scm | 34 ---------------------------------- 1 file changed, 34 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 85c1722d62..b3732f61ed 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1313,40 +1313,6 @@ are cross-built for TARGET." (define (generation-numbers profile) "Return the sorted list of generation numbers of PROFILE, or '(0) if no former profiles were found." - (define* (scandir name #:optional (select? (const #t)) - (entry (file-system-fold enter? leaf down up skip error #f name lstat) - (lambda (files) - (sort files entry)) (#f ; no profile directory -- cgit v1.2.3 From edbe07cd67d6050d94fe8ac1af15ab15e857b61d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Jul 2017 15:23:13 +0200 Subject: guix package: Trim trailing slashes from the profile name. Fixes . Reported by Ricardo Wurmus . * guix/scripts/package.scm (canonicalize-profile): Trim trailing slashes from PROFILE. --- guix/scripts/package.scm | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 58da3113a0..96ee5c00ed 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -84,12 +84,16 @@ "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if '-p' was omitted." ; see - (if (and %user-profile-directory - (string=? (canonicalize-path (dirname profile)) - (dirname %user-profile-directory)) - (string=? (basename profile) (basename %user-profile-directory))) - %current-profile - profile)) + + ;; Trim trailing slashes so that the basename comparison below works as + ;; intended. + (let ((profile (string-trim-right profile #\/))) + (if (and %user-profile-directory + (string=? (canonicalize-path (dirname profile)) + (dirname %user-profile-directory)) + (string=? (basename profile) (basename %user-profile-directory))) + %current-profile + profile))) (define (user-friendly-profile profile) "Return either ~/.guix-profile if that's what PROFILE refers to, directly or -- cgit v1.2.3 From 561f4e450078a06c707d3dcda2cf0e7d6eb5ebae Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Jul 2017 15:27:54 +0200 Subject: guix package: '-l' correctly handles zero-generation profiles. * guix/scripts/package.scm (process-query) <'list-generations>: Properly handle the case where 'profile-generations' returns the empty list. --- guix/scripts/package.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 96ee5c00ed..8da7a3fd3a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -713,9 +713,12 @@ processed, #f otherwise." (raise (condition (&profile-not-found-error (profile profile))))) ((string-null? pattern) - (list-generation display-profile-content - (car (profile-generations profile))) - (diff-profiles profile (profile-generations profile))) + (match (profile-generations profile) + (() + #t) + ((first rest ...) + (list-generation display-profile-content first) + (diff-profiles profile (cons first rest))))) ((matching-generations pattern profile) => (lambda (numbers) -- cgit v1.2.3 From 41209a6f3a9945b55bcc06b989628e09e9f98b6a Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Wed, 12 Jul 2017 19:33:05 +0530 Subject: licenses: Add MirOS license. * guix/licenses.scm (miros): New variable. --- guix/licenses.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 1bed56af20..b7dadd9750 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -12,6 +12,7 @@ ;;; Copyright © 2017 Clément Lassieur ;;; Copyright © 2017 Petter ;;; Copyright © 2017 Marius Bakke +;;; Copyright © 2017 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -67,6 +68,7 @@ lppl1.3a lppl1.3a+ lppl1.3b lppl1.3b+ lppl1.3c lppl1.3c+ + miros mpl1.0 mpl1.1 mpl2.0 ms-pl ncsa @@ -452,6 +454,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.latex-project.org/lppl/lppl-1-3c/" "LaTeX Project Public License 1.3c or later")) +(define miros + (license "MirOS" + "https://www.mirbsd.org/MirOS-Licence.htm" + "MirOS License")) + (define mpl1.0 (license "MPL 1.0" "http://www.mozilla.org/MPL/1.0/" -- cgit v1.2.3 From 302d46e63f406f0f8acb024557498deaef2d4255 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Jul 2017 15:48:09 +0200 Subject: gexp: Slightly improve error reporting for 'local-file'. Reported by Ricardo Wurmus. * guix/gexp.scm (local-file): Define using 'syntax-case' instead of 'syntax-rules'. Explicitly handle the zero-argument case and the use-as-an-identifier case. --- guix/gexp.scm | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 2094c495d6..2622c5cb62 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -269,8 +269,9 @@ vicinity of DIRECTORY." (string-append directory "/" file)) (else file)))) -(define-syntax-rule (local-file file rest ...) - "Return an object representing local file FILE to add to the store; this +(define-syntax local-file + (lambda (s) + "Return an object representing local file FILE to add to the store; this object can be used in a gexp. If FILE is a relative file name, it is looked up relative to the source file where this form appears. FILE will be added to the store under NAME--by default the base name of FILE. @@ -283,10 +284,23 @@ When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry, where FILE is the entry's absolute file name and STAT is the result of 'lstat'; exclude entries for which SELECT? does not return true. -This is the declarative counterpart of the 'interned-file' monadic procedure." - (%local-file file - (delay (absolute-file-name file (current-source-directory))) - rest ...)) +This is the declarative counterpart of the 'interned-file' monadic procedure. +It is implemented as a macro to capture the current source directory where it +appears." + (syntax-case s () + ((_ file rest ...) + #'(%local-file file + (delay (absolute-file-name file (current-source-directory))) + rest ...)) + ((_) + #'(syntax-error "missing file name")) + (id + (identifier? #'id) + ;; XXX: We could return #'(lambda (file . rest) ...). However, + ;; (syntax-source #'id) is #f so (current-source-directory) would not + ;; work. Thus, simply forbid this form. + #'(syntax-error + "'local-file' is a macro and cannot be used like this"))))) (define (local-file-absolute-file-name file) "Return the absolute file name for FILE, a instance. A -- cgit v1.2.3 From 3d3e93b3f9cdf05f3dde07db45147f5919242fa2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Jul 2017 14:07:29 +0200 Subject: substitute: Optimize hash-part-to-path conversion on non-200 responses. Previously this operation was linear in the number of requests and involved costly calls to 'string-contains'. * guix/scripts/substitute.scm (fetch-narinfos)[hash-part->path]: New procedure. [handle-narinfo-response]: Use it for caching when CODE is not 200. --- guix/scripts/substitute.scm | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 9348599193..c066016aa4 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -47,6 +47,7 @@ #:use-module (ice-9 format) #:use-module (ice-9 ftw) #:use-module (ice-9 binary-ports) + #:use-module (ice-9 vlist) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -609,6 +610,17 @@ if file doesn't exist, and the narinfo otherwise." url (* 100. (/ done (length paths)))) (set! done (+ 1 done))))) + (define hash-part->path + (let ((mapping (fold (lambda (path result) + (vhash-cons (store-path-hash-part path) path + result)) + vlist-null + paths))) + (lambda (hash) + (match (vhash-assoc hash mapping) + (#f #f) + ((_ . path) path))))) + (define (handle-narinfo-response request response port result) (let* ((code (response-code response)) (len (response-content-length response)) @@ -627,9 +639,7 @@ if file doesn't exist, and the narinfo otherwise." (if len (get-bytevector-n port len) (read-to-eof port)) - (cache-narinfo! url - (find (cut string-contains <> hash-part) paths) - #f + (cache-narinfo! url (hash-part->path hash-part) #f (if (= 404 code) ttl %narinfo-transient-error-ttl)) -- cgit v1.2.3 From 75a4d86f50e1682b96c51eb46a6aba24afc25d03 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Jul 2017 14:13:58 +0200 Subject: substitute: Avoid repeated calls to 'length'. * guix/scripts/substitute.scm (fetch-narinfos)[update-progress!]: Move 'length' call outside of lambda. --- guix/scripts/substitute.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index c066016aa4..35282f9027 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -601,13 +601,14 @@ if file doesn't exist, and the narinfo otherwise." (define (fetch-narinfos url paths) "Retrieve all the narinfos for PATHS from the cache at URL and return them." (define update-progress! - (let ((done 0)) + (let ((done 0) + (total (length paths))) (lambda () (display #\cr (current-error-port)) (force-output (current-error-port)) (format (current-error-port) (G_ "updating list of substitutes from '~a'... ~5,1f%") - url (* 100. (/ done (length paths)))) + url (* 100. (/ done total))) (set! done (+ 1 done))))) (define hash-part->path -- cgit v1.2.3 From 0a94dc63964c88903079c0a040162439fe07a306 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Jul 2017 14:32:24 +0200 Subject: base32: Export the base32 charsets. * guix/base32.scm (%nix-base32-charset, %rfc4648-base32-charset): New variables. --- guix/base32.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/base32.scm b/guix/base32.scm index 7b2e2a6712..49f191ba26 100644 --- a/guix/base32.scm +++ b/guix/base32.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2015 Ludovic Courtès +;;; Copyright © 2012, 2015, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +28,8 @@ bytevector->nix-base32-string base32-string->bytevector nix-base32-string->bytevector + %nix-base32-charset + %rfc4648-base32-charset &invalid-base32-character invalid-base32-character? invalid-base32-character-value @@ -152,11 +154,17 @@ the previous application or INIT." #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n #\p #\q #\r #\s #\v #\w #\x #\y #\z)) +(define %nix-base32-charset + (list->char-set (vector->list %nix-base32-chars))) + (define %rfc4648-base32-chars #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\2 #\3 #\4 #\5 #\6 #\7)) +(define %rfc4648-base32-charset + (list->char-set (vector->list %rfc4648-base32-chars))) + (define bytevector->base32-string (make-bytevector->base32-string bytevector-quintet-fold %rfc4648-base32-chars)) -- cgit v1.2.3 From 33463986ba5093c7513c9dc7702a66929f504aa5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Jul 2017 14:48:52 +0200 Subject: publish: Remove 'regexp-exec' call from the hot path. * guix/scripts/publish.scm (extract-narinfo-hash): Rewrite without resorting to regexps. --- guix/scripts/publish.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index a7e3e6d629..cb1abc32fb 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -565,13 +565,13 @@ has the given HASH of type ALGO." " speaking. Welcome!"))) port))))) -(define extract-narinfo-hash - (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$"))) - (lambda (str) - "Return the hash within the narinfo resource string STR, or false if STR +(define (extract-narinfo-hash str) + "Return the hash within the narinfo resource string STR, or false if STR is invalid." - (and=> (regexp-exec regexp str) - (cut match:substring <> 1))))) + (and (string-suffix? ".narinfo" str) + (let ((base (string-drop-right str 8))) + (and (string-every %nix-base32-charset base) + base)))) (define (get-request? request) "Return #t if REQUEST uses the GET method." -- cgit v1.2.3 From 35eb77b09d957019b2437e7681bd88013d67d3cd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Jul 2017 14:50:16 +0200 Subject: store: Rewrite 'store-path-hash-part' to not use regexps. * guix/store.scm (store-path-hash-part): Rewrite without using a regexp. This speeds up 'guix substitute'. --- guix/store.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index b15da54852..2563d26fa0 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1549,9 +1549,12 @@ valid inputs." (define (store-path-hash-part path) "Return the hash part of PATH as a base32 string, or #f if PATH is not a syntactically valid store path." - (let ((path-rx (store-regexp* (%store-prefix)))) - (and=> (regexp-exec path-rx path) - (cut match:substring <> 1)))) + (and (string-prefix? (%store-prefix) path) + (let ((base (string-drop path (+ 1 (string-length (%store-prefix)))))) + (and (> (string-length base) 33) + (let ((hash (string-take base 32))) + (and (string-every %nix-base32-charset hash) + hash)))))) (define (log-file store file) "Return the build log file for FILE, or #f if none could be found. FILE -- cgit v1.2.3 From deac674ab4015e52fb6fb883f578e5c5891291a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Jul 2017 14:52:08 +0200 Subject: publish: Avoid 'valid-path?' RPC for non-existent items. * guix/scripts/publish.scm (render-narinfo/cached): Call 'file-exists?' before calling 'valid-path?'. This makes the 404 path slightly faster. --- guix/scripts/publish.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index cb1abc32fb..cd57b13dc3 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -417,7 +417,8 @@ requested using POOL." (display (call-with-input-file cached read-string) port)))) - ((valid-path? store item) + ((and (file-exists? item) ;cheaper than the 'valid-path?' RPC + (valid-path? store item)) ;; Nothing in cache: bake the narinfo and nar in the background and ;; return 404. (eventually pool -- cgit v1.2.3 From c95644f0172ba87822ee7ecee3d2743ebd2c84bc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Jul 2017 17:02:19 +0200 Subject: publish: Make the cache eviction policy less aggressive. Suggested by Mark H Weaver . * guix/scripts/publish.scm (nar-expiration-time): New procedure. (render-narinfo/cached): Use it as the #:entry-expiration passed to 'maybe-remove-expired-cache-entries'. --- doc/guix.texi | 3 ++- guix/scripts/publish.scm | 20 +++++++++++++++++++- 2 files changed, 21 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index dbdd9b5ff5..875c1ffa26 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6960,7 +6960,8 @@ guarantee that the store items it provides will indeed remain available for as long as @var{ttl}. Additionally, when @option{--cache} is used, cached entries that have -not been accessed for @var{ttl} may be deleted. +not been accessed for @var{ttl} and that no longer have a corresponding +item in the store, may be deleted. @item --nar-path=@var{path} Use @var{path} as the prefix for the URLs of ``nar'' files diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index cd57b13dc3..ade3c49a54 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -385,6 +385,24 @@ at a time." (string-suffix? ".narinfo" file))) '())) +(define (nar-expiration-time ttl) + "Return the narinfo expiration time (in seconds since the Epoch). The +expiration time is +inf.0 when passed an item that is still in the store; in +other cases, it is the last-access time of the item plus TTL. + +This policy allows us to keep cached nars that correspond to valid store +items. Failing that, we could eventually have to recompute them and return +404 in the meantime." + (let ((expiration-time (file-expiration-time ttl))) + (lambda (file) + (let ((item (string-append (%store-prefix) "/" + (basename file ".narinfo")))) + ;; Note: We don't need to use 'valid-path?' here because FILE would + ;; not exist if ITEM were not valid in the first place. + (if (file-exists? item) + +inf.0 + (expiration-time file)))))) + (define* (render-narinfo/cached store request hash #:key ttl (compression %no-compression) (nar-path "nar") @@ -436,7 +454,7 @@ requested using POOL." (maybe-remove-expired-cache-entries cache narinfo-files #:entry-expiration - (file-expiration-time ttl) + (nar-expiration-time ttl) #:delete-entry delete-entry #:cleanup-period ttl)))) (not-found request -- cgit v1.2.3