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