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 (rnrs bytevectors)
  32   #:use-module (ice-9 match)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-11)
  35   #:use-module (srfi srfi-34)
  36   #:use-module (srfi srfi-35)
  37   #:export (%repository-cache-directory
  38             honor-system-x509-certificates!
  39
  40             update-cached-checkout
  41             latest-repository-commit
  42
  43             git-checkout
  44             git-checkout?
  45             git-checkout-url
  46             git-checkout-branch))
  47
  48 ;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
  49 ;; See <http://bugs.gnu.org/12202>.
  50 (module-autoload! (current-module)
  51                   '(git submodule) '(repository-submodules))
  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 (define (clone* url directory)
 114   "Clone git repository at URL into DIRECTORY.  Upon failure,
 115 make sure no empty directory is left behind."
 116   (with-throw-handler #t
 117     (lambda ()
 118       (mkdir-p directory)
 119
 120       ;; Note: Explicitly pass options to work around the invalid default
 121       ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
 122       (if (module-defined? (resolve-interface '(git))
 123                            'clone-init-options)
 124           (clone url directory (clone-init-options))
 125           (clone url directory)))
 126     (lambda _
 127       (false-if-exception (rmdir directory)))))
 128
 129 (define (url+commit->name url sha1)
 130   "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
 131 the git repository, extracted from URL and SHA1:7 the seven first digits
 132 of SHA1 string."
 133   (string-append
 134    (string-replace-substring
 135     (last (string-split url #\/)) ".git" "")
 136    "-" (string-take sha1 7)))
 137
 138 (define (switch-to-ref repository ref)
 139   "Switch to REPOSITORY's branch, commit or tag specified by REF.  Return the
 140 OID (roughly the commit hash) corresponding to REF."
 141   (define obj
 142     (match ref
 143       (('branch . branch)
 144        (let ((oid (reference-target
 145                    (branch-lookup repository branch BRANCH-REMOTE))))
 146          (object-lookup repository oid)))
 147       (('commit . commit)
 148        (let ((len (string-length commit)))
 149          ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
 150          ;; can't be sure it's available.  Furthermore, 'string->oid' used to
 151          ;; read out-of-bounds when passed a string shorter than 40 chars,
 152          ;; which is why we delay calls to it below.
 153          (if (< len 40)
 154              (if (module-defined? (resolve-interface '(git object))
 155                                   'object-lookup-prefix)
 156                  (object-lookup-prefix repository (string->oid commit) len)
 157                  (raise (condition
 158                          (&message
 159                           (message "long Git object ID is required")))))
 160              (object-lookup repository (string->oid commit)))))
 161       (('tag    . tag)
 162        (let ((oid (reference-name->oid repository
 163                                        (string-append "refs/tags/" tag))))
 164          (object-lookup repository oid)))))
 165
 166   (reset repository obj RESET_HARD)
 167   (object-id obj))
 168
 169 (define (call-with-repository directory proc)
 170   (let ((repository #f))
 171    (dynamic-wind
 172      (lambda ()
 173        (set! repository (repository-open directory)))
 174      (lambda ()
 175        (proc repository))
 176      (lambda ()
 177        (repository-close! repository)))))
 178
 179 (define-syntax-rule (with-repository directory repository exp ...)
 180   "Open the repository at DIRECTORY and bind REPOSITORY to it within the
 181 dynamic extent of EXP."
 182   (call-with-repository directory
 183                         (lambda (repository) exp ...)))
 184
 185 (define* (update-submodules repository
 186                             #:key (log-port (current-error-port)))
 187   "Update the submodules of REPOSITORY, a Git repository object."
 188   ;; Guile-Git < 0.2.0 did not have (git submodule).
 189   (if (false-if-exception (resolve-interface '(git submodule)))
 190       (for-each (lambda (name)
 191                   (let ((submodule (submodule-lookup repository name)))
 192                     (format log-port (G_ "updating submodule '~a'...~%")
 193                             name)
 194                     (submodule-update submodule)
 195
 196                     ;; Recurse in SUBMODULE.
 197                     (let ((directory (string-append
 198                                       (repository-working-directory repository)
 199                                       "/" (submodule-path submodule))))
 200                       (with-repository directory repository
 201                         (update-submodules repository
 202                                            #:log-port log-port)))))
 203                 (repository-submodules repository))
 204       (format (current-error-port)
 205               (G_ "Support for submodules is missing; \
 206 please upgrade Guile-Git.~%"))))
 207
 208 (define* (update-cached-checkout url
 209                                  #:key
 210                                  (ref '(branch . "master"))
 211                                  recursive?
 212                                  (log-port (%make-void-port "w"))
 213                                  (cache-directory
 214                                   (url-cache-directory
 215                                    url (%repository-cache-directory)
 216                                    #:recursive? recursive?)))
 217   "Update the cached checkout of URL to REF in CACHE-DIRECTORY.  Return two
 218 values: the cache directory name, and the SHA1 commit (a string) corresponding
 219 to REF.
 220
 221 REF is pair whose key is [branch | commit | tag] and value the associated
 222 data, respectively [<branch name> | <sha1> | <tag name>].
 223
 224 When RECURSIVE? is true, check out submodules as well, if any."
 225   (define canonical-ref
 226     ;; We used to require callers to specify "origin/" for each branch, which
 227     ;; made little sense since the cache should be transparent to them.  So
 228     ;; here we append "origin/" if it's missing and otherwise keep it.
 229     (match ref
 230       (('branch . branch)
 231        `(branch . ,(if (string-prefix? "origin/" branch)
 232                        branch
 233                        (string-append "origin/" branch))))
 234       (_ ref)))
 235
 236   (with-libgit2
 237    (let* ((cache-exists? (openable-repository? cache-directory))
 238           (repository    (if cache-exists?
 239                              (repository-open cache-directory)
 240                              (clone* url cache-directory))))
 241      ;; Only fetch remote if it has not been cloned just before.
 242      (when cache-exists?
 243        (remote-fetch (remote-lookup repository "origin")))
 244      (when recursive?
 245        (update-submodules repository #:log-port log-port))
 246      (let ((oid (switch-to-ref repository canonical-ref)))
 247
 248        ;; Reclaim file descriptors and memory mappings associated with
 249        ;; REPOSITORY as soon as possible.
 250        (when (module-defined? (resolve-interface '(git repository))
 251                               'repository-close!)
 252          (repository-close! repository))
 253
 254        (values cache-directory (oid->string oid))))))
 255
 256 (define* (latest-repository-commit store url
 257                                    #:key
 258                                    recursive?
 259                                    (log-port (%make-void-port "w"))
 260                                    (cache-directory
 261                                     (%repository-cache-directory))
 262                                    (ref '(branch . "master")))
 263   "Return two values: the content of the git repository at URL copied into a
 264 store directory and the sha1 of the top level commit in this directory.  The
 265 reference to be checkout, once the repository is fetched, is specified by REF.
 266 REF is pair whose key is [branch | commit | tag] and value the associated
 267 data, respectively [<branch name> | <sha1> | <tag name>].
 268
 269 When RECURSIVE? is true, check out submodules as well, if any.
 270
 271 Git repositories are kept in the cache directory specified by
 272 %repository-cache-directory parameter.
 273
 274 Log progress and checkout info to LOG-PORT."
 275   (define (dot-git? file stat)
 276     (and (string=? (basename file) ".git")
 277          (or (eq? 'directory (stat:type stat))
 278
 279              ;; Submodule checkouts end up with a '.git' regular file that
 280              ;; contains metadata about where their actual '.git' directory
 281              ;; lives.
 282              (and recursive?
 283                   (eq? 'regular (stat:type stat))))))
 284
 285   (format log-port "updating checkout of '~a'...~%" url)
 286   (let*-values
 287       (((checkout commit)
 288         (update-cached-checkout url
 289                                 #:recursive? recursive?
 290                                 #:ref ref
 291                                 #:cache-directory
 292                                 (url-cache-directory url cache-directory
 293                                                      #:recursive?
 294                                                      recursive?)
 295                                 #:log-port log-port))
 296        ((name)
 297         (url+commit->name url commit)))
 298     (format log-port "retrieved commit ~a~%" commit)
 299     (values (add-to-store store name #t "sha256" checkout
 300                           #:select? (negate dot-git?))
 301             commit)))
 302
 303 (define (print-git-error port key args default-printer)
 304   (match args
 305     (((? git-error? error) . _)
 306      (format port (G_ "Git error: ~a~%")
 307              (git-error-message error)))))
 308
 309 (set-exception-printer! 'git-error print-git-error)
 310
 311 \f
 312 ;;;
 313 ;;; Checkouts.
 314 ;;;
 315
 316 ;; Representation of the "latest" checkout of a branch or a specific commit.
 317 (define-record-type* <git-checkout>
 318   git-checkout make-git-checkout
 319   git-checkout?
 320   (url     git-checkout-url)
 321   (branch  git-checkout-branch (default "master"))
 322   (commit  git-checkout-commit (default #f))
 323   (recursive? git-checkout-recursive? (default #f)))
 324
 325 (define* (latest-repository-commit* url #:key ref recursive? log-port)
 326   ;; Monadic variant of 'latest-repository-commit'.
 327   (lambda (store)
 328     ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
 329     ;; translate it into '&message' conditions that we know will be properly
 330     ;; handled.
 331     (catch 'git-error
 332       (lambda ()
 333         (values (latest-repository-commit store url
 334                                           #:ref ref
 335                                           #:recursive? recursive?
 336                                           #:log-port log-port)
 337                 store))
 338       (lambda (key error . _)
 339         (raise (condition
 340                 (&message
 341                  (message
 342                   (match ref
 343                     (('commit . commit)
 344                      (format #f (G_ "cannot fetch commit ~a from ~a: ~a")
 345                              commit url (git-error-message error)))
 346                     (('branch . branch)
 347                      (format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
 348                              branch url (git-error-message error)))
 349                     (_
 350                      (format #f (G_ "Git failure while fetching ~a: ~a")
 351                              url (git-error-message error))))))))))))
 352
 353 (define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
 354                                              system target)
 355   ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
 356   ;; store.
 357   (match checkout
 358     (($ <git-checkout> url branch commit recursive?)
 359      (latest-repository-commit* url
 360                                 #:ref (if commit
 361                                           `(commit . ,commit)
 362                                           `(branch . ,branch))
 363                                 #:recursive? recursive?
 364                                 #:log-port (current-error-port)))))
 365
 366 ;; Local Variables:
 367 ;; eval: (put 'with-repository 'scheme-indent-function 2)
 368 ;; End: