From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp0 ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id qB65JQ6Fnl/5SgAA0tVLHw (envelope-from ) for ; Sun, 01 Nov 2020 09:51:10 +0000 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp0 with LMTPS id gPy7IQ6Fnl86dAAA1q6Kng (envelope-from ) for ; Sun, 01 Nov 2020 09:51:10 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 5D1AB9403E6 for ; Sun, 1 Nov 2020 09:51:10 +0000 (UTC) Received: from localhost ([::1]:54542 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kZA0z-0003tS-70 for larch@yhetil.org; Sun, 01 Nov 2020 04:51:09 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:55328) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kZA0s-0003sm-3g for guix-patches@gnu.org; Sun, 01 Nov 2020 04:51:02 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:52365) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kZA0r-0000dC-RH for guix-patches@gnu.org; Sun, 01 Nov 2020 04:51:01 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kZA0r-00038l-Q3 for guix-patches@gnu.org; Sun, 01 Nov 2020 04:51:01 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#44367] [PATCH 1/2] guix: hg-download: Add hg-predicate Resent-From: Holger Peters Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sun, 01 Nov 2020 09:51:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 44367 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 44367@debbugs.gnu.org Cc: Holger Peters Received: via spool by 44367-submit@debbugs.gnu.org id=B44367.160422424012026 (code B ref 44367); Sun, 01 Nov 2020 09:51:01 +0000 Received: (at 44367) by debbugs.gnu.org; 1 Nov 2020 09:50:40 +0000 Received: from localhost ([127.0.0.1]:35675 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kZA0W-00037t-0p for submit@debbugs.gnu.org; Sun, 01 Nov 2020 04:50:40 -0500 Received: from mout01.posteo.de ([185.67.36.65]:57999) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kZA0U-00037b-4e for 44367@debbugs.gnu.org; Sun, 01 Nov 2020 04:50:38 -0500 Received: from submission (posteo.de [89.146.220.130]) by mout01.posteo.de (Postfix) with ESMTPS id 717A0160063 for <44367@debbugs.gnu.org>; Sun, 1 Nov 2020 10:50:31 +0100 (CET) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=posteo.de; s=2017; t=1604224231; bh=sw7ae4g95zb0sH3+qP/ZmB095VaC9o0DokOQr+ZaFk4=; h=From:To:Cc:Subject:Date:From; b=M/ED59LMsbG3GSnLY5/GKEgjJ5S7Jz9m6gGM8zEUls0BvWuESJ6HyklWGrJigTnD0 d78R7N4TkawpCGOuXyz6u+97ijMRc8pSl8n2S4VilTFJH5kRfnpMO+ijp6s/SXrJWP 7BZGpW980gP5BLxMHaEcFdCNm8vf/Q3YVoMA0HscETg3LOJiGlS13DpUvWGtvB8zah 5zwEHCmTqV3GFSDQTwY7PthmXTXiWaC8U0SMgpbTt7ZUKEjJ/ZjCapsUQfh1IbObKq 0yUOutqVt2/0E2r4BtoO0JvYEN2HeZbYk9W3bduNuFcqZ2OMFm+4oOJ8guvu5aitXJ emxN/f3JTyRxA== Received: from customer (localhost [127.0.0.1]) by submission (posteo.de) with ESMTPSA id 4CPB9y4sk5z9rxK; Sun, 1 Nov 2020 10:50:30 +0100 (CET) From: Holger Peters Date: Sun, 1 Nov 2020 10:50:24 +0100 Message-Id: <9169d111edc807df292fe0566ce72f84e6d5dd44.1604223741.git.holger.peters@posteo.de> X-Mailer: git-send-email 2.28.0 In-Reply-To: References: MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-Spam-Score: -3.3 (---) X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Scanner: ns3122888.ip-94-23-21.eu Authentication-Results: aspmx1.migadu.com; dkim=fail (headers rsa verify failed) header.d=posteo.de header.s=2017 header.b=M/ED59LM; dmarc=fail reason="SPF not aligned (strict)" header.from=posteo.de (policy=none); spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Spam-Score: 5.09 X-TUID: O8D7lZtMLe3q `hg-predicate' acts for mercurial repositories as `git-predicate' acts for git-repositories. * guix/hg-download.scm (hg-predicate): New variable. --- guix/hg-download.scm | 38 +++++++++++++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/guix/hg-download.scm b/guix/hg-download.scm index 694105ceba..44212e295e 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -26,12 +26,14 @@ #: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) #:export (hg-reference hg-reference? hg-reference-url hg-reference-changeset hg-reference-recursive? - + hg-predicate hg-fetch)) ;;; Commentary: @@ -93,4 +95,38 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:recursive? #t #:guile-for-build guile))) +(define (hg-file-list directory) + "Evaluates to a list of files contained in the repository at path + @var{directory}" + (let* ((port (open-input-pipe (format #f "hg files --repository ~s" directory))) + (files (let loop ((files '())) + (let ((line (read-line port))) + (cond + ((eof-object? line) files) + (else + (loop (cons line files)))))))) + (close-pipe port) + (map canonicalize-path files))) + +(define (should-select? pth-lst candidate) + "Returns #t in case that @var{candidate} is a file is part of the given file + list @var{path-list}." + (let ((canon-candidate (canonicalize-path candidate))) + (let loop ((xs pth-lst)) + (cond + ((null? xs) + ;; Directories are not part of `hg files', but `local-file' will not + ;; recurse if we don't return #t for directories. + (equal? (array-ref (lstat candidate) 13) 'directory)) + ((string-contains candidate (car xs)) #t) + (else (loop (cdr xs))))))) + +(define (hg-predicate directory) + "This procedure evaluates to a predicate that reports back whether a given + @var{file} - @var{stat} combination is part of the files tracked by + mercurial." + (let ((files (hg-file-list directory))) + (lambda (file stat) + (should-select? files file)))) + ;;; hg-download.scm ends here -- 2.28.0