guix/git-download.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018 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))
  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                      (swh-download (getenv "git url") (getenv "git commit")
 143                                    #$output)))))))
 144
 145   (mlet %store-monad ((guile (package->derivation guile system)))
 146     (gexp->derivation (or name "git-checkout") build
 147
 148                       ;; Use environment variables and a fixed script name so
 149                       ;; there's only one script in store for all the
 150                       ;; downloads.
 151                       #:script-name "git-download"
 152                       #:env-vars
 153                       `(("git url" . ,(git-reference-url ref))
 154                         ("git commit" . ,(git-reference-commit ref))
 155                         ("git recursive?" . ,(object->string
 156                                               (git-reference-recursive? ref))))
 157
 158                       #:system system
 159                       #:local-build? #t           ;don't offload repo cloning
 160                       #:hash-algo hash-algo
 161                       #:hash hash
 162                       #:recursive? #t
 163                       #:guile-for-build guile)))
 164
 165 (define (git-version version revision commit)
 166   "Return the version string for packages using git-download."
 167   (string-append version "-" revision "." (string-take commit 7)))
 168
 169 (define (git-file-name name version)
 170   "Return the file-name for packages using git-download."
 171   (string-append name "-" version "-checkout"))
 172
 173 \f
 174 ;;;
 175 ;;; 'git-predicate'.
 176 ;;;
 177
 178 (define (git-file-list directory)
 179   "Return the list of files checked in in the Git repository at DIRECTORY.
 180 The result is similar to that of the 'git ls-files' command, except that it
 181 also includes directories, not just regular files.  The returned file names
 182 are relative to DIRECTORY, which is not necessarily the root of the checkout."
 183   (let* (;; 'repository-working-directory' always returns a trailing "/",
 184          ;; so add one here to ease the comparisons below.
 185          (directory  (string-append (canonicalize-path directory) "/"))
 186          (dot-git    (repository-discover directory))
 187          (repository (repository-open dot-git))
 188          ;; XXX: This procedure is mistakenly private in Guile-Git 0.1.0.
 189          (workdir    ((@@ (git repository) repository-working-directory)
 190                       repository))
 191          (head       (repository-head repository))
 192          (oid        (reference-target head))
 193          (commit     (commit-lookup repository oid))
 194          (tree       (commit-tree commit))
 195          (files      (tree-list tree)))
 196     (repository-close! repository)
 197     (if (string=? workdir directory)
 198         files
 199         (let ((relative (string-drop directory (string-length workdir))))
 200           (filter-map (lambda (file)
 201                         (and (string-prefix? relative file)
 202                              (string-drop file (string-length relative))))
 203                       files)))))
 204
 205 (define (git-predicate directory)
 206   "Return a predicate that returns true if a file is part of the Git checkout
 207 living at DIRECTORY.  If DIRECTORY does not lie within a Git checkout, and
 208 upon Git errors, return #f instead of a predicate.
 209
 210 The returned predicate takes two arguments FILE and STAT where FILE is an
 211 absolute file name and STAT is the result of 'lstat'."
 212   (catch 'git-error
 213     (lambda ()
 214       (let* ((files  (git-file-list directory))
 215              (inodes (fold (lambda (file result)
 216                              (let ((stat
 217                                     (lstat (string-append directory "/"
 218                                                           file))))
 219                                (vhash-consv (stat:ino stat) (stat:dev stat)
 220                                             result)))
 221                            vlist-null
 222                            files)))
 223         (lambda (file stat)
 224           ;; Comparing file names is always tricky business so we rely on inode
 225           ;; numbers instead.
 226           (match (vhash-assv (stat:ino stat) inodes)
 227             ((_ . dev) (= dev (stat:dev stat)))
 228             (#f        #f)))))
 229     (const #f)))
 230
 231 ;;; git-download.scm ends here