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