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