guix/git-download.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 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 zlib
  88     (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
  89
  90   (define guile-json
  91     (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-3))
  92
  93   (define gnutls
  94     (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
  95
  96   (define config.scm
  97     (scheme-file "config.scm"
  98                  #~(begin
  99                      (define-module (guix config)
 100                        #:export (%libz))
 101
 102                      (define %libz
 103                        #+(file-append zlib "/lib/libz")))))
 104
 105   (define modules
 106     (cons `((guix config) => ,config.scm)
 107           (delete '(guix config)
 108                   (source-module-closure '((guix build git)
 109                                            (guix build utils)
 110                                            (guix build download-nar)
 111                                            (guix swh))))))
 112
 113   (define build
 114     (with-imported-modules modules
 115       (with-extensions (list guile-json gnutls)   ;for (guix swh)
 116         #~(begin
 117             (use-modules (guix build git)
 118                          (guix build utils)
 119                          (guix build download-nar)
 120                          (guix swh)
 121                          (ice-9 match))
 122
 123             (define recursive?
 124               (call-with-input-string (getenv "git recursive?") read))
 125
 126             ;; The 'git submodule' commands expects Coreutils, sed,
 127             ;; grep, etc. to be in $PATH.
 128             (set-path-environment-variable "PATH" '("bin")
 129                                            (match '#+inputs
 130                                              (((names dirs outputs ...) ...)
 131                                               dirs)))
 132
 133             (setvbuf (current-output-port) 'line)
 134             (setvbuf (current-error-port) 'line)
 135
 136             (or (git-fetch (getenv "git url") (getenv "git commit")
 137                            #$output
 138                            #:recursive? recursive?
 139                            #:git-command (string-append #+git "/bin/git"))
 140                 (download-nar #$output)
 141
 142                 ;; As a last resort, attempt to download from Software Heritage.
 143                 ;; Disable X.509 certificate verification to avoid depending
 144                 ;; on nss-certs--we're authenticating the checkout anyway.
 145                 ;; XXX: Currently recursive checkouts are not supported.
 146                 (and (not recursive?)
 147                      (parameterize ((%verify-swh-certificate? #f))
 148                        (format (current-error-port)
 149                                "Trying to download from Software Heritage...~%")
 150                        (swh-download (getenv "git url") (getenv "git commit")
 151                                      #$output))))))))
 152
 153   (mlet %store-monad ((guile (package->derivation guile system)))
 154     (gexp->derivation (or name "git-checkout") build
 155
 156                       ;; Use environment variables and a fixed script name so
 157                       ;; there's only one script in store for all the
 158                       ;; downloads.
 159                       #:script-name "git-download"
 160                       #:env-vars
 161                       `(("git url" . ,(git-reference-url ref))
 162                         ("git commit" . ,(git-reference-commit ref))
 163                         ("git recursive?" . ,(object->string
 164                                               (git-reference-recursive? ref))))
 165                       #:leaked-env-vars '("http_proxy" "https_proxy"
 166                                           "LC_ALL" "LC_MESSAGES" "LANG"
 167                                           "COLUMNS")
 168
 169                       #:system system
 170                       #:local-build? #t           ;don't offload repo cloning
 171                       #:hash-algo hash-algo
 172                       #:hash hash
 173                       #:recursive? #t
 174                       #:guile-for-build guile)))
 175
 176 (define (git-version version revision commit)
 177   "Return the version string for packages using git-download."
 178   ;; git-version is almost exclusively executed while modules are being loaded.
 179   ;; This makes any errors hide their backtrace. Avoid the mysterious error
 180   ;; "Value out of range 0 to N: 7" when the commit ID is too short, which
 181   ;; can happen, for example, when the user swapped the revision and commit
 182   ;; arguments by mistake.
 183   (when (< (string-length commit) 7)
 184     (raise
 185       (condition
 186         (&message (message "git-version: commit ID unexpectedly short")))))
 187   (string-append version "-" revision "." (string-take commit 7)))
 188
 189 (define (git-file-name name version)
 190   "Return the file-name for packages using git-download."
 191   (string-append name "-" version "-checkout"))
 192
 193 \f
 194 ;;;
 195 ;;; 'git-predicate'.
 196 ;;;
 197
 198 (define (git-file-list directory)
 199   "Return the list of files checked in in the Git repository at DIRECTORY.
 200 The result is similar to that of the 'git ls-files' command, except that it
 201 also includes directories, not just regular files.  The returned file names
 202 are relative to DIRECTORY, which is not necessarily the root of the checkout."
 203   (let* (;; 'repository-working-directory' always returns a trailing "/",
 204          ;; so add one here to ease the comparisons below.
 205          (directory  (string-append (canonicalize-path directory) "/"))
 206          (dot-git    (repository-discover directory))
 207          (repository (repository-open dot-git))
 208          (workdir    (repository-working-directory repository))
 209          (head       (repository-head repository))
 210          (oid        (reference-target head))
 211          (commit     (commit-lookup repository oid))
 212          (tree       (commit-tree commit))
 213          (files      (tree-list tree)))
 214     (repository-close! repository)
 215     (if (string=? workdir directory)
 216         files
 217         (let ((relative (string-drop directory (string-length workdir))))
 218           (filter-map (lambda (file)
 219                         (and (string-prefix? relative file)
 220                              (string-drop file (string-length relative))))
 221                       files)))))
 222
 223 (define (git-predicate directory)
 224   "Return a predicate that returns true if a file is part of the Git checkout
 225 living at DIRECTORY.  If DIRECTORY does not lie within a Git checkout, and
 226 upon Git errors, return #f instead of a predicate.
 227
 228 The returned predicate takes two arguments FILE and STAT where FILE is an
 229 absolute file name and STAT is the result of 'lstat'."
 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