guix/git.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com>
   5 ;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
   6 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (guix git)
  24   #:use-module (git)
  25   #:use-module (git object)
  26   #:use-module (git submodule)
  27   #:use-module (guix i18n)
  28   #:use-module (guix base32)
  29   #:use-module (guix cache)
  30   #:use-module (gcrypt hash)
  31   #:use-module ((guix build utils)
  32                 #:select (mkdir-p delete-file-recursively))
  33   #:use-module (guix store)
  34   #:use-module (guix utils)
  35   #:use-module (guix records)
  36   #:use-module (guix gexp)
  37   #:autoload   (guix git-download)
  38   (git-reference-url git-reference-commit git-reference-recursive?)
  39   #:use-module (guix sets)
  40   #:use-module ((guix diagnostics) #:select (leave warning))
  41   #:use-module (guix progress)
  42   #:autoload   (guix swh) (swh-download commit-id?)
  43   #:use-module (rnrs bytevectors)
  44   #:use-module (ice-9 format)
  45   #:use-module (ice-9 match)
  46   #:use-module (ice-9 ftw)
  47   #:use-module (srfi srfi-1)
  48   #:use-module (srfi srfi-11)
  49   #:use-module (srfi srfi-26)
  50   #:use-module (srfi srfi-34)
  51   #:use-module (srfi srfi-35)
  52   #:export (%repository-cache-directory
  53             honor-system-x509-certificates!
  54
  55             url-cache-directory
  56             with-repository
  57             with-git-error-handling
  58             false-if-git-not-found
  59             update-cached-checkout
  60             url+commit->name
  61             latest-repository-commit
  62             commit-difference
  63             commit-relation
  64             commit-descendant?
  65             commit-id?
  66
  67             remote-refs
  68
  69             git-checkout
  70             git-checkout?
  71             git-checkout-url
  72             git-checkout-branch
  73             git-checkout-commit
  74             git-checkout-recursive?
  75
  76             git-reference->git-checkout))
  77
  78 (define %repository-cache-directory
  79   (make-parameter (string-append (cache-directory #:ensure? #f)
  80                                  "/checkouts")))
  81
  82 (define (honor-system-x509-certificates!)
  83   "Use the system's X.509 certificates for Git checkouts over HTTPS.  Honor
  84 the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
  85   ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of
  86   ;; files (instead of all the certificates) among which "ca-bundle.crt".  On
  87   ;; other distros /etc/ssl/certs usually contains the whole set of
  88   ;; certificates along with "ca-certificates.crt".  Try to choose the right
  89   ;; one.
  90   (let ((file      (letrec-syntax ((choose
  91                                     (syntax-rules ()
  92                                       ((_ file rest ...)
  93                                        (let ((f file))
  94                                          (if (and f (file-exists? f))
  95                                              f
  96                                              (choose rest ...))))
  97                                       ((_)
  98                                        #f))))
  99                      (choose (getenv "SSL_CERT_FILE")
 100                              "/etc/ssl/certs/ca-certificates.crt"
 101                              "/etc/ssl/certs/ca-bundle.crt")))
 102         (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
 103     (and (or file
 104              (and=> (stat directory #f)
 105                     (lambda (st)
 106                       (> (stat:nlink st) 2))))
 107          (begin
 108            (set-tls-certificate-locations! directory file)
 109            #t))))
 110
 111 (define %certificates-initialized?
 112   ;; Whether 'honor-system-x509-certificates!' has already been called.
 113   #f)
 114
 115 (define-syntax-rule (with-libgit2 thunk ...)
 116   (begin
 117     ;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
 118     ;; but pointer finalizers used in guile-git may be called after shutdown,
 119     ;; resulting in a segfault. Hence, let's skip shutdown call for now.
 120     (libgit2-init!)
 121     (unless %certificates-initialized?
 122       (honor-system-x509-certificates!)
 123       (set! %certificates-initialized? #t))
 124     thunk ...))
 125
 126 (define* (url-cache-directory url
 127                               #:optional (cache-directory
 128                                           (%repository-cache-directory))
 129                               #:key recursive?)
 130   "Return the directory associated to URL in %repository-cache-directory."
 131   (string-append
 132    cache-directory "/"
 133    (bytevector->base32-string
 134     (sha256 (string->utf8 (if recursive?
 135                               (string-append "R:" url)
 136                               url))))))
 137
 138 (define (show-progress progress)
 139   "Display a progress bar as we fetch Git code.  PROGRESS is an
 140 <indexer-progress> record from (git)."
 141   (define total
 142     (indexer-progress-total-objects progress))
 143
 144   (define hundredth
 145     (match (quotient (indexer-progress-total-objects progress) 100)
 146       (0 1)
 147       (x x)))
 148
 149   (define-values (done label)
 150     (if (< (indexer-progress-received-objects progress) total)
 151         (values (indexer-progress-received-objects progress)
 152                 (G_ "receiving objects"))
 153         (values (indexer-progress-indexed-objects progress)
 154                 (G_ "indexing objects"))))
 155
 156   (define %
 157     (* 100. (/ done total)))
 158
 159   (when (and (< % 100) (zero? (modulo done hundredth)))
 160     (erase-current-line (current-error-port))
 161     (let ((width (max (- (current-terminal-columns)
 162                          (string-length label) 7)
 163                       3)))
 164       (format (current-error-port) "~a ~3,d% ~a"
 165               label (inexact->exact (round %))
 166               (progress-bar % width)))
 167     (force-output (current-error-port)))
 168
 169   (when (= % 100.)
 170     ;; We're done, erase the line.
 171     (erase-current-line (current-error-port))
 172     (force-output (current-error-port)))
 173
 174   ;; Return true to indicate that we should go on.
 175   #t)
 176
 177 (define (make-default-fetch-options)
 178   "Return the default fetch options."
 179   (let ((auth-method (%make-auth-ssh-agent)))
 180     ;; The #:transfer-progress and #:proxy-url options appeared in Guile-Git
 181     ;; 0.4.0.  Omit them when using an older version.
 182     (catch 'wrong-number-of-args
 183       (lambda ()
 184         (make-fetch-options auth-method
 185                             ;; Guile-Git doesn't distinguish between these.
 186                             #:proxy-url (or (getenv "http_proxy")
 187                                             (getenv "https_proxy"))
 188                             #:transfer-progress
 189                             (and (isatty? (current-error-port))
 190                                  show-progress)))
 191       (lambda args
 192         (make-fetch-options auth-method)))))
 193
 194 (define GITERR_HTTP
 195   ;; Guile-Git <= 0.5.2 lacks this constant.
 196   (let ((errors (resolve-interface '(git errors))))
 197     (if (module-defined? errors 'GITERR_HTTP)
 198         (module-ref errors 'GITERR_HTTP)
 199         34)))
 200
 201 (define (clone* url directory)
 202   "Clone git repository at URL into DIRECTORY.  Upon failure,
 203 make sure no empty directory is left behind."
 204   (with-throw-handler #t
 205     (lambda ()
 206       (mkdir-p directory)
 207
 208       (clone url directory
 209              (make-clone-options
 210               #:fetch-options (make-default-fetch-options))))
 211     (lambda _
 212       (false-if-exception (rmdir directory)))))
 213
 214 (define (url+commit->name url sha1)
 215   "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
 216 the git repository, extracted from URL and SHA1:7 the seven first digits
 217 of SHA1 string."
 218   (string-append
 219    (string-replace-substring
 220     (last (string-split url #\/)) ".git" "")
 221    "-" (string-take sha1 7)))
 222
 223 (define (commit-id? str)
 224   "Return true if STR is likely a Git commit ID, false otherwise---e.g., if it
 225 is a tag name.  This is based on a simple heuristic so use with care!"
 226   (and (= (string-length str) 40)
 227        (string-every char-set:hex-digit str)))
 228
 229 (define (resolve-reference repository ref)
 230   "Resolve the branch, commit or tag specified by REF, and return the
 231 corresponding Git object."
 232   (let resolve ((ref ref))
 233     (match ref
 234       (('branch . branch)
 235        (let ((oid (reference-target
 236                    (branch-lookup repository branch BRANCH-REMOTE))))
 237          (object-lookup repository oid)))
 238       (('symref . symref)
 239        (let ((oid (reference-name->oid repository symref)))
 240          (object-lookup repository oid)))
 241       (('commit . commit)
 242        (let ((len (string-length commit)))
 243          ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
 244          ;; can't be sure it's available.  Furthermore, 'string->oid' used to
 245          ;; read out-of-bounds when passed a string shorter than 40 chars,
 246          ;; which is why we delay calls to it below.
 247          (if (< len 40)
 248              (object-lookup-prefix repository (string->oid commit) len)
 249              (object-lookup repository (string->oid commit)))))
 250       (('tag-or-commit . str)
 251        (cond ((and (string-contains str "-g")
 252                    (match (string-split str #\-)
 253                      ((version ... revision g+commit)
 254                       (if (and (> (string-length g+commit) 4)
 255                                (string-every char-set:digit revision)
 256                                (string-every char-set:hex-digit
 257                                              (string-drop g+commit 1)))
 258                           ;; Looks like a 'git describe' style ID, like
 259                           ;; v1.3.0-7-gaa34d4d28d.
 260                           (string-drop g+commit 1)
 261                           #f))
 262                      (_ #f)))
 263               => (lambda (commit) (resolve `(commit . ,commit))))
 264              ((or (> (string-length str) 40)
 265                   (not (string-every char-set:hex-digit str)))
 266               (resolve `(tag . ,str)))      ;definitely a tag
 267              (else
 268               (catch 'git-error
 269                 (lambda ()
 270                   (resolve `(tag . ,str)))
 271                 (lambda _
 272                   ;; There's no such tag, so it must be a commit ID.
 273                   (resolve `(commit . ,str)))))))
 274       (('tag    . tag)
 275        (let* ((oid (reference-name->oid repository
 276                                         (string-append "refs/tags/" tag)))
 277               (obj (object-lookup repository oid)))
 278          ;; OID may designate an "annotated tag" object or a "commit" object.
 279          ;; Return the commit object in both cases.
 280          (if (= OBJ-TAG (object-type obj))
 281              (object-lookup repository
 282                             (tag-target-id (tag-lookup repository oid)))
 283              obj))))))
 284
 285 (define (switch-to-ref repository ref)
 286   "Switch to REPOSITORY's branch, commit or tag specified by REF.  Return the
 287 OID (roughly the commit hash) corresponding to REF."
 288   (define obj
 289     (resolve-reference repository ref))
 290
 291   (reset repository obj RESET_HARD)
 292   (object-id obj))
 293
 294 (define (call-with-repository directory proc)
 295   (let ((repository #f))
 296    (dynamic-wind
 297      (lambda ()
 298        (set! repository (repository-open directory)))
 299      (lambda ()
 300        (proc repository))
 301      (lambda ()
 302        (repository-close! repository)))))
 303
 304 (define-syntax-rule (with-repository directory repository exp ...)
 305   "Open the repository at DIRECTORY and bind REPOSITORY to it within the
 306 dynamic extent of EXP."
 307   (call-with-repository directory
 308                         (lambda (repository) exp ...)))
 309
 310 (define (report-git-error error)
 311   "Report the given Guile-Git error."
 312   ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
 313   ;; errors would be represented by integers.
 314   (match error
 315     ((? integer? error)                           ;old Guile-Git
 316      (leave (G_ "Git error ~a~%") error))
 317     ((? git-error? error)                         ;new Guile-Git
 318      (leave (G_ "Git error: ~a~%") (git-error-message error)))))
 319
 320 (define-syntax-rule (with-git-error-handling body ...)
 321   (catch 'git-error
 322     (lambda ()
 323       body ...)
 324     (lambda (key err)
 325       (report-git-error err))))
 326
 327 (define* (update-submodules repository
 328                             #:key (log-port (current-error-port))
 329                             (fetch-options #f))
 330   "Update the submodules of REPOSITORY, a Git repository object."
 331   (for-each (lambda (name)
 332               (let ((submodule (submodule-lookup repository name)))
 333                 (format log-port (G_ "updating submodule '~a'...~%")
 334                         name)
 335                 (submodule-update submodule
 336                                   #:fetch-options fetch-options)
 337
 338                 ;; Recurse in SUBMODULE.
 339                 (let ((directory (string-append
 340                                   (repository-working-directory repository)
 341                                   "/" (submodule-path submodule))))
 342                   (with-repository directory repository
 343                     (update-submodules repository
 344                                        #:fetch-options fetch-options
 345                                        #:log-port log-port)))))
 346             (repository-submodules repository)))
 347
 348 (define-syntax-rule (false-if-git-not-found exp)
 349   "Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised."
 350   (catch 'git-error
 351     (lambda ()
 352       exp)
 353     (lambda (key error . rest)
 354       (if (= GIT_ENOTFOUND (git-error-code error))
 355           #f
 356           (apply throw key error rest)))))
 357
 358 (define (reference-available? repository ref)
 359   "Return true if REF, a reference such as '(commit . \"cabba9e\"), is
 360 definitely available in REPOSITORY, false otherwise."
 361   (match ref
 362     ((or ('commit . commit)
 363          ('tag-or-commit . (? commit-id? commit)))
 364      (let ((len (string-length commit))
 365            (oid (string->oid commit)))
 366        (false-if-git-not-found
 367         (->bool (if (< len 40)
 368                     (object-lookup-prefix repository oid len OBJ-COMMIT)
 369                     (commit-lookup repository oid))))))
 370     (_
 371      #f)))
 372
 373 (define (clone-from-swh url tag-or-commit output)
 374   "Attempt to clone TAG-OR-COMMIT (a string), which originates from URL, using
 375 a copy archived at Software Heritage."
 376   (call-with-temporary-directory
 377    (lambda (bare)
 378      (and (swh-download url tag-or-commit bare
 379                         #:archive-type 'git-bare)
 380           (let ((repository (clone* bare output)))
 381             (remote-set-url! repository "origin" url)
 382             repository)))))
 383
 384 (define (clone/swh-fallback url ref cache-directory)
 385   "Like 'clone', but fallback to Software Heritage if the repository cannot be
 386 found at URL."
 387   (define (inaccessible-url-error? err)
 388     (let ((class (git-error-class err))
 389           (code  (git-error-code err)))
 390       (or (= class GITERR_HTTP)                   ;404 or similar
 391           (= class GITERR_NET))))                 ;unknown host, etc.
 392
 393   (catch 'git-error
 394     (lambda ()
 395       (clone* url cache-directory))
 396     (lambda (key err)
 397       (match ref
 398         (((or 'commit 'tag-or-commit) . commit)
 399          (if (inaccessible-url-error? err)
 400              (or (clone-from-swh url commit cache-directory)
 401                  (begin
 402                    (warning (G_ "revision ~a of ~a \
 403 could not be fetched from Software Heritage~%")
 404                             commit url)
 405                    (throw key err)))
 406              (throw key err)))
 407         (_ (throw key err))))))
 408
 409 (define cached-checkout-expiration
 410   ;; Return the expiration time procedure for a cached checkout.
 411   ;; TODO: Honor $GUIX_GIT_CACHE_EXPIRATION.
 412
 413   ;; Use the mtime rather than the atime to cope with file systems mounted
 414   ;; with 'noatime'.
 415   (file-expiration-time (* 90 24 3600) stat:mtime))
 416
 417 (define %checkout-cache-cleanup-period
 418   ;; Period for the removal of expired cached checkouts.
 419   (* 5 24 3600))
 420
 421 (define (delete-checkout directory)
 422   "Delete DIRECTORY recursively, in an atomic fashion."
 423   (let ((trashed (string-append directory ".trashed")))
 424     (rename-file directory trashed)
 425     (delete-file-recursively trashed)))
 426
 427 (define* (update-cached-checkout url
 428                                  #:key
 429                                  (ref '())
 430                                  recursive?
 431                                  (check-out? #t)
 432                                  starting-commit
 433                                  (log-port (%make-void-port "w"))
 434                                  (cache-directory
 435                                   (url-cache-directory
 436                                    url (%repository-cache-directory)
 437                                    #:recursive? recursive?)))
 438   "Update the cached checkout of URL to REF in CACHE-DIRECTORY.  Return three
 439 values: the cache directory name, and the SHA1 commit (a string) corresponding
 440 to REF, and the relation of the new commit relative to STARTING-COMMIT (if
 441 provided) as returned by 'commit-relation'.
 442
 443 REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
 444 the associated data: [<branch name> | <sha1> | <tag name> | <string>].
 445 If REF is the empty list, the remote HEAD is used.
 446
 447 When RECURSIVE? is true, check out submodules as well, if any.
 448
 449 When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave
 450 it unchanged."
 451   (define (cache-entries directory)
 452     (filter-map (match-lambda
 453                   ((or "." "..")
 454                    #f)
 455                   (file
 456                    (string-append directory "/" file)))
 457                 (or (scandir directory) '())))
 458
 459   (define canonical-ref
 460     ;; We used to require callers to specify "origin/" for each branch, which
 461     ;; made little sense since the cache should be transparent to them.  So
 462     ;; here we append "origin/" if it's missing and otherwise keep it.
 463     (match ref
 464       (() '(symref . "refs/remotes/origin/HEAD"))
 465       (('branch . branch)
 466        `(branch . ,(if (string-prefix? "origin/" branch)
 467                        branch
 468                        (string-append "origin/" branch))))
 469       (_ ref)))
 470
 471   (with-libgit2
 472    (let* ((cache-exists? (openable-repository? cache-directory))
 473           (repository    (if cache-exists?
 474                              (repository-open cache-directory)
 475                              (clone/swh-fallback url ref cache-directory))))
 476      ;; Only fetch remote if it has not been cloned just before.
 477      (when (and cache-exists?
 478                 (not (reference-available? repository ref)))
 479        (remote-fetch (remote-lookup repository "origin")
 480                      #:fetch-options (make-default-fetch-options)))
 481      (when recursive?
 482        (update-submodules repository #:log-port log-port
 483                           #:fetch-options (make-default-fetch-options)))
 484
 485      ;; Note: call 'commit-relation' from here because it's more efficient
 486      ;; than letting users re-open the checkout later on.
 487      (let* ((oid      (if check-out?
 488                           (switch-to-ref repository canonical-ref)
 489                           (object-id
 490                            (resolve-reference repository canonical-ref))))
 491             (new      (and starting-commit
 492                            (commit-lookup repository oid)))
 493             (old      (and starting-commit
 494                            (false-if-git-not-found
 495                             (commit-lookup repository
 496                                            (string->oid starting-commit)))))
 497             (relation (and starting-commit
 498                            (if old
 499                                (commit-relation old new)
 500                                'unrelated))))
 501
 502        ;; Reclaim file descriptors and memory mappings associated with
 503        ;; REPOSITORY as soon as possible.
 504        (repository-close! repository)
 505
 506        ;; Update CACHE-DIRECTORY's mtime to so the cache logic sees it.
 507        (match (gettimeofday)
 508          ((seconds . microseconds)
 509           (let ((nanoseconds (* 1000 microseconds)))
 510             (utime cache-directory
 511                    seconds seconds
 512                    nanoseconds nanoseconds))))
 513
 514        ;; When CACHE-DIRECTORY is a sub-directory of the default cache
 515        ;; directory, remove expired checkouts that are next to it.
 516        (let ((parent (dirname cache-directory)))
 517          (when (string=? parent (%repository-cache-directory))
 518            (maybe-remove-expired-cache-entries parent cache-entries
 519                                                #:entry-expiration
 520                                                cached-checkout-expiration
 521                                                #:delete-entry delete-checkout
 522                                                #:cleanup-period
 523                                                %checkout-cache-cleanup-period)))
 524
 525        (values cache-directory (oid->string oid) relation)))))
 526
 527 (define* (latest-repository-commit store url
 528                                    #:key
 529                                    recursive?
 530                                    (log-port (%make-void-port "w"))
 531                                    (cache-directory
 532                                     (%repository-cache-directory))
 533                                    (ref '()))
 534   "Return two values: the content of the git repository at URL copied into a
 535 store directory and the sha1 of the top level commit in this directory.  The
 536 reference to be checkout, once the repository is fetched, is specified by REF.
 537 REF is pair whose key is [branch | commit | tag] and value the associated
 538 data, respectively [<branch name> | <sha1> | <tag name>].  If REF is the empty
 539 list, the remote HEAD is used.
 540
 541 When RECURSIVE? is true, check out submodules as well, if any.
 542
 543 Git repositories are kept in the cache directory specified by
 544 %repository-cache-directory parameter.
 545
 546 Log progress and checkout info to LOG-PORT."
 547   (define (dot-git? file stat)
 548     (and (string=? (basename file) ".git")
 549          (or (eq? 'directory (stat:type stat))
 550
 551              ;; Submodule checkouts end up with a '.git' regular file that
 552              ;; contains metadata about where their actual '.git' directory
 553              ;; lives.
 554              (and recursive?
 555                   (eq? 'regular (stat:type stat))))))
 556
 557   (format log-port "updating checkout of '~a'...~%" url)
 558   (let*-values
 559       (((checkout commit _)
 560         (update-cached-checkout url
 561                                 #:recursive? recursive?
 562                                 #:ref ref
 563                                 #:cache-directory
 564                                 (url-cache-directory url cache-directory
 565                                                      #:recursive?
 566                                                      recursive?)
 567                                 #:log-port log-port))
 568        ((name)
 569         (url+commit->name url commit)))
 570     (format log-port "retrieved commit ~a~%" commit)
 571     (values (add-to-store store name #t "sha256" checkout
 572                           #:select? (negate dot-git?))
 573             commit)))
 574
 575 (define (print-git-error port key args default-printer)
 576   (match args
 577     (((? git-error? error) . _)
 578      (format port (G_ "Git error: ~a~%")
 579              (git-error-message error)))))
 580
 581 (set-exception-printer! 'git-error print-git-error)
 582
 583 \f
 584 ;;;
 585 ;;; Commit difference.
 586 ;;;
 587
 588 (define* (commit-closure commit #:optional (visited (setq)))
 589   "Return the closure of COMMIT as a set.  Skip commits contained in VISITED,
 590 a set, and adjoin VISITED to the result."
 591   (let loop ((commits (list commit))
 592              (visited visited))
 593     (match commits
 594       (()
 595        visited)
 596       ((head . tail)
 597        (if (set-contains? visited head)
 598            (loop tail visited)
 599            (loop (append (commit-parents head) tail)
 600                  (set-insert head visited)))))))
 601
 602 (define* (commit-difference new old #:optional (excluded '()))
 603   "Return the list of commits between NEW and OLD, where OLD is assumed to be
 604 an ancestor of NEW.  Exclude all the commits listed in EXCLUDED along with
 605 their ancestors.
 606
 607 Essentially, this computes the set difference between the closure of NEW and
 608 that of OLD."
 609   (let loop ((commits (list new))
 610              (result '())
 611              (visited (fold commit-closure
 612                             (setq)
 613                             (cons old excluded))))
 614     (match commits
 615       (()
 616        (reverse result))
 617       ((head . tail)
 618        (if (set-contains? visited head)
 619            (loop tail result visited)
 620            (loop (append (commit-parents head) tail)
 621                  (cons head result)
 622                  (set-insert head visited)))))))
 623
 624 (define (commit-relation old new)
 625   "Return a symbol denoting the relation between OLD and NEW, two commit
 626 objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
 627 'unrelated, or 'self (OLD and NEW are the same commit)."
 628   (if (eq? old new)
 629       'self
 630       (let ((newest (commit-closure new)))
 631         (if (set-contains? newest old)
 632             'ancestor
 633             (let* ((seen   (list->setq (commit-parents new)))
 634                    (oldest (commit-closure old seen)))
 635               (if (set-contains? oldest new)
 636                   'descendant
 637                   'unrelated))))))
 638
 639 (define (commit-descendant? new old)
 640   "Return true if NEW is the descendant of one of OLD, a list of commits.
 641
 642 When the expected result is likely #t, this is faster than using
 643 'commit-relation' since fewer commits need to be traversed."
 644   (let ((old (list->setq old)))
 645     (let loop ((commits (list new))
 646                (visited (setq)))
 647       (match commits
 648         (()
 649          #f)
 650         (_
 651          ;; Perform a breadth-first search as this is likely going to
 652          ;; terminate more quickly than a depth-first search.
 653          (let ((commits (remove (cut set-contains? visited <>) commits)))
 654            (or (any (cut set-contains? old <>) commits)
 655                (loop (append-map commit-parents commits)
 656                      (fold set-insert visited commits)))))))))
 657
 658 \f
 659 ;;
 660 ;;; Remote operations.
 661 ;;;
 662
 663 (define* (remote-refs url #:key tags?)
 664   "Return the list of references advertised at Git repository URL.  If TAGS?
 665 is true, limit to only refs/tags."
 666   (define (ref? ref)
 667     ;; Like `git ls-remote --refs', only show actual references.
 668     (and (string-prefix? "refs/" ref)
 669          (not (string-suffix? "^{}" ref))))
 670
 671   (define (tag? ref)
 672     (string-prefix? "refs/tags/" ref))
 673
 674   (define (include? ref)
 675     (and (ref? ref)
 676          (or (not tags?) (tag? ref))))
 677
 678   (define (remote-head->ref remote)
 679     (let ((name (remote-head-name remote)))
 680       (and (include? name)
 681            name)))
 682
 683   (with-libgit2
 684    (call-with-temporary-directory
 685     (lambda (cache-directory)
 686       (let* ((repository (repository-init cache-directory))
 687              ;; Create an in-memory remote so we don't touch disk.
 688              (remote (remote-create-anonymous repository url)))
 689         (remote-connect remote)
 690
 691         (let* ((remote-heads (remote-ls remote))
 692                (refs (filter-map remote-head->ref remote-heads)))
 693           ;; Wait until we're finished with the repository before closing it.
 694           (remote-disconnect remote)
 695           (repository-close! repository)
 696           refs))))))
 697
 698 \f
 699 ;;;
 700 ;;; Checkouts.
 701 ;;;
 702
 703 ;; Representation of the "latest" checkout of a branch or a specific commit.
 704 (define-record-type* <git-checkout>
 705   git-checkout make-git-checkout
 706   git-checkout?
 707   (url     git-checkout-url)
 708   (branch  git-checkout-branch (default #f))
 709   (commit  git-checkout-commit (default #f))      ;#f | tag | commit
 710   (recursive? git-checkout-recursive? (default #f)))
 711
 712 (define (git-reference->git-checkout reference)
 713   "Convert the <git-reference> REFERENCE to an equivalent <git-checkout>."
 714   (git-checkout
 715    (url (git-reference-url reference))
 716    (commit (git-reference-commit reference))
 717    (recursive? (git-reference-recursive? reference))))
 718
 719 (define* (latest-repository-commit* url #:key ref recursive? log-port)
 720   ;; Monadic variant of 'latest-repository-commit'.
 721   (lambda (store)
 722     ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
 723     ;; translate it into '&message' conditions that we know will be properly
 724     ;; handled.
 725     (catch 'git-error
 726       (lambda ()
 727         (values (latest-repository-commit store url
 728                                           #:ref ref
 729                                           #:recursive? recursive?
 730                                           #:log-port log-port)
 731                 store))
 732       (lambda (key error . _)
 733         (raise (condition
 734                 (&message
 735                  (message
 736                   (match ref
 737                     (('commit . commit)
 738                      (format #f (G_ "cannot fetch commit ~a from ~a: ~a")
 739                              commit url (git-error-message error)))
 740                     (('branch . branch)
 741                      (format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
 742                              branch url (git-error-message error)))
 743                     (_
 744                      (format #f (G_ "Git failure while fetching ~a: ~a")
 745                              url (git-error-message error))))))))))))
 746
 747 (define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
 748                                              system target)
 749   ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
 750   ;; store.
 751   (match checkout
 752     (($ <git-checkout> url branch commit recursive?)
 753      (latest-repository-commit* url
 754                                 #:ref (cond (commit
 755                                              `(tag-or-commit . ,commit))
 756                                             (branch
 757                                              `(branch . ,branch))
 758                                             (else '()))
 759                                 #:recursive? recursive?
 760                                 #:log-port (current-error-port)))))
 761
 762 ;; Local Variables:
 763 ;; eval: (put 'with-repository 'scheme-indent-function 2)
 764 ;; End: