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 <liliana.prikler@gmail.com>

7 files changed, 239 insertions, 0 deletions

diff --git a/CODEOWNERS b/CODEOWNERS
index 2daec3630cc..1b7dc17d1f5 100644
--- a/CODEOWNERS
+++ b/CODEOWNERS
@@ -68,6 +68,7 @@ guix/discovery\.scm                                @guix/core
 guix/docker\.scm                                   @guix/core
 guix/download\.scm                                 @guix/core
 guix/elf\.scm                                      @guix/core
+guix/fossil-download\.scm                          @guix/core
 guix/ftp-client\.scm                               @guix/core
 guix/gexp\.scm                                     @guix/core
 guix/git-authenticate\.scm                         @guix/core
@@ -484,6 +485,7 @@ gnu/services/version-control\.scm                  @guix/vcs
 gnu/tests/version-control\.scm                     @guix/vcs
 guix/build/bzr\.scm                                @guix/vcs
 guix/build/cvs\.scm                                @guix/vcs
+guix/build/fossil\.scm                             @guix/vcs
 guix/build/git\.scm                                @guix/vcs
 guix/build/hg\.scm                                 @guix/vcs
 guix/build/svn\.scm                                @guix/vcs
diff --git a/Makefile.am b/Makefile.am
index 976c5cad742..7fd6cf892f3 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -104,6 +104,7 @@ MODULES =					\
   guix/discovery.scm                            \
   guix/android-repo-download.scm                \
   guix/bzr-download.scm                         \
+  guix/fossil-download.scm                      \
   guix/git-download.scm                         \
   guix/hg-download.scm                          \
   guix/hash.scm                                 \
@@ -236,6 +237,7 @@ MODULES =					\
   guix/build/asdf-build-system.scm              \
   guix/build/bzr.scm                            \
   guix/build/copy-build-system.scm              \
+  guix/build/fossil.scm                         \
   guix/build/git.scm                            \
   guix/build/hg.scm                             \
   guix/build/glib-or-gtk-build-system.scm       \
diff --git a/NEWS b/NEWS
index 6fd51b38fa4..4d95880c575 100644
--- a/NEWS
+++ b/NEWS
@@ -20,6 +20,9 @@ Please send Guix bug reports to bug-guix@gnu.org.
 *** New service for Fossil SCM
 *** TeX Live updated to 2026.1
 
+** Programming interfaces
+*** New (guix fossil-download) module, for fetching Fossil repositories
+
 * Changes in 1.5.0 (since 1.4.0)
 ** Package management
 *** New ‘rpm’ format for the ‘guix pack’ command
diff --git a/doc/guix.texi b/doc/guix.texi
index 198ecb3413b..aaee903d95a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -8737,6 +8737,52 @@ The example below denotes a version of gnu-standards to fetch:
 
 @end deftp
 
+For Fossil repositories, the module @code{(guix fossil-download)} defines
+the @code{fossil-fetch} origin method and @code{fossil-reference} data type
+for support of the Fossil @abbr{SCM, software configuration management} system.
+
+@deffn {Procedure} fossil-fetch ref hash-algo hash [name]
+Return a fixed-output derivation that fetches @var{ref}, a
+@code{<fossil-reference>} object.  The output is expected to have recursive
+hash @var{hash} of type @var{hash-algo} (a symbol).  Use @var{name} as
+the file name, or a generic name if @code{#f}.
+@end deffn
+
+@deftp {Data Type} fossil-reference
+This data type represents a Fossil reference
+for @code{fossil-fetch} to retrieve.
+
+@table @asis
+@item @code{uri} (type: string)
+The URI of a Fossil repository to clone, in one of the following forms,
+in which @code{[...]} denotes optional elements:
+
+@table @code
+@item http[s]://[userid[:password]@@]host[:port][/path]
+A HTTP/HTTPS URL.
+@item [file://]path/to/repo.fossil
+A file URI, where the path must have an extra leading @code{/}
+to use an absolute path (without the URI scheme, the repository
+is opened directly without cloning).
+@end table
+
+@item @code{check-in} (type: string)
+A @url{https://fossil-scm.org/home/doc/trunk/www/checkin_names.wiki,
+name of the check-in} to fetch, e.g.@: its canonical hexadecimal identifier,
+associated tag and/or timestamp.
+@end table
+
+The example below denotes the @code{version-3.51.1} tag
+of the SQLite repository:
+
+@lisp
+(fossil-reference
+ (uri "https://sqlite.org/src")
+ (check-in "version-3.51.1"))
+@end lisp
+
+@end deftp
+
 @node Defining Package Variants
 @section Defining Package Variants
 
diff --git a/etc/teams.scm b/etc/teams.scm
index c26a0c11f83..1e179f445df 100755
--- a/etc/teams.scm
+++ b/etc/teams.scm
@@ -565,6 +565,7 @@ challenges"))
               "guix/docker.scm"
               "guix/download.scm"
               "guix/elf.scm"
+              "guix/fossil-download.scm"
               "guix/ftp-client.scm"
               "guix/gexp.scm"
               "guix/git-authenticate.scm"
@@ -1214,6 +1215,7 @@ the \"texlive\" importer."
                       "gnu/tests/version-control.scm"
                       "guix/build/bzr.scm"
                       "guix/build/cvs.scm"
+                      "guix/build/fossil.scm"
                       "guix/build/git.scm"
                       "guix/build/hg.scm"
                       "guix/build/svn.scm")))
diff --git a/guix/build/fossil.scm b/guix/build/fossil.scm
new file mode 100644
index 00000000000..a8c03e3eb80
--- /dev/null
+++ b/guix/build/fossil.scm
@@ -0,0 +1,59 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2025 Nguyễn Gia Phong <cnx@loang.net>
+;;;
+;;; 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/>.
+;;;
+;;; 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 00000000000..d371ee2d0db
--- /dev/null
+++ b/guix/fossil-download.scm
@@ -0,0 +1,125 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2025 Nguyễn Gia Phong <cnx@loang.net>
+;;;
+;;; 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/>.
+;;;
+;;; Commentary:
+;;;
+;;; An <origin> method that open Fossil checkout at a specific version.
+;;; The repository URI and version are specified
+;;; with a <fossil-reference> 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>
+  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 <fossil-reference>
+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))))