From 66b14dccdd0d83c875ce3a8d50ceab8b6f0a3ce2 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Fri, 19 Mar 2021 23:03:25 -0400 Subject: download: Use Disarchive as a last resort. * guix/download.scm (%disarchive-mirrors): New variable. (%disarchive-mirror-file): New variable. (built-in-download): Add 'disarchive-mirrors' keyword argument and pass its value along to the 'builtin:download' derivation. (url-fetch): Pass '%disarchive-mirror-file' to 'built-in-download'. * guix/scripts/perform-download.scm (perform-download): Read Disarchive mirrors from the environment and pass them to 'url-fetch'. * guix/build/download.scm (disarchive-fetch/any): New procedure. (url-fetch): Add 'disarchive-mirrors' keyword argument, use it to make a list of URIs, and use the new procedure to fetch the file if all other methods fail. --- guix/build/download.scm | 83 +++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 73 insertions(+), 10 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index a22d4064ca..5431d7c682 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Tobias Geerinckx-Rice +;;; Copyright © 2021 Timothy Sample ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,6 +35,8 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:autoload (ice-9 ftw) (scandir) + #:autoload (guix base16) (bytevector->base16-string) + #:autoload (guix swh) (swh-download-directory) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (open-socket-for-uri @@ -626,10 +629,53 @@ Return a list of URIs." (else (list uri)))) +(define* (disarchive-fetch/any uris file + #:key (timeout 10) (verify-certificate? #t)) + "Fetch a Disarchive specification from any of URIS, assemble it, +and write the output to FILE." + (define (fetch-specification uris) + (any (lambda (uri) + (false-if-exception* + (let-values (((port size) (http-fetch uri + #:verify-certificate? + verify-certificate? + #:timeout timeout))) + (let ((specification (read port))) + (close-port port) + specification)))) + uris)) + + (define (resolve addresses output) + (any (match-lambda + (('swhid swhid) + (match (string-split swhid #\:) + (("swh" "1" "dir" id) + (format #t "Downloading from Software Heritage...~%" file) + (false-if-exception* + (swh-download-directory id output))) + (_ #f))) + (_ #f)) + addresses)) + + (format #t "Trying to use Disarchive to assemble ~a...~%" file) + (match (and=> (resolve-module '(disarchive) #:ensure #f) + (lambda (disarchive) + (cons (module-ref disarchive '%disarchive-log-port) + (module-ref disarchive 'disarchive-assemble)))) + (#f + (format #t "could not load Disarchive~%")) + ((%disarchive-log-port . disarchive-assemble) + (match (fetch-specification uris) + (#f + (format #t "could not find its Disarchive specification~%")) + (spec (parameterize ((%disarchive-log-port (current-output-port))) + (disarchive-assemble spec file #:resolver resolve))))))) + (define* (url-fetch url file #:key (timeout 10) (verify-certificate? #t) (mirrors '()) (content-addressed-mirrors '()) + (disarchive-mirrors '()) (hashes '()) print-build-trace?) "Fetch FILE from URL; URL may be either a single string, or a list of @@ -693,6 +739,18 @@ otherwise simply ignore them." hashes)) content-addressed-mirrors)) + (define disarchive-uris + (append-map (match-lambda + ((? string? mirror) + (map (match-lambda + ((hash-algo . hash) + (string->uri + (string-append mirror + (symbol->string hash-algo) "/" + (bytevector->base16-string hash))))) + hashes))) + disarchive-mirrors)) + ;; Make this unbuffered so 'progress-report/file' works as expected. 'line ;; means '\n', not '\r', so it's not appropriate here. (setvbuf (current-output-port) 'none) @@ -705,15 +763,20 @@ otherwise simply ignore them." (or (fetch uri file) (try tail))) (() - (format (current-error-port) "failed to download ~s from ~s~%" - file url) - - ;; Remove FILE in case we made an incomplete download, for example due - ;; to ENOSPC. - (catch 'system-error - (lambda () - (delete-file file)) - (const #f)) - #f)))) + ;; If we are looking for a software archive, one last thing we + ;; can try is to use Disarchive to assemble it. + (or (disarchive-fetch/any disarchive-uris file + #:verify-certificate? verify-certificate? + #:timeout timeout) + (begin + (format (current-error-port) "failed to download ~s from ~s~%" + file url) + ;; Remove FILE in case we made an incomplete download, for + ;; example due to ENOSPC. + (catch 'system-error + (lambda () + (delete-file file)) + (const #f)) + #f)))))) ;;; download.scm ends here -- cgit v1.2.3 From e74250c3c535b75dd2225a26df51febb7ed94654 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Wed, 28 Apr 2021 00:23:09 -0400 Subject: Revert "download: Use Disarchive as a last resort." This reverts commit 66b14dccdd0d83c875ce3a8d50ceab8b6f0a3ce2, which broke 'guix pull'. --- guix/build/download.scm | 83 +++++---------------------------------- guix/download.scm | 19 ++------- guix/scripts/perform-download.scm | 7 +--- 3 files changed, 14 insertions(+), 95 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index 5431d7c682..a22d4064ca 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -2,7 +2,6 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Tobias Geerinckx-Rice -;;; Copyright © 2021 Timothy Sample ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,8 +34,6 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:autoload (ice-9 ftw) (scandir) - #:autoload (guix base16) (bytevector->base16-string) - #:autoload (guix swh) (swh-download-directory) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (open-socket-for-uri @@ -629,53 +626,10 @@ Return a list of URIs." (else (list uri)))) -(define* (disarchive-fetch/any uris file - #:key (timeout 10) (verify-certificate? #t)) - "Fetch a Disarchive specification from any of URIS, assemble it, -and write the output to FILE." - (define (fetch-specification uris) - (any (lambda (uri) - (false-if-exception* - (let-values (((port size) (http-fetch uri - #:verify-certificate? - verify-certificate? - #:timeout timeout))) - (let ((specification (read port))) - (close-port port) - specification)))) - uris)) - - (define (resolve addresses output) - (any (match-lambda - (('swhid swhid) - (match (string-split swhid #\:) - (("swh" "1" "dir" id) - (format #t "Downloading from Software Heritage...~%" file) - (false-if-exception* - (swh-download-directory id output))) - (_ #f))) - (_ #f)) - addresses)) - - (format #t "Trying to use Disarchive to assemble ~a...~%" file) - (match (and=> (resolve-module '(disarchive) #:ensure #f) - (lambda (disarchive) - (cons (module-ref disarchive '%disarchive-log-port) - (module-ref disarchive 'disarchive-assemble)))) - (#f - (format #t "could not load Disarchive~%")) - ((%disarchive-log-port . disarchive-assemble) - (match (fetch-specification uris) - (#f - (format #t "could not find its Disarchive specification~%")) - (spec (parameterize ((%disarchive-log-port (current-output-port))) - (disarchive-assemble spec file #:resolver resolve))))))) - (define* (url-fetch url file #:key (timeout 10) (verify-certificate? #t) (mirrors '()) (content-addressed-mirrors '()) - (disarchive-mirrors '()) (hashes '()) print-build-trace?) "Fetch FILE from URL; URL may be either a single string, or a list of @@ -739,18 +693,6 @@ otherwise simply ignore them." hashes)) content-addressed-mirrors)) - (define disarchive-uris - (append-map (match-lambda - ((? string? mirror) - (map (match-lambda - ((hash-algo . hash) - (string->uri - (string-append mirror - (symbol->string hash-algo) "/" - (bytevector->base16-string hash))))) - hashes))) - disarchive-mirrors)) - ;; Make this unbuffered so 'progress-report/file' works as expected. 'line ;; means '\n', not '\r', so it's not appropriate here. (setvbuf (current-output-port) 'none) @@ -763,20 +705,15 @@ otherwise simply ignore them." (or (fetch uri file) (try tail))) (() - ;; If we are looking for a software archive, one last thing we - ;; can try is to use Disarchive to assemble it. - (or (disarchive-fetch/any disarchive-uris file - #:verify-certificate? verify-certificate? - #:timeout timeout) - (begin - (format (current-error-port) "failed to download ~s from ~s~%" - file url) - ;; Remove FILE in case we made an incomplete download, for - ;; example due to ENOSPC. - (catch 'system-error - (lambda () - (delete-file file)) - (const #f)) - #f)))))) + (format (current-error-port) "failed to download ~s from ~s~%" + file url) + + ;; Remove FILE in case we made an incomplete download, for example due + ;; to ENOSPC. + (catch 'system-error + (lambda () + (delete-file file)) + (const #f)) + #f)))) ;;; download.scm ends here diff --git a/guix/download.scm b/guix/download.scm index 72094e7318..30f69c0325 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -406,19 +406,12 @@ (plain-file "content-addressed-mirrors" (object->string %content-addressed-mirrors))) -(define %disarchive-mirrors - '("https://disarchive.ngyro.com/")) - -(define %disarchive-mirror-file - (plain-file "disarchive-mirrors" (object->string %disarchive-mirrors))) - (define built-in-builders* (store-lift built-in-builders)) (define* (built-in-download file-name url #:key system hash-algo hash mirrors content-addressed-mirrors - disarchive-mirrors executable? (guile 'unused)) "Download FILE-NAME from URL using the built-in 'download' builder. When @@ -429,16 +422,13 @@ explicitly depend on Guile, GnuTLS, etc. Instead, the daemon performs the download by itself using its own dependencies." (mlet %store-monad ((mirrors (lower-object mirrors)) (content-addressed-mirrors - (lower-object content-addressed-mirrors)) - (disarchive-mirrors (lower-object disarchive-mirrors))) + (lower-object content-addressed-mirrors))) (raw-derivation file-name "builtin:download" '() #:system system #:hash-algo hash-algo #:hash hash #:recursive? executable? - #:sources (list mirrors - content-addressed-mirrors - disarchive-mirrors) + #:sources (list mirrors content-addressed-mirrors) ;; Honor the user's proxy and locale settings. #:leaked-env-vars '("http_proxy" "https_proxy" @@ -449,7 +439,6 @@ download by itself using its own dependencies." ("mirrors" . ,mirrors) ("content-addressed-mirrors" . ,content-addressed-mirrors) - ("disarchive-mirrors" . ,disarchive-mirrors) ,@(if executable? '(("executable" . "1")) '())) @@ -503,9 +492,7 @@ name in the store." #:executable? executable? #:mirrors %mirror-file #:content-addressed-mirrors - %content-addressed-mirror-file - #:disarchive-mirrors - %disarchive-mirror-file))))) + %content-addressed-mirror-file))))) (define* (url-fetch/executable url hash-algo hash #:optional name diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 6889bcef79..8d409092ba 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -54,8 +54,7 @@ actual output is different from that when we're doing a 'bmCheck' or (output* "out") (executable "executable") (mirrors "mirrors") - (content-addressed-mirrors "content-addressed-mirrors") - (disarchive-mirrors "disarchive-mirrors")) + (content-addressed-mirrors "content-addressed-mirrors")) (unless url (leave (G_ "~a: missing URL~%") (derivation-file-name drv))) @@ -80,10 +79,6 @@ actual output is different from that when we're doing a 'bmCheck' or (lambda (port) (eval (read port) %user-module))) '()) - #:disarchive-mirrors - (if disarchive-mirrors - (call-with-input-file disarchive-mirrors read) - '()) #:hashes `((,algo . ,hash)) ;; Since DRV's output hash is known, X.509 certificate -- cgit v1.2.3 From fbc2a52a32ddc664db8ebab420c2e17b1432c744 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Fri, 19 Mar 2021 23:03:25 -0400 Subject: download: Use Disarchive as a last resort. This is a fixed version of 66b14dccdd0d83c875ce3a8d50ceab8b6f0a3ce2, which was reverted in e74250c3c535b75dd2225a26df51febb7ed94654. * guix/download.scm (%disarchive-mirrors): New variable. (%disarchive-mirror-file): New variable. (built-in-download): Add 'disarchive-mirrors' keyword argument and pass its value along to the 'builtin:download' derivation. (url-fetch): Pass '%disarchive-mirror-file' to 'built-in-download'. * guix/scripts/perform-download.scm (perform-download): Read Disarchive mirrors from the environment and pass them to 'url-fetch'. * guix/build/download.scm (disarchive-fetch/any): New procedure. (url-fetch): Add 'disarchive-mirrors' keyword argument, use it to make a list of URIs, and use the new procedure to fetch the file if all other methods fail. * build-aux/build-self.scm (build-program)[select?]: Exclude '(guix build download)'. * guix/self.scm (compiled-guix)[*core-modules*]: Add 'guile-json' to the list of extensions. --- build-aux/build-self.scm | 1 + guix/build/download.scm | 83 ++++++++++++++++++++++++++++++++++----- guix/download.scm | 19 +++++++-- guix/scripts/perform-download.scm | 7 +++- guix/self.scm | 3 +- 5 files changed, 98 insertions(+), 15 deletions(-) (limited to 'guix/build') diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index 853a2f328f..f100ff4aae 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -250,6 +250,7 @@ interface (FFI) of Guile.") (match-lambda (('guix 'config) #f) (('guix 'channels) #f) + (('guix 'build 'download) #f) ;autoloaded by (guix download) (('guix _ ...) #t) (('gnu _ ...) #t) (_ #f))) diff --git a/guix/build/download.scm b/guix/build/download.scm index a22d4064ca..ce31038b05 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Tobias Geerinckx-Rice +;;; Copyright © 2021 Timothy Sample ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,6 +35,8 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:autoload (ice-9 ftw) (scandir) + #:autoload (guix base16) (bytevector->base16-string) + #:autoload (guix swh) (swh-download-directory) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (open-socket-for-uri @@ -626,10 +629,53 @@ Return a list of URIs." (else (list uri)))) +(define* (disarchive-fetch/any uris file + #:key (timeout 10) (verify-certificate? #t)) + "Fetch a Disarchive specification from any of URIS, assemble it, +and write the output to FILE." + (define (fetch-specification uris) + (any (lambda (uri) + (false-if-exception* + (let-values (((port size) (http-fetch uri + #:verify-certificate? + verify-certificate? + #:timeout timeout))) + (let ((specification (read port))) + (close-port port) + specification)))) + uris)) + + (define (resolve addresses output) + (any (match-lambda + (('swhid swhid) + (match (string-split swhid #\:) + (("swh" "1" "dir" id) + (format #t "Downloading ~a from Software Heritage...~%" file) + (false-if-exception* + (swh-download-directory id output))) + (_ #f))) + (_ #f)) + addresses)) + + (format #t "Trying to use Disarchive to assemble ~a...~%" file) + (match (and=> (resolve-module '(disarchive) #:ensure #f) + (lambda (disarchive) + (cons (module-ref disarchive '%disarchive-log-port) + (module-ref disarchive 'disarchive-assemble)))) + (#f + (format #t "could not load Disarchive~%")) + ((%disarchive-log-port . disarchive-assemble) + (match (fetch-specification uris) + (#f + (format #t "could not find its Disarchive specification~%")) + (spec (parameterize ((%disarchive-log-port (current-output-port))) + (disarchive-assemble spec file #:resolver resolve))))))) + (define* (url-fetch url file #:key (timeout 10) (verify-certificate? #t) (mirrors '()) (content-addressed-mirrors '()) + (disarchive-mirrors '()) (hashes '()) print-build-trace?) "Fetch FILE from URL; URL may be either a single string, or a list of @@ -693,6 +739,18 @@ otherwise simply ignore them." hashes)) content-addressed-mirrors)) + (define disarchive-uris + (append-map (match-lambda + ((? string? mirror) + (map (match-lambda + ((hash-algo . hash) + (string->uri + (string-append mirror + (symbol->string hash-algo) "/" + (bytevector->base16-string hash))))) + hashes))) + disarchive-mirrors)) + ;; Make this unbuffered so 'progress-report/file' works as expected. 'line ;; means '\n', not '\r', so it's not appropriate here. (setvbuf (current-output-port) 'none) @@ -705,15 +763,20 @@ otherwise simply ignore them." (or (fetch uri file) (try tail))) (() - (format (current-error-port) "failed to download ~s from ~s~%" - file url) - - ;; Remove FILE in case we made an incomplete download, for example due - ;; to ENOSPC. - (catch 'system-error - (lambda () - (delete-file file)) - (const #f)) - #f)))) + ;; If we are looking for a software archive, one last thing we + ;; can try is to use Disarchive to assemble it. + (or (disarchive-fetch/any disarchive-uris file + #:verify-certificate? verify-certificate? + #:timeout timeout) + (begin + (format (current-error-port) "failed to download ~s from ~s~%" + file url) + ;; Remove FILE in case we made an incomplete download, for + ;; example due to ENOSPC. + (catch 'system-error + (lambda () + (delete-file file)) + (const #f)) + #f)))))) ;;; download.scm ends here diff --git a/guix/download.scm b/guix/download.scm index 30f69c0325..72094e7318 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -406,12 +406,19 @@ (plain-file "content-addressed-mirrors" (object->string %content-addressed-mirrors))) +(define %disarchive-mirrors + '("https://disarchive.ngyro.com/")) + +(define %disarchive-mirror-file + (plain-file "disarchive-mirrors" (object->string %disarchive-mirrors))) + (define built-in-builders* (store-lift built-in-builders)) (define* (built-in-download file-name url #:key system hash-algo hash mirrors content-addressed-mirrors + disarchive-mirrors executable? (guile 'unused)) "Download FILE-NAME from URL using the built-in 'download' builder. When @@ -422,13 +429,16 @@ explicitly depend on Guile, GnuTLS, etc. Instead, the daemon performs the download by itself using its own dependencies." (mlet %store-monad ((mirrors (lower-object mirrors)) (content-addressed-mirrors - (lower-object content-addressed-mirrors))) + (lower-object content-addressed-mirrors)) + (disarchive-mirrors (lower-object disarchive-mirrors))) (raw-derivation file-name "builtin:download" '() #:system system #:hash-algo hash-algo #:hash hash #:recursive? executable? - #:sources (list mirrors content-addressed-mirrors) + #:sources (list mirrors + content-addressed-mirrors + disarchive-mirrors) ;; Honor the user's proxy and locale settings. #:leaked-env-vars '("http_proxy" "https_proxy" @@ -439,6 +449,7 @@ download by itself using its own dependencies." ("mirrors" . ,mirrors) ("content-addressed-mirrors" . ,content-addressed-mirrors) + ("disarchive-mirrors" . ,disarchive-mirrors) ,@(if executable? '(("executable" . "1")) '())) @@ -492,7 +503,9 @@ name in the store." #:executable? executable? #:mirrors %mirror-file #:content-addressed-mirrors - %content-addressed-mirror-file))))) + %content-addressed-mirror-file + #:disarchive-mirrors + %disarchive-mirror-file))))) (define* (url-fetch/executable url hash-algo hash #:optional name diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 8d409092ba..6889bcef79 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -54,7 +54,8 @@ actual output is different from that when we're doing a 'bmCheck' or (output* "out") (executable "executable") (mirrors "mirrors") - (content-addressed-mirrors "content-addressed-mirrors")) + (content-addressed-mirrors "content-addressed-mirrors") + (disarchive-mirrors "disarchive-mirrors")) (unless url (leave (G_ "~a: missing URL~%") (derivation-file-name drv))) @@ -79,6 +80,10 @@ actual output is different from that when we're doing a 'bmCheck' or (lambda (port) (eval (read port) %user-module))) '()) + #:disarchive-mirrors + (if disarchive-mirrors + (call-with-input-file disarchive-mirrors read) + '()) #:hashes `((,algo . ,hash)) ;; Since DRV's output hash is known, X.509 certificate diff --git a/guix/self.scm b/guix/self.scm index 3154d180ac..7181205610 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -878,7 +878,8 @@ itself." ("guix/store/schema.sql" ,(local-file "../guix/store/schema.sql"))) - #:extensions (list guile-gcrypt) + #:extensions (list guile-gcrypt + guile-json) ;for (guix swh) #:guile-for-build guile-for-build)) (define *extra-modules* -- cgit v1.2.3 From 79cfe30f3eb10bd3dbf7aa0f6e873c945d7d0ea5 Mon Sep 17 00:00:00 2001 From: Leo Prikler Date: Sat, 17 Apr 2021 19:06:19 +0200 Subject: build-system: emacs: Use subdirectories again. With this, Emacs libraries are installed in the ELPA_NAME-VERSION subdirectory of site-lisp and potential subdirectories should no longer collide. * guix/build/emacs-build-system.scm (add-source-to-load-path): Rename to... (expand-load-path): ... this. Also expand lone subdirectories of site-lisp. (%standard-phases): Adjust accordingly. (elpa-directory): New variable. Export it publicly for use in other build systems. (build, patch-el-files, make-autoloads): Use ELPA name and version to construct subdirectories of %install-dir. (install): Install in subdirectory. --- guix/build/emacs-build-system.scm | 70 +++++++++++++++++++++++++-------------- 1 file changed, 45 insertions(+), 25 deletions(-) (limited to 'guix/build') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 26ea59bc25..ae0f2e569e 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -26,13 +26,16 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (ice-9 format) + #:use-module (ice-9 ftw) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:export (%standard-phases %default-include %default-exclude - emacs-build)) + emacs-build + elpa-directory)) ;; Commentary: ;; @@ -73,33 +76,43 @@ archive, a directory, or an Emacs Lisp file." #t) (gnu:unpack #:source source))) -(define* (add-source-to-load-path #:key dummy #:allow-other-keys) - "Augment the EMACSLOADPATH environment variable with the source directory." +(define* (expand-load-path #:key (prepend-source? #t) #:allow-other-keys) + "Expand EMACSLOADPATH, so that inputs, whose code resides in subdirectories, +are properly found. +If @var{prepend-source?} is @code{#t} (the default), also add the current +directory to EMACSLOADPATH in front of any other directories." (let* ((source-directory (getcwd)) (emacs-load-path (string-split (getenv "EMACSLOADPATH") #\:)) - ;; XXX: Make sure the Emacs core libraries appear at the end of - ;; EMACSLOADPATH, to avoid shadowing any other libraries depended - ;; upon. - (emacs-load-path-non-core (filter (cut string-contains <> - "/share/emacs/site-lisp") - emacs-load-path)) + (emacs-load-path* + (map + (lambda (dir) + (match (scandir dir (negate (cute member <> '("." "..")))) + ((sub) (string-append dir "/" sub)) + (_ dir))) + emacs-load-path)) (emacs-load-path-value (string-append - (string-join (cons source-directory - emacs-load-path-non-core) - ":") + (string-join + (if prepend-source? + (cons source-directory emacs-load-path*) + emacs-load-path*) + ":") ":"))) (setenv "EMACSLOADPATH" emacs-load-path-value) - (format #t "source directory ~s prepended to the `EMACSLOADPATH' \ -environment variable\n" source-directory))) + (when prepend-source? + (format #t "source directory ~s prepended to the `EMACSLOADPATH' \ +environment variable\n" source-directory)) + (let ((diff (lset-difference string=? emacs-load-path* emacs-load-path))) + (unless (null? diff) + (format #t "expanded load paths for ~{~a~^, ~}\n" + (map basename diff)))))) (define* (build #:key outputs inputs #:allow-other-keys) "Compile .el files." (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs")) - (out (assoc-ref outputs "out")) - (site-lisp (string-append out %install-dir))) + (out (assoc-ref outputs "out"))) (setenv "SHELL" "sh") (parameterize ((%emacs emacs)) - (emacs-byte-compile-directory site-lisp)))) + (emacs-byte-compile-directory (elpa-directory out))))) (define* (patch-el-files #:key outputs #:allow-other-keys) "Substitute the absolute \"/bin/\" directory with the right location in the @@ -116,7 +129,8 @@ store in '.el' files." #:binary #t)) (let* ((out (assoc-ref outputs "out")) - (site-lisp (string-append out %install-dir)) + (elpa-name-ver (store-directory->elpa-name-version out)) + (el-dir (string-append out %install-dir "/" elpa-name-ver)) ;; (ice-9 regex) uses libc's regexp routines, which cannot deal with ;; strings containing NULs. Filter out such files. TODO: Remove ;; this workaround when is fixed. @@ -130,7 +144,7 @@ store in '.el' files." (error "patch-el-files: unable to locate " cmd-name)) (string-append "\"" cmd "\""))))) - (with-directory-excursion site-lisp + (with-directory-excursion el-dir ;; Some old '.el' files (e.g., tex-buf.el in AUCTeX) are still ;; ISO-8859-1-encoded. (unless (false-if-exception (substitute-program-names)) @@ -181,14 +195,14 @@ parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND." (not (any (cut match-stripped-file "excluded" <>) exclude))))) (let* ((out (assoc-ref outputs "out")) - (site-lisp (string-append out %install-dir)) + (el-dir (elpa-directory out)) (files-to-install (find-files source install-file?))) (cond ((not (null? files-to-install)) (for-each (lambda (file) (let* ((stripped-file (string-drop file (string-length source))) - (target-file (string-append site-lisp stripped-file))) + (target-file (string-append el-dir stripped-file))) (format #t "`~a' -> `~a'~%" file target-file) (install-file file (dirname target-file)))) files-to-install) @@ -219,11 +233,11 @@ parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND." "Generate the autoloads file." (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs")) (out (assoc-ref outputs "out")) - (site-lisp (string-append out %install-dir)) (elpa-name-ver (store-directory->elpa-name-version out)) - (elpa-name (package-name->name+version elpa-name-ver))) + (elpa-name (package-name->name+version elpa-name-ver)) + (el-dir (elpa-directory out))) (parameterize ((%emacs emacs)) - (emacs-generate-autoloads elpa-name site-lisp)))) + (emacs-generate-autoloads elpa-name el-dir)))) (define* (enable-autoloads-compilation #:key outputs #:allow-other-keys) "Remove the NO-BYTE-COMPILATION local variable embedded in the generated @@ -258,10 +272,16 @@ second hyphen. This corresponds to 'name-version' as used in ELPA packages." strip-store-file-name) store-dir)) +(define (elpa-directory store-dir) + "Given the store directory STORE-DIR return the absolute install directory +for libraries following the ELPA convention." + (string-append store-dir %install-dir "/" + (store-directory->elpa-name-version store-dir))) + (define %standard-phases (modify-phases gnu:%standard-phases (replace 'unpack unpack) - (add-after 'unpack 'add-source-to-load-path add-source-to-load-path) + (add-after 'unpack 'expand-load-path expand-load-path) (delete 'bootstrap) (delete 'configure) (delete 'build) -- cgit v1.2.3 From 0f116d7f909b6c1f1cc95c8b07d688b697d229b1 Mon Sep 17 00:00:00 2001 From: Leo Prikler Date: Wed, 5 May 2021 09:52:02 +0200 Subject: build-system: emacs: Clarify %install-dir. The old comment is no longer adequate, see . * guix/build/emacs-build-system.scm (%install-dir): Adjust comment to better reflect usage of this variable. --- guix/build/emacs-build-system.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix/build') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index ae0f2e569e..e41e9a6595 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -43,9 +43,12 @@ ;; ;; Code: -;;; All the packages are installed directly under site-lisp, which means that -;;; having that directory in the EMACSLOADPATH is enough to have them found by -;;; Emacs. +;;; The location in which Emacs looks for packages. Emacs Lisp code that is +;;; installed there directly will be found when that directory is added to +;;; EMACSLOADPATH. To avoid clashes between packages (particularly considering +;;; auxiliary files), we install them one directory level below, however. +;;; This indirection is handled by ‘expand-load-path’ during build and a +;;; profile hook otherwise. (define %install-dir "/share/emacs/site-lisp") ;; These are the default inclusion/exclusion regexps for the install phase. -- cgit v1.2.3 From 7262619d6fa570fa47228daaead1b0473914c069 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Wed, 5 May 2021 23:10:25 -0400 Subject: download: Restore error reporting. Normal error reporting was disrupted by the introduction of Disarchive in commit fbc2a52a32ddc664db8ebab420c2e17b1432c744. In particular, running 'guix download' would succeed with a partially downloaded file. * guix/build/download.scm (disarchive-fetch/any): Return '#f' when Disarchive cannot be found, the specification cannot be found, or Disarchive fails due to an error. --- guix/build/download.scm | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index ce31038b05..b14db42352 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -662,14 +662,15 @@ and write the output to FILE." (lambda (disarchive) (cons (module-ref disarchive '%disarchive-log-port) (module-ref disarchive 'disarchive-assemble)))) - (#f - (format #t "could not load Disarchive~%")) + (#f (format #t "could not load Disarchive~%") + #f) ((%disarchive-log-port . disarchive-assemble) (match (fetch-specification uris) - (#f - (format #t "could not find its Disarchive specification~%")) + (#f (format #t "could not find its Disarchive specification~%") + #f) (spec (parameterize ((%disarchive-log-port (current-output-port))) - (disarchive-assemble spec file #:resolver resolve))))))) + (false-if-exception* + (disarchive-assemble spec file #:resolver resolve)))))))) (define* (url-fetch url file #:key -- cgit v1.2.3 From 2fa8fd4af59af0de392352915fa50fc21a4cf98a Mon Sep 17 00:00:00 2001 From: Guillaume Le Vaillant Date: Thu, 6 May 2021 10:32:56 +0200 Subject: build-system: asdf: Work around package-name->name+version bug. This patch modifies how the name of the main Common Lisp system is extracted from the full Guix package name to work around bug#48225 concerning the 'package-name->name+version' function. Fixes . * guix/build-system/asdf.scm (asdf-build): Fix 'systems' function. * guix/build/asdf-build-system.scm (main-system-name): Fix it. --- guix/build-system/asdf.scm | 18 +++++++++--------- guix/build/asdf-build-system.scm | 15 ++++++++------- 2 files changed, 17 insertions(+), 16 deletions(-) (limited to 'guix/build') diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index 28403a1960..b4e40ee8c2 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson -;;; Copyright © 2019, 2020 Guillaume Le Vaillant +;;; Copyright © 2019, 2020, 2021 Guillaume Le Vaillant ;;; ;;; This file is part of GNU Guix. ;;; @@ -291,16 +291,16 @@ set up using CL source package conventions." (imported-modules %asdf-build-system-modules) (modules %asdf-build-modules)) - ;; FIXME: The definition of 'systems' is pretty hacky. - ;; Is there a more elegant way to do it? (define systems (if (null? (cadr asd-systems)) - `(quote - ,(list - (string-drop - ;; NAME is the value returned from `package-full-name'. - (hyphen-separated-name->name+version name) - (1+ (string-length lisp-type))))) ; drop the "-" prefix. + ;; FIXME: Find a more reliable way to get the main system name. + (let* ((lisp-prefix (string-append lisp-type "-")) + (package-name (hyphen-separated-name->name+version + (if (string-prefix? lisp-prefix name) + (string-drop name + (string-length lisp-prefix)) + name)))) + `(quote ,(list package-name))) asd-systems)) (define builder diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index 6ad855cab2..7f1037c4f9 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson -;;; Copyright © 2020 Guillaume Le Vaillant +;;; Copyright © 2020, 2021 Guillaume Le Vaillant ;;; ;;; This file is part of GNU Guix. ;;; @@ -52,12 +52,13 @@ (string-append %source-install-prefix "/systems")) (define (main-system-name output) - (let ((package-name (package-name->name+version - (strip-store-file-name output))) - (lisp-prefix (string-append (%lisp-type) "-"))) - (if (string-prefix? lisp-prefix package-name) - (string-drop package-name (string-length lisp-prefix)) - package-name))) + ;; FIXME: Find a more reliable way to get the main system name. + (let* ((full-name (strip-store-file-name output)) + (lisp-prefix (string-append (%lisp-type) "-")) + (package-name (if (string-prefix? lisp-prefix full-name) + (string-drop full-name (string-length lisp-prefix)) + full-name))) + (package-name->name+version package-name))) (define (lisp-source-directory output name) (string-append output (%lisp-source-install-prefix) "/" name)) -- cgit v1.2.3