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