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 submodule)  (repository-submodules
  37                                  submodule-lookup
  38                                  submodule-path)
  39   #:autoload   (git commit)     (commit-lookup commit-tree)
  40   #:autoload   (git reference)  (reference-target)
  41   #:autoload   (git tree)       (tree-list)
  42   #:use-module (ice-9 match)
  43   #:use-module (ice-9 vlist)
  44   #:use-module (srfi srfi-1)
  45   #:use-module (srfi srfi-34)
  46   #:use-module (srfi srfi-35)
  47   #:export (git-reference
  48             git-reference?
  49             git-reference-url
  50             git-reference-commit
  51             git-reference-recursive?
  52
  53             git-fetch
  54             git-version
  55             git-file-name
  56             git-predicate))
  57
  58 ;;; Commentary:
  59 ;;;
  60 ;;; An <origin> method that fetches a specific commit from a Git repository.
  61 ;;; The repository URL and commit hash are specified with a <git-reference>
  62 ;;; object.
  63 ;;;
  64 ;;; Code:
  65
  66 (define-record-type* <git-reference>
  67   git-reference make-git-reference
  68   git-reference?
  69   (url        git-reference-url)
  70   (commit     git-reference-commit)
  71   (recursive? git-reference-recursive?   ; whether to recurse into sub-modules
  72               (default #f)))
  73
  74 (define (git-package)
  75   "Return the default Git package."
  76   (let ((distro (resolve-interface '(gnu packages version-control))))
  77     (module-ref distro 'git-minimal)))
  78
  79 (define* (git-fetch ref hash-algo hash
  80                     #:optional name
  81                     #:key (system (%current-system)) (guile (default-guile))
  82                     (git (git-package)))
  83   "Return a fixed-output derivation that fetches REF, a <git-reference>
  84 object.  The output is expected to have recursive hash HASH of type
  85 HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
  86   (define inputs
  87     ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
  88     ;; available so that 'git submodule' works.
  89     (if (git-reference-recursive? ref)
  90         (standard-packages)
  91
  92         ;; The 'swh-download' procedure requires tar and gzip.
  93         `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression))
  94                                'gzip))
  95           ("tar" ,(module-ref (resolve-interface '(gnu packages base))
  96                               'tar)))))
  97
  98   (define guile-json
  99     (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
 100
 101   (define guile-zlib
 102     (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
 103
 104   (define gnutls
 105     (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
 106
 107   (define modules
 108     (delete '(guix config)
 109             (source-module-closure '((guix build git)
 110                                      (guix build utils)
 111                                      (guix build download-nar)
 112                                      (guix swh)))))
 113
 114   (define build
 115     (with-imported-modules modules
 116       (with-extensions (list guile-json gnutls   ;for (guix swh)
 117                              guile-zlib)
 118         #~(begin
 119             (use-modules (guix build git)
 120                          (guix build utils)
 121                          (guix build download-nar)
 122                          (guix swh)
 123                          (ice-9 match))
 124
 125             (define recursive?
 126               (call-with-input-string (getenv "git recursive?") read))
 127
 128             ;; The 'git submodule' commands expects Coreutils, sed,
 129             ;; grep, etc. to be in $PATH.
 130             (set-path-environment-variable "PATH" '("bin")
 131                                            (match '#+inputs
 132                                              (((names dirs outputs ...) ...)
 133                                               dirs)))
 134
 135             (setvbuf (current-output-port) 'line)
 136             (setvbuf (current-error-port) 'line)
 137
 138             (or (git-fetch (getenv "git url") (getenv "git commit")
 139                            #$output
 140                            #:recursive? recursive?
 141                            #:git-command (string-append #+git "/bin/git"))
 142                 (download-nar #$output)
 143
 144                 ;; As a last resort, attempt to download from Software Heritage.
 145                 ;; Disable X.509 certificate verification to avoid depending
 146                 ;; on nss-certs--we're authenticating the checkout anyway.
 147                 ;; XXX: Currently recursive checkouts are not supported.
 148                 (and (not recursive?)
 149                      (parameterize ((%verify-swh-certificate? #f))
 150                        (format (current-error-port)
 151                                "Trying to download from Software Heritage...~%")
 152                        (swh-download (getenv "git url") (getenv "git commit")
 153                                      #$output))))))))
 154
 155   (mlet %store-monad ((guile (package->derivation guile system)))
 156     (gexp->derivation (or name "git-checkout") build
 157
 158                       ;; Use environment variables and a fixed script name so
 159                       ;; there's only one script in store for all the
 160                       ;; downloads.
 161                       #:script-name "git-download"
 162                       #:env-vars
 163                       `(("git url" . ,(git-reference-url ref))
 164                         ("git commit" . ,(git-reference-commit ref))
 165                         ("git recursive?" . ,(object->string
 166                                               (git-reference-recursive? ref))))
 167                       #:leaked-env-vars '("http_proxy" "https_proxy"
 168                                           "LC_ALL" "LC_MESSAGES" "LANG"
 169                                           "COLUMNS")
 170
 171                       #:system system
 172                       #:local-build? #t           ;don't offload repo cloning
 173                       #:hash-algo hash-algo
 174                       #:hash hash
 175                       #:recursive? #t
 176                       #:guile-for-build guile)))
 177
 178 (define (git-version version revision commit)
 179   "Return the version string for packages using git-download."
 180   ;; git-version is almost exclusively executed while modules are being loaded.
 181   ;; This makes any errors hide their backtrace. Avoid the mysterious error
 182   ;; "Value out of range 0 to N: 7" when the commit ID is too short, which
 183   ;; can happen, for example, when the user swapped the revision and commit
 184   ;; arguments by mistake.
 185   (when (< (string-length commit) 7)
 186     (raise
 187       (condition
 188         (&message (message "git-version: commit ID unexpectedly short")))))
 189   (string-append version "-" revision "." (string-take commit 7)))
 190
 191 (define (git-file-name name version)
 192   "Return the file-name for packages using git-download."
 193   (string-append name "-" version "-checkout"))
 194
 195 \f
 196 ;;;
 197 ;;; 'git-predicate'.
 198 ;;;
 199
 200 (define* (git-file-list directory #:optional prefix #:key (recursive? #t))
 201   "Return the list of files checked in in the Git repository at DIRECTORY.
 202 The result is similar to that of the 'git ls-files' command, except that it
 203 also includes directories, not just regular files.
 204
 205 When RECURSIVE? is true, also list files in submodules, similar to the 'git
 206 ls-files --recurse-submodules' command.  This is enabled by default.
 207
 208 The returned file names are relative to DIRECTORY, which is not necessarily
 209 the root of the checkout.  If a PREFIX is provided, it is prepended to each
 210 file name."
 211   (let* (;; 'repository-working-directory' always returns a trailing "/",
 212          ;; so add one here to ease the comparisons below.
 213          (directory  (string-append (canonicalize-path directory) "/"))
 214          (dot-git    (repository-discover directory))
 215          (repository (repository-open dot-git))
 216          (workdir    (repository-working-directory repository))
 217          (head       (repository-head repository))
 218          (oid        (reference-target head))
 219          (commit     (commit-lookup repository oid))
 220          (tree       (commit-tree commit))
 221          (files      (tree-list tree))
 222          (submodules (if recursive?
 223                          (map (lambda (name)
 224                                 (submodule-path
 225                                  (submodule-lookup repository name)))
 226                               (repository-submodules repository))
 227                          '()))
 228          (relative      (and (not (string=? workdir directory))
 229                              (string-drop directory (string-length workdir))))
 230          (included?     (lambda (path)
 231                           (or (not relative)
 232                               (string-prefix? relative path))))
 233          (make-relative (lambda (path)
 234                           (if relative
 235                               (string-drop path (string-length relative))
 236                               path)))
 237          (add-prefix    (lambda (path)
 238                           (if prefix
 239                               (string-append prefix "/" path)
 240                               path)))
 241          (rectify       (compose add-prefix make-relative)))
 242     (repository-close! repository)
 243     (append
 244      (if (or relative prefix)
 245          (filter-map (lambda (file)
 246                        (and (included? file)
 247                             (rectify file)))
 248                      files)
 249          files)
 250      (append-map (lambda (submodule)
 251                    (if (included? submodule)
 252                        (git-file-list
 253                         (string-append workdir submodule)
 254                         (rectify submodule))
 255                        '()))
 256                  submodules))))
 257
 258 (define* (git-predicate directory #:key (recursive? #t))
 259   "Return a predicate that returns true if a file is part of the Git checkout
 260 living at DIRECTORY.  If DIRECTORY does not lie within a Git checkout, and
 261 upon Git errors, return #f instead of a predicate.
 262
 263 When RECURSIVE? is true, the predicate also returns true if a file is part of
 264 any Git submodule under DIRECTORY.  This is enabled by default.
 265
 266 The returned predicate takes two arguments FILE and STAT where FILE is an
 267 absolute file name and STAT is the result of 'lstat'."
 268   (libgit2-init!)
 269   (catch 'git-error
 270     (lambda ()
 271       (let* ((files  (git-file-list directory #:recursive? recursive?))
 272              (inodes (fold (lambda (file result)
 273                              (let* ((file (string-append directory "/" file))
 274                                     (stat (false-if-exception (lstat file))))
 275                                ;; Ignore FILE if it has been deleted.
 276                                (if stat
 277                                    (vhash-consv (stat:ino stat) (stat:dev stat)
 278                                                 result)
 279                                    result)))
 280                            vlist-null
 281                            files)))
 282         (lambda (file stat)
 283           ;; Comparing file names is always tricky business so we rely on inode
 284           ;; numbers instead.
 285           (match (vhash-assv (stat:ino stat) inodes)
 286             ((_ . dev) (= dev (stat:dev stat)))
 287             (#f        #f)))))
 288     (const #f)))
 289
 290 ;;; git-download.scm ends here