guix/git.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2018, 2019 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
  51 ;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
  52 ;; See <http://bugs.gnu.org/12202>.
  53 (module-autoload! (current-module)
  54                   '(git submodule) '(repository-submodules))
  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 (define (clone* url directory)
 117   "Clone git repository at URL into DIRECTORY.  Upon failure,
 118 make sure no empty directory is left behind."
 119   (with-throw-handler #t
 120     (lambda ()
 121       (mkdir-p directory)
 122
 123       ;; Note: Explicitly pass options to work around the invalid default
 124       ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
 125       (if (module-defined? (resolve-interface '(git))
 126                            'clone-init-options)
 127           (clone url directory (clone-init-options))
 128           (clone url directory)))
 129     (lambda _
 130       (false-if-exception (rmdir directory)))))
 131
 132 (define (url+commit->name url sha1)
 133   "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
 134 the git repository, extracted from URL and SHA1:7 the seven first digits
 135 of SHA1 string."
 136   (string-append
 137    (string-replace-substring
 138     (last (string-split url #\/)) ".git" "")
 139    "-" (string-take sha1 7)))
 140
 141 (define (switch-to-ref repository ref)
 142   "Switch to REPOSITORY's branch, commit or tag specified by REF.  Return the
 143 OID (roughly the commit hash) corresponding to REF."
 144   (define obj
 145     (let resolve ((ref ref))
 146       (match ref
 147         (('branch . branch)
 148          (let ((oid (reference-target
 149                      (branch-lookup repository branch BRANCH-REMOTE))))
 150            (object-lookup repository oid)))
 151         (('commit . commit)
 152          (let ((len (string-length commit)))
 153            ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
 154            ;; can't be sure it's available.  Furthermore, 'string->oid' used to
 155            ;; read out-of-bounds when passed a string shorter than 40 chars,
 156            ;; which is why we delay calls to it below.
 157            (if (< len 40)
 158                (if (module-defined? (resolve-interface '(git object))
 159                                     'object-lookup-prefix)
 160                    (object-lookup-prefix repository (string->oid commit) len)
 161                    (raise (condition
 162                            (&message
 163                             (message "long Git object ID is required")))))
 164                (object-lookup repository (string->oid commit)))))
 165         (('tag-or-commit . str)
 166          (if (or (> (string-length str) 40)
 167                  (not (string-every char-set:hex-digit str)))
 168              (resolve `(tag . ,str))              ;definitely a tag
 169              (catch 'git-error
 170                (lambda ()
 171                  (resolve `(tag . ,str)))
 172                (lambda _
 173                  ;; There's no such tag, so it must be a commit ID.
 174                  (resolve `(commit . ,str))))))
 175         (('tag    . tag)
 176          (let ((oid (reference-name->oid repository
 177                                          (string-append "refs/tags/" tag))))
 178            ;; Get the commit that the tag at OID refers to.  This is not
 179            ;; strictly needed, but it's more consistent to always return the
 180            ;; OID of a commit.
 181            (object-lookup repository
 182                           (tag-target-id (tag-lookup repository oid))))))))
 183
 184   (reset repository obj RESET_HARD)
 185   (object-id obj))
 186
 187 (define (call-with-repository directory proc)
 188   (let ((repository #f))
 189    (dynamic-wind
 190      (lambda ()
 191        (set! repository (repository-open directory)))
 192      (lambda ()
 193        (proc repository))
 194      (lambda ()
 195        (repository-close! repository)))))
 196
 197 (define-syntax-rule (with-repository directory repository exp ...)
 198   "Open the repository at DIRECTORY and bind REPOSITORY to it within the
 199 dynamic extent of EXP."
 200   (call-with-repository directory
 201                         (lambda (repository) exp ...)))
 202
 203 (define* (update-submodules repository
 204                             #:key (log-port (current-error-port)))
 205   "Update the submodules of REPOSITORY, a Git repository object."
 206   ;; Guile-Git < 0.2.0 did not have (git submodule).
 207   (if (false-if-exception (resolve-interface '(git submodule)))
 208       (for-each (lambda (name)
 209                   (let ((submodule (submodule-lookup repository name)))
 210                     (format log-port (G_ "updating submodule '~a'...~%")
 211                             name)
 212                     (submodule-update submodule)
 213
 214                     ;; Recurse in SUBMODULE.
 215                     (let ((directory (string-append
 216                                       (repository-working-directory repository)
 217                                       "/" (submodule-path submodule))))
 218                       (with-repository directory repository
 219                         (update-submodules repository
 220                                            #:log-port log-port)))))
 221                 (repository-submodules repository))
 222       (format (current-error-port)
 223               (G_ "Support for submodules is missing; \
 224 please upgrade Guile-Git.~%"))))
 225
 226 (define (reference-available? repository ref)
 227   "Return true if REF, a reference such as '(commit . \"cabba9e\"), is
 228 definitely available in REPOSITORY, false otherwise."
 229   (match ref
 230     (('commit . commit)
 231      (catch 'git-error
 232        (lambda ()
 233          (->bool (commit-lookup repository (string->oid commit))))
 234        (lambda (key error . rest)
 235          (if (= GIT_ENOTFOUND (git-error-code error))
 236              #f
 237              (apply throw key error rest)))))
 238     (_
 239      #f)))
 240
 241 (define* (update-cached-checkout url
 242                                  #:key
 243                                  (ref '(branch . "master"))
 244                                  recursive?
 245                                  (log-port (%make-void-port "w"))
 246                                  (cache-directory
 247                                   (url-cache-directory
 248                                    url (%repository-cache-directory)
 249                                    #:recursive? recursive?)))
 250   "Update the cached checkout of URL to REF in CACHE-DIRECTORY.  Return two
 251 values: the cache directory name, and the SHA1 commit (a string) corresponding
 252 to REF.
 253
 254 REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
 255 the associated data: [<branch name> | <sha1> | <tag name> | <string>].
 256
 257 When RECURSIVE? is true, check out submodules as well, if any."
 258   (define canonical-ref
 259     ;; We used to require callers to specify "origin/" for each branch, which
 260     ;; made little sense since the cache should be transparent to them.  So
 261     ;; here we append "origin/" if it's missing and otherwise keep it.
 262     (match ref
 263       (('branch . branch)
 264        `(branch . ,(if (string-prefix? "origin/" branch)
 265                        branch
 266                        (string-append "origin/" branch))))
 267       (_ ref)))
 268
 269   (with-libgit2
 270    (let* ((cache-exists? (openable-repository? cache-directory))
 271           (repository    (if cache-exists?
 272                              (repository-open cache-directory)
 273                              (clone* url cache-directory))))
 274      ;; Only fetch remote if it has not been cloned just before.
 275      (when (and cache-exists?
 276                 (not (reference-available? repository ref)))
 277        (remote-fetch (remote-lookup repository "origin")))
 278      (when recursive?
 279        (update-submodules repository #:log-port log-port))
 280      (let ((oid (switch-to-ref repository canonical-ref)))
 281
 282        ;; Reclaim file descriptors and memory mappings associated with
 283        ;; REPOSITORY as soon as possible.
 284        (when (module-defined? (resolve-interface '(git repository))
 285                               'repository-close!)
 286          (repository-close! repository))
 287
 288        (values cache-directory (oid->string oid))))))
 289
 290 (define* (latest-repository-commit store url
 291                                    #:key
 292                                    recursive?
 293                                    (log-port (%make-void-port "w"))
 294                                    (cache-directory
 295                                     (%repository-cache-directory))
 296                                    (ref '(branch . "master")))
 297   "Return two values: the content of the git repository at URL copied into a
 298 store directory and the sha1 of the top level commit in this directory.  The
 299 reference to be checkout, once the repository is fetched, is specified by REF.
 300 REF is pair whose key is [branch | commit | tag] and value the associated
 301 data, respectively [<branch name> | <sha1> | <tag name>].
 302
 303 When RECURSIVE? is true, check out submodules as well, if any.
 304
 305 Git repositories are kept in the cache directory specified by
 306 %repository-cache-directory parameter.
 307
 308 Log progress and checkout info to LOG-PORT."
 309   (define (dot-git? file stat)
 310     (and (string=? (basename file) ".git")
 311          (or (eq? 'directory (stat:type stat))
 312
 313              ;; Submodule checkouts end up with a '.git' regular file that
 314              ;; contains metadata about where their actual '.git' directory
 315              ;; lives.
 316              (and recursive?
 317                   (eq? 'regular (stat:type stat))))))
 318
 319   (format log-port "updating checkout of '~a'...~%" url)
 320   (let*-values
 321       (((checkout commit)
 322         (update-cached-checkout url
 323                                 #:recursive? recursive?
 324                                 #:ref ref
 325                                 #:cache-directory
 326                                 (url-cache-directory url cache-directory
 327                                                      #:recursive?
 328                                                      recursive?)
 329                                 #:log-port log-port))
 330        ((name)
 331         (url+commit->name url commit)))
 332     (format log-port "retrieved commit ~a~%" commit)
 333     (values (add-to-store store name #t "sha256" checkout
 334                           #:select? (negate dot-git?))
 335             commit)))
 336
 337 (define (print-git-error port key args default-printer)
 338   (match args
 339     (((? git-error? error) . _)
 340      (format port (G_ "Git error: ~a~%")
 341              (git-error-message error)))))
 342
 343 (set-exception-printer! 'git-error print-git-error)
 344
 345 \f
 346 ;;;
 347 ;;; Commit difference.
 348 ;;;
 349
 350 (define (commit-closure commit)
 351   "Return the closure of COMMIT as a set."
 352   (let loop ((commits (list commit))
 353              (visited (setq)))
 354     (match commits
 355       (()
 356        visited)
 357       ((head . tail)
 358        (if (set-contains? visited head)
 359            (loop tail visited)
 360            (loop (append (commit-parents head) tail)
 361                  (set-insert head visited)))))))
 362
 363 (define (commit-difference new old)
 364   "Return the list of commits between NEW and OLD, where OLD is assumed to be
 365 an ancestor of NEW.
 366
 367 Essentially, this computes the set difference between the closure of NEW and
 368 that of OLD."
 369   (let loop ((commits (list new))
 370              (result '())
 371              (visited (commit-closure old)))
 372     (match commits
 373       (()
 374        (reverse result))
 375       ((head . tail)
 376        (if (set-contains? visited head)
 377            (loop tail result visited)
 378            (loop (append (commit-parents head) tail)
 379                  (cons head result)
 380                  (set-insert head visited)))))))
 381
 382 \f
 383 ;;;
 384 ;;; Checkouts.
 385 ;;;
 386
 387 ;; Representation of the "latest" checkout of a branch or a specific commit.
 388 (define-record-type* <git-checkout>
 389   git-checkout make-git-checkout
 390   git-checkout?
 391   (url     git-checkout-url)
 392   (branch  git-checkout-branch (default "master"))
 393   (commit  git-checkout-commit (default #f))      ;#f | tag | commit
 394   (recursive? git-checkout-recursive? (default #f)))
 395
 396 (define* (latest-repository-commit* url #:key ref recursive? log-port)
 397   ;; Monadic variant of 'latest-repository-commit'.
 398   (lambda (store)
 399     ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
 400     ;; translate it into '&message' conditions that we know will be properly
 401     ;; handled.
 402     (catch 'git-error
 403       (lambda ()
 404         (values (latest-repository-commit store url
 405                                           #:ref ref
 406                                           #:recursive? recursive?
 407                                           #:log-port log-port)
 408                 store))
 409       (lambda (key error . _)
 410         (raise (condition
 411                 (&message
 412                  (message
 413                   (match ref
 414                     (('commit . commit)
 415                      (format #f (G_ "cannot fetch commit ~a from ~a: ~a")
 416                              commit url (git-error-message error)))
 417                     (('branch . branch)
 418                      (format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
 419                              branch url (git-error-message error)))
 420                     (_
 421                      (format #f (G_ "Git failure while fetching ~a: ~a")
 422                              url (git-error-message error))))))))))))
 423
 424 (define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
 425                                              system target)
 426   ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
 427   ;; store.
 428   (match checkout
 429     (($ <git-checkout> url branch commit recursive?)
 430      (latest-repository-commit* url
 431                                 #:ref (if commit
 432                                           `(tag-or-commit . ,commit)
 433                                           `(branch . ,branch))
 434                                 #:recursive? recursive?
 435                                 #:log-port (current-error-port)))))
 436
 437 ;; Local Variables:
 438 ;; eval: (put 'with-repository 'scheme-indent-function 2)
 439 ;; End: