From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:46288) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d6I5y-0004tZ-Gr for guix-patches@gnu.org; Thu, 04 May 2017 10:51:07 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d6I5u-0007Fl-A5 for guix-patches@gnu.org; Thu, 04 May 2017 10:51:06 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:56472) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d6I5u-0007Fc-6S for guix-patches@gnu.org; Thu, 04 May 2017 10:51:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1d6I5t-0001TD-Vh for guix-patches@gnu.org; Thu, 04 May 2017 10:51:02 -0400 Subject: bug#26777: [PATCH] guix: git: Add new module. Resent-Message-ID: Received: from eggs.gnu.org ([2001:4830:134:3::10]:45855) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d6I4q-0004m5-N4 for guix-patches@gnu.org; Thu, 04 May 2017 10:50:00 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d6I4l-0006Z8-N0 for guix-patches@gnu.org; Thu, 04 May 2017 10:49:56 -0400 Received: from mail-wr0-x233.google.com ([2a00:1450:400c:c0c::233]:34461) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d6I4l-0006Yg-Di for guix-patches@gnu.org; Thu, 04 May 2017 10:49:51 -0400 Received: by mail-wr0-x233.google.com with SMTP id l9so9269770wre.1 for ; Thu, 04 May 2017 07:49:51 -0700 (PDT) From: Mathieu Othacehe Date: Thu, 4 May 2017 16:49:44 +0200 Message-Id: <20170504144944.8635-1-m.othacehe@gmail.com> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 26777@debbugs.gnu.org * guix/git.scm: New file. * configure.ac: Check for (guile git). * Makefile.am: Build guix/git.scm if (guile git) is available. --- Makefile.am | 7 +++ configure.ac | 4 ++ guix/git.scm | 140 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 151 insertions(+) create mode 100644 guix/git.scm diff --git a/Makefile.am b/Makefile.am index c6d8de68b..67491a11a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -197,6 +197,13 @@ MODULES += \ endif HAVE_GUILE_SSH +if HAVE_GUILE_GIT + +MODULES += \ + guix/git.scm + +endif HAVE_GUILE_GIT + if BUILD_DAEMON_OFFLOAD MODULES += \ diff --git a/configure.ac b/configure.ac index 2b4620c44..2f6eff128 100644 --- a/configure.ac +++ b/configure.ac @@ -102,6 +102,10 @@ dnl Guile-JSON is used in various places. GUILE_MODULE_AVAILABLE([have_guile_json], [(json)]) AM_CONDITIONAL([HAVE_GUILE_JSON], [test "x$have_guile_json" = "xyes"]) +dnl Check for Guile-Git. +GUILE_MODULE_AVAILABLE([have_guile_git], [(git)]) +AM_CONDITIONAL([HAVE_GUILE_GIT], [test "x$have_guile_git" = "xyes"]) + dnl Make sure we have a full-fledged Guile. GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads]) diff --git a/guix/git.scm b/guix/git.scm new file mode 100644 index 000000000..b6bc00838 --- /dev/null +++ b/guix/git.scm @@ -0,0 +1,140 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (guix git) + #:use-module (git) + #:use-module (git object) + #:use-module (guix base32) + #:use-module (guix hash) + #:use-module (guix build utils) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (%repository-cache-path + latest-repository-commit)) + +(define %repository-cache-path + (make-parameter "/var/cache/guix/checkouts")) + +(define-syntax-rule (with-libgit2 thunk ...) + (dynamic-wind + (lambda () + (libgit2-init!)) + (lambda () + thunk ...) + (lambda () + (libgit2-shutdown)))) + +(define (repository-cache-directory url) + "Return the directory associated to URL in %repository-cache-path." + (string-append + (%repository-cache-path) "/" + (bytevector->base32-string (sha256 (string->utf8 url))))) + +(define (clone-with-error-handling url path) + "Clone git repository at URL into PATH with error handling." + (catch 'git-error + (lambda () + (mkdir-p path) + (clone url path)) + (lambda (key . parameters) + (rmdir path) + (error "Clone error: " parameters)))) + +(define (repository->head-sha1 repo) + "Return the sha1 of the HEAD commit in REPOSITORY as a string." + (let ((oid (reference-target (repository-head repo)))) + (oid->string (commit-id (commit-lookup repo oid))))) + +(define (url+commit->name url sha1) + "Return the string \"-\" 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* (copy-to-store cache-path #:key url repository) + "Copy items in cache-path to store. URL and REPOSITORY are used +to forge store directory name." + (let* ((commit (repository->head-sha1 repository)) + (name (url+commit->name url commit))) + (with-store store + (values (add-to-store store name #t "sha256" cache-path) commit)))) + +(define (switch-to-ref repository ref) + "Switch to REPOSITORY's branch, commit or tag specified by REF." + (let* ((oid (match ref + (('branch . branch) + (reference-target + (branch-lookup repository branch BRANCH-REMOTE))) + (('commit . commit) + (string->oid commit)) + (('tag . tag) + (reference-name->oid repository + (string-append "refs/tags/" tag))))) + (obj (object-lookup repository oid))) + ;; guile-git checkout binding seems broken. + (reset repository obj RESET_HARD))) + +(define (switch-to-ref* repository ref) + "Switch to REF in REPOSITORY with error handling." + (catch 'git-error + (lambda () + (switch-to-ref repository ref)) + (lambda (key . parameters) + (error + (format #f "Failed to switch to ref ~s: ~s" ref parameters))))) + +(define (remote-fetch* repository remote-name) + "Fetch REMOTE-NAME of REPOSITORY with error handling." + (catch 'git-error + (lambda () + (remote-fetch (remote-lookup repository remote-name))) + (lambda (key . parameters) + (error + (format #f "Failed to fetch remote ~a: ~a" remote-name parameters))))) + +(define* (latest-repository-commit url + #:key + (ref '(branch . "origin/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 [ | | ]. + +Git repositories are kept in the cache directory specified by +%repository-cache-path parameter." + (with-libgit2 + (let* ((cache-dir (repository-cache-directory url)) + (cache-exists? (openable-repository? cache-dir)) + (repository (if cache-exists? + (repository-open cache-dir) + (clone-with-error-handling url cache-dir)))) + ;; Only fetch remote if it has not been cloned just before. + (when cache-exists? + (remote-fetch* repository "origin")) + + (switch-to-ref* repository ref) + (copy-to-store cache-dir + #:url url + #:repository repository)))) -- 2.12.2