guix/git-download.scm

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