From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:60685) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d6ZAg-0004LY-BR for guix-patches@gnu.org; Fri, 05 May 2017 05:05:07 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d6ZAd-0006qp-6W for guix-patches@gnu.org; Fri, 05 May 2017 05:05:06 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:57172) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d6ZAd-0006qI-2x for guix-patches@gnu.org; Fri, 05 May 2017 05:05:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1d6ZAc-0002wR-5Q for guix-patches@gnu.org; Fri, 05 May 2017 05:05:02 -0400 Subject: bug#26777: [PATCH] guix: git: Add new module. References: <20170504144944.8635-1-m.othacehe@gmail.com> In-Reply-To: <20170504144944.8635-1-m.othacehe@gmail.com> Resent-Message-ID: From: Mathieu Othacehe Date: Fri, 5 May 2017 11:04:01 +0200 Message-Id: <20170505090401.9036-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 | 122 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 133 insertions(+) create mode 100644 guix/git.scm diff --git a/Makefile.am b/Makefile.am index 8fe9e350c..76e5d99c7 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 dc3d8f377..c937e948d 100644 --- a/configure.ac +++ b/configure.ac @@ -104,6 +104,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..d0c1c51a3 --- /dev/null +++ b/guix/git.scm @@ -0,0 +1,122 @@ +;;; 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-directory + latest-repository-commit)) + +(define %repository-cache-directory + (make-parameter "/var/cache/guix/checkouts")) + +(define-syntax-rule (with-libgit2 thunk ...) + (dynamic-wind + (lambda () + (libgit2-init!)) + (lambda () + thunk ...) + (lambda () + (libgit2-shutdown)))) + +(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) + (clone url directory)) + (lambda _ + (false-if-exception (rmdir directory))))) + +(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-directory store #:key url repository) + "Copy items in cache-directory to store. URL and REPOSITORY are used +to forge store directory name." + (let* ((commit (repository->head-sha1 repository)) + (name (url+commit->name url commit))) + (values (add-to-store store name #t "sha256" cache-directory) 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* (latest-repository-commit url store + #: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-directory parameter." + (with-libgit2 + (let* ((cache-dir (url-cache-directory url)) + (cache-exists? (openable-repository? cache-dir)) + (repository (if cache-exists? + (repository-open cache-dir) + (clone* 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 store + #:url url + #:repository repository)))) -- 2.12.2