1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
5 ;;; This file is part of GNU Guix.
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
8 ;;; under the terms of the GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 3 of the License, or (at
10 ;;; your option) any later version.
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details.
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (guix git-download)
21 #:use-module (guix build utils)
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 #:autoload (guix build-system gnu) (standard-packages)
28 #:use-module (ice-9 match)
29 #:use-module (ice-9 popen)
30 #:use-module (ice-9 rdelim)
31 #:use-module (srfi srfi-1)
32 #:export (git-reference
36 git-reference-recursive?
45 ;;; An <origin> method that fetches a specific commit from a Git repository.
46 ;;; The repository URL and commit hash are specified with a <git-reference>
51 (define-record-type* <git-reference>
52 git-reference make-git-reference
54 (url git-reference-url)
55 (commit git-reference-commit)
56 (recursive? git-reference-recursive? ; whether to recurse into sub-modules
60 "Return the default Git package."
61 (let ((distro (resolve-interface '(gnu packages version-control))))
62 (module-ref distro 'git)))
64 (define* (git-fetch ref hash-algo hash
66 #:key (system (%current-system)) (guile (default-guile))
68 "Return a fixed-output derivation that fetches REF, a <git-reference>
69 object. The output is expected to have recursive hash HASH of type
70 HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
72 ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
73 ;; available so that 'git submodule' works.
74 (if (git-reference-recursive? ref)
79 (with-imported-modules '((guix build git)
82 (use-modules (guix build git)
86 ;; The 'git submodule' commands expects Coreutils, sed,
87 ;; grep, etc. to be in $PATH.
88 (set-path-environment-variable "PATH" '("bin")
93 (git-fetch (getenv "git url") (getenv "git commit")
95 #:recursive? (call-with-input-string
96 (getenv "git recursive?")
98 #:git-command (string-append #+git "/bin/git")))))
100 (mlet %store-monad ((guile (package->derivation guile system)))
101 (gexp->derivation (or name "git-checkout") build
103 ;; Use environment variables and a fixed script name so
104 ;; there's only one script in store for all the
106 #:script-name "git-download"
108 `(("git url" . ,(git-reference-url ref))
109 ("git commit" . ,(git-reference-commit ref))
110 ("git recursive?" . ,(object->string
111 (git-reference-recursive? ref))))
114 #:local-build? #t ;don't offload repo cloning
115 #:hash-algo hash-algo
118 #:guile-for-build guile)))
120 (define (git-version version revision commit)
121 "Return the version string for packages using git-download."
122 (string-append version "-" revision "." (string-take commit 7)))
124 (define (git-file-name name version)
125 "Return the file-name for packages using git-download."
126 (string-append name "-" version "-checkout"))
128 (define (git-predicate directory)
129 "Return a predicate that returns true if a file is part of the Git checkout
130 living at DIRECTORY. Upon Git failure, return #f instead of a predicate.
132 The returned predicate takes two arguments FILE and STAT where FILE is an
133 absolute file name and STAT is the result of 'lstat'."
134 (define (parent-directory? thing directory)
135 ;; Return #t if DIRECTORY is the parent of THING.
136 (or (string-suffix? thing directory)
137 (and (string-index thing #\/)
138 (parent-directory? (dirname thing) directory))))
140 (let* ((pipe (with-directory-excursion directory
141 (open-pipe* OPEN_READ "git" "ls-files")))
142 (files (let loop ((lines '()))
143 (match (read-line pipe)
147 (loop (cons line lines))))))
148 (status (close-pipe pipe)))
151 (match (stat:type stat)
153 ;; 'git ls-files' does not list directories, only regular files,
154 ;; so we need this special trick.
155 (any (lambda (f) (parent-directory? f file))
157 ((or 'regular 'symlink)
158 (any (lambda (f) (string-suffix? f file))
163 ;;; git-download.scm ends here