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