[jackhill/guix/guix.git] / guix / git.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix git)
  #:use-module (git)
  #:use-module (git object)
  #:use-module (guix i18n)
  #:use-module (guix base32)
  #:use-module (gcrypt hash)
  #:use-module ((guix build utils) #:select (mkdir-p))
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (%repository-cache-directory
            honor-system-x509-certificates!

            update-cached-checkout
            latest-repository-commit

            git-checkout
            git-checkout?
            git-checkout-url
            git-checkout-branch))

;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
;; See <http://bugs.gnu.org/12202>.
(module-autoload! (current-module)
                  '(git submodule) '(repository-submodules))

(define %repository-cache-directory
  (make-parameter (string-append (cache-directory #:ensure? #f)
                                 "/checkouts")))

(define (honor-system-x509-certificates!)
  "Use the system's X.509 certificates for Git checkouts over HTTPS.  Honor
the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
  ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of
  ;; files (instead of all the certificates) among which "ca-bundle.crt".  On
  ;; other distros /etc/ssl/certs usually contains the whole set of
  ;; certificates along with "ca-certificates.crt".  Try to choose the right
  ;; one.
  (let ((file      (letrec-syntax ((choose
                                    (syntax-rules ()
                                      ((_ file rest ...)
                                       (let ((f file))
                                         (if (and f (file-exists? f))
                                             f
                                             (choose rest ...))))
                                      ((_)
                                       #f))))
                     (choose (getenv "SSL_CERT_FILE")
                             "/etc/ssl/certs/ca-certificates.crt"
                             "/etc/ssl/certs/ca-bundle.crt")))
        (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
    (and (or file
             (and=> (stat directory #f)
                    (lambda (st)
                      (> (stat:nlink st) 2))))
         (begin
           (set-tls-certificate-locations! directory file)
           #t))))

(define %certificates-initialized?
  ;; Whether 'honor-system-x509-certificates!' has already been called.
  #f)

(define-syntax-rule (with-libgit2 thunk ...)
  (begin
    ;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
    ;; but pointer finalizers used in guile-git may be called after shutdown,
    ;; resulting in a segfault. Hence, let's skip shutdown call for now.
    (libgit2-init!)
    (unless %certificates-initialized?
      (honor-system-x509-certificates!)
      (set! %certificates-initialized? #t))
    thunk ...))

(define* (url-cache-directory url
                              #:optional (cache-directory
                                          (%repository-cache-directory))
                              #:key recursive?)
  "Return the directory associated to URL in %repository-cache-directory."
  (string-append
   cache-directory "/"
   (bytevector->base32-string
    (sha256 (string->utf8 (if recursive?
                              (string-append "R:" url)
                              url))))))

(define (clone* url directory)
  "Clone git repository at URL into DIRECTORY.  Upon failure,
make sure no empty directory is left behind."
  (with-throw-handler #t
    (lambda ()
      (mkdir-p directory)

      ;; Note: Explicitly pass options to work around the invalid default
      ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
      (if (module-defined? (resolve-interface '(git))
                           'clone-init-options)
          (clone url directory (clone-init-options))
          (clone url directory)))
    (lambda _
      (false-if-exception (rmdir directory)))))

(define (url+commit->name url sha1)
  "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
the git repository, extracted from URL and SHA1:7 the seven first digits
of SHA1 string."
  (string-append
   (string-replace-substring
    (last (string-split url #\/)) ".git" "")
   "-" (string-take sha1 7)))

(define (switch-to-ref repository ref)
  "Switch to REPOSITORY's branch, commit or tag specified by REF.  Return the
OID (roughly the commit hash) corresponding to REF."
  (define obj
    (let resolve ((ref ref))
      (match ref
        (('branch . branch)
         (let ((oid (reference-target
                     (branch-lookup repository branch BRANCH-REMOTE))))
           (object-lookup repository oid)))
        (('commit . commit)
         (let ((len (string-length commit)))
           ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
           ;; can't be sure it's available.  Furthermore, 'string->oid' used to
           ;; read out-of-bounds when passed a string shorter than 40 chars,
           ;; which is why we delay calls to it below.
           (if (< len 40)
               (if (module-defined? (resolve-interface '(git object))
                                    'object-lookup-prefix)
                   (object-lookup-prefix repository (string->oid commit) len)
                   (raise (condition
                           (&message
                            (message "long Git object ID is required")))))
               (object-lookup repository (string->oid commit)))))
        (('tag-or-commit . str)
         (if (or (> (string-length str) 40)
                 (not (string-every char-set:hex-digit str)))
             (resolve `(tag . ,str))              ;definitely a tag
             (catch 'git-error
               (lambda ()
                 (resolve `(tag . ,str)))
               (lambda _
                 ;; There's no such tag, so it must be a commit ID.
                 (resolve `(commit . ,str))))))
        (('tag    . tag)
         (let ((oid (reference-name->oid repository
                                         (string-append "refs/tags/" tag))))
           ;; Get the commit that the tag at OID refers to.  This is not
           ;; strictly needed, but it's more consistent to always return the
           ;; OID of a commit.
           (object-lookup repository
                          (tag-target-id (tag-lookup repository oid))))))))

  (reset repository obj RESET_HARD)
  (object-id obj))

(define (call-with-repository directory proc)
  (let ((repository #f))
   (dynamic-wind
     (lambda ()
       (set! repository (repository-open directory)))
     (lambda ()
       (proc repository))
     (lambda ()
       (repository-close! repository)))))

(define-syntax-rule (with-repository directory repository exp ...)
  "Open the repository at DIRECTORY and bind REPOSITORY to it within the
dynamic extent of EXP."
  (call-with-repository directory
                        (lambda (repository) exp ...)))

(define* (update-submodules repository
                            #:key (log-port (current-error-port)))
  "Update the submodules of REPOSITORY, a Git repository object."
  ;; Guile-Git < 0.2.0 did not have (git submodule).
  (if (false-if-exception (resolve-interface '(git submodule)))
      (for-each (lambda (name)
                  (let ((submodule (submodule-lookup repository name)))
                    (format log-port (G_ "updating submodule '~a'...~%")
                            name)
                    (submodule-update submodule)

                    ;; Recurse in SUBMODULE.
                    (let ((directory (string-append
                                      (repository-working-directory repository)
                                      "/" (submodule-path submodule))))
                      (with-repository directory repository
                        (update-submodules repository
                                           #:log-port log-port)))))
                (repository-submodules repository))
      (format (current-error-port)
              (G_ "Support for submodules is missing; \
please upgrade Guile-Git.~%"))))

(define* (update-cached-checkout url
                                 #:key
                                 (ref '(branch . "master"))
                                 recursive?
                                 (log-port (%make-void-port "w"))
                                 (cache-directory
                                  (url-cache-directory
                                   url (%repository-cache-directory)
                                   #:recursive? recursive?)))
  "Update the cached checkout of URL to REF in CACHE-DIRECTORY.  Return two
values: the cache directory name, and the SHA1 commit (a string) corresponding
to REF.

REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
the associated data: [<branch name> | <sha1> | <tag name> | <string>].

When RECURSIVE? is true, check out submodules as well, if any."
  (define canonical-ref
    ;; We used to require callers to specify "origin/" for each branch, which
    ;; made little sense since the cache should be transparent to them.  So
    ;; here we append "origin/" if it's missing and otherwise keep it.
    (match ref
      (('branch . branch)
       `(branch . ,(if (string-prefix? "origin/" branch)
                       branch
                       (string-append "origin/" branch))))
      (_ ref)))

  (with-libgit2
   (let* ((cache-exists? (openable-repository? cache-directory))
          (repository    (if cache-exists?
                             (repository-open cache-directory)
                             (clone* url cache-directory))))
     ;; Only fetch remote if it has not been cloned just before.
     (when cache-exists?
       (remote-fetch (remote-lookup repository "origin")))
     (when recursive?
       (update-submodules repository #:log-port log-port))
     (let ((oid (switch-to-ref repository canonical-ref)))

       ;; Reclaim file descriptors and memory mappings associated with
       ;; REPOSITORY as soon as possible.
       (when (module-defined? (resolve-interface '(git repository))
                              'repository-close!)
         (repository-close! repository))

       (values cache-directory (oid->string oid))))))

(define* (latest-repository-commit store url
                                   #:key
                                   recursive?
                                   (log-port (%make-void-port "w"))
                                   (cache-directory
                                    (%repository-cache-directory))
                                   (ref '(branch . "master")))
  "Return two values: the content of the git repository at URL copied into a
store directory and the sha1 of the top level commit in this directory.  The
reference to be checkout, once the repository is fetched, is specified by REF.
REF is pair whose key is [branch | commit | tag] and value the associated
data, respectively [<branch name> | <sha1> | <tag name>].

When RECURSIVE? is true, check out submodules as well, if any.

Git repositories are kept in the cache directory specified by
%repository-cache-directory parameter.

Log progress and checkout info to LOG-PORT."
  (define (dot-git? file stat)
    (and (string=? (basename file) ".git")
         (or (eq? 'directory (stat:type stat))

             ;; Submodule checkouts end up with a '.git' regular file that
             ;; contains metadata about where their actual '.git' directory
             ;; lives.
             (and recursive?
                  (eq? 'regular (stat:type stat))))))

  (format log-port "updating checkout of '~a'...~%" url)
  (let*-values
      (((checkout commit)
        (update-cached-checkout url
                                #:recursive? recursive?
                                #:ref ref
                                #:cache-directory
                                (url-cache-directory url cache-directory
                                                     #:recursive?
                                                     recursive?)
                                #:log-port log-port))
       ((name)
        (url+commit->name url commit)))
    (format log-port "retrieved commit ~a~%" commit)
    (values (add-to-store store name #t "sha256" checkout
                          #:select? (negate dot-git?))
            commit)))

(define (print-git-error port key args default-printer)
  (match args
    (((? git-error? error) . _)
     (format port (G_ "Git error: ~a~%")
             (git-error-message error)))))

(set-exception-printer! 'git-error print-git-error)

\f
;;;
;;; Checkouts.
;;;

;; Representation of the "latest" checkout of a branch or a specific commit.
(define-record-type* <git-checkout>
  git-checkout make-git-checkout
  git-checkout?
  (url     git-checkout-url)
  (branch  git-checkout-branch (default "master"))
  (commit  git-checkout-commit (default #f))      ;#f | tag | commit
  (recursive? git-checkout-recursive? (default #f)))

(define* (latest-repository-commit* url #:key ref recursive? log-port)
  ;; Monadic variant of 'latest-repository-commit'.
  (lambda (store)
    ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
    ;; translate it into '&message' conditions that we know will be properly
    ;; handled.
    (catch 'git-error
      (lambda ()
        (values (latest-repository-commit store url
                                          #:ref ref
                                          #:recursive? recursive?
                                          #:log-port log-port)
                store))
      (lambda (key error . _)
        (raise (condition
                (&message
                 (message
                  (match ref
                    (('commit . commit)
                     (format #f (G_ "cannot fetch commit ~a from ~a: ~a")
                             commit url (git-error-message error)))
                    (('branch . branch)
                     (format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
                             branch url (git-error-message error)))
                    (_
                     (format #f (G_ "Git failure while fetching ~a: ~a")
                             url (git-error-message error))))))))))))

(define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
                                             system target)
  ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
  ;; store.
  (match checkout
    (($ <git-checkout> url branch commit recursive?)
     (latest-repository-commit* url
                                #:ref (if commit
                                          `(tag-or-commit . ,commit)
                                          `(branch . ,branch))
                                #:recursive? recursive?
                                #:log-port (current-error-port)))))

;; Local Variables:
;; eval: (put 'with-repository 'scheme-indent-function 2)
;; End:
Commit	Line	Data
6b7b3ca9 MO	1	;;; GNU Guix --- Functional package management for GNU
6b7b3ca9 MO	2	;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
60cbc6a8	3	;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
6b7b3ca9 MO	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)
a3d77c51	23	#:use-module (guix i18n)
6b7b3ca9	24	#:use-module (guix base32)
ca719424	25	#:use-module (gcrypt hash)
0ad5f809	26	#:use-module ((guix build utils) #:select (mkdir-p))
6b7b3ca9 MO	27	#:use-module (guix store)
6b7b3ca9 MO	28	#:use-module (guix utils)
49ae3f6d LC	29	#:use-module (guix records)
49ae3f6d LC	30	#:use-module (guix gexp)
6b7b3ca9 MO	31	#:use-module (rnrs bytevectors)
	32	#:use-module (ice-9 match)
	33	#:use-module (srfi srfi-1)
91881986	34	#:use-module (srfi srfi-11)
95bd9f65 LC	35	#:use-module (srfi srfi-34)
95bd9f65 LC	36	#:use-module (srfi srfi-35)
6b7b3ca9	37	#:export (%repository-cache-directory
bc041b3e LC	38	honor-system-x509-certificates!
bc041b3e LC	39
91881986	40	update-cached-checkout
49ae3f6d LC	41	latest-repository-commit
	42
	43	git-checkout
	44	git-checkout?
	45	git-checkout-url
	46	git-checkout-branch))
6b7b3ca9	47
60cbc6a8 LC	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
6b7b3ca9	53	(define %repository-cache-directory
e83b2b0f LC	54	(make-parameter (string-append (cache-directory #:ensure? #f)
e83b2b0f LC	55	"/checkouts")))
6b7b3ca9	56
bc041b3e LC	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
6b7b3ca9	90	(define-syntax-rule (with-libgit2 thunk ...)
b02469d2 MO	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!)
bc041b3e LC	96	(unless %certificates-initialized?
	97	(honor-system-x509-certificates!)
	98	(set! %certificates-initialized? #t))
b02469d2	99	thunk ...))
6b7b3ca9 MO	100
	101	(define* (url-cache-directory url
	102	#:optional (cache-directory
60cbc6a8 LC	103	(%repository-cache-directory))
60cbc6a8 LC	104	#:key recursive?)
6b7b3ca9 MO	105	"Return the directory associated to URL in %repository-cache-directory."
	106	(string-append
	107	cache-directory "/"
60cbc6a8 LC	108	(bytevector->base32-string
	109	(sha256 (string->utf8 (if recursive?
	110	(string-append "R:" url)
	111	url))))))
6b7b3ca9 MO	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)
195f0d05 LC	119
	120	;; Note: Explicitly pass options to work around the invalid default
	121	;; value in Guile-Git: <https://bugs.gnu.org/29238>.
b1488c76 LC	122	(if (module-defined? (resolve-interface '(git))
	123	'clone-init-options)
	124	(clone url directory (clone-init-options))
	125	(clone url directory)))
6b7b3ca9 MO	126	(lambda _
	127	(false-if-exception (rmdir directory)))))
	128
6b7b3ca9 MO	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
6b7b3ca9	138	(define (switch-to-ref repository ref)
91881986 LC	139	"Switch to REPOSITORY's branch, commit or tag specified by REF. Return the
91881986 LC	140	OID (roughly the commit hash) corresponding to REF."
95bd9f65	141	(define obj
c4c2449f LC	142	(let resolve ((ref ref))
	143	(match ref
	144	(('branch . branch)
	145	(let ((oid (reference-target
	146	(branch-lookup repository branch BRANCH-REMOTE))))
	147	(object-lookup repository oid)))
	148	(('commit . commit)
	149	(let ((len (string-length commit)))
	150	;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
	151	;; can't be sure it's available. Furthermore, 'string->oid' used to
	152	;; read out-of-bounds when passed a string shorter than 40 chars,
	153	;; which is why we delay calls to it below.
	154	(if (< len 40)
	155	(if (module-defined? (resolve-interface '(git object))
	156	'object-lookup-prefix)
	157	(object-lookup-prefix repository (string->oid commit) len)
	158	(raise (condition
	159	(&message
	160	(message "long Git object ID is required")))))
	161	(object-lookup repository (string->oid commit)))))
	162	(('tag-or-commit . str)
	163	(if (or (> (string-length str) 40)
	164	(not (string-every char-set:hex-digit str)))
	165	(resolve `(tag . ,str)) ;definitely a tag
	166	(catch 'git-error
	167	(lambda ()
	168	(resolve `(tag . ,str)))
	169	(lambda _
	170	;; There's no such tag, so it must be a commit ID.
	171	(resolve `(commit . ,str))))))
	172	(('tag . tag)
	173	(let ((oid (reference-name->oid repository
	174	(string-append "refs/tags/" tag))))
10a8c2bb LC	175	;; Get the commit that the tag at OID refers to. This is not
	176	;; strictly needed, but it's more consistent to always return the
	177	;; OID of a commit.
	178	(object-lookup repository
	179	(tag-target-id (tag-lookup repository oid))))))))
95bd9f65	180
91881986 LC	181	(reset repository obj RESET_HARD)
	182	(object-id obj))
	183
60cbc6a8 LC	184	(define (call-with-repository directory proc)
	185	(let ((repository #f))
	186	(dynamic-wind
	187	(lambda ()
	188	(set! repository (repository-open directory)))
	189	(lambda ()
	190	(proc repository))
	191	(lambda ()
	192	(repository-close! repository)))))
	193
	194	(define-syntax-rule (with-repository directory repository exp ...)
	195	"Open the repository at DIRECTORY and bind REPOSITORY to it within the
	196	dynamic extent of EXP."
	197	(call-with-repository directory
	198	(lambda (repository) exp ...)))
	199
	200	(define* (update-submodules repository
	201	#:key (log-port (current-error-port)))
	202	"Update the submodules of REPOSITORY, a Git repository object."
	203	;; Guile-Git < 0.2.0 did not have (git submodule).
	204	(if (false-if-exception (resolve-interface '(git submodule)))
	205	(for-each (lambda (name)
	206	(let ((submodule (submodule-lookup repository name)))
	207	(format log-port (G_ "updating submodule '~a'...~%")
	208	name)
	209	(submodule-update submodule)
	210
	211	;; Recurse in SUBMODULE.
	212	(let ((directory (string-append
	213	(repository-working-directory repository)
	214	"/" (submodule-path submodule))))
	215	(with-repository directory repository
	216	(update-submodules repository
	217	#:log-port log-port)))))
	218	(repository-submodules repository))
	219	(format (current-error-port)
	220	(G_ "Support for submodules is missing; \
	221	please upgrade Guile-Git.~%"))))
	222
91881986 LC	223	(define* (update-cached-checkout url
91881986 LC	224	#:key
37a6cdbf	225	(ref '(branch . "master"))
60cbc6a8 LC	226	recursive?
60cbc6a8 LC	227	(log-port (%make-void-port "w"))
91881986	228	(cache-directory
ffc3fcad	229	(url-cache-directory
60cbc6a8 LC	230	url (%repository-cache-directory)
60cbc6a8 LC	231	#:recursive? recursive?)))
91881986 LC	232	"Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two
	233	values: the cache directory name, and the SHA1 commit (a string) corresponding
	234	to REF.
	235
c4c2449f LC	236	REF is pair whose key is [branch \| commit \| tag \| tag-or-commit ] and value
c4c2449f LC	237	the associated data: [<branch name> \| <sha1> \| <tag name> \| <string>].
60cbc6a8 LC	238
60cbc6a8 LC	239	When RECURSIVE? is true, check out submodules as well, if any."
37a6cdbf LC	240	(define canonical-ref
	241	;; We used to require callers to specify "origin/" for each branch, which
	242	;; made little sense since the cache should be transparent to them. So
	243	;; here we append "origin/" if it's missing and otherwise keep it.
	244	(match ref
	245	(('branch . branch)
	246	`(branch . ,(if (string-prefix? "origin/" branch)
	247	branch
	248	(string-append "origin/" branch))))
	249	(_ ref)))
	250
91881986	251	(with-libgit2
ffc3fcad	252	(let* ((cache-exists? (openable-repository? cache-directory))
91881986	253	(repository (if cache-exists?
ffc3fcad OP	254	(repository-open cache-directory)
ffc3fcad OP	255	(clone* url cache-directory))))
91881986 LC	256	;; Only fetch remote if it has not been cloned just before.
	257	(when cache-exists?
	258	(remote-fetch (remote-lookup repository "origin")))
60cbc6a8 LC	259	(when recursive?
60cbc6a8 LC	260	(update-submodules repository #:log-port log-port))
37a6cdbf	261	(let ((oid (switch-to-ref repository canonical-ref)))
91881986 LC	262
	263	;; Reclaim file descriptors and memory mappings associated with
	264	;; REPOSITORY as soon as possible.
	265	(when (module-defined? (resolve-interface '(git repository))
	266	'repository-close!)
	267	(repository-close! repository))
	268
ffc3fcad	269	(values cache-directory (oid->string oid))))))
6b7b3ca9 MO	270
	271	(define* (latest-repository-commit store url
	272	#:key
60cbc6a8	273	recursive?
35cb37ea	274	(log-port (%make-void-port "w"))
6b7b3ca9 MO	275	(cache-directory
6b7b3ca9 MO	276	(%repository-cache-directory))
37a6cdbf	277	(ref '(branch . "master")))
6b7b3ca9 MO	278	"Return two values: the content of the git repository at URL copied into a
	279	store directory and the sha1 of the top level commit in this directory. The
	280	reference to be checkout, once the repository is fetched, is specified by REF.
	281	REF is pair whose key is [branch \| commit \| tag] and value the associated
	282	data, respectively [<branch name> \| <sha1> \| <tag name>].
	283
60cbc6a8 LC	284	When RECURSIVE? is true, check out submodules as well, if any.
60cbc6a8 LC	285
6b7b3ca9	286	Git repositories are kept in the cache directory specified by
35cb37ea LC	287	%repository-cache-directory parameter.
	288
	289	Log progress and checkout info to LOG-PORT."
91881986 LC	290	(define (dot-git? file stat)
91881986 LC	291	(and (string=? (basename file) ".git")
60cbc6a8 LC	292	(or (eq? 'directory (stat:type stat))
	293
	294	;; Submodule checkouts end up with a '.git' regular file that
	295	;; contains metadata about where their actual '.git' directory
	296	;; lives.
	297	(and recursive?
	298	(eq? 'regular (stat:type stat))))))
dfca2418	299
35cb37ea	300	(format log-port "updating checkout of '~a'...~%" url)
ffc3fcad OP	301	(let*-values
	302	(((checkout commit)
	303	(update-cached-checkout url
60cbc6a8	304	#:recursive? recursive?
ffc3fcad OP	305	#:ref ref
ffc3fcad OP	306	#:cache-directory
60cbc6a8 LC	307	(url-cache-directory url cache-directory
	308	#:recursive?
	309	recursive?)
	310	#:log-port log-port))
ffc3fcad OP	311	((name)
ffc3fcad OP	312	(url+commit->name url commit)))
35cb37ea	313	(format log-port "retrieved commit ~a~%" commit)
91881986 LC	314	(values (add-to-store store name #t "sha256" checkout
	315	#:select? (negate dot-git?))
	316	commit)))
49ae3f6d	317
1d8b10d0 LC	318	(define (print-git-error port key args default-printer)
	319	(match args
	320	(((? git-error? error) . _)
	321	(format port (G_ "Git error: ~a~%")
	322	(git-error-message error)))))
	323
	324	(set-exception-printer! 'git-error print-git-error)
	325
49ae3f6d LC	326	\f
	327	;;;
	328	;;; Checkouts.
	329	;;;
	330
b18f7234	331	;; Representation of the "latest" checkout of a branch or a specific commit.
49ae3f6d LC	332	(define-record-type* <git-checkout>
	333	git-checkout make-git-checkout
	334	git-checkout?
	335	(url git-checkout-url)
b18f7234	336	(branch git-checkout-branch (default "master"))
177fecb5	337	(commit git-checkout-commit (default #f)) ;#f \| tag \| commit
06fff484	338	(recursive? git-checkout-recursive? (default #f)))
49ae3f6d	339
06fff484	340	(define* (latest-repository-commit* url #:key ref recursive? log-port)
a3d77c51 LC	341	;; Monadic variant of 'latest-repository-commit'.
	342	(lambda (store)
	343	;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
	344	;; translate it into '&message' conditions that we know will be properly
	345	;; handled.
	346	(catch 'git-error
	347	(lambda ()
	348	(values (latest-repository-commit store url
06fff484 LC	349	#:ref ref
	350	#:recursive? recursive?
	351	#:log-port log-port)
a3d77c51 LC	352	store))
	353	(lambda (key error . _)
	354	(raise (condition
	355	(&message
	356	(message
	357	(match ref
	358	(('commit . commit)
	359	(format #f (G_ "cannot fetch commit ~a from ~a: ~a")
	360	commit url (git-error-message error)))
	361	(('branch . branch)
	362	(format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
	363	branch url (git-error-message error)))
	364	(_
	365	(format #f (G_ "Git failure while fetching ~a: ~a")
	366	url (git-error-message error))))))))))))
49ae3f6d LC	367
	368	(define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
	369	system target)
	370	;; "Compile" CHECKOUT by updating the local checkout and adding it to the
	371	;; store.
	372	(match checkout
06fff484	373	(($ <git-checkout> url branch commit recursive?)
49ae3f6d	374	(latest-repository-commit* url
b18f7234	375	#:ref (if commit
177fecb5	376	`(tag-or-commit . ,commit)
b18f7234	377	`(branch . ,branch))
06fff484	378	#:recursive? recursive?
49ae3f6d	379	#:log-port (current-error-port)))))
60cbc6a8 LC	380
	381	;; Local Variables:
	382	;; eval: (put 'with-repository 'scheme-indent-function 2)
	383	;; End: