From 882383a9aa5fbeef6f29d359a786a6db7c9e03db Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 3 Oct 2014 11:02:11 +0200
Subject: [PATCH] download: Allow raw file names or file:// URLs.

* guix/download.scm (url-fetch): When URL is a string, if it's not a URI
  or if it's a URI with 'file' or #f scheme, use 'add-to-store'.
* tests/builders.scm ("url-fetch, file", "url-fetch, file URI"): New
  tests.
---
 guix/download.scm  | 31 ++++++++++++++++++-------------
 tests/builders.scm | 17 +++++++++++++++++
 2 files changed, 35 insertions(+), 13 deletions(-)

diff --git a/guix/download.scm b/guix/download.scm
index e956e08470..2d4bf74951 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -242,20 +242,25 @@ (define builder
         (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
@@ -25,6 +25,7 @@ (define-module (test-builders)
   #: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 @@ (define network-reachable?
          (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))))