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 i18n)
  24   #:use-module (guix base32)
  25   #:use-module (gcrypt hash)
  26   #:use-module ((guix build utils) #:select (mkdir-p))
  27   #:use-module (guix store)
  28   #:use-module (guix utils)
  29   #:use-module (guix records)
  30   #:use-module (guix gexp)
  31   #:use-module (rnrs bytevectors)
  32   #:use-module (ice-9 match)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-11)
  35   #:use-module (srfi srfi-34)
  36   #:use-module (srfi srfi-35)
  37   #:export (%repository-cache-directory
  38             update-cached-checkout
  39             latest-repository-commit
  40
  41             git-checkout
  42             git-checkout?
  43             git-checkout-url
  44             git-checkout-branch))
  45
  46 (define %repository-cache-directory
  47   (make-parameter (string-append (cache-directory #:ensure? #f)
  48                                  "/checkouts")))
  49
  50 (define-syntax-rule (with-libgit2 thunk ...)
  51   (begin
  52     ;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
  53     ;; but pointer finalizers used in guile-git may be called after shutdown,
  54     ;; resulting in a segfault. Hence, let's skip shutdown call for now.
  55     (libgit2-init!)
  56     thunk ...))
  57
  58 (define* (url-cache-directory url
  59                               #:optional (cache-directory
  60                                           (%repository-cache-directory)))
  61   "Return the directory associated to URL in %repository-cache-directory."
  62   (string-append
  63    cache-directory "/"
  64    (bytevector->base32-string (sha256 (string->utf8 url)))))
  65
  66 (define (clone* url directory)
  67   "Clone git repository at URL into DIRECTORY.  Upon failure,
  68 make sure no empty directory is left behind."
  69   (with-throw-handler #t
  70     (lambda ()
  71       (mkdir-p directory)
  72
  73       ;; Note: Explicitly pass options to work around the invalid default
  74       ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
  75       (if (module-defined? (resolve-interface '(git))
  76                            'clone-init-options)
  77           (clone url directory (clone-init-options))
  78           (clone url directory)))
  79     (lambda _
  80       (false-if-exception (rmdir directory)))))
  81
  82 (define (url+commit->name url sha1)
  83   "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
  84 the git repository, extracted from URL and SHA1:7 the seven first digits
  85 of SHA1 string."
  86   (string-append
  87    (string-replace-substring
  88     (last (string-split url #\/)) ".git" "")
  89    "-" (string-take sha1 7)))
  90
  91 (define (switch-to-ref repository ref)
  92   "Switch to REPOSITORY's branch, commit or tag specified by REF.  Return the
  93 OID (roughly the commit hash) corresponding to REF."
  94   (define obj
  95     (match ref
  96       (('branch . branch)
  97        (let ((oid (reference-target
  98                    (branch-lookup repository branch BRANCH-REMOTE))))
  99          (object-lookup repository oid)))
 100       (('commit . commit)
 101        (let ((len (string-length commit)))
 102          ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
 103          ;; can't be sure it's available.  Furthermore, 'string->oid' used to
 104          ;; read out-of-bounds when passed a string shorter than 40 chars,
 105          ;; which is why we delay calls to it below.
 106          (if (< len 40)
 107              (if (module-defined? (resolve-interface '(git object))
 108                                   'object-lookup-prefix)
 109                  (object-lookup-prefix repository (string->oid commit) len)
 110                  (raise (condition
 111                          (&message
 112                           (message "long Git object ID is required")))))
 113              (object-lookup repository (string->oid commit)))))
 114       (('tag    . tag)
 115        (let ((oid (reference-name->oid repository
 116                                        (string-append "refs/tags/" tag))))
 117          (object-lookup repository oid)))))
 118
 119   (reset repository obj RESET_HARD)
 120   (object-id obj))
 121
 122 (define* (update-cached-checkout url
 123                                  #:key
 124                                  (ref '(branch . "master"))
 125                                  (cache-directory
 126                                   (url-cache-directory
 127                                    url (%repository-cache-directory))))
 128   "Update the cached checkout of URL to REF in CACHE-DIRECTORY.  Return two
 129 values: the cache directory name, and the SHA1 commit (a string) corresponding
 130 to REF.
 131
 132 REF is pair whose key is [branch | commit | tag] and value the associated
 133 data, respectively [<branch name> | <sha1> | <tag name>]."
 134   (define canonical-ref
 135     ;; We used to require callers to specify "origin/" for each branch, which
 136     ;; made little sense since the cache should be transparent to them.  So
 137     ;; here we append "origin/" if it's missing and otherwise keep it.
 138     (match ref
 139       (('branch . branch)
 140        `(branch . ,(if (string-prefix? "origin/" branch)
 141                        branch
 142                        (string-append "origin/" branch))))
 143       (_ ref)))
 144
 145   (with-libgit2
 146    (let* ((cache-exists? (openable-repository? cache-directory))
 147           (repository    (if cache-exists?
 148                              (repository-open cache-directory)
 149                              (clone* url cache-directory))))
 150      ;; Only fetch remote if it has not been cloned just before.
 151      (when cache-exists?
 152        (remote-fetch (remote-lookup repository "origin")))
 153      (let ((oid (switch-to-ref repository canonical-ref)))
 154
 155        ;; Reclaim file descriptors and memory mappings associated with
 156        ;; REPOSITORY as soon as possible.
 157        (when (module-defined? (resolve-interface '(git repository))
 158                               'repository-close!)
 159          (repository-close! repository))
 160
 161        (values cache-directory (oid->string oid))))))
 162
 163 (define* (latest-repository-commit store url
 164                                    #:key
 165                                    (log-port (%make-void-port "w"))
 166                                    (cache-directory
 167                                     (%repository-cache-directory))
 168                                    (ref '(branch . "master")))
 169   "Return two values: the content of the git repository at URL copied into a
 170 store directory and the sha1 of the top level commit in this directory.  The
 171 reference to be checkout, once the repository is fetched, is specified by REF.
 172 REF is pair whose key is [branch | commit | tag] and value the associated
 173 data, respectively [<branch name> | <sha1> | <tag name>].
 174
 175 Git repositories are kept in the cache directory specified by
 176 %repository-cache-directory parameter.
 177
 178 Log progress and checkout info to LOG-PORT."
 179   (define (dot-git? file stat)
 180     (and (string=? (basename file) ".git")
 181          (eq? 'directory (stat:type stat))))
 182
 183   (format log-port "updating checkout of '~a'...~%" url)
 184   (let*-values
 185       (((checkout commit)
 186         (update-cached-checkout url
 187                                 #:ref ref
 188                                 #:cache-directory
 189                                 (url-cache-directory url cache-directory)))
 190        ((name)
 191         (url+commit->name url commit)))
 192     (format log-port "retrieved commit ~a~%" commit)
 193     (values (add-to-store store name #t "sha256" checkout
 194                           #:select? (negate dot-git?))
 195             commit)))
 196
 197 \f
 198 ;;;
 199 ;;; Checkouts.
 200 ;;;
 201
 202 ;; Representation of the "latest" checkout of a branch or a specific commit.
 203 (define-record-type* <git-checkout>
 204   git-checkout make-git-checkout
 205   git-checkout?
 206   (url     git-checkout-url)
 207   (branch  git-checkout-branch (default "master"))
 208   (commit  git-checkout-commit (default #f)))
 209
 210 (define* (latest-repository-commit* url #:key ref log-port)
 211   ;; Monadic variant of 'latest-repository-commit'.
 212   (lambda (store)
 213     ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
 214     ;; translate it into '&message' conditions that we know will be properly
 215     ;; handled.
 216     (catch 'git-error
 217       (lambda ()
 218         (values (latest-repository-commit store url
 219                                           #:ref ref #:log-port log-port)
 220                 store))
 221       (lambda (key error . _)
 222         (raise (condition
 223                 (&message
 224                  (message
 225                   (match ref
 226                     (('commit . commit)
 227                      (format #f (G_ "cannot fetch commit ~a from ~a: ~a")
 228                              commit url (git-error-message error)))
 229                     (('branch . branch)
 230                      (format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
 231                              branch url (git-error-message error)))
 232                     (_
 233                      (format #f (G_ "Git failure while fetching ~a: ~a")
 234                              url (git-error-message error))))))))))))
 235
 236 (define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
 237                                              system target)
 238   ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
 239   ;; store.
 240   (match checkout
 241     (($ <git-checkout> url branch commit)
 242      (latest-repository-commit* url
 243                                 #:ref (if commit
 244                                           `(commit . ,commit)
 245                                           `(branch . ,branch))
 246                                 #:log-port (current-error-port)))))