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