guix/git.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix git)
  20   #:use-module (git)
  21   #:use-module (git object)
  22   #:use-module (guix base32)
  23   #:use-module (guix hash)
  24   #:use-module (guix build utils)
  25   #:use-module (guix store)
  26   #:use-module (guix utils)
  27   #:use-module (rnrs bytevectors)
  28   #:use-module (ice-9 match)
  29   #:use-module (srfi srfi-1)
  30   #:export (%repository-cache-directory
  31             latest-repository-commit))
  32
  33 (define %repository-cache-directory
  34   (make-parameter "/var/cache/guix/checkouts"))
  35
  36 (define-syntax-rule (with-libgit2 thunk ...)
  37   (dynamic-wind
  38     (lambda ()
  39       (libgit2-init!))
  40     (lambda ()
  41       thunk ...)
  42     (lambda ()
  43       (libgit2-shutdown))))
  44
  45 (define* (url-cache-directory url
  46                               #:optional (cache-directory
  47                                           (%repository-cache-directory)))
  48   "Return the directory associated to URL in %repository-cache-directory."
  49   (string-append
  50    cache-directory "/"
  51    (bytevector->base32-string (sha256 (string->utf8 url)))))
  52
  53 (define (clone* url directory)
  54   "Clone git repository at URL into DIRECTORY.  Upon failure,
  55 make sure no empty directory is left behind."
  56   (with-throw-handler #t
  57     (lambda ()
  58       (mkdir-p directory)
  59       (clone url directory))
  60     (lambda _
  61       (false-if-exception (rmdir directory)))))
  62
  63 (define (repository->head-sha1 repo)
  64   "Return the sha1 of the HEAD commit in REPOSITORY as a string."
  65   (let ((oid (reference-target (repository-head repo))))
  66     (oid->string (commit-id (commit-lookup repo oid)))))
  67
  68 (define (url+commit->name url sha1)
  69   "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
  70 the git repository, extracted from URL and SHA1:7 the seven first digits
  71 of SHA1 string."
  72   (string-append
  73    (string-replace-substring
  74     (last (string-split url #\/)) ".git" "")
  75    "-" (string-take sha1 7)))
  76
  77 (define* (copy-to-store store cache-directory #:key url repository)
  78   "Copy items in cache-directory to store.  URL and REPOSITORY are used
  79 to forge store directory name."
  80   (let* ((commit (repository->head-sha1 repository))
  81          (name   (url+commit->name url commit)))
  82     (values (add-to-store store name #t "sha256" cache-directory) commit)))
  83
  84 (define (switch-to-ref repository ref)
  85   "Switch to REPOSITORY's branch, commit or tag specified by REF."
  86   (let* ((oid (match ref
  87                 (('branch . branch)
  88                  (reference-target
  89                   (branch-lookup repository branch BRANCH-REMOTE)))
  90                 (('commit . commit)
  91                  (string->oid commit))
  92                 (('tag    . tag)
  93                  (reference-name->oid repository
  94                                       (string-append "refs/tags/" tag)))))
  95          (obj (object-lookup repository oid)))
  96     (reset repository obj RESET_HARD)))
  97
  98 (define* (latest-repository-commit store url
  99                                    #:key
 100                                    (cache-directory
 101                                     (%repository-cache-directory))
 102                                    (ref '(branch . "origin/master")))
 103   "Return two values: the content of the git repository at URL copied into a
 104 store directory and the sha1 of the top level commit in this directory.  The
 105 reference to be checkout, once the repository is fetched, is specified by REF.
 106 REF is pair whose key is [branch | commit | tag] and value the associated
 107 data, respectively [<branch name> | <sha1> | <tag name>].
 108
 109 Git repositories are kept in the cache directory specified by
 110 %repository-cache-directory parameter."
 111   (with-libgit2
 112    (let* ((cache-dir     (url-cache-directory url cache-directory))
 113           (cache-exists? (openable-repository? cache-dir))
 114           (repository    (if cache-exists?
 115                              (repository-open cache-dir)
 116                              (clone* url cache-dir))))
 117      ;; Only fetch remote if it has not been cloned just before.
 118      (when cache-exists?
 119        (remote-fetch (remote-lookup repository "origin")))
 120      (switch-to-ref repository ref)
 121      (copy-to-store store cache-dir
 122                     #:url url
 123                     #:repository repository))))