gnu: esbuild: Update to 0.11.14.
[jackhill/guix/guix.git] / guix / git-download.scm
index 6cf267d..199effe 100644 (file)
@@ -1,7 +1,8 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
   #:use-module (guix packages)
   #:use-module (guix modules)
   #:autoload   (guix build-system gnu) (standard-packages)
-  #:use-module (git)
+  #:autoload   (git bindings)   (libgit2-init!)
+  #:autoload   (git repository) (repository-open
+                                 repository-close!
+                                 repository-discover
+                                 repository-head
+                                 repository-working-directory)
+  #:autoload   (git commit)     (commit-lookup commit-tree)
+  #:autoload   (git reference)  (reference-target)
+  #:autoload   (git tree)       (tree-list)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:export (git-reference
             git-reference?
             git-reference-url
@@ -81,35 +92,26 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
           ("tar" ,(module-ref (resolve-interface '(gnu packages base))
                               'tar)))))
 
-  (define zlib
-    (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
-
   (define guile-json
-    (module-ref (resolve-interface '(gnu packages guile)) 'guile-json))
+    (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
+
+  (define guile-zlib
+    (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
 
   (define gnutls
     (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
 
-  (define config.scm
-    (scheme-file "config.scm"
-                 #~(begin
-                     (define-module (guix config)
-                       #:export (%libz))
-
-                     (define %libz
-                       #+(file-append zlib "/lib/libz")))))
-
   (define modules
-    (cons `((guix config) => ,config.scm)
-          (delete '(guix config)
-                  (source-module-closure '((guix build git)
-                                           (guix build utils)
-                                           (guix build download-nar)
-                                           (guix swh))))))
+    (delete '(guix config)
+            (source-module-closure '((guix build git)
+                                     (guix build utils)
+                                     (guix build download-nar)
+                                     (guix swh)))))
 
   (define build
     (with-imported-modules modules
-      (with-extensions (list guile-json gnutls)   ;for (guix swh)
+      (with-extensions (list guile-json gnutls   ;for (guix swh)
+                             guile-zlib)
         #~(begin
             (use-modules (guix build git)
                          (guix build utils)
@@ -137,10 +139,15 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
                 (download-nar #$output)
 
                 ;; As a last resort, attempt to download from Software Heritage.
+                ;; Disable X.509 certificate verification to avoid depending
+                ;; on nss-certs--we're authenticating the checkout anyway.
                 ;; XXX: Currently recursive checkouts are not supported.
                 (and (not recursive?)
-                     (swh-download (getenv "git url") (getenv "git commit")
-                                   #$output)))))))
+                     (parameterize ((%verify-swh-certificate? #f))
+                       (format (current-error-port)
+                               "Trying to download from Software Heritage...~%")
+                       (swh-download (getenv "git url") (getenv "git commit")
+                                     #$output))))))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "git-checkout") build
@@ -154,6 +161,9 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
                         ("git commit" . ,(git-reference-commit ref))
                         ("git recursive?" . ,(object->string
                                               (git-reference-recursive? ref))))
+                      #:leaked-env-vars '("http_proxy" "https_proxy"
+                                          "LC_ALL" "LC_MESSAGES" "LANG"
+                                          "COLUMNS")
 
                       #:system system
                       #:local-build? #t           ;don't offload repo cloning
@@ -164,6 +174,15 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
 
 (define (git-version version revision commit)
   "Return the version string for packages using git-download."
+  ;; git-version is almost exclusively executed while modules are being loaded.
+  ;; This makes any errors hide their backtrace. Avoid the mysterious error
+  ;; "Value out of range 0 to N: 7" when the commit ID is too short, which
+  ;; can happen, for example, when the user swapped the revision and commit
+  ;; arguments by mistake.
+  (when (< (string-length commit) 7)
+    (raise
+      (condition
+        (&message (message "git-version: commit ID unexpectedly short")))))
   (string-append version "-" revision "." (string-take commit 7)))
 
 (define (git-file-name name version)
@@ -185,9 +204,7 @@ are relative to DIRECTORY, which is not necessarily the root of the checkout."
          (directory  (string-append (canonicalize-path directory) "/"))
          (dot-git    (repository-discover directory))
          (repository (repository-open dot-git))
-         ;; XXX: This procedure is mistakenly private in Guile-Git 0.1.0.
-         (workdir    ((@@ (git repository) repository-working-directory)
-                      repository))
+         (workdir    (repository-working-directory repository))
          (head       (repository-head repository))
          (oid        (reference-target head))
          (commit     (commit-lookup repository oid))
@@ -209,6 +226,7 @@ upon Git errors, return #f instead of a predicate.
 
 The returned predicate takes two arguments FILE and STAT where FILE is an
 absolute file name and STAT is the result of 'lstat'."
+  (libgit2-init!)
   (catch 'git-error
     (lambda ()
       (let* ((files  (git-file-list directory))