guix/git-download.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
   4 ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
   5 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (guix git-download)
  23   #:use-module (guix gexp)
  24   #:use-module (guix store)
  25   #:use-module (guix monads)
  26   #:use-module (guix records)
  27   #:use-module (guix packages)
  28   #:use-module (guix modules)
  29   #:autoload   (guix build-system gnu) (standard-packages)
  30   #:autoload   (git bindings)   (libgit2-init!)
  31   #:autoload   (git repository) (repository-open
  32                                  repository-close!
  33                                  repository-discover
  34                                  repository-head
  35                                  repository-working-directory)
  36   #:autoload   (git commit)     (commit-lookup commit-tree)
  37   #:autoload   (git reference)  (reference-target)
  38   #:autoload   (git tree)       (tree-list)
  39   #:use-module (ice-9 match)
  40   #:use-module (ice-9 vlist)
  41   #:use-module (srfi srfi-1)
  42   #:use-module (srfi srfi-34)
  43   #:use-module (srfi srfi-35)
  44   #:export (git-reference
  45             git-reference?
  46             git-reference-url
  47             git-reference-commit
  48             git-reference-recursive?
  49
  50             git-fetch
  51             git-version
  52             git-file-name
  53             git-predicate))
  54
  55 ;;; Commentary:
  56 ;;;
  57 ;;; An <origin> method that fetches a specific commit from a Git repository.
  58 ;;; The repository URL and commit hash are specified with a <git-reference>
  59 ;;; object.
  60 ;;;
  61 ;;; Code:
  62
  63 (define-record-type* <git-reference>
  64   git-reference make-git-reference
  65   git-reference?
  66   (url        git-reference-url)
  67   (commit     git-reference-commit)
  68   (recursive? git-reference-recursive?   ; whether to recurse into sub-modules
  69               (default #f)))
  70
  71 (define (git-package)
  72   "Return the default Git package."
  73   (let ((distro (resolve-interface '(gnu packages version-control))))
  74     (module-ref distro 'git-minimal)))
  75
  76 (define* (git-fetch ref hash-algo hash
  77                     #:optional name
  78                     #:key (system (%current-system)) (guile (default-guile))
  79                     (git (git-package)))
  80   "Return a fixed-output derivation that fetches REF, a <git-reference>
  81 object.  The output is expected to have recursive hash HASH of type
  82 HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
  83   (define inputs
  84     ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
  85     ;; available so that 'git submodule' works.
  86     (if (git-reference-recursive? ref)
  87         (standard-packages)
  88
  89         ;; The 'swh-download' procedure requires tar and gzip.
  90         `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression))
  91                                'gzip))
  92           ("tar" ,(module-ref (resolve-interface '(gnu packages base))
  93                               'tar)))))
  94
  95   (define guile-json
  96     (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
  97
  98   (define guile-zlib
  99     (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
 100
 101   (define gnutls
 102     (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
 103
 104   (define modules
 105     (delete '(guix config)
 106             (source-module-closure '((guix build git)
 107                                      (guix build utils)
 108                                      (guix build download-nar)
 109                                      (guix swh)))))
 110
 111   (define build
 112     (with-imported-modules modules
 113       (with-extensions (list guile-json gnutls   ;for (guix swh)
 114                              guile-zlib)
 115         #~(begin
 116             (use-modules (guix build git)
 117                          (guix build utils)
 118                          (guix build download-nar)
 119                          (guix swh)
 120                          (ice-9 match))
 121
 122             (define recursive?
 123               (call-with-input-string (getenv "git recursive?") read))
 124
 125             ;; The 'git submodule' commands expects Coreutils, sed,
 126             ;; grep, etc. to be in $PATH.
 127             (set-path-environment-variable "PATH" '("bin")
 128                                            (match '#+inputs
 129                                              (((names dirs outputs ...) ...)
 130                                               dirs)))
 131
 132             (setvbuf (current-output-port) 'line)
 133             (setvbuf (current-error-port) 'line)
 134
 135             (or (git-fetch (getenv "git url") (getenv "git commit")
 136                            #$output
 137                            #:recursive? recursive?
 138                            #:git-command (string-append #+git "/bin/git"))
 139                 (download-nar #$output)
 140
 141                 ;; As a last resort, attempt to download from Software Heritage.
 142                 ;; Disable X.509 certificate verification to avoid depending
 143                 ;; on nss-certs--we're authenticating the checkout anyway.
 144                 ;; XXX: Currently recursive checkouts are not supported.
 145                 (and (not recursive?)
 146                      (parameterize ((%verify-swh-certificate? #f))
 147                        (format (current-error-port)
 148                                "Trying to download from Software Heritage...~%")
 149                        (swh-download (getenv "git url") (getenv "git commit")
 150                                      #$output))))))))
 151
 152   (mlet %store-monad ((guile (package->derivation guile system)))
 153     (gexp->derivation (or name "git-checkout") build
 154
 155                       ;; Use environment variables and a fixed script name so
 156                       ;; there's only one script in store for all the
 157                       ;; downloads.
 158                       #:script-name "git-download"
 159                       #:env-vars
 160                       `(("git url" . ,(git-reference-url ref))
 161                         ("git commit" . ,(git-reference-commit ref))
 162                         ("git recursive?" . ,(object->string
 163                                               (git-reference-recursive? ref))))
 164                       #:leaked-env-vars '("http_proxy" "https_proxy"
 165                                           "LC_ALL" "LC_MESSAGES" "LANG"
 166                                           "COLUMNS")
 167
 168                       #:system system
 169                       #:local-build? #t           ;don't offload repo cloning
 170                       #:hash-algo hash-algo
 171                       #:hash hash
 172                       #:recursive? #t
 173                       #:guile-for-build guile)))
 174
 175 (define (git-version version revision commit)
 176   "Return the version string for packages using git-download."
 177   ;; git-version is almost exclusively executed while modules are being loaded.
 178   ;; This makes any errors hide their backtrace. Avoid the mysterious error
 179   ;; "Value out of range 0 to N: 7" when the commit ID is too short, which
 180   ;; can happen, for example, when the user swapped the revision and commit
 181   ;; arguments by mistake.
 182   (when (< (string-length commit) 7)
 183     (raise
 184       (condition
 185         (&message (message "git-version: commit ID unexpectedly short")))))
 186   (string-append version "-" revision "." (string-take commit 7)))
 187
 188 (define (git-file-name name version)
 189   "Return the file-name for packages using git-download."
 190   (string-append name "-" version "-checkout"))
 191
 192 \f
 193 ;;;
 194 ;;; 'git-predicate'.
 195 ;;;
 196
 197 (define (git-file-list directory)
 198   "Return the list of files checked in in the Git repository at DIRECTORY.
 199 The result is similar to that of the 'git ls-files' command, except that it
 200 also includes directories, not just regular files.  The returned file names
 201 are relative to DIRECTORY, which is not necessarily the root of the checkout."
 202   (let* (;; 'repository-working-directory' always returns a trailing "/",
 203          ;; so add one here to ease the comparisons below.
 204          (directory  (string-append (canonicalize-path directory) "/"))
 205          (dot-git    (repository-discover directory))
 206          (repository (repository-open dot-git))
 207          (workdir    (repository-working-directory repository))
 208          (head       (repository-head repository))
 209          (oid        (reference-target head))
 210          (commit     (commit-lookup repository oid))
 211          (tree       (commit-tree commit))
 212          (files      (tree-list tree)))
 213     (repository-close! repository)
 214     (if (string=? workdir directory)
 215         files
 216         (let ((relative (string-drop directory (string-length workdir))))
 217           (filter-map (lambda (file)
 218                         (and (string-prefix? relative file)
 219                              (string-drop file (string-length relative))))
 220                       files)))))
 221
 222 (define (git-predicate directory)
 223   "Return a predicate that returns true if a file is part of the Git checkout
 224 living at DIRECTORY.  If DIRECTORY does not lie within a Git checkout, and
 225 upon Git errors, return #f instead of a predicate.
 226
 227 The returned predicate takes two arguments FILE and STAT where FILE is an
 228 absolute file name and STAT is the result of 'lstat'."
 229   (libgit2-init!)
 230   (catch 'git-error
 231     (lambda ()
 232       (let* ((files  (git-file-list directory))
 233              (inodes (fold (lambda (file result)
 234                              (let ((stat
 235                                     (lstat (string-append directory "/"
 236                                                           file))))
 237                                (vhash-consv (stat:ino stat) (stat:dev stat)
 238                                             result)))
 239                            vlist-null
 240                            files)))
 241         (lambda (file stat)
 242           ;; Comparing file names is always tricky business so we rely on inode
 243           ;; numbers instead.
 244           (match (vhash-assv (stat:ino stat) inodes)
 245             ((_ . dev) (= dev (stat:dev stat)))
 246             (#f        #f)))))
 247     (const #f)))
 248
 249 ;;; git-download.scm ends here