From 05e669ac50cd15db30c2bfc0681a4c2a24cf080d Mon Sep 17 00:00:00 2001 From: Nguyễn Gia Phong Date: Thu, 27 Nov 2025 17:46:50 +0900 Subject: guix: Implement fossil-download. * guix/fossil-download.scm: New file. * guix/build/fossil.scm: New file. * Makefile.am (MODULES): Add them. * etc/teams.scm (core)[#:scope]: Add "guix/fossil-download.scm". (vcs)[#:scope]: Add "guix/build/fossil.scm". * CODEOWNERS: Regenerate file. * doc/guix.texi (origin Reference): Document fossil-fetch and fossil-reference. * NEWS: Add entry about fossil-fetch. Change-Id: Ia252bcbbb417159a842d5092a937e2aad55a1656 Signed-off-by: Liliana Marie Prikler --- guix/build/fossil.scm | 59 ++++++++++++++++++++++ guix/fossil-download.scm | 125 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 184 insertions(+) create mode 100644 guix/build/fossil.scm create mode 100644 guix/fossil-download.scm (limited to 'guix') diff --git a/guix/build/fossil.scm b/guix/build/fossil.scm new file mode 100644 index 0000000000..a8c03e3eb8 --- /dev/null +++ b/guix/build/fossil.scm @@ -0,0 +1,59 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2025 Nguyễn Gia Phong +;;; +;;; 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 . +;;; +;;; Commentary: +;;; +;;; This is the build-side support code of (guix fossil-download). +;;; It allows a Fossil repository to be opened at a specific revision. +;;; +;;; Code: + +(define-module (guix build fossil) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (web uri) + #:export (fossil-fetch)) + +(define* (fossil-fetch uri check-in file #:key (fossil-command "fossil")) + "Fetch CHECK-IN from URI into DIRECTORY. CHECK-IN must be a valid +Fossil check-in name. Return #t on success, else raise an exception." + (setenv "FOSSIL_HOME" "/tmp") + (invoke fossil-command + "tarball" check-in file "-R" + (case (uri-scheme (string->uri-reference uri)) + ((file https) ;clone the repository first + (match-let ((repository (simple-format #f "/tmp/~a.fossil" + (basename file ".tar.gz"))) + ((input . output) (pipe))) + ;; Trust the TLS certificate of the server, + ;; since we'll later verify the tarball's checksum. + (display "y" output) + (close-port output) + (with-input-from-port input + (cut invoke fossil-command "clone" + "--no-open" "--once" uri repository)) + (close-port input) + repository)) + ((ssh) ;TODO: authentication for SSH + (let ((message (string-append "fetching a Fossil repository through SSH" + " is not supported: " uri))) + (raise (condition (&message (message message)))))) + ((#f) uri)))) ;local file diff --git a/guix/fossil-download.scm b/guix/fossil-download.scm new file mode 100644 index 0000000000..d371ee2d0d --- /dev/null +++ b/guix/fossil-download.scm @@ -0,0 +1,125 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2025 Nguyễn Gia Phong +;;; +;;; 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 . +;;; +;;; Commentary: +;;; +;;; An method that open Fossil checkout at a specific version. +;;; The repository URI and version are specified +;;; with a object. +;;; +;;; Code: + +(define-module (guix fossil-download) + #:use-module (guix build-system) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix records) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (web uri) + #:export (fossil-reference + fossil-reference? + fossil-reference-uri + fossil-reference-check-in + + fossil-fetch + fossil-version + fossil-file-name)) + +(define-record-type* + fossil-reference make-fossil-reference fossil-reference? + (uri fossil-reference-uri) + (check-in fossil-reference-check-in)) + +(define (fossil-version version revision check-in) + "Return the version string for packages using fossil-download." + ;; fossil-version is almost exclusively executed while modules + ;; are being loaded, leading to any errors hiding their backtrace. + ;; Avoid the mysterious error "Value out of range 0 to N: 10" + ;; when the check-in ID is too short, which can happen, for example, + ;; when the user swapped the revision and check-in arguments by mistake. + (when (< (string-length check-in) 10) + (raise + (condition + (&message (message "fossil-version: check-in ID unexpectedly short"))))) + (string-append version "-" revision "." (string-take check-in 10))) + +(define (fossil-file-name name version) + "Return the file-name for packages using fossil-download." + (string-append name "-" version ".tar.gz")) + +(define* (fossil-fetch ref hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile)) + (fossil (@* (gnu packages version-control) + fossil))) + "Return a fixed-output derivation that fetches REF, a +object. The output is expected to have recursive hash HASH of type +HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." + (let* ((modules (source-module-closure '((guix build fossil) + (guix build download) + (guix build download-nar)))) + (uri (fossil-reference-uri ref)) + (scheme-of-uri (uri-scheme (string->uri-reference uri))) + (check-in (fossil-reference-check-in ref)) + (tarball-name (or name (fossil-file-name (basename uri) check-in))) + (tarball-url (and (eq? 'https scheme-of-uri) + (simple-format #f "~a/tarball/~a/~a" + uri check-in tarball-name))) + (guile-json (@* (gnu packages guile) guile-json-4)) + (gnutls (@* (gnu packages tls) guile-gnutls)) + (guile-lzlib (@* (gnu packages guile) guile-lzlib)) + (build + (with-imported-modules modules + (with-extensions (list guile-json gnutls ;for (guix swh) + guile-lzlib) + #~(begin + (use-modules (guix build fossil) + ((guix build download) + #:select (download-method-enabled? url-fetch)) + (guix build download-nar)) + (or (and (download-method-enabled? 'upstream) + (or (and #$tarball-url + (url-fetch #$tarball-url #$output)) + (fossil-fetch + #$(if scheme-of-uri uri (local-file uri)) + #$check-in + #$output + #:fossil-command + #+(file-append fossil "/bin/fossil")))) + (and (download-method-enabled? 'nar) + (download-nar #$output)))))))) + (mlet %store-monad ((guile (package->derivation guile system))) + (gexp->derivation tarball-name build + #:leaked-env-vars '("http_proxy" "https_proxy" + "COLUMNS" "USER") + #:env-vars (match (getenv "GUIX_DOWNLOAD_METHODS") + (#f '()) + (value + `(("GUIX_DOWNLOAD_METHODS" . ,value)))) + #:system system + #:hash-algo hash-algo + #:hash hash + #:recursive? #t + #:guile-for-build guile + #:local-build? #t)))) -- cgit v1.3