guix/git.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2018, 2019, 2020, 2021 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 (git submodule)
  24   #:use-module (guix i18n)
  25   #:use-module (guix base32)
  26   #:use-module (guix cache)
  27   #:use-module (gcrypt hash)
  28   #:use-module ((guix build utils)
  29                 #:select (mkdir-p delete-file-recursively))
  30   #:use-module (guix store)
  31   #:use-module (guix utils)
  32   #:use-module (guix records)
  33   #:use-module (guix gexp)
  34   #:use-module (guix sets)
  35   #:use-module ((guix diagnostics) #:select (leave))
  36   #:use-module (guix progress)
  37   #:use-module (rnrs bytevectors)
  38   #:use-module (ice-9 format)
  39   #:use-module (ice-9 match)
  40   #:use-module (ice-9 ftw)
  41   #:use-module (srfi srfi-1)
  42   #:use-module (srfi srfi-11)
  43   #:use-module (srfi srfi-34)
  44   #:use-module (srfi srfi-35)
  45   #:export (%repository-cache-directory
  46             honor-system-x509-certificates!
  47
  48             url-cache-directory
  49             with-repository
  50             with-git-error-handling
  51             false-if-git-not-found
  52             update-cached-checkout
  53             url+commit->name
  54             latest-repository-commit
  55             commit-difference
  56             commit-relation
  57
  58             git-checkout
  59             git-checkout?
  60             git-checkout-url
  61             git-checkout-branch
  62             git-checkout-commit
  63             git-checkout-recursive?))
  64
  65 (define %repository-cache-directory
  66   (make-parameter (string-append (cache-directory #:ensure? #f)
  67                                  "/checkouts")))
  68
  69 (define (honor-system-x509-certificates!)
  70   "Use the system's X.509 certificates for Git checkouts over HTTPS.  Honor
  71 the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
  72   ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of
  73   ;; files (instead of all the certificates) among which "ca-bundle.crt".  On
  74   ;; other distros /etc/ssl/certs usually contains the whole set of
  75   ;; certificates along with "ca-certificates.crt".  Try to choose the right
  76   ;; one.
  77   (let ((file      (letrec-syntax ((choose
  78                                     (syntax-rules ()
  79                                       ((_ file rest ...)
  80                                        (let ((f file))
  81                                          (if (and f (file-exists? f))
  82                                              f
  83                                              (choose rest ...))))
  84                                       ((_)
  85                                        #f))))
  86                      (choose (getenv "SSL_CERT_FILE")
  87                              "/etc/ssl/certs/ca-certificates.crt"
  88                              "/etc/ssl/certs/ca-bundle.crt")))
  89         (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
  90     (and (or file
  91              (and=> (stat directory #f)
  92                     (lambda (st)
  93                       (> (stat:nlink st) 2))))
  94          (begin
  95            (set-tls-certificate-locations! directory file)
  96            #t))))
  97
  98 (define %certificates-initialized?
  99   ;; Whether 'honor-system-x509-certificates!' has already been called.
 100   #f)
 101
 102 (define-syntax-rule (with-libgit2 thunk ...)
 103   (begin
 104     ;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
 105     ;; but pointer finalizers used in guile-git may be called after shutdown,
 106     ;; resulting in a segfault. Hence, let's skip shutdown call for now.
 107     (libgit2-init!)
 108     (unless %certificates-initialized?
 109       (honor-system-x509-certificates!)
 110       (set! %certificates-initialized? #t))
 111     thunk ...))
 112
 113 (define* (url-cache-directory url
 114                               #:optional (cache-directory
 115                                           (%repository-cache-directory))
 116                               #:key recursive?)
 117   "Return the directory associated to URL in %repository-cache-directory."
 118   (string-append
 119    cache-directory "/"
 120    (bytevector->base32-string
 121     (sha256 (string->utf8 (if recursive?
 122                               (string-append "R:" url)
 123                               url))))))
 124
 125 (define (show-progress progress)
 126   "Display a progress bar as we fetch Git code.  PROGRESS is an
 127 <indexer-progress> record from (git)."
 128   (define total
 129     (indexer-progress-total-objects progress))
 130
 131   (define hundredth
 132     (match (quotient (indexer-progress-total-objects progress) 100)
 133       (0 1)
 134       (x x)))
 135
 136   (define-values (done label)
 137     (if (< (indexer-progress-received-objects progress) total)
 138         (values (indexer-progress-received-objects progress)
 139                 (G_ "receiving objects"))
 140         (values (indexer-progress-indexed-objects progress)
 141                 (G_ "indexing objects"))))
 142
 143   (define %
 144     (* 100. (/ done total)))
 145
 146   (when (and (< % 100) (zero? (modulo done hundredth)))
 147     (erase-current-line (current-error-port))
 148     (let ((width (max (- (current-terminal-columns)
 149                          (string-length label) 7)
 150                       3)))
 151       (format (current-error-port) "~a ~3,d% ~a"
 152               label (inexact->exact (round %))
 153               (progress-bar % width)))
 154     (force-output (current-error-port)))
 155
 156   (when (= % 100.)
 157     ;; We're done, erase the line.
 158     (erase-current-line (current-error-port))
 159     (force-output (current-error-port)))
 160
 161   ;; Return true to indicate that we should go on.
 162   #t)
 163
 164 (define (make-default-fetch-options)
 165   "Return the default fetch options."
 166   (let ((auth-method (%make-auth-ssh-agent)))
 167     ;; The #:transfer-progress and #:proxy-url options appeared in Guile-Git
 168     ;; 0.4.0.  Omit them when using an older version.
 169     (catch 'wrong-number-of-args
 170       (lambda ()
 171         (make-fetch-options auth-method
 172                             ;; Guile-Git doesn't distinguish between these.
 173                             #:proxy-url (or (getenv "http_proxy")
 174                                             (getenv "https_proxy"))
 175                             #:transfer-progress
 176                             (and (isatty? (current-error-port))
 177                                  show-progress)))
 178       (lambda args
 179         (make-fetch-options auth-method)))))
 180
 181 (define (clone* url directory)
 182   "Clone git repository at URL into DIRECTORY.  Upon failure,
 183 make sure no empty directory is left behind."
 184   (with-throw-handler #t
 185     (lambda ()
 186       (mkdir-p directory)
 187
 188       (let ((auth-method (%make-auth-ssh-agent)))
 189         (clone url directory
 190                (make-clone-options
 191                 #:fetch-options (make-default-fetch-options)))))
 192     (lambda _
 193       (false-if-exception (rmdir directory)))))
 194
 195 (define (url+commit->name url sha1)
 196   "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
 197 the git repository, extracted from URL and SHA1:7 the seven first digits
 198 of SHA1 string."
 199   (string-append
 200    (string-replace-substring
 201     (last (string-split url #\/)) ".git" "")
 202    "-" (string-take sha1 7)))
 203
 204 (define (resolve-reference repository ref)
 205   "Resolve the branch, commit or tag specified by REF, and return the
 206 corresponding Git object."
 207   (let resolve ((ref ref))
 208     (match ref
 209       (('branch . branch)
 210        (let ((oid (reference-target
 211                    (branch-lookup repository branch BRANCH-REMOTE))))
 212          (object-lookup repository oid)))
 213       (('commit . commit)
 214        (let ((len (string-length commit)))
 215          ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
 216          ;; can't be sure it's available.  Furthermore, 'string->oid' used to
 217          ;; read out-of-bounds when passed a string shorter than 40 chars,
 218          ;; which is why we delay calls to it below.
 219          (if (< len 40)
 220              (object-lookup-prefix repository (string->oid commit) len)
 221              (object-lookup repository (string->oid commit)))))
 222       (('tag-or-commit . str)
 223        (if (or (> (string-length str) 40)
 224                (not (string-every char-set:hex-digit str)))
 225            (resolve `(tag . ,str))              ;definitely a tag
 226            (catch 'git-error
 227              (lambda ()
 228                (resolve `(tag . ,str)))
 229              (lambda _
 230                ;; There's no such tag, so it must be a commit ID.
 231                (resolve `(commit . ,str))))))
 232       (('tag    . tag)
 233        (let ((oid (reference-name->oid repository
 234                                        (string-append "refs/tags/" tag))))
 235          ;; OID may point to a "tag" object, but it can also point directly
 236          ;; to a "commit" object, as surprising as it may seem.  Return that
 237          ;; object, whatever that is.
 238          (object-lookup repository oid))))))
 239
 240 (define (switch-to-ref repository ref)
 241   "Switch to REPOSITORY's branch, commit or tag specified by REF.  Return the
 242 OID (roughly the commit hash) corresponding to REF."
 243   (define obj
 244     (resolve-reference repository ref))
 245
 246   (reset repository obj RESET_HARD)
 247   (object-id obj))
 248
 249 (define (call-with-repository directory proc)
 250   (let ((repository #f))
 251    (dynamic-wind
 252      (lambda ()
 253        (set! repository (repository-open directory)))
 254      (lambda ()
 255        (proc repository))
 256      (lambda ()
 257        (repository-close! repository)))))
 258
 259 (define-syntax-rule (with-repository directory repository exp ...)
 260   "Open the repository at DIRECTORY and bind REPOSITORY to it within the
 261 dynamic extent of EXP."
 262   (call-with-repository directory
 263                         (lambda (repository) exp ...)))
 264
 265 (define (report-git-error error)
 266   "Report the given Guile-Git error."
 267   ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
 268   ;; errors would be represented by integers.
 269   (match error
 270     ((? integer? error)                           ;old Guile-Git
 271      (leave (G_ "Git error ~a~%") error))
 272     ((? git-error? error)                         ;new Guile-Git
 273      (leave (G_ "Git error: ~a~%") (git-error-message error)))))
 274
 275 (define-syntax-rule (with-git-error-handling body ...)
 276   (catch 'git-error
 277     (lambda ()
 278       body ...)
 279     (lambda (key err)
 280       (report-git-error err))))
 281
 282 (define* (update-submodules repository
 283                             #:key (log-port (current-error-port)))
 284   "Update the submodules of REPOSITORY, a Git repository object."
 285   (for-each (lambda (name)
 286               (let ((submodule (submodule-lookup repository name)))
 287                 (format log-port (G_ "updating submodule '~a'...~%")
 288                         name)
 289                 (submodule-update submodule)
 290
 291                 ;; Recurse in SUBMODULE.
 292                 (let ((directory (string-append
 293                                   (repository-working-directory repository)
 294                                   "/" (submodule-path submodule))))
 295                   (with-repository directory repository
 296                     (update-submodules repository
 297                                        #:log-port log-port)))))
 298             (repository-submodules repository)))
 299
 300 (define-syntax-rule (false-if-git-not-found exp)
 301   "Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised."
 302   (catch 'git-error
 303     (lambda ()
 304       exp)
 305     (lambda (key error . rest)
 306       (if (= GIT_ENOTFOUND (git-error-code error))
 307           #f
 308           (apply throw key error rest)))))
 309
 310 (define (reference-available? repository ref)
 311   "Return true if REF, a reference such as '(commit . \"cabba9e\"), is
 312 definitely available in REPOSITORY, false otherwise."
 313   (match ref
 314     (('commit . commit)
 315      (let ((len (string-length commit))
 316            (oid (string->oid commit)))
 317        (false-if-git-not-found
 318         (->bool (if (< len 40)
 319                     (object-lookup-prefix repository oid len OBJ-COMMIT)
 320                     (commit-lookup repository oid))))))
 321     (_
 322      #f)))
 323
 324 (define cached-checkout-expiration
 325   ;; Return the expiration time procedure for a cached checkout.
 326   ;; TODO: Honor $GUIX_GIT_CACHE_EXPIRATION.
 327
 328   ;; Use the mtime rather than the atime to cope with file systems mounted
 329   ;; with 'noatime'.
 330   (file-expiration-time (* 90 24 3600) stat:mtime))
 331
 332 (define %checkout-cache-cleanup-period
 333   ;; Period for the removal of expired cached checkouts.
 334   (* 5 24 3600))
 335
 336 (define (delete-checkout directory)
 337   "Delete DIRECTORY recursively, in an atomic fashion."
 338   (let ((trashed (string-append directory ".trashed")))
 339     (rename-file directory trashed)
 340     (delete-file-recursively trashed)))
 341
 342 (define* (update-cached-checkout url
 343                                  #:key
 344                                  (ref '(branch . "master"))
 345                                  recursive?
 346                                  (check-out? #t)
 347                                  starting-commit
 348                                  (log-port (%make-void-port "w"))
 349                                  (cache-directory
 350                                   (url-cache-directory
 351                                    url (%repository-cache-directory)
 352                                    #:recursive? recursive?)))
 353   "Update the cached checkout of URL to REF in CACHE-DIRECTORY.  Return three
 354 values: the cache directory name, and the SHA1 commit (a string) corresponding
 355 to REF, and the relation of the new commit relative to STARTING-COMMIT (if
 356 provided) as returned by 'commit-relation'.
 357
 358 REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
 359 the associated data: [<branch name> | <sha1> | <tag name> | <string>].
 360
 361 When RECURSIVE? is true, check out submodules as well, if any.
 362
 363 When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave
 364 it unchanged."
 365   (define (cache-entries directory)
 366     (filter-map (match-lambda
 367                   ((or "." "..")
 368                    #f)
 369                   (file
 370                    (string-append directory "/" file)))
 371                 (or (scandir directory) '())))
 372
 373   (define canonical-ref
 374     ;; We used to require callers to specify "origin/" for each branch, which
 375     ;; made little sense since the cache should be transparent to them.  So
 376     ;; here we append "origin/" if it's missing and otherwise keep it.
 377     (match ref
 378       (('branch . branch)
 379        `(branch . ,(if (string-prefix? "origin/" branch)
 380                        branch
 381                        (string-append "origin/" branch))))
 382       (_ ref)))
 383
 384   (with-libgit2
 385    (let* ((cache-exists? (openable-repository? cache-directory))
 386           (repository    (if cache-exists?
 387                              (repository-open cache-directory)
 388                              (clone* url cache-directory))))
 389      ;; Only fetch remote if it has not been cloned just before.
 390      (when (and cache-exists?
 391                 (not (reference-available? repository ref)))
 392        (let ((auth-method (%make-auth-ssh-agent)))
 393          (remote-fetch (remote-lookup repository "origin")
 394                        #:fetch-options (make-default-fetch-options))))
 395      (when recursive?
 396        (update-submodules repository #:log-port log-port))
 397
 398      ;; Note: call 'commit-relation' from here because it's more efficient
 399      ;; than letting users re-open the checkout later on.
 400      (let* ((oid      (if check-out?
 401                           (switch-to-ref repository canonical-ref)
 402                           (object-id
 403                            (resolve-reference repository canonical-ref))))
 404             (new      (and starting-commit
 405                            (commit-lookup repository oid)))
 406             (old      (and starting-commit
 407                            (false-if-git-not-found
 408                             (commit-lookup repository
 409                                            (string->oid starting-commit)))))
 410             (relation (and starting-commit
 411                            (if old
 412                                (commit-relation old new)
 413                                'unrelated))))
 414
 415        ;; Reclaim file descriptors and memory mappings associated with
 416        ;; REPOSITORY as soon as possible.
 417        (repository-close! repository)
 418
 419        ;; When CACHE-DIRECTORY is a sub-directory of the default cache
 420        ;; directory, remove expired checkouts that are next to it.
 421        (let ((parent (dirname cache-directory)))
 422          (when (string=? parent (%repository-cache-directory))
 423            (maybe-remove-expired-cache-entries parent cache-entries
 424                                                #:entry-expiration
 425                                                cached-checkout-expiration
 426                                                #:delete-entry delete-checkout
 427                                                #:cleanup-period
 428                                                %checkout-cache-cleanup-period)))
 429
 430        (values cache-directory (oid->string oid) relation)))))
 431
 432 (define* (latest-repository-commit store url
 433                                    #:key
 434                                    recursive?
 435                                    (log-port (%make-void-port "w"))
 436                                    (cache-directory
 437                                     (%repository-cache-directory))
 438                                    (ref '(branch . "master")))
 439   "Return two values: the content of the git repository at URL copied into a
 440 store directory and the sha1 of the top level commit in this directory.  The
 441 reference to be checkout, once the repository is fetched, is specified by REF.
 442 REF is pair whose key is [branch | commit | tag] and value the associated
 443 data, respectively [<branch name> | <sha1> | <tag name>].
 444
 445 When RECURSIVE? is true, check out submodules as well, if any.
 446
 447 Git repositories are kept in the cache directory specified by
 448 %repository-cache-directory parameter.
 449
 450 Log progress and checkout info to LOG-PORT."
 451   (define (dot-git? file stat)
 452     (and (string=? (basename file) ".git")
 453          (or (eq? 'directory (stat:type stat))
 454
 455              ;; Submodule checkouts end up with a '.git' regular file that
 456              ;; contains metadata about where their actual '.git' directory
 457              ;; lives.
 458              (and recursive?
 459                   (eq? 'regular (stat:type stat))))))
 460
 461   (format log-port "updating checkout of '~a'...~%" url)
 462   (let*-values
 463       (((checkout commit _)
 464         (update-cached-checkout url
 465                                 #:recursive? recursive?
 466                                 #:ref ref
 467                                 #:cache-directory
 468                                 (url-cache-directory url cache-directory
 469                                                      #:recursive?
 470                                                      recursive?)
 471                                 #:log-port log-port))
 472        ((name)
 473         (url+commit->name url commit)))
 474     (format log-port "retrieved commit ~a~%" commit)
 475     (values (add-to-store store name #t "sha256" checkout
 476                           #:select? (negate dot-git?))
 477             commit)))
 478
 479 (define (print-git-error port key args default-printer)
 480   (match args
 481     (((? git-error? error) . _)
 482      (format port (G_ "Git error: ~a~%")
 483              (git-error-message error)))))
 484
 485 (set-exception-printer! 'git-error print-git-error)
 486
 487 \f
 488 ;;;
 489 ;;; Commit difference.
 490 ;;;
 491
 492 (define* (commit-closure commit #:optional (visited (setq)))
 493   "Return the closure of COMMIT as a set.  Skip commits contained in VISITED,
 494 a set, and adjoin VISITED to the result."
 495   (let loop ((commits (list commit))
 496              (visited visited))
 497     (match commits
 498       (()
 499        visited)
 500       ((head . tail)
 501        (if (set-contains? visited head)
 502            (loop tail visited)
 503            (loop (append (commit-parents head) tail)
 504                  (set-insert head visited)))))))
 505
 506 (define* (commit-difference new old #:optional (excluded '()))
 507   "Return the list of commits between NEW and OLD, where OLD is assumed to be
 508 an ancestor of NEW.  Exclude all the commits listed in EXCLUDED along with
 509 their ancestors.
 510
 511 Essentially, this computes the set difference between the closure of NEW and
 512 that of OLD."
 513   (let loop ((commits (list new))
 514              (result '())
 515              (visited (fold commit-closure
 516                             (setq)
 517                             (cons old excluded))))
 518     (match commits
 519       (()
 520        (reverse result))
 521       ((head . tail)
 522        (if (set-contains? visited head)
 523            (loop tail result visited)
 524            (loop (append (commit-parents head) tail)
 525                  (cons head result)
 526                  (set-insert head visited)))))))
 527
 528 (define (commit-relation old new)
 529   "Return a symbol denoting the relation between OLD and NEW, two commit
 530 objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
 531 'unrelated, or 'self (OLD and NEW are the same commit)."
 532   (if (eq? old new)
 533       'self
 534       (let ((newest (commit-closure new)))
 535         (if (set-contains? newest old)
 536             'ancestor
 537             (let* ((seen   (list->setq (commit-parents new)))
 538                    (oldest (commit-closure old seen)))
 539               (if (set-contains? oldest new)
 540                   'descendant
 541                   'unrelated))))))
 542
 543 \f
 544 ;;;
 545 ;;; Checkouts.
 546 ;;;
 547
 548 ;; Representation of the "latest" checkout of a branch or a specific commit.
 549 (define-record-type* <git-checkout>
 550   git-checkout make-git-checkout
 551   git-checkout?
 552   (url     git-checkout-url)
 553   (branch  git-checkout-branch (default "master"))
 554   (commit  git-checkout-commit (default #f))      ;#f | tag | commit
 555   (recursive? git-checkout-recursive? (default #f)))
 556
 557 (define* (latest-repository-commit* url #:key ref recursive? log-port)
 558   ;; Monadic variant of 'latest-repository-commit'.
 559   (lambda (store)
 560     ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
 561     ;; translate it into '&message' conditions that we know will be properly
 562     ;; handled.
 563     (catch 'git-error
 564       (lambda ()
 565         (values (latest-repository-commit store url
 566                                           #:ref ref
 567                                           #:recursive? recursive?
 568                                           #:log-port log-port)
 569                 store))
 570       (lambda (key error . _)
 571         (raise (condition
 572                 (&message
 573                  (message
 574                   (match ref
 575                     (('commit . commit)
 576                      (format #f (G_ "cannot fetch commit ~a from ~a: ~a")
 577                              commit url (git-error-message error)))
 578                     (('branch . branch)
 579                      (format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
 580                              branch url (git-error-message error)))
 581                     (_
 582                      (format #f (G_ "Git failure while fetching ~a: ~a")
 583                              url (git-error-message error))))))))))))
 584
 585 (define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
 586                                              system target)
 587   ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
 588   ;; store.
 589   (match checkout
 590     (($ <git-checkout> url branch commit recursive?)
 591      (latest-repository-commit* url
 592                                 #:ref (if commit
 593                                           `(tag-or-commit . ,commit)
 594                                           `(branch . ,branch))
 595                                 #:recursive? recursive?
 596                                 #:log-port (current-error-port)))))
 597
 598 ;; Local Variables:
 599 ;; eval: (put 'with-repository 'scheme-indent-function 2)
 600 ;; End: