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