diff o
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2022, 2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 (test-cpio)
#:use-module (guix cpio)
#:use-module (guix tests)
#:use-module ((guix build utils)
#:select (which call-with-temporary-output-file))
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64))
(define %cpio-program
(which "cpio"))
(define %test-file
(search-path %load-path "guix.scm"))
(test-begin "cpio")
;; The cpio format expects 'ino' to fit in 32 bits. If we have a bigger inode
;; number, skip this test.
(test-skip
(if (>= (stat:ino (lstat %test-file)) (expt 2 32)) 1 0))
(test-assert "file->cpio-header + write-cpio-header + read-cpio-header"
(let* ((header (file->cpio-header %test-file)))
(call-with-values
(lambda ()
(open-bytevector-output-port))
(lambda (port get-bv)
(write-cpio-header header port)
(let ((port (open-bytevector-input-port (get-bv))))
(equal? header (read-cpio-header port)))))))
(unless %cpio-program (test-skip 1))
(test-assert "bit-identical to GNU cpio's output"
(call-with-temporary-output-file
(lambda (link _)
(delete-file link)
(symlink "chbouib" link)
(let ((files (cons* "/"
(canonicalize-path
(dirname (search-path %load-path "guix.scm")))
link
(map (compose canonicalize-path
(cut s
index e956e08470..2d4bf74951 100644
--- a/guix/download.scm
+++ b/guix/download.scm@@ -242,20 +242,25 @@ must be a list of symbol/URL-list pairs."
(url-fetch '#$url #$output
#:mirrors '#$mirrors)))
- (run-with-store store
- (gexp->derivation (or name file-name) builder
- #:system system
- #:hash-algo hash-algo
- #:hash hash
- #:modules '((guix build download)
- (guix build utils)
- (guix ftp-client))
- #:guile-for-build guile-for-build
+ (let ((uri (and (string? url) (string->uri url))))
+ (if (or (and (string? url) (not uri))
+ (and uri (memq (uri-scheme uri) '(#f file))))
+ (add-to-store store (or name file-name)
+ #f "sha256" (if uri (uri-path uri) url))
+ (run-with-store store
+ (gexp->derivation (or name file-name) builder
+ #:system system
+ #:hash-algo hash-algo
+ #:hash hash
+ #:modules '((guix build download)
+ (guix build utils)
+ (guix ftp-client))
+ #:guile-for-build guile-for-build
- ;; In general, offloading downloads is not a good idea.
- #:local-build? #t)
- #:guile-for-build guile-for-build
- #:system system))
+ ;; In general, offloading downloads is not a good idea.
+ #:local-build? #t)
+ #:guile-for-build guile-for-build
+ #:system system))))
(define* (download-to-store store url #:optional (name (basename url))
#:key (log (current-error-port)))
diff --git a/tests/builders.scm b/tests/builders.scm
index ce1f3852d7..a2f500a94d 100644
--- a/tests/builders.scm
+++ b/tests/builders.scm
index ce1f3852d7..a2f500a94d 100644
--- a/tests/builders.scm
+++ b/tests/builders.scm
@@ -25,6 +25,7 @@
#:use-module (guix utils)
#:use-module (guix base32)
#:use-module (guix derivations)
+ #:use-module (guix hash)
#:use-module (guix tests)
#:use-module ((guix packages)
#:select (package-derivation package-native-search-paths))
@@ -74,6 +75,22 @@
(file-exists? out-path)
(valid-path? %store out-path))))
+(test-assert "url-fetch, file"
+ (let* ((file (search-path %load-path "guix.scm"))
+ (hash (call-with-input-file file port-sha256))
+ (out (url-fetch %store file 'sha256 hash)))
+ (and (file-exists? out)
+ (valid-path? %store out))))
+
+(test-assert "url-fetch, file URI"
+ (let* ((file (search-path %load-path "guix.scm"))
+ (hash (call-with-input-file file port-sha256))
+ (out (url-fetch %store
+ (string-append "file://" (canonicalize-path file))
+ 'sha256 hash)))
+ (and (file-exists? out)
+ (valid-path? %store out))))
+
(test-assert "gnu-build-system"
(and (build-system? gnu-build-system)
(eq? gnu-build (build-system-builder gnu-build-system))))