guix/git.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   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.
  11 ;;;
  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.
  16 ;;;
  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/>.
  19
  20 (define-module (guix git)
  21   #:use-module (git)
  22   #:use-module (git object)
  23   #:use-module (guix base32)
  24   #:use-module (guix hash)
  25   #:use-module ((guix build utils) #:select (mkdir-p))
  26   #:use-module (guix store)
  27   #:use-module (guix utils)
  28   #:use-module (rnrs bytevectors)
  29   #:use-module (ice-9 match)
  30   #:use-module (srfi srfi-1)
  31   #:use-module (srfi srfi-34)
  32   #:use-module (srfi srfi-35)
  33   #:export (%repository-cache-directory
  34             latest-repository-commit))
  35
  36 (define %repository-cache-directory
  37   (make-parameter "/var/cache/guix/checkouts"))
  38
  39 (define-syntax-rule (with-libgit2 thunk ...)
  40   (begin
  41     ;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
  42     ;; but pointer finalizers used in guile-git may be called after shutdown,
  43     ;; resulting in a segfault. Hence, let's skip shutdown call for now.
  44     (libgit2-init!)
  45     thunk ...))
  46
  47 (define* (url-cache-directory url
  48                               #:optional (cache-directory
  49                                           (%repository-cache-directory)))
  50   "Return the directory associated to URL in %repository-cache-directory."
  51   (string-append
  52    cache-directory "/"
  53    (bytevector->base32-string (sha256 (string->utf8 url)))))
  54
  55 (define (clone* url directory)
  56   "Clone git repository at URL into DIRECTORY.  Upon failure,
  57 make sure no empty directory is left behind."
  58   (with-throw-handler #t
  59     (lambda ()
  60       (mkdir-p directory)
  61
  62       ;; Note: Explicitly pass options to work around the invalid default
  63       ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
  64       (if (module-defined? (resolve-interface '(git))
  65                            'clone-init-options)
  66           (clone url directory (clone-init-options))
  67           (clone url directory)))
  68     (lambda _
  69       (false-if-exception (rmdir directory)))))
  70
  71 (define (repository->head-sha1 repo)
  72   "Return the sha1 of the HEAD commit in REPOSITORY as a string."
  73   (let ((oid (reference-target (repository-head repo))))
  74     (oid->string (commit-id (commit-lookup repo oid)))))
  75
  76 (define (url+commit->name url sha1)
  77   "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
  78 the git repository, extracted from URL and SHA1:7 the seven first digits
  79 of SHA1 string."
  80   (string-append
  81    (string-replace-substring
  82     (last (string-split url #\/)) ".git" "")
  83    "-" (string-take sha1 7)))
  84
  85 (define* (copy-to-store store cache-directory #:key url repository)
  86   "Copy CACHE-DIRECTORY recursively to STORE.  URL and REPOSITORY are used to
  87 create the store directory name."
  88   (define (dot-git? file stat)
  89     (and (string=? (basename file) ".git")
  90          (eq? 'directory (stat:type stat))))
  91
  92   (let* ((commit (repository->head-sha1 repository))
  93          (name   (url+commit->name url commit)))
  94     (values (add-to-store store name #t "sha256" cache-directory
  95                           #:select? (negate dot-git?))
  96             commit)))
  97
  98 (define (switch-to-ref repository ref)
  99   "Switch to REPOSITORY's branch, commit or tag specified by REF."
 100   (define obj
 101     (match ref
 102       (('branch . branch)
 103        (let ((oid (reference-target
 104                    (branch-lookup repository branch BRANCH-REMOTE))))
 105          (object-lookup repository oid)))
 106       (('commit . commit)
 107        (let ((len (string-length commit)))
 108          ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
 109          ;; can't be sure it's available.  Furthermore, 'string->oid' used to
 110          ;; read out-of-bounds when passed a string shorter than 40 chars,
 111          ;; which is why we delay calls to it below.
 112          (if (< len 40)
 113              (if (module-defined? (resolve-interface '(git object))
 114                                   'object-lookup-prefix)
 115                  (object-lookup-prefix repository (string->oid commit) len)
 116                  (raise (condition
 117                          (&message
 118                           (message "long Git object ID is required")))))
 119              (object-lookup repository (string->oid commit)))))
 120       (('tag    . tag)
 121        (let ((oid (reference-name->oid repository
 122                                        (string-append "refs/tags/" tag))))
 123          (object-lookup repository oid)))))
 124
 125   (reset repository obj RESET_HARD))
 126
 127 (define* (latest-repository-commit store url
 128                                    #:key
 129                                    (cache-directory
 130                                     (%repository-cache-directory))
 131                                    (ref '(branch . "origin/master")))
 132   "Return two values: the content of the git repository at URL copied into a
 133 store directory and the sha1 of the top level commit in this directory.  The
 134 reference to be checkout, once the repository is fetched, is specified by REF.
 135 REF is pair whose key is [branch | commit | tag] and value the associated
 136 data, respectively [<branch name> | <sha1> | <tag name>].
 137
 138 Git repositories are kept in the cache directory specified by
 139 %repository-cache-directory parameter."
 140   (with-libgit2
 141    (let* ((cache-dir     (url-cache-directory url cache-directory))
 142           (cache-exists? (openable-repository? cache-dir))
 143           (repository    (if cache-exists?
 144                              (repository-open cache-dir)
 145                              (clone* url cache-dir))))
 146      ;; Only fetch remote if it has not been cloned just before.
 147      (when cache-exists?
 148        (remote-fetch (remote-lookup repository "origin")))
 149      (switch-to-ref repository ref)
 150      (copy-to-store store cache-dir
 151                     #:url url
 152                     #:repository repository))))