guix/git.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2018, 2019 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             honor-system-x509-certificates!
  39
  40             update-cached-checkout
  41             latest-repository-commit
  42
  43             git-checkout
  44             git-checkout?
  45             git-checkout-url
  46             git-checkout-branch))
  47
  48 ;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
  49 ;; See <http://bugs.gnu.org/12202>.
  50 (module-autoload! (current-module)
  51                   '(git submodule) '(repository-submodules))
  52
  53 (define %repository-cache-directory
  54   (make-parameter (string-append (cache-directory #:ensure? #f)
  55                                  "/checkouts")))
  56
  57 (define (honor-system-x509-certificates!)
  58   "Use the system's X.509 certificates for Git checkouts over HTTPS.  Honor
  59 the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
  60   ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of
  61   ;; files (instead of all the certificates) among which "ca-bundle.crt".  On
  62   ;; other distros /etc/ssl/certs usually contains the whole set of
  63   ;; certificates along with "ca-certificates.crt".  Try to choose the right
  64   ;; one.
  65   (let ((file      (letrec-syntax ((choose
  66                                     (syntax-rules ()
  67                                       ((_ file rest ...)
  68                                        (let ((f file))
  69                                          (if (and f (file-exists? f))
  70                                              f
  71                                              (choose rest ...))))
  72                                       ((_)
  73                                        #f))))
  74                      (choose (getenv "SSL_CERT_FILE")
  75                              "/etc/ssl/certs/ca-certificates.crt"
  76                              "/etc/ssl/certs/ca-bundle.crt")))
  77         (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
  78     (and (or file
  79              (and=> (stat directory #f)
  80                     (lambda (st)
  81                       (> (stat:nlink st) 2))))
  82          (begin
  83            (set-tls-certificate-locations! directory file)
  84            #t))))
  85
  86 (define %certificates-initialized?
  87   ;; Whether 'honor-system-x509-certificates!' has already been called.
  88   #f)
  89
  90 (define-syntax-rule (with-libgit2 thunk ...)
  91   (begin
  92     ;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
  93     ;; but pointer finalizers used in guile-git may be called after shutdown,
  94     ;; resulting in a segfault. Hence, let's skip shutdown call for now.
  95     (libgit2-init!)
  96     (unless %certificates-initialized?
  97       (honor-system-x509-certificates!)
  98       (set! %certificates-initialized? #t))
  99     thunk ...))
 100
 101 (define* (url-cache-directory url
 102                               #:optional (cache-directory
 103                                           (%repository-cache-directory))
 104                               #:key recursive?)
 105   "Return the directory associated to URL in %repository-cache-directory."
 106   (string-append
 107    cache-directory "/"
 108    (bytevector->base32-string
 109     (sha256 (string->utf8 (if recursive?
 110                               (string-append "R:" url)
 111                               url))))))
 112
 113 (define (clone* url directory)
 114   "Clone git repository at URL into DIRECTORY.  Upon failure,
 115 make sure no empty directory is left behind."
 116   (with-throw-handler #t
 117     (lambda ()
 118       (mkdir-p directory)
 119
 120       ;; Note: Explicitly pass options to work around the invalid default
 121       ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
 122       (if (module-defined? (resolve-interface '(git))
 123                            'clone-init-options)
 124           (clone url directory (clone-init-options))
 125           (clone url directory)))
 126     (lambda _
 127       (false-if-exception (rmdir directory)))))
 128
 129 (define (url+commit->name url sha1)
 130   "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
 131 the git repository, extracted from URL and SHA1:7 the seven first digits
 132 of SHA1 string."
 133   (string-append
 134    (string-replace-substring
 135     (last (string-split url #\/)) ".git" "")
 136    "-" (string-take sha1 7)))
 137
 138 (define (switch-to-ref repository ref)
 139   "Switch to REPOSITORY's branch, commit or tag specified by REF.  Return the
 140 OID (roughly the commit hash) corresponding to REF."
 141   (define obj
 142     (let resolve ((ref ref))
 143       (match ref
 144         (('branch . branch)
 145          (let ((oid (reference-target
 146                      (branch-lookup repository branch BRANCH-REMOTE))))
 147            (object-lookup repository oid)))
 148         (('commit . commit)
 149          (let ((len (string-length commit)))
 150            ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
 151            ;; can't be sure it's available.  Furthermore, 'string->oid' used to
 152            ;; read out-of-bounds when passed a string shorter than 40 chars,
 153            ;; which is why we delay calls to it below.
 154            (if (< len 40)
 155                (if (module-defined? (resolve-interface '(git object))
 156                                     'object-lookup-prefix)
 157                    (object-lookup-prefix repository (string->oid commit) len)
 158                    (raise (condition
 159                            (&message
 160                             (message "long Git object ID is required")))))
 161                (object-lookup repository (string->oid commit)))))
 162         (('tag-or-commit . str)
 163          (if (or (> (string-length str) 40)
 164                  (not (string-every char-set:hex-digit str)))
 165              (resolve `(tag . ,str))              ;definitely a tag
 166              (catch 'git-error
 167                (lambda ()
 168                  (resolve `(tag . ,str)))
 169                (lambda _
 170                  ;; There's no such tag, so it must be a commit ID.
 171                  (resolve `(commit . ,str))))))
 172         (('tag    . tag)
 173          (let ((oid (reference-name->oid repository
 174                                          (string-append "refs/tags/" tag))))
 175            ;; Get the commit that the tag at OID refers to.  This is not
 176            ;; strictly needed, but it's more consistent to always return the
 177            ;; OID of a commit.
 178            (object-lookup repository
 179                           (tag-target-id (tag-lookup repository oid))))))))
 180
 181   (reset repository obj RESET_HARD)
 182   (object-id obj))
 183
 184 (define (call-with-repository directory proc)
 185   (let ((repository #f))
 186    (dynamic-wind
 187      (lambda ()
 188        (set! repository (repository-open directory)))
 189      (lambda ()
 190        (proc repository))
 191      (lambda ()
 192        (repository-close! repository)))))
 193
 194 (define-syntax-rule (with-repository directory repository exp ...)
 195   "Open the repository at DIRECTORY and bind REPOSITORY to it within the
 196 dynamic extent of EXP."
 197   (call-with-repository directory
 198                         (lambda (repository) exp ...)))
 199
 200 (define* (update-submodules repository
 201                             #:key (log-port (current-error-port)))
 202   "Update the submodules of REPOSITORY, a Git repository object."
 203   ;; Guile-Git < 0.2.0 did not have (git submodule).
 204   (if (false-if-exception (resolve-interface '(git submodule)))
 205       (for-each (lambda (name)
 206                   (let ((submodule (submodule-lookup repository name)))
 207                     (format log-port (G_ "updating submodule '~a'...~%")
 208                             name)
 209                     (submodule-update submodule)
 210
 211                     ;; Recurse in SUBMODULE.
 212                     (let ((directory (string-append
 213                                       (repository-working-directory repository)
 214                                       "/" (submodule-path submodule))))
 215                       (with-repository directory repository
 216                         (update-submodules repository
 217                                            #:log-port log-port)))))
 218                 (repository-submodules repository))
 219       (format (current-error-port)
 220               (G_ "Support for submodules is missing; \
 221 please upgrade Guile-Git.~%"))))
 222
 223 (define* (update-cached-checkout url
 224                                  #:key
 225                                  (ref '(branch . "master"))
 226                                  recursive?
 227                                  (log-port (%make-void-port "w"))
 228                                  (cache-directory
 229                                   (url-cache-directory
 230                                    url (%repository-cache-directory)
 231                                    #:recursive? recursive?)))
 232   "Update the cached checkout of URL to REF in CACHE-DIRECTORY.  Return two
 233 values: the cache directory name, and the SHA1 commit (a string) corresponding
 234 to REF.
 235
 236 REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
 237 the associated data: [<branch name> | <sha1> | <tag name> | <string>].
 238
 239 When RECURSIVE? is true, check out submodules as well, if any."
 240   (define canonical-ref
 241     ;; We used to require callers to specify "origin/" for each branch, which
 242     ;; made little sense since the cache should be transparent to them.  So
 243     ;; here we append "origin/" if it's missing and otherwise keep it.
 244     (match ref
 245       (('branch . branch)
 246        `(branch . ,(if (string-prefix? "origin/" branch)
 247                        branch
 248                        (string-append "origin/" branch))))
 249       (_ ref)))
 250
 251   (with-libgit2
 252    (let* ((cache-exists? (openable-repository? cache-directory))
 253           (repository    (if cache-exists?
 254                              (repository-open cache-directory)
 255                              (clone* url cache-directory))))
 256      ;; Only fetch remote if it has not been cloned just before.
 257      (when cache-exists?
 258        (remote-fetch (remote-lookup repository "origin")))
 259      (when recursive?
 260        (update-submodules repository #:log-port log-port))
 261      (let ((oid (switch-to-ref repository canonical-ref)))
 262
 263        ;; Reclaim file descriptors and memory mappings associated with
 264        ;; REPOSITORY as soon as possible.
 265        (when (module-defined? (resolve-interface '(git repository))
 266                               'repository-close!)
 267          (repository-close! repository))
 268
 269        (values cache-directory (oid->string oid))))))
 270
 271 (define* (latest-repository-commit store url
 272                                    #:key
 273                                    recursive?
 274                                    (log-port (%make-void-port "w"))
 275                                    (cache-directory
 276                                     (%repository-cache-directory))
 277                                    (ref '(branch . "master")))
 278   "Return two values: the content of the git repository at URL copied into a
 279 store directory and the sha1 of the top level commit in this directory.  The
 280 reference to be checkout, once the repository is fetched, is specified by REF.
 281 REF is pair whose key is [branch | commit | tag] and value the associated
 282 data, respectively [<branch name> | <sha1> | <tag name>].
 283
 284 When RECURSIVE? is true, check out submodules as well, if any.
 285
 286 Git repositories are kept in the cache directory specified by
 287 %repository-cache-directory parameter.
 288
 289 Log progress and checkout info to LOG-PORT."
 290   (define (dot-git? file stat)
 291     (and (string=? (basename file) ".git")
 292          (or (eq? 'directory (stat:type stat))
 293
 294              ;; Submodule checkouts end up with a '.git' regular file that
 295              ;; contains metadata about where their actual '.git' directory
 296              ;; lives.
 297              (and recursive?
 298                   (eq? 'regular (stat:type stat))))))
 299
 300   (format log-port "updating checkout of '~a'...~%" url)
 301   (let*-values
 302       (((checkout commit)
 303         (update-cached-checkout url
 304                                 #:recursive? recursive?
 305                                 #:ref ref
 306                                 #:cache-directory
 307                                 (url-cache-directory url cache-directory
 308                                                      #:recursive?
 309                                                      recursive?)
 310                                 #:log-port log-port))
 311        ((name)
 312         (url+commit->name url commit)))
 313     (format log-port "retrieved commit ~a~%" commit)
 314     (values (add-to-store store name #t "sha256" checkout
 315                           #:select? (negate dot-git?))
 316             commit)))
 317
 318 (define (print-git-error port key args default-printer)
 319   (match args
 320     (((? git-error? error) . _)
 321      (format port (G_ "Git error: ~a~%")
 322              (git-error-message error)))))
 323
 324 (set-exception-printer! 'git-error print-git-error)
 325
 326 \f
 327 ;;;
 328 ;;; Checkouts.
 329 ;;;
 330
 331 ;; Representation of the "latest" checkout of a branch or a specific commit.
 332 (define-record-type* <git-checkout>
 333   git-checkout make-git-checkout
 334   git-checkout?
 335   (url     git-checkout-url)
 336   (branch  git-checkout-branch (default "master"))
 337   (commit  git-checkout-commit (default #f))      ;#f | tag | commit
 338   (recursive? git-checkout-recursive? (default #f)))
 339
 340 (define* (latest-repository-commit* url #:key ref recursive? log-port)
 341   ;; Monadic variant of 'latest-repository-commit'.
 342   (lambda (store)
 343     ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
 344     ;; translate it into '&message' conditions that we know will be properly
 345     ;; handled.
 346     (catch 'git-error
 347       (lambda ()
 348         (values (latest-repository-commit store url
 349                                           #:ref ref
 350                                           #:recursive? recursive?
 351                                           #:log-port log-port)
 352                 store))
 353       (lambda (key error . _)
 354         (raise (condition
 355                 (&message
 356                  (message
 357                   (match ref
 358                     (('commit . commit)
 359                      (format #f (G_ "cannot fetch commit ~a from ~a: ~a")
 360                              commit url (git-error-message error)))
 361                     (('branch . branch)
 362                      (format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
 363                              branch url (git-error-message error)))
 364                     (_
 365                      (format #f (G_ "Git failure while fetching ~a: ~a")
 366                              url (git-error-message error))))))))))))
 367
 368 (define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
 369                                              system target)
 370   ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
 371   ;; store.
 372   (match checkout
 373     (($ <git-checkout> url branch commit recursive?)
 374      (latest-repository-commit* url
 375                                 #:ref (if commit
 376                                           `(tag-or-commit . ,commit)
 377                                           `(branch . ,branch))
 378                                 #:recursive? recursive?
 379                                 #:log-port (current-error-port)))))
 380
 381 ;; Local Variables:
 382 ;; eval: (put 'with-repository 'scheme-indent-function 2)
 383 ;; End: