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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 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
            update-cached-checkout
            latest-repository-commit

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

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

(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!)
    thunk ...))

(define* (url-cache-directory url
                              #:optional (cache-directory
                                          (%repository-cache-directory)))
  "Return the directory associated to URL in %repository-cache-directory."
  (string-append
   cache-directory "/"
   (bytevector->base32-string (sha256 (string->utf8 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
    (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    . tag)
       (let ((oid (reference-name->oid repository
                                       (string-append "refs/tags/" tag))))
         (object-lookup repository oid)))))

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

(define* (update-cached-checkout url
                                 #:key
                                 (ref '(branch . "master"))
                                 (cache-directory
                                  (url-cache-directory
                                   url (%repository-cache-directory))))
  "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] and value the associated
data, respectively [<branch name> | <sha1> | <tag name>]."
  (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")))
     (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
                                   (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>].

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")
         (eq? 'directory (stat:type stat))))

  (format log-port "updating checkout of '~a'...~%" url)
  (let*-values
      (((checkout commit)
        (update-cached-checkout url
                                #:ref ref
                                #:cache-directory
                                (url-cache-directory url cache-directory)))
       ((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)))

\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)))

(define* (latest-repository-commit* url #:key ref 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 #: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)
     (latest-repository-commit* url
                                #:ref (if commit
                                          `(commit . ,commit)
                                          `(branch . ,branch))
                                #:log-port (current-error-port)))))
Commit	Line	Data
6b7b3ca9 MO	1	;;; GNU Guix --- Functional package management for GNU
6b7b3ca9 MO	2	;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
95bd9f65	3	;;; Copyright © 2018 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
91881986	38	update-cached-checkout
49ae3f6d LC	39	latest-repository-commit
	40
	41	git-checkout
	42	git-checkout?
	43	git-checkout-url
	44	git-checkout-branch))
6b7b3ca9 MO	45
6b7b3ca9 MO	46	(define %repository-cache-directory
e83b2b0f LC	47	(make-parameter (string-append (cache-directory #:ensure? #f)
e83b2b0f LC	48	"/checkouts")))
6b7b3ca9 MO	49
6b7b3ca9 MO	50	(define-syntax-rule (with-libgit2 thunk ...)
b02469d2 MO	51	(begin
	52	;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
	53	;; but pointer finalizers used in guile-git may be called after shutdown,
	54	;; resulting in a segfault. Hence, let's skip shutdown call for now.
	55	(libgit2-init!)
	56	thunk ...))
6b7b3ca9 MO	57
	58	(define* (url-cache-directory url
	59	#:optional (cache-directory
	60	(%repository-cache-directory)))
	61	"Return the directory associated to URL in %repository-cache-directory."
	62	(string-append
	63	cache-directory "/"
	64	(bytevector->base32-string (sha256 (string->utf8 url)))))
	65
	66	(define (clone* url directory)
	67	"Clone git repository at URL into DIRECTORY. Upon failure,
	68	make sure no empty directory is left behind."
	69	(with-throw-handler #t
	70	(lambda ()
	71	(mkdir-p directory)
195f0d05 LC	72
	73	;; Note: Explicitly pass options to work around the invalid default
	74	;; value in Guile-Git: <https://bugs.gnu.org/29238>.
b1488c76 LC	75	(if (module-defined? (resolve-interface '(git))
	76	'clone-init-options)
	77	(clone url directory (clone-init-options))
	78	(clone url directory)))
6b7b3ca9 MO	79	(lambda _
	80	(false-if-exception (rmdir directory)))))
	81
6b7b3ca9 MO	82	(define (url+commit->name url sha1)
	83	"Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
	84	the git repository, extracted from URL and SHA1:7 the seven first digits
	85	of SHA1 string."
	86	(string-append
	87	(string-replace-substring
	88	(last (string-split url #\/)) ".git" "")
	89	"-" (string-take sha1 7)))
	90
6b7b3ca9	91	(define (switch-to-ref repository ref)
91881986 LC	92	"Switch to REPOSITORY's branch, commit or tag specified by REF. Return the
91881986 LC	93	OID (roughly the commit hash) corresponding to REF."
95bd9f65 LC	94	(define obj
	95	(match ref
	96	(('branch . branch)
	97	(let ((oid (reference-target
	98	(branch-lookup repository branch BRANCH-REMOTE))))
	99	(object-lookup repository oid)))
	100	(('commit . commit)
	101	(let ((len (string-length commit)))
	102	;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
	103	;; can't be sure it's available. Furthermore, 'string->oid' used to
	104	;; read out-of-bounds when passed a string shorter than 40 chars,
	105	;; which is why we delay calls to it below.
	106	(if (< len 40)
	107	(if (module-defined? (resolve-interface '(git object))
	108	'object-lookup-prefix)
	109	(object-lookup-prefix repository (string->oid commit) len)
	110	(raise (condition
	111	(&message
	112	(message "long Git object ID is required")))))
	113	(object-lookup repository (string->oid commit)))))
	114	(('tag . tag)
	115	(let ((oid (reference-name->oid repository
	116	(string-append "refs/tags/" tag))))
	117	(object-lookup repository oid)))))
	118
91881986 LC	119	(reset repository obj RESET_HARD)
	120	(object-id obj))
	121
	122	(define* (update-cached-checkout url
	123	#:key
37a6cdbf	124	(ref '(branch . "master"))
91881986	125	(cache-directory
ffc3fcad OP	126	(url-cache-directory
ffc3fcad OP	127	url (%repository-cache-directory))))
91881986 LC	128	"Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two
	129	values: the cache directory name, and the SHA1 commit (a string) corresponding
	130	to REF.
	131
	132	REF is pair whose key is [branch \| commit \| tag] and value the associated
	133	data, respectively [<branch name> \| <sha1> \| <tag name>]."
37a6cdbf LC	134	(define canonical-ref
	135	;; We used to require callers to specify "origin/" for each branch, which
	136	;; made little sense since the cache should be transparent to them. So
	137	;; here we append "origin/" if it's missing and otherwise keep it.
	138	(match ref
	139	(('branch . branch)
	140	`(branch . ,(if (string-prefix? "origin/" branch)
	141	branch
	142	(string-append "origin/" branch))))
	143	(_ ref)))
	144
91881986	145	(with-libgit2
ffc3fcad	146	(let* ((cache-exists? (openable-repository? cache-directory))
91881986	147	(repository (if cache-exists?
ffc3fcad OP	148	(repository-open cache-directory)
ffc3fcad OP	149	(clone* url cache-directory))))
91881986 LC	150	;; Only fetch remote if it has not been cloned just before.
	151	(when cache-exists?
	152	(remote-fetch (remote-lookup repository "origin")))
37a6cdbf	153	(let ((oid (switch-to-ref repository canonical-ref)))
91881986 LC	154
	155	;; Reclaim file descriptors and memory mappings associated with
	156	;; REPOSITORY as soon as possible.
	157	(when (module-defined? (resolve-interface '(git repository))
	158	'repository-close!)
	159	(repository-close! repository))
	160
ffc3fcad	161	(values cache-directory (oid->string oid))))))
6b7b3ca9 MO	162
	163	(define* (latest-repository-commit store url
	164	#:key
35cb37ea	165	(log-port (%make-void-port "w"))
6b7b3ca9 MO	166	(cache-directory
6b7b3ca9 MO	167	(%repository-cache-directory))
37a6cdbf	168	(ref '(branch . "master")))
6b7b3ca9 MO	169	"Return two values: the content of the git repository at URL copied into a
	170	store directory and the sha1 of the top level commit in this directory. The
	171	reference to be checkout, once the repository is fetched, is specified by REF.
	172	REF is pair whose key is [branch \| commit \| tag] and value the associated
	173	data, respectively [<branch name> \| <sha1> \| <tag name>].
	174
	175	Git repositories are kept in the cache directory specified by
35cb37ea LC	176	%repository-cache-directory parameter.
	177
	178	Log progress and checkout info to LOG-PORT."
91881986 LC	179	(define (dot-git? file stat)
	180	(and (string=? (basename file) ".git")
	181	(eq? 'directory (stat:type stat))))
dfca2418	182
35cb37ea	183	(format log-port "updating checkout of '~a'...~%" url)
ffc3fcad OP	184	(let*-values
	185	(((checkout commit)
	186	(update-cached-checkout url
	187	#:ref ref
	188	#:cache-directory
	189	(url-cache-directory url cache-directory)))
	190	((name)
	191	(url+commit->name url commit)))
35cb37ea	192	(format log-port "retrieved commit ~a~%" commit)
91881986 LC	193	(values (add-to-store store name #t "sha256" checkout
	194	#:select? (negate dot-git?))
	195	commit)))
49ae3f6d LC	196
	197	\f
	198	;;;
	199	;;; Checkouts.
	200	;;;
	201
b18f7234	202	;; Representation of the "latest" checkout of a branch or a specific commit.
49ae3f6d LC	203	(define-record-type* <git-checkout>
	204	git-checkout make-git-checkout
	205	git-checkout?
	206	(url git-checkout-url)
b18f7234 LC	207	(branch git-checkout-branch (default "master"))
b18f7234 LC	208	(commit git-checkout-commit (default #f)))
49ae3f6d	209
a3d77c51 LC	210	(define* (latest-repository-commit* url #:key ref log-port)
	211	;; Monadic variant of 'latest-repository-commit'.
	212	(lambda (store)
	213	;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
	214	;; translate it into '&message' conditions that we know will be properly
	215	;; handled.
	216	(catch 'git-error
	217	(lambda ()
	218	(values (latest-repository-commit store url
	219	#:ref ref #:log-port log-port)
	220	store))
	221	(lambda (key error . _)
	222	(raise (condition
	223	(&message
	224	(message
	225	(match ref
	226	(('commit . commit)
	227	(format #f (G_ "cannot fetch commit ~a from ~a: ~a")
	228	commit url (git-error-message error)))
	229	(('branch . branch)
	230	(format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
	231	branch url (git-error-message error)))
	232	(_
	233	(format #f (G_ "Git failure while fetching ~a: ~a")
	234	url (git-error-message error))))))))))))
49ae3f6d LC	235
	236	(define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
	237	system target)
	238	;; "Compile" CHECKOUT by updating the local checkout and adding it to the
	239	;; store.
	240	(match checkout
b18f7234	241	(($ <git-checkout> url branch commit)
49ae3f6d	242	(latest-repository-commit* url
b18f7234 LC	243	#:ref (if commit
	244	`(commit . ,commit)
	245	`(branch . ,branch))
49ae3f6d	246	#:log-port (current-error-port)))))