;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix packages)
+ #:use-module (guix modules)
#:autoload (guix build-system gnu) (standard-packages)
+ #:use-module (git)
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+ #:use-module (srfi srfi-1)
#:export (git-reference
git-reference?
git-reference-url
git-reference-commit
git-reference-recursive?
- git-fetch))
+ git-fetch
+ git-version
+ git-file-name
+ git-predicate))
;;; Commentary:
;;;
(define (git-package)
"Return the default Git package."
(let ((distro (resolve-interface '(gnu packages version-control))))
- (module-ref distro 'git)))
+ (module-ref distro 'git-minimal)))
(define* (git-fetch ref hash-algo hash
#:optional name
;; available so that 'git submodule' works.
(if (git-reference-recursive? ref)
(standard-packages)
- '()))
+
+ ;; The 'swh-download' procedure requires tar and gzip.
+ `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression))
+ 'gzip))
+ ("tar" ,(module-ref (resolve-interface '(gnu packages base))
+ 'tar)))))
+
+ (define zlib
+ (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
+
+ (define guile-json
+ (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-3))
+
+ (define gnutls
+ (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
+
+ (define config.scm
+ (scheme-file "config.scm"
+ #~(begin
+ (define-module (guix config)
+ #:export (%libz))
+
+ (define %libz
+ #+(file-append zlib "/lib/libz")))))
+
+ (define modules
+ (cons `((guix config) => ,config.scm)
+ (delete '(guix config)
+ (source-module-closure '((guix build git)
+ (guix build utils)
+ (guix build download-nar)
+ (guix swh))))))
(define build
- #~(begin
- (use-modules (guix build git)
- (guix build utils)
- (ice-9 match))
-
- ;; The 'git submodule' commands expects Coreutils, sed,
- ;; grep, etc. to be in $PATH.
- (set-path-environment-variable "PATH" '("bin")
- (match '#+inputs
- (((names dirs) ...)
- dirs)))
-
- (git-fetch '#$(git-reference-url ref)
- '#$(git-reference-commit ref)
- #$output
- #:recursive? '#$(git-reference-recursive? ref)
- #:git-command (string-append #+git "/bin/git"))))
+ (with-imported-modules modules
+ (with-extensions (list guile-json gnutls) ;for (guix swh)
+ #~(begin
+ (use-modules (guix build git)
+ (guix build utils)
+ (guix build download-nar)
+ (guix swh)
+ (ice-9 match))
+
+ (define recursive?
+ (call-with-input-string (getenv "git recursive?") read))
+
+ ;; The 'git submodule' commands expects Coreutils, sed,
+ ;; grep, etc. to be in $PATH.
+ (set-path-environment-variable "PATH" '("bin")
+ (match '#+inputs
+ (((names dirs outputs ...) ...)
+ dirs)))
+
+ (setvbuf (current-output-port) 'line)
+ (setvbuf (current-error-port) 'line)
+
+ (or (git-fetch (getenv "git url") (getenv "git commit")
+ #$output
+ #:recursive? recursive?
+ #:git-command (string-append #+git "/bin/git"))
+ (download-nar #$output)
+
+ ;; As a last resort, attempt to download from Software Heritage.
+ ;; XXX: Currently recursive checkouts are not supported.
+ (and (not recursive?)
+ (begin
+ (format (current-error-port)
+ "Trying to download from Software Heritage...~%")
+ (swh-download (getenv "git url") (getenv "git commit")
+ #$output))))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "git-checkout") build
+
+ ;; Use environment variables and a fixed script name so
+ ;; there's only one script in store for all the
+ ;; downloads.
+ #:script-name "git-download"
+ #:env-vars
+ `(("git url" . ,(git-reference-url ref))
+ ("git commit" . ,(git-reference-commit ref))
+ ("git recursive?" . ,(object->string
+ (git-reference-recursive? ref))))
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
+
#:system system
- ;; FIXME: See <https://bugs.gnu.org/18747>.
- ;;#:local-build? #t
+ #:local-build? #t ;don't offload repo cloning
#:hash-algo hash-algo
#:hash hash
#:recursive? #t
- #:modules '((guix build git)
- (guix build utils))
- #:guile-for-build guile
- #:local-build? #t)))
+ #:guile-for-build guile)))
+
+(define (git-version version revision commit)
+ "Return the version string for packages using git-download."
+ (string-append version "-" revision "." (string-take commit 7)))
+
+(define (git-file-name name version)
+ "Return the file-name for packages using git-download."
+ (string-append name "-" version "-checkout"))
+
+\f
+;;;
+;;; 'git-predicate'.
+;;;
+
+(define (git-file-list directory)
+ "Return the list of files checked in in the Git repository at DIRECTORY.
+The result is similar to that of the 'git ls-files' command, except that it
+also includes directories, not just regular files. The returned file names
+are relative to DIRECTORY, which is not necessarily the root of the checkout."
+ (let* (;; 'repository-working-directory' always returns a trailing "/",
+ ;; so add one here to ease the comparisons below.
+ (directory (string-append (canonicalize-path directory) "/"))
+ (dot-git (repository-discover directory))
+ (repository (repository-open dot-git))
+ (workdir (repository-working-directory repository))
+ (head (repository-head repository))
+ (oid (reference-target head))
+ (commit (commit-lookup repository oid))
+ (tree (commit-tree commit))
+ (files (tree-list tree)))
+ (repository-close! repository)
+ (if (string=? workdir directory)
+ files
+ (let ((relative (string-drop directory (string-length workdir))))
+ (filter-map (lambda (file)
+ (and (string-prefix? relative file)
+ (string-drop file (string-length relative))))
+ files)))))
+
+(define (git-predicate directory)
+ "Return a predicate that returns true if a file is part of the Git checkout
+living at DIRECTORY. If DIRECTORY does not lie within a Git checkout, and
+upon Git errors, return #f instead of a predicate.
+
+The returned predicate takes two arguments FILE and STAT where FILE is an
+absolute file name and STAT is the result of 'lstat'."
+ (catch 'git-error
+ (lambda ()
+ (let* ((files (git-file-list directory))
+ (inodes (fold (lambda (file result)
+ (let ((stat
+ (lstat (string-append directory "/"
+ file))))
+ (vhash-consv (stat:ino stat) (stat:dev stat)
+ result)))
+ vlist-null
+ files)))
+ (lambda (file stat)
+ ;; Comparing file names is always tricky business so we rely on inode
+ ;; numbers instead.
+ (match (vhash-assv (stat:ino stat) inodes)
+ ((_ . dev) (= dev (stat:dev stat)))
+ (#f #f)))))
+ (const #f)))
;;; git-download.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff