diff options
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/perl.scm | 4 | ||||
-rw-r--r-- | guix/build/cargo-build-system.scm | 3 | ||||
-rw-r--r-- | guix/build/git.scm | 20 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 55 | ||||
-rw-r--r-- | guix/channels.scm | 132 | ||||
-rw-r--r-- | guix/git-download.scm | 4 | ||||
-rw-r--r-- | guix/import/cran.scm | 71 | ||||
-rw-r--r-- | guix/import/json.scm | 13 | ||||
-rw-r--r-- | guix/lint.scm | 30 | ||||
-rw-r--r-- | guix/platforms/or1k.scm | 28 | ||||
-rw-r--r-- | guix/scripts/describe.scm | 2 | ||||
-rw-r--r-- | guix/scripts/download.scm | 167 | ||||
-rw-r--r-- | guix/scripts/git/authenticate.scm | 15 | ||||
-rw-r--r-- | guix/scripts/import.scm | 82 | ||||
-rw-r--r-- | guix/scripts/perform-download.scm | 4 | ||||
-rw-r--r-- | guix/scripts/weather.scm | 9 | ||||
-rw-r--r-- | guix/self.scm | 5 | ||||
-rw-r--r-- | guix/swh.scm | 113 | ||||
-rw-r--r-- | guix/upstream.scm | 28 | ||||
-rw-r--r-- | guix/utils.scm | 30 |
20 files changed, 642 insertions, 173 deletions
diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 0d5493ab90..3f7a2dea27 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -197,7 +197,9 @@ XS or similar." native-search-paths)) #:make-maker? #$make-maker? #:make-maker-flags #$make-maker-flags - #:module-build-flags #$(sexp->gexp module-build-flags) + #:module-build-flags #$(if (pair? module-build-flags) + (sexp->gexp module-build-flags) + module-build-flags) #:phases #$phases #:build #$build #:system #$system diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index ffb2ec898e..70ddf063d2 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com> -;;; Copyright © 2019-2023 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2019-2024 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2020 Marius Bakke <marius@gnu.org> ;;; @@ -162,6 +162,7 @@ libraries or executables." ("powerpc64le-linux-gnu" "powerpc64le-unknown-linux-gnu") ("riscv64-linux-gnu" "riscv64gc-unknown-linux-gnu") ("x86_64-linux-gnu" "x86_64-unknown-linux-gnu") + ("x86_64-linux-gnux32" "x86_64-unknown-linux-gnux32") ("i586-pc-gnu" "i686-unknown-hurd-gnu") ("i686-w64-mingw32" "i686-pc-windows-gnu") ("x86_64-w64-mingw32" "x86_64-pc-windows-gnu") diff --git a/guix/build/git.scm b/guix/build/git.scm index 867cade2c4..4c69365a7b 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2016, 2019, 2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2016, 2019, 2023-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -20,7 +20,9 @@ (define-module (guix build git) #:use-module (guix build utils) #:autoload (guix build download-nar) (download-nar) - #:autoload (guix swh) (%verify-swh-certificate? swh-download) + #:autoload (guix swh) (%verify-swh-certificate? + swh-download + swh-download-directory-by-nar-hash) #:use-module (srfi srfi-34) #:use-module (ice-9 format) #:export (git-fetch @@ -91,10 +93,13 @@ fetched, recursively. Return #t on success, #f otherwise." (define* (git-fetch-with-fallback url commit directory #:key (git-command "git") + hash hash-algorithm lfs? recursive?) "Like 'git-fetch', fetch COMMIT from URL into DIRECTORY, but fall back to alternative methods when fetching from URL fails: attempt to download a nar, -and if that also fails, download from the Software Heritage archive." +and if that also fails, download from the Software Heritage archive. When +HASH and HASH-ALGORITHM are provided, they are interpreted as the nar hash of +the directory of interested and are used as its content address at SWH." (or (git-fetch url commit directory #:lfs? lfs? #:recursive? recursive? @@ -110,7 +115,14 @@ and if that also fails, download from the Software Heritage archive." (format (current-error-port) "Trying to download from Software Heritage...~%") - (swh-download url commit directory) + ;; First try to look up and download the directory corresponding + ;; to HASH: this is fundamentally more reliable than looking up + ;; COMMIT, especially when COMMIT denotes a tag. + (or (and hash hash-algorithm + (swh-download-directory-by-nar-hash hash hash-algorithm + directory)) + (swh-download url commit directory)) + (when (file-exists? (string-append directory "/.gitattributes")) ;; Perform CR/LF conversion and other changes diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index b2871c3c10..39bcffd516 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2024 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> @@ -765,27 +765,50 @@ current process." (list (strerror err)) (list err))))))) -(define (kernel? pid) - "Return #t if PID designates a \"kernel thread\" rather than a normal -user-land process." - (let ((stat (call-with-input-file (format #f "/proc/~a/stat" pid) - (compose string-tokenize read-string)))) - ;; See proc.txt in Linux's documentation for the list of fields. - (match stat - ((pid tcomm state ppid pgrp sid tty_nr tty_pgrp flags min_flt - cmin_flt maj_flt cmaj_flt utime stime cutime cstime - priority nice num_thread it_real_value start_time - vsize rss rsslim - (= string->number start_code) (= string->number end_code) _ ...) - ;; Got this obscure trick from sysvinit's 'killall5' program. - (and (zero? start_code) (zero? end_code)))))) +(define (linux-process-flags pid) ;copied from the Shepherd + "Return the process flags of @var{pid} (or'd @code{PF_} constants), assuming +the Linux /proc file system is mounted; raise a @code{system-error} exception +otherwise." + (call-with-input-file (string-append "/proc/" (number->string pid) + "/stat") + (lambda (port) + (define line + (read-string port)) + + ;; Parse like systemd's 'is_kernel_thread' function. + (let ((offset (string-index line #\)))) ;offset past 'tcomm' field + (match (and offset + (string-tokenize (string-drop line (+ offset 1)))) + ((state ppid pgrp sid tty-nr tty-pgrp flags . _) + (or (string->number flags) 0)) + (_ + 0)))))) + +;; Per-process flag defined in <linux/sched.h>. +(define PF_KTHREAD #x00200000) ;I am a kernel thread + +(define (linux-kernel-thread? pid) + "Return true if @var{pid} is a Linux kernel thread." + (= PF_KTHREAD (logand (linux-process-flags pid) PF_KTHREAD))) + +(define pseudo-process? + (if (string-contains %host-type "linux") + (lambda (pid) + "Return true if @var{pid} denotes a \"pseudo-process\" such as a Linux +kernel thread rather than a \"regular\" process. A pseudo-process is one that +may never terminate, even after sending it SIGKILL---e.g., kthreadd on Linux." + (catch 'system-error + (lambda () + (linux-kernel-thread? pid)) + (const #f))) + (const #f))) (define (processes) "Return the list of live processes." (sort (filter-map (lambda (file) (let ((pid (string->number file))) (and pid - (not (kernel? pid)) + (not (pseudo-process? pid)) pid))) (scandir "/proc")) <)) diff --git a/guix/channels.scm b/guix/channels.scm index f01903642d..1b07eb5221 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -34,7 +34,6 @@ #:use-module (guix packages) #:use-module (guix progress) #:use-module (guix derivations) - #:use-module (guix combinators) #:use-module (guix diagnostics) #:use-module (guix sets) #:use-module (guix store) @@ -510,16 +509,6 @@ CURRENT-CHANNELS is the list of currently used channels. It is compared against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called for each channel update and can choose to emit warnings or raise an error, depending on the policy it implements." - ;; Only process channels that are unique, or that are more specific than a - ;; previous channel specification. - (define (ignore? channel others) - (member channel others - (lambda (a b) - (and (eq? (channel-name a) (channel-name b)) - (or (channel-commit b) - (not (or (channel-commit a) - (channel-commit b)))))))) - (define (current-commit name) ;; Return the current commit for channel NAME. (any (lambda (channel) @@ -527,60 +516,77 @@ depending on the policy it implements." (channel-commit channel))) current-channels)) + (define instance-name + (compose channel-name channel-instance-channel)) + + (define (same-named? channel) + (let ((name (channel-name channel))) + (lambda (candidate) + (eq? (channel-name candidate) name)))) + + (define (more-specific? a b) + ;; A is more specific than B if it specifies a commit. + (and (channel-commit a) + (not (channel-commit b)))) + (let loop ((channels channels) - (previous-channels '())) - ;; Accumulate a list of instances. A list of processed channels is also - ;; accumulated to decide on duplicate channel specifications. - (define-values (resulting-channels instances) - (fold2 (lambda (channel previous-channels instances) - (if (ignore? channel previous-channels) - (values previous-channels instances) - (begin - (format (current-error-port) - (G_ "Updating channel '~a' from Git repository at '~a'...~%") - (channel-name channel) - (channel-url channel)) - (let* ((current (current-commit (channel-name channel))) - (instance - (latest-channel-instance store channel - #:authenticate? - authenticate? - #:validate-pull - validate-pull - #:starting-commit - current))) - (when authenticate? - ;; CHANNEL is authenticated so we can trust the - ;; primary URL advertised in its metadata and warn - ;; about possibly stale mirrors. - (let ((primary-url (channel-instance-primary-url - instance))) - (unless (or (not primary-url) - (channel-commit channel) - (string=? primary-url (channel-url channel))) - (warning (G_ "pulled channel '~a' from a mirror \ + (previous-channels '()) + (instances '())) + (match channels + (() + (reverse instances)) + ((channel . rest) + (let ((previous (find (same-named? channel) previous-channels))) + ;; If there's already an instance for CHANNEL, keep the most specific + ;; one. + (if (and previous + (not (more-specific? channel previous))) + (loop rest previous-channels instances) + (begin + (format (current-error-port) + (G_ "Updating channel '~a' from Git repository at '~a'...~%") + (channel-name channel) + (channel-url channel)) + (let* ((current (current-commit (channel-name channel))) + (instance + (latest-channel-instance store channel + #:authenticate? + authenticate? + #:validate-pull + validate-pull + #:starting-commit + current))) + (when authenticate? + ;; CHANNEL is authenticated so we can trust the + ;; primary URL advertised in its metadata and warn + ;; about possibly stale mirrors. + (let ((primary-url (channel-instance-primary-url + instance))) + (unless (or (not primary-url) + (channel-commit channel) + (string=? primary-url (channel-url channel))) + (warning (G_ "pulled channel '~a' from a mirror \ of ~a, which might be stale~%") - (channel-name channel) - primary-url)))) - - (let-values (((new-instances new-channels) - (loop (channel-instance-dependencies instance) - previous-channels))) - (values (append (cons channel new-channels) - previous-channels) - (append (cons instance new-instances) - instances))))))) - previous-channels - '() ;instances - channels)) - - (let ((instance-name (compose channel-name channel-instance-channel))) - ;; Remove all earlier channel specifications if they are followed by a - ;; more specific one. - (values (delete-duplicates instances - (lambda (a b) - (eq? (instance-name a) (instance-name b)))) - resulting-channels)))) + (channel-name channel) + primary-url)))) + + ;; Perform a breadth-first traversal with the idea that the + ;; user-provided channels may be more specific than what + ;; '.guix-channel' specifies, and so it is on those instances + ;; that 'channel-instance-dependencies' should be called. + (loop (append rest + (channel-instance-dependencies instance)) + (cons channel + (if previous + (delq previous previous-channels) + previous-channels)) + (cons instance + (if previous + (remove (lambda (instance) + (eq? (instance-name instance) + (channel-name channel))) + instances) + instances))))))))))) (define* (checkout->channel-instance checkout #:key commit diff --git a/guix/git-download.scm b/guix/git-download.scm index 3de6ae970d..aadcbd234c 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014-2021, 2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2021, 2023-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> @@ -165,6 +165,8 @@ respective documentation." (git-fetch-with-fallback (getenv "git url") (getenv "git commit") #$output + #:hash #$hash + #:hash-algorithm '#$hash-algo #:lfs? lfs? #:recursive? recursive? #:git-command "git"))))) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index d7497e6fb9..9b30dc30e0 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -90,7 +90,7 @@ (map (lambda (input) (case (%input-style) ((specification) - `(specification->package ,(upstream-input-name input))) + `(specification->package ,(upstream-input-downstream-name input))) (else ((compose string->symbol upstream-input-downstream-name) @@ -672,6 +672,54 @@ of META, a package in REPOSITORY." (string<? (upstream-input-downstream-name input1) (upstream-input-downstream-name input2)))))) +(define (phases-for-inputs input-names) + "Generate a list of build phases based on the provided INPUT-NAMES, a list +of package names for all input packages." + (let ((rules + (list (lambda () + (and (any (lambda (name) + (member name '("styler" "ExperimentHub"))) + input-names) + '(add-after 'unpack 'set-HOME + (lambda _ (setenv "HOME" "/tmp"))))) + (lambda () + (and (member "esbuild" input-names) + '(add-after 'unpack 'process-javascript + (lambda* (#:key inputs #:allow-other-keys) + (with-directory-excursion "inst/" + (for-each (match-lambda + ((source . target) + (minify source #:target target))) + '()))))))))) + (fold (lambda (rule phases) + (let ((new-phase (rule))) + (if new-phase (cons new-phase phases) phases))) + (list) + rules))) + +(define (maybe-arguments inputs) + "Generate a list for the arguments field that can be spliced into a package +S-expression." + (let ((input-names (map upstream-input-name inputs)) + (esbuild-modules '(#:modules + '((guix build r-build-system) + (guix build minify-build-system) + (guix build utils) + (ice-9 match)) + #:imported-modules + `(,@%r-build-system-modules + (guix build minify-build-system))))) + (match (phases-for-inputs input-names) + (() '()) + (phases + `((arguments + (list + ,@(if (member "esbuild" input-names) + esbuild-modules '()) + #:phases + '(modify-phases %standard-phases + ,@phases)))))))) + (define* (description->package repository meta #:key (license-prefix identity) (download-source download)) "Return the `package' s-expression for an R package published on REPOSITORY @@ -751,7 +799,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) '()) (build-system r-build-system) - + ,@(maybe-arguments inputs) ,@(maybe-inputs (filter (upstream-input-type-predicate 'regular) inputs) 'inputs) @@ -882,15 +930,25 @@ s-expression corresponding to that package, or #f on failure." (define upstream-name (package->upstream-name pkg)) + (define type + (cond + ((bioconductor-data-package? pkg) + 'annotation) + ((bioconductor-experiment-package? pkg) + 'experiment) + ((bioconductor-package? pkg) + #true) + (else #false))) + (define latest-version - (latest-bioconductor-package-version upstream-name)) + (latest-bioconductor-package-version upstream-name type)) (and latest-version ;; Bioconductor does not provide signatures. (upstream-source (package (package-name pkg)) (version latest-version) - (urls (bioconductor-uri upstream-name latest-version)) + (urls (bioconductor-uri upstream-name latest-version type)) (inputs (let ((meta (fetch-description 'bioconductor upstream-name))) (cran-package-inputs meta 'bioconductor)))))) @@ -944,7 +1002,10 @@ s-expression corresponding to that package, or #f on failure." (upstream-updater (name 'bioconductor) (description "Updater for Bioconductor packages") - (pred bioconductor-package?) + (pred (lambda (pkg) + (or (bioconductor-package? pkg) + (bioconductor-data-package? pkg) + (bioconductor-experiment-package? pkg)))) (import latest-bioconductor-release))) ;;; cran.scm ends here diff --git a/guix/import/json.scm b/guix/import/json.scm index b87e9918c5..bf346a1bef 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -78,14 +78,13 @@ a list of S-expressions, or return #F when the JSON is invalid." #:result (append result (list - (package->code (alist->package pkg names)) - (string->symbol (assoc-ref pkg "name")))))))) - (list #:names '() - #:result '()) - packages)))) + (package->code + (alist->package pkg names)))))))) + (list #:names '() + #:result '()) + packages)))) (package - (list (package->code (alist->package json)) - (string->symbol (assoc-ref json "name"))))))) + (list (package->code (alist->package json))))))) (const #f))) (define (json->scheme-file file) diff --git a/guix/lint.scm b/guix/lint.scm index 861e352b93..c95de85e69 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -1658,24 +1658,31 @@ try again later") (or (not (request-rate-limit-reached? url method)) (throw skip-key #t))) + (define (lookup-by-nar-hash hash) + (lookup-directory-by-nar-hash (content-hash-value hash) + (content-hash-algorithm hash))) + (parameterize ((%allow-request? skip-when-limit-reached)) (catch #t (lambda () (match (package-source package) (#f ;no source '()) - ((and (? origin?) + ((and (? origin? origin) (= origin-uri (? git-reference? reference))) (define url (git-reference-url reference)) (define commit (git-reference-commit reference)) - - (match (if (commit-id? commit) - (or (lookup-revision commit) - (lookup-origin-revision url commit)) - (lookup-origin-revision url commit)) - ((? revision? revision) + (define hash + (origin-hash origin)) + + (match (or (lookup-by-nar-hash hash) + (if (commit-id? commit) + (or (lookup-revision commit) + (lookup-origin-revision url commit)) + (lookup-origin-revision url commit))) + ((or (? string?) (? revision?)) '()) (#f ;; Revision is missing from the archive, attempt to save it. @@ -1704,9 +1711,10 @@ try again later") (if (and=> (origin-hash origin) ;XXX: for ungoogled-chromium content-hash-value) ;& icecat (let ((hash (origin-hash origin))) - (match (lookup-content (content-hash-value hash) - (symbol->string - (content-hash-algorithm hash))) + (match (or (lookup-by-nar-hash hash) + (lookup-content (content-hash-value hash) + (symbol->string + (content-hash-algorithm hash)))) (#f ;; If SWH doesn't have HASH as is, it may be because it's ;; a hand-crafted tarball. In that case, check whether diff --git a/guix/platforms/or1k.scm b/guix/platforms/or1k.scm new file mode 100644 index 0000000000..bf983085c5 --- /dev/null +++ b/guix/platforms/or1k.scm @@ -0,0 +1,28 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2024 Foundation Devices, Inc. <hello@foundationdevices.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix platforms or1k) + #:use-module (guix platform) + #:use-module (guix records) + #:export (or1k-elf)) + +(define or1k-elf + (platform + (target "or1k-elf") + (system #f) + (glibc-dynamic-linker #f))) diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 6d451dc902..449ab4b252 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -168,6 +168,8 @@ string is ~a.~%") (format #t (G_ " commit: ~a~%") (channel-commit channel))) ('channels (pretty-print `(list ,(channel->code channel)))) + ('channels-sans-intro + (pretty-print `(list ,(channel->code channel #:include-introduction? #f)))) ('json (display (channel->json channel)) (newline)) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 19052d5652..de68e6f328 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -22,17 +22,24 @@ #:use-module (guix scripts) #:use-module (guix store) #:use-module (gcrypt hash) + #:use-module (guix hash) #:use-module (guix base16) #:use-module (guix base32) #:autoload (guix base64) (base64-encode) #:use-module ((guix download) #:hide (url-fetch)) + #:use-module ((guix git) + #:select (latest-repository-commit + update-cached-checkout + with-git-error-handling)) #:use-module ((guix build download) #:select (url-fetch)) + #:use-module (guix build utils) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module (web uri) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -54,6 +61,57 @@ (url-fetch url file #:mirrors %mirrors))) file)) +;; This is a simplified version of 'copy-recursively'. +;; It allows us to filter out the ".git" subfolder. +;; TODO: Remove when 'copy-recursively' supports '#:select?'. +(define (copy-recursively-without-dot-git source destination) + (define strip-source + (let ((len (string-length source))) + (lambda (file) + (substring file len)))) + + (file-system-fold (lambda (file stat result) ; enter? + (not (string-suffix? "/.git" file))) + (lambda (file stat result) ; leaf + (let ((dest (string-append destination + (strip-source file)))) + (case (stat:type stat) + ((symlink) + (let ((target (readlink file))) + (symlink target dest))) + (else + (copy-file file dest))))) + (lambda (dir stat result) ; down + (let ((target (string-append destination + (strip-source dir)))) + (mkdir-p target))) + (const #t) ; up + (const #t) ; skip + (lambda (file stat errno result) + (format (current-error-port) "i/o error: ~a: ~a~%" + file (strerror errno)) + #f) + #t + source)) + +(define (git-download-to-file url file reference recursive?) + "Download the git repo at URL to file, checked out at REFERENCE. +REFERENCE must be a pair argument as understood by 'latest-repository-commit'. +Return FILE." + ;; 'libgit2' doesn't support the URL format generated by 'uri->string' so + ;; we have to do a little fixup. Dropping completely the 'file:' protocol + ;; part gives better performance. + (let ((url (cond ((string-prefix? "file://" url) + (string-drop url (string-length "file://"))) + ((string-prefix? "file:" url) + (string-drop url (string-length "file:"))) + (else url)))) + (copy-recursively-without-dot-git + (with-git-error-handling + (update-cached-checkout url #:ref reference #:recursive? recursive?)) + file)) + file) + (define (ensure-valid-store-file-name name) "Replace any character not allowed in a store name by an underscore." @@ -67,17 +125,46 @@ name)) -(define* (download-to-store* url #:key (verify-certificate? #t)) +(define* (download-to-store* url + #:key (verify-certificate? #t) + #:allow-other-keys) (with-store store (download-to-store store url (ensure-valid-store-file-name (basename url)) #:verify-certificate? verify-certificate?))) +(define* (git-download-to-store* url + reference + recursive? + #:key (verify-certificate? #t)) + "Download the git repository at URL to the store, checked out at REFERENCE. +URL must specify a protocol (i.e https:// or file://), REFERENCE must be a +pair argument as understood by 'latest-repository-commit'." + ;; Ensure the URL string is properly formatted when using the 'file' + ;; protocol: URL is generated using 'uri->string', which returns + ;; "file:/path/to/file" instead of "file:///path/to/file", which in turn + ;; makes 'git-download-to-store' fail. + (let* ((file? (string-prefix? "file:" url)) + (url (if (and file? + (not (string-prefix? "file:///" url))) + (string-append "file://" + (string-drop url (string-length "file:"))) + url))) + (with-store store + ;; TODO: Verify certificate support and deactivation. + (with-git-error-handling + (latest-repository-commit store + url + #:recursive? recursive? + #:ref reference))))) + (define %default-options ;; Alist of default option values. `((format . ,bytevector->nix-base32-string) (hash-algorithm . ,(hash-algorithm sha256)) (verify-certificate? . #t) + (git-reference . #f) + (recursive? . #f) (download-proc . ,download-to-store*))) (define (show-help) @@ -97,6 +184,19 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) do not validate the certificate of HTTPS servers ")) (format #t (G_ " -o, --output=FILE download to FILE")) + (format #t (G_ " + -g, --git download the default branch's latest commit of the + Git repository at URL")) + (format #t (G_ " + --commit=COMMIT-OR-TAG + download the given commit or tag of the Git + repository at URL")) + (format #t (G_ " + --branch=BRANCH download the given branch of the Git repository + at URL")) + (format #t (G_ " + -r, --recursive download a Git repository recursively")) + (newline) (display (G_ " -h, --help display this help and exit")) @@ -105,6 +205,13 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (newline) (show-bug-report-information)) +(define (add-git-download-option result) + (alist-cons 'download-proc + ;; XXX: #:verify-certificate? currently ignored. + (lambda* (url #:key verify-certificate? ref recursive?) + (git-download-to-store* url ref recursive?)) + (alist-delete 'download result))) + (define %options ;; Specifications of the command-line options. (list (option '(#\f "format") #t #f @@ -136,10 +243,46 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (alist-cons 'verify-certificate? #f result))) (option '(#\o "output") #t #f (lambda (opt name arg result) - (alist-cons 'download-proc - (lambda* (url #:key verify-certificate?) - (download-to-file url arg)) - (alist-delete 'download result)))) + (let* ((git + (assoc-ref result 'git-reference))) + (if git + (alist-cons 'download-proc + (lambda* (url + #:key + verify-certificate? + ref + recursive?) + (git-download-to-file + url + arg + (assoc-ref result 'git-reference) + recursive?)) + (alist-delete 'download result)) + (alist-cons 'download-proc + (lambda* (url + #:key verify-certificate? + #:allow-other-keys) + (download-to-file url arg)) + (alist-delete 'download result)))))) + (option '(#\g "git") #f #f + (lambda (opt name arg result) + ;; Ignore this option if 'commit' or 'branch' has + ;; already been provided + (if (assoc-ref result 'git-reference) + result + (alist-cons 'git-reference '() + (add-git-download-option result))))) + (option '("commit") #t #f + (lambda (opt name arg result) + (alist-cons 'git-reference `(tag-or-commit . ,arg) + (add-git-download-option result)))) + (option '("branch") #t #f + (lambda (opt name arg result) + (alist-cons 'git-reference `(branch . ,arg) + (add-git-download-option result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive? #t result))) (option '(#\h "help") #f #f (lambda args @@ -183,12 +326,14 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (terminal-columns))) (fetch (uri->string uri) #:verify-certificate? - (assq-ref opts 'verify-certificate?)))) - (hash (call-with-input-file - (or path - (leave (G_ "~a: download failed~%") - arg)) - (cute port-hash (assoc-ref opts 'hash-algorithm) <>))) + (assq-ref opts 'verify-certificate?) + #:ref (assq-ref opts 'git-reference) + #:recursive? (assq-ref opts 'recursive?)))) + (hash (let* ((path* (or path + (leave (G_ "~a: download failed~%") + arg)))) + (file-hash* path* + #:algorithm (assoc-ref opts 'hash-algorithm)))) (fmt (assq-ref opts 'format))) (format #t "~a~%~a~%" path (fmt hash)) #t))) diff --git a/guix/scripts/git/authenticate.scm b/guix/scripts/git/authenticate.scm index 5f5d423f28..6ff5cee682 100644 --- a/guix/scripts/git/authenticate.scm +++ b/guix/scripts/git/authenticate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020, 2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +27,7 @@ #:use-module ((guix git) #:select (with-git-error-handling)) #:use-module (guix progress) #:use-module (guix base64) + #:autoload (rnrs bytevectors) (bytevector-length) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) @@ -133,6 +134,16 @@ Authenticate the given Git checkout using COMMIT/SIGNER as its introduction.\n") (define commit-short-id (compose (cut string-take <> 7) oid->string commit-id)) + (define (openpgp-fingerprint* str) + (unless (string-every (char-set-union char-set:hex-digit + char-set:whitespace) + str) + (leave (G_ "~a: invalid OpenPGP fingerprint~%") str)) + (let ((fingerprint (openpgp-fingerprint str))) + (unless (= 20 (bytevector-length fingerprint)) + (leave (G_ "~a: wrong length for OpenPGP fingerprint~%") str)) + fingerprint)) + (define (make-reporter start-commit end-commit commits) (format (current-error-port) (G_ "Authenticating commits ~a to ~a (~h new \ @@ -165,7 +176,7 @@ commits)...~%") (repository-cache-key repository)))) (define stats (authenticate-repository repository (string->oid commit) - (openpgp-fingerprint signer) + (openpgp-fingerprint* signer) #:end end #:keyring-reference keyring #:historical-authorizations history diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index d2a1cee56e..1f34cab088 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com> +;;; Copyright © 2024 Herman Rimm <herman@rimm.ee> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +24,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts import) + #:use-module (guix import utils) #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix read-print) @@ -65,10 +67,39 @@ Run IMPORTER with ARGS.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -i, --insert insert packages into file alphabetically")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) +(define (import-as-definitions importer args proc) + "Wrap package expressions from IMPORTER with 'define-public and invoke +PROC callback." + (if (member importer importers) + (match (apply (resolve-importer importer) args) + ((and expr (or ('package _ ...) + ('let _ ...))) + (proc (package->definition expr))) + ((and expr ('define-public _ ...)) + (proc expr)) + ((expressions ...) + (for-each (lambda (expr) + (match expr + ((and expr (or ('package _ ...) + ('let _ ...))) + (proc (package->definition expr))) + ((and expr ('define-public _ ...)) + (proc expr)))) + expressions)) + (x + (leave (G_ "'~a' import failed~%") importer))) + (let ((hint (string-closest importer importers #:threshold 3))) + (report-error (G_ "~a: invalid importer~%") importer) + (when hint + (display-hint (G_ "Did you mean @code{~a}?~%") hint)) + (exit 1)))) + (define-command (guix-import . args) (category packaging) (synopsis "import a package definition from an external repository") @@ -77,32 +108,33 @@ Run IMPORTER with ARGS.\n")) (() (format (current-error-port) (G_ "guix import: missing importer name~%"))) - ((or ("-h") ("--help")) + ((or ("-h" _ ...) ("--help" _ ...)) (leave-on-EPIPE (show-help)) (exit 0)) - ((or ("-V") ("--version")) + ((or ("-V" _ ...) ("--version" _ ...)) (show-version-and-exit "guix import")) + ((or ("-i" file importer args ...) + ("--insert" file importer args ...)) + (let ((find-and-insert + (lambda (expr) + (match expr + (('define-public term _ ...) + (let ((source-properties + (find-definition-insertion-location + file term))) + (if source-properties + (insert-expression source-properties expr) + (let ((port (open-file file "a"))) + (pretty-print-with-comments port expr) + (newline port) + (close-port port))))))))) + (import-as-definitions importer args find-and-insert))) ((importer args ...) - (if (member importer importers) - (let ((print (lambda (expr) - (leave-on-EPIPE - (pretty-print-with-comments (current-output-port) expr))))) - (match (apply (resolve-importer importer) args) - ((and expr (or ('package _ ...) - ('let _ ...) - ('define-public _ ...))) - (print expr)) - ((? list? expressions) - (for-each (lambda (expr) - (print expr) - ;; Two newlines: one after the closing paren, and - ;; one to leave a blank line. - (newline) (newline)) - expressions)) - (x - (leave (G_ "'~a' import failed~%") importer)))) - (let ((hint (string-closest importer importers #:threshold 3))) - (report-error (G_ "~a: invalid importer~%") importer) - (when hint - (display-hint (G_ "Did you mean @code{~a}?~%") hint)) - (exit 1)))))) + (let ((print (lambda (expr) + (leave-on-EPIPE + (pretty-print-with-comments + (current-output-port) expr) + ;; Two newlines: one after the closing paren, and + ;; one to leave a blank line. + (newline) (newline))))) + (import-as-definitions importer args print))))) diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 9aa0e61e9d..e7eb3b2a1f 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016-2018, 2020, 2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2018, 2020, 2023-2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -115,6 +115,8 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or (setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin") (git-fetch-with-fallback url commit output + #:hash hash + #:hash-algorithm algo #:recursive? recursive? #:git-command %git)))) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 2f8985593d..08a1b22a74 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> @@ -388,6 +388,8 @@ Report the availability of substitutes.\n")) -m, --manifest=MANIFEST look up substitutes for packages specified in MANIFEST")) (display (G_ " + -e, --expression=EXPR build the object EXPR evaluates to")) + (display (G_ " -c, --coverage[=COUNT] show substitute coverage for packages with at least COUNT dependents")) @@ -426,6 +428,9 @@ Report the availability of substitutes.\n")) (option '(#\m "manifest") #t #f (lambda (opt name arg result) (alist-cons 'manifest arg result))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) (option '(#\c "coverage") #f #t (lambda (opt name arg result) (alist-cons 'coverage @@ -611,6 +616,8 @@ SERVER. Display information for packages with at least THRESHOLD dependents." (base (filter-map (match-lambda (('argument . spec) (specification->package spec)) + (('expression . str) + (read/eval-package-expression str)) (_ #f)) opts))) diff --git a/guix/self.scm b/guix/self.scm index f378548959..19c6d08e01 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -65,6 +65,7 @@ ("guile-gnutls" . ,(ref 'tls 'guile-gnutls)) ("guix-daemon" . ,(ref 'package-management 'guix-daemon)) ("disarchive" . ,(ref 'backup 'disarchive)) + ("guile-bzip2" . ,(ref 'guile 'guile-bzip2)) ("guile-lzma" . ,(ref 'guile 'guile-lzma)) ("gzip" . ,(ref 'compression 'gzip)) ("bzip2" . ,(ref 'compression 'bzip2)) @@ -827,6 +828,9 @@ itself." (define disarchive (specification->package "disarchive")) + (define guile-bzip2 + (specification->package "guile-bzip2")) + (define guile-lzma (specification->package "guile-lzma")) @@ -1058,6 +1062,7 @@ itself." #:source source #:dependencies (cons* disarchive + guile-bzip2 guile-lzma dependencies) #:guile guile-for-build diff --git a/guix/swh.scm b/guix/swh.scm index c7c1c873a2..04cecd854c 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2021, 2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> @@ -78,6 +78,14 @@ lookup-revision lookup-origin-revision + external-id? + external-id-value + external-id-type + external-id-version + external-id-target + lookup-external-id + lookup-directory-by-nar-hash + content? content-checksums content-data-url @@ -115,6 +123,7 @@ commit-id? swh-download-directory + swh-download-directory-by-nar-hash swh-download)) ;;; Commentary: @@ -382,6 +391,15 @@ FALSE-IF-404? is true, return #f upon 404 responses." (permissions directory-entry-permissions "perms") (target-url directory-entry-target-url "target_url")) +;; <https://archive.softwareheritage.org/api/1/extid/doc/> +(define-json-mapping <external-id> make-external-id external-id? + json->external-id + (value external-id-value "extid") + (type external-id-type "extid_type") + (version external-id-version "extid_version") + (target external-id-target) + (target-url external-id-target-url "target_url")) + ;; <https://archive.softwareheritage.org/api/1/origin/save/> (define-json-mapping <save-reply> make-save-reply save-reply? json->save-reply @@ -428,7 +446,7 @@ FALSE-IF-404? is true, return #f upon 404 responses." json->revision) (define-query (lookup-directory id) - "Return the directory with the given ID." + "Return the list of entries of the directory with the given ID." (path "/api/1/directory" id) json->directory-entries) @@ -436,6 +454,24 @@ FALSE-IF-404? is true, return #f upon 404 responses." (map json->directory-entry (vector->list (json->scm port)))) +(define (lookup-external-id type id) + "Return the external ID record for ID, a bytevector, of the given TYPE +(currently one of: \"bzr-nodeid\", \"hg-nodeid\", \"nar-sha256\", +\"checksum-sha512\")." + (call (swh-url "/api/1/extid" type + (string-append "hex:" (bytevector->base16-string id))) + json->external-id)) + +(define* (lookup-directory-by-nar-hash hash #:optional (algorithm 'sha256)) + "Return the SWHID of a directory---i.e., prefixed by \"swh:1:dir\"---for the +directory that with the given HASH (a bytevector), assuming nar serialization +and use of ALGORITHM." + ;; example: + ;; https://archive.softwareheritage.org/api/1/extid/nar-sha256/base64url:0jD6Z4TLMm5g1CviuNNuVNP31KWyoT_oevfr8TQwc3Y/ + (and=> (lookup-external-id (string-append "nar-" (symbol->string algorithm)) + hash) + external-id-target)) + (define (origin-visits origin) "Return the list of visits of ORIGIN, a record as returned by 'lookup-origin'." @@ -583,6 +619,41 @@ directory identifier is deprecated." json->vault-reply http-post*)) +(define* (http-get/follow url + #:key + (verify-certificate? (%verify-swh-certificate?))) + "Like 'http-get' but follow redirects (HTTP 30x). On success, return two +values: an input port to read the response body and its 'Content-Length'. On +failure return #f and #f." + (define uri + (if (string? url) (string->uri url) url)) + + (let loop ((uri uri)) + (define (resolve-uri-reference target) + (if (and (uri-scheme target) (uri-host target)) + target + (build-uri (uri-scheme uri) #:host (uri-host uri) + #:port (uri-port uri) + #:path (uri-path target)))) + + (let*-values (((response port) + (http-get* uri #:streaming? #t + #:verify-certificate? verify-certificate?)) + ((code) + (response-code response))) + (case code + ((200) + (values port (response-content-length response))) + ((301 ; moved permanently + 302 ; found (redirection) + 303 ; see other + 307 ; temporary redirection + 308) ; permanent redirection + (close-port port) + (loop (resolve-uri-reference (response-location response)))) + (else + (values #f #f)))))) + (define* (vault-fetch id #:optional kind #:key @@ -604,16 +675,11 @@ for a tarball containing a bare Git repository corresponding to a revision." (match (vault-reply-status reply) ('done ;; Fetch the bundle. - (let-values (((response port) - (http-get* (swh-url (vault-reply-fetch-url reply)) - #:streaming? #t - #:verify-certificate? - (%verify-swh-certificate?)))) - (if (= (response-code response) 200) - port - (begin ;shouldn't happen - (close-port port) - #f)))) + (let-values (((port length) + (http-get/follow (swh-url (vault-reply-fetch-url reply)) + #:verify-certificate? + (%verify-swh-certificate?)))) + port)) ('failed ;; Upon failure, we're supposed to try again. (format log-port "SWH vault: failure: ~a~%" @@ -740,3 +806,26 @@ wait until it becomes available, which could take several minutes." "SWH: revision ~s originating from ~a could not be found~%" reference url) #f))) + +(define* (swh-download-directory-by-nar-hash hash algorithm output + #:key + (log-port (current-error-port))) + "Download from Software Heritage the directory with the given nar HASH for +ALGORITHM (a symbol such as 'sha256), and unpack it in OUTPUT. Return #t on +success and #f on failure. + +This procedure uses the \"vault\", which contains \"cooked\" directories in +the form of tarballs. If the requested directory is not cooked yet, it will +wait until it becomes available, which could take several minutes." + (match (lookup-directory-by-nar-hash hash algorithm) + (#f + (format log-port + "SWH: directory with nar-~a hash ~a not found~%" + algorithm (bytevector->base16-string hash)) + #f) + (swhid + (format log-port "SWH: found directory with nar-~a hash ~a at '~a'~%" + algorithm (bytevector->base16-string hash) swhid) + (swh-download-archive swhid output + #:archive-type 'flat ;SWHID denotes a directory + #:log-port log-port)))) diff --git a/guix/upstream.scm b/guix/upstream.scm index e28ae12f3f..180ae21dcf 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> -;;; Copyright © 2019, 2022, 2023 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019, 2022-2024 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -566,17 +566,21 @@ specified in SOURCE, an <upstream-source>." (properties (package-properties package)) (ignore (or (assoc-ref properties ignore-property) '())) (extra (or (assoc-ref properties extra-property) '()))) - (append (if (null? ignore) - inputs - (remove (lambda (input) - (member (upstream-input-downstream-name input) - ignore)) - inputs)) - (map (lambda (name) - (upstream-input - (name name) - (downstream-name name))) - extra))))) + (sort + (append (if (null? ignore) + inputs + (remove (lambda (input) + (member (upstream-input-downstream-name input) + ignore)) + inputs)) + (map (lambda (name) + (upstream-input + (name name) + (downstream-name name))) + extra)) + (lambda (a b) + (string-ci<? (upstream-input-downstream-name a) + (upstream-input-downstream-name b))))))) (define regular-inputs (filtered-inputs upstream-source-regular-inputs diff --git a/guix/utils.scm b/guix/utils.scm index e4e9d922e7..29ad09d9f7 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -20,6 +20,7 @@ ;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2023 Zheng Junjie <873216071@qq.com> ;;; Copyright © 2023 Foundation Devices, Inc. <hello@foundationdevices.com> +;;; Copyright © 2024 Herman Rimm <herman@rimm.ee> ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,6 +39,7 @@ (define-module (guix utils) #:use-module (guix config) + #:autoload (guix read-print) (object->string*) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -145,6 +147,8 @@ go-to-location edit-expression delete-expression + insert-expression + find-definition-insertion-location filtered-port decompressed-port @@ -502,6 +506,32 @@ the trailing line is included in the edited expression." "Delete the expression specified by SOURCE-PROPERTIES." (edit-expression source-properties (const "") #:include-trailing-newline? #t)) +(define (insert-expression source-properties expr) + "Insert EXPR before the top-level expression specified by +SOURCE-PROPERTIES." + (let* ((expr (object->string* expr 0)) + (insert (lambda (str) + (string-append expr "\n\n" str)))) + (edit-expression source-properties insert))) + +(define (find-definition-insertion-location file term) + "Search in FILE for a top-level public definition whose defined term +alphabetically succeeds TERM. Return the location if found, or #f +otherwise." + (let ((search-term (symbol->string term))) + (call-with-input-file file + (lambda (port) + (do ((syntax (read-syntax port) + (read-syntax port))) + ((match (syntax->datum syntax) + (('define-public current-term _ ...) + (string> (symbol->string current-term) + search-term)) + ((? eof-object?) #t) + (_ #f)) + (and (not (eof-object? syntax)) + (syntax-source syntax)))))))) + ;;; ;;; Keyword arguments. |