From mboxrd@z Thu Jan 1 00:00:00 1970 From: Mathieu Lirzin Subject: Re: Add a generalized git-file? to Guix? Date: Sun, 29 Jan 2017 00:50:15 +0100 Message-ID: <87vasyg2x4.fsf@gnu.org> References: <87twkpkdpw.fsf@drakenvlieg.flower> <87eg0eouv6.fsf@gnu.org> <87a8b1fg7q.fsf@dustycloud.org> <871swbe7ev.fsf@gnu.org> <87eg0ag9q8.fsf@dustycloud.org> <87bmvdfwdz.fsf@dustycloud.org> <877f6132va.fsf@gnu.org> <87h9542vtq.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:33858) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cXclJ-0000Xk-RU for guix-devel@gnu.org; Sat, 28 Jan 2017 18:50:35 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cXclE-0002Sk-RT for guix-devel@gnu.org; Sat, 28 Jan 2017 18:50:29 -0500 In-Reply-To: <87h9542vtq.fsf@gnu.org> ("Ludovic \=\?utf-8\?Q\?Court\=C3\=A8s\=22'\?\= \=\?utf-8\?Q\?s\?\= message of "Thu, 12 Jan 2017 15:32:01 +0100") List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: Ludovic =?utf-8?Q?Court=C3=A8s?= Cc: Guix-devel --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Hello, ludo@gnu.org (Ludovic Court=C3=A8s) writes: > Mathieu Lirzin skribis: > >> Christopher Allan Webber writes: >> >>> 8sync now uses `git-file?' in its guix.scm, a predicate check which >>> allows for checking out the whole local directory as a "source" for >>> testing a package. I borrowed it from Dave who originally adapted >>> it from some code in Guix itself. See: >>> >>> http://git.savannah.gnu.org/cgit/8sync.git/tree/guix.scm#n62 >>> >>> This is pretty handy; probably other projects would like to make use of >>> it. What do we think of making it a generally available utility? >> >> I would make use of it and I am in favour of adding it to Guix. > > I think it comes from =E2=80=98current-guix=E2=80=99 in package-managemen= t.scm, and yes, > we should probably make it public. > > Would someone like to submit a patch? The most difficult issue is > finding in file in which to store it. ;-) Maybe git-download.scm? Here is a patch renaming 'make-git-predicate' to 'git-predicate' and moving it to (guix git-download). --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: inline; filename=0001-git-download-Add-git-predicate.patch Content-Transfer-Encoding: quoted-printable >From f104b3745097746d6ef89b6198ec7b81e8b679f4 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 29 Jan 2017 00:34:48 +0100 Subject: [PATCH] git-download: Add 'git-predicate'. * guix/git-download.scm (git-predicate): New procedure. * gnu/packages/package-management.scm (current-guix): Use it. (make-git-predicate): Remove. --- gnu/packages/package-management.scm | 37 +------------------------------ guix/git-download.scm | 43 +++++++++++++++++++++++++++++++++= +++- 2 files changed, 43 insertions(+), 37 deletions(-) diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-man= agement.scm index 92787d76c..272fc6ab0 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -25,7 +25,6 @@ #:use-module (guix utils) #:use-module (guix build-system gnu) #:use-module (guix build-system python) - #:use-module ((guix build utils) #:select (with-directory-excursion)) #:use-module ((guix licenses) #:select (gpl2+ gpl3+ lgpl2.1+ asl2.0)) #:use-module (gnu packages) #:use-module (gnu packages guile) @@ -53,10 +52,6 @@ #:use-module (gnu packages tls) #:use-module (gnu packages ssh) #:use-module (gnu packages vim) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (ice-9 popen) - #:use-module (ice-9 rdelim) #:use-module (ice-9 match)) =20 (define (boot-guile-uri arch) @@ -275,38 +270,8 @@ generated file." (_ #t))) =20 -(define (make-git-predicate directory) - "Return a predicate that returns true if a file is part of the Git check= out -living at DIRECTORY. Upon Git failure, return #f instead of a predicate." - (define (parent-directory? thing directory) - ;; Return #t if DIRECTORY is the parent of THING. - (or (string-suffix? thing directory) - (and (string-index thing #\/) - (parent-directory? (dirname thing) directory)))) - - (let* ((pipe (with-directory-excursion directory - (open-pipe* OPEN_READ "git" "ls-files"))) - (files (let loop ((lines '())) - (match (read-line pipe) - ((? eof-object?) - (reverse lines)) - (line - (loop (cons line lines)))))) - (status (close-pipe pipe))) - (and (zero? status) - (lambda (file stat) - (match (stat:type stat) - ('directory - ;; 'git ls-files' does not list directories, only regular fi= les, - ;; so we need this special trick. - (any (cut parent-directory? <> file) files)) - ((or 'regular 'symlink) - (any (cut string-suffix? <> file) files)) - (_ - #f)))))) - (define-public current-guix - (let ((select? (delay (or (make-git-predicate + (let ((select? (delay (or (git-predicate (string-append (current-source-directory) "/../..")) source-file?)))) diff --git a/guix/git-download.scm b/guix/git-download.scm index 62e625c71..5d86ab2b6 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright =C2=A9 2014, 2015, 2016 Ludovic Court=C3=A8s +;;; Copyright =C2=A9 2017 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,6 +18,7 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (guix git-download) + #:use-module (guix build utils) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) @@ -24,6 +26,9 @@ #:use-module (guix packages) #:autoload (guix build-system gnu) (standard-packages) #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-1) #:export (git-reference git-reference? git-reference-url @@ -32,7 +37,8 @@ =20 git-fetch git-version - git-file-name)) + git-file-name + git-predicate)) =20 ;;; Commentary: ;;; @@ -119,4 +125,39 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a= generic name if #f." "Return the file-name for packages using git-download." (string-append name "-" version "-checkout")) =20 +(define (git-predicate directory) + "Return a predicate that returns true if a file is part of the Git check= out +living at DIRECTORY. Upon Git failure, return #f instead of a predicate. + +The returned predicate takes two arguments FILE and STAT where FILE is an +absolute file name and STAT is the result of 'lstat'." + (define (parent-directory? thing directory) + ;; Return #t if DIRECTORY is the parent of THING. + (or (string-suffix? thing directory) + (and (string-index thing #\/) + (parent-directory? (dirname thing) directory)))) + + (let* ((pipe (with-directory-excursion directory + (open-pipe* OPEN_READ "git" "ls-files"))) + (files (let loop ((lines '())) + (match (read-line pipe) + ((? eof-object?) + (reverse lines)) + (line + (loop (cons line lines)))))) + (status (close-pipe pipe))) + (and (zero? status) + (lambda (file stat) + (match (stat:type stat) + ('directory + ;; 'git ls-files' does not list directories, only regular fi= les, + ;; so we need this special trick. + (any (lambda (f) (parent-directory? f file)) + files)) + ((or 'regular 'symlink) + (any (lambda (f) (string-suffix? f file)) + files)) + (_ + #f)))))) + ;;; git-download.scm ends here --=20 2.11.0 --=-=-= Content-Type: text/plain Thanks. -- Mathieu Lirzin GPG: F2A3 8D7E EB2B 6640 5761 070D 0ADE E100 9460 4D37 --=-=-=--