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