GNU bug report logs - #26645
guix potluck

Please note: This is a static page, with minimal formatting, updated once a day.
Click here to see this page with the latest information and nicer formatting.

Package: guix-patches; Severity: important; Reported by: Andy Wingo <wingo@HIDDEN>; dated Mon, 24 Apr 2017 20:54:02 UTC; Maintainer for guix-patches is guix-patches@HIDDEN.
Severity set to 'important' from 'normal' Request was from ludo@HIDDEN (Ludovic Courtès) to control <at> debbugs.gnu.org. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:21:51 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:21:50 2017
Received: from localhost ([127.0.0.1]:38590 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2lQc-0005BP-M2
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:21:50 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:56131
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2lQa-0005BH-PL
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:21:49 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 6A1E174E7C
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 17:21:48 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=eG2k
 rKcvNvQ8npyQ1pmoxifFQcY=; b=qUnUgfqiotgBYt73o+x9lIuPl8vU0RYWiri0
 WJTIAZtsLSgpweOjWY+RMrGBnh21fIwxgu9z9KIt5w/DzHTt4XpmKdx5SsxsVPyT
 rjPwl3CwAG0fhd9Y6S+y7RFfyQGwh7wnxp+O1PpV4tKx2zs4HH1ht7UnTrocyvFZ
 y9xiN5c=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 627D274E7B
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 17:21:48 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 6B40E74E7A
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 17:21:47 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 6/9] gnu: Add find-package-binding.
Date: Mon, 24 Apr 2017 22:59:20 +0200
Message-Id: <20170424205923.27726-6-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: 061C7CDE-2934-11E7-933C-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* gnu/packages.scm (find-package-binding): New export.
---
 gnu/packages.scm | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 61 insertions(+), 1 deletion(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 92bab7228..5e85d3dd6 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -55,7 +55,9 @@
             find-newest-available-packages
 
             specification->package
-            specification->package+output))
+            specification->package+output
+
+            find-package-binding))
 
 ;;; Commentary:
 ;;;
@@ -368,3 +370,61 @@ version; if SPEC does not specify an output, return OUTPUT."
            (leave (_ "package `~a' lacks output `~a'~%")
                   (package-full-name package)
                   sub-drv))))))
+
+(define (find-package-binding package)
+  "Find the module that exports PACKAGE.  Return two values, an interface name
+and a symbol that can be used to import PACKAGE.  Signal an error if no public variable binds PACKAGE."
+  (define (strip-extension file exts)
+    (or (or-map (lambda (ext)
+                  (and (string-suffix? ext file)
+                       (substring file 0 (- (string-length file)
+                                            (string-length ext)))))
+                exts)
+        file))
+  (define (file-name->module-name file)
+    (and (not (absolute-file-name? file))
+         (map string->symbol
+              (string-split (strip-extension file %load-extensions)
+                            #\/))))
+  ;; Instead of building a table and always doing a search, first just see if
+  ;; we can use the package's location to find its module and look in that
+  ;; module.
+  (define (global-search)
+    (let search ((modules (all-package-modules)))
+      (match modules
+        (()
+         (raise (condition
+                 (&message (message
+                            (format #f (_ "~a@~a: binding not found")
+                                    (package-name package)
+                                    (package-version package)))))))
+        ((mod . modules)
+         (let ((next (lambda () (search modules))))
+           (local-search (module-name mod) mod next))))))
+  (define (local-search module-name iface k)
+    (let lp ((bindings (module-map cons iface)))
+      (match bindings
+        (() (k))
+        (((sym . var) . bindings)
+         (if (eq? (variable-ref var) package)
+             (values module-name sym)
+             (lp bindings))))))
+  (cond
+   ((package-location package)
+    => (lambda (loc)
+         (cond
+          ((file-name->module-name (location-file loc))
+           => (lambda (module-name)
+                (cond
+                 ((false-if-exception (resolve-interface module-name))
+                  => (lambda (iface)
+                       (let ((def (string->symbol (package-name package))))
+                         (cond
+                          ((and (module-variable iface def)
+                                (eq? (module-ref iface def) package))
+                           (values module-name def))
+                          (else
+                           (local-search module-name iface global-search))))))
+                 (else (global-search)))))
+          (else (global-search)))))
+   (else (global-search))))
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:10:05 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:10:05 2017
Received: from localhost ([127.0.0.1]:38575 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2lFF-0004ug-Ch
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:10:05 -0400
Received: from fragranza.investici.org ([178.175.144.26]:26962)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <contact.ng0@HIDDEN>) id 1d2lFB-0004uB-L8
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:10:03 -0400
Received: from [178.175.144.26] (fragranza [178.175.144.26]) (Authenticated
 sender: niasterisk@HIDDEN) by localhost (Postfix) with ESMTPSA id
 A24232C012A; Mon, 24 Apr 2017 21:09:59 +0000 (UTC)
DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=cryptolab.net;
 s=stigmate; t=1493068199;
 bh=OsXJh3YZpwdNha0zZzfp1pkaS0W2zJmqL/cO49UPkYs=;
 h=Date:From:To:Cc:Subject:References:In-Reply-To;
 b=f6710eGsiIjTivNH5V8B1tbCfEcR+YcSKrPY4ufnbIqfJT6gCiyTtShqPruqWOL/L
 rk4ZIVz9xCN65WfWaA0plchoupX1RHQualEWPzJZo9Ek9HCej94q7B+1zmX7qGMOHS
 9jB8NmHz2Aqq3+ZZBN/ADsA4r2AxnldKa5QExhss=
Date: Mon, 24 Apr 2017 21:09:18 +0000
From: ng0 <contact.ng0@HIDDEN>
To: Andy Wingo <wingo@HIDDEN>
Subject: Re: bug#26645: guix potluck
Message-ID: <20170424210918.pwipe4a26ivaexvc@abyayala>
Mail-Followup-To: Andy Wingo <wingo@HIDDEN>, 26645 <at> debbugs.gnu.org
References: <87y3upttm7.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Disposition: inline
In-Reply-To: <87y3upttm7.fsf@HIDDEN>
X-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: 26645
Cc: 26645 <at> debbugs.gnu.org
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.0 (/)

Andy Wingo transcribed 0.2K bytes:
> Hi,
> 
> The attached patches add a "guix potluck" facility, as described on
> guix-devel:
> 
>   https://lists.gnu.org/archive/html/guix-devel/2017-04/msg00250.html
> 
> Cheers,
> 
> Andy
> 
> 
> 

Cool :)

(but as you might've realized, this broke guix-patches in the way that you've just sent 57 new messages, hopefully all in one bug)
-- 
PGP and more: https://people.pragmatique.xyz/ng0/




Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:12 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:04:12 2017
Received: from localhost ([127.0.0.1]:38563 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l9U-0004lc-Eb
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:04:12 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:54962
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l9F-0004jF-U9
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:03:59 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id EC5FF74D32
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:mime-version:content-type
 :content-transfer-encoding; s=sasl; bh=/U7YvCWRRtgTKxEHLu0Z1p51m
 q8=; b=ZJLLE08bbd2ZgXgLzNshldrM7FvCboEfoC/MF00t2JlZjsUEK3c6lXXOK
 aofa0nahKRpjAztIMsHViUZKj1V7K+ms1vX1//3pzaK9yVnM1jch70hgkc5vXpsg
 vZw0QF4ob1bVGZSwbFsJOYqrAL41e0nAh5mtCDXZKxuiNyZFxc=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id E3D2D74D31
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id AED0174D16
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:43 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 1/9] guix: Add "potluck" packages.
Date: Mon, 24 Apr 2017 22:59:15 +0200
Message-Id: <20170424205923.27726-1-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F11E17AA-2930-11E7-8B69-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/build-systems.scm:
* guix/potluck/licenses.scm:
* guix/potluck/packages.scm: New files.
* guix/scripts/build.scm (load-package-or-derivation-from-file):
(options->things-to-build, options->derivations): Add "potluck-package" a=
nd
"potluck-source" to environment of file.  Lower potluck packages to Guix
packages.
---
 Makefile.am                    |   3 +
 guix/potluck/build-systems.scm |  55 ++++++
 guix/potluck/licenses.scm      |  41 +++++
 guix/potluck/packages.scm      | 399 +++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/build.scm         |  54 +++---
 5 files changed, 532 insertions(+), 20 deletions(-)
 create mode 100644 guix/potluck/build-systems.scm
 create mode 100644 guix/potluck/licenses.scm
 create mode 100644 guix/potluck/packages.scm

diff --git a/Makefile.am b/Makefile.am
index db4ebe04d..22ba00e90 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,9 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/potluck/build-systems.scm		\
+  guix/potluck/licenses.scm			\
+  guix/potluck/packages.scm			\
   guix/import/utils.scm				\
   guix/import/gnu.scm				\
   guix/import/snix.scm				\
diff --git a/guix/potluck/build-systems.scm b/guix/potluck/build-systems.=
scm
new file mode 100644
index 000000000..1f6aa1fe3
--- /dev/null
+++ b/guix/potluck/build-systems.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck build-systems)
+  #:use-module ((guix build-system) #:select (build-system?))
+  #:use-module ((gnu packages) #:select (scheme-modules))
+  #:use-module (ice-9 match)
+  #:export (build-system-by-name all-potluck-build-system-names))
+
+(define all-build-systems
+  (delay
+    (let* ((gbs (or (search-path %load-path "guix/build-system.scm")
+                    (error "can't find (guix build-system)")))
+           (root (dirname (dirname gbs)))
+           (by-name (make-hash-table)))
+      (for-each (lambda (iface)
+                  (module-for-each
+                   (lambda (k var)
+                     (let* ((str (symbol->string k))
+                            (pos (string-contains str "-build-system"))
+                            (val (variable-ref var)))
+                       (when (and pos (build-system? val))
+                         (let* ((head (substring str 0 pos))
+                                (tail (substring str
+                                                 (+ pos (string-length
+                                                         "-build-system"=
))))
+                                (name (string->symbol
+                                       (string-append head tail))))
+                           (hashq-set! by-name name val)))))
+                   iface))
+                (scheme-modules root "guix/build-system"))
+      by-name)))
+
+(define (all-potluck-build-system-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-build-systems))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (build-system-by-name name)
+  (hashq-ref (force all-build-systems) name))
diff --git a/guix/potluck/licenses.scm b/guix/potluck/licenses.scm
new file mode 100644
index 000000000..6efeee21a
--- /dev/null
+++ b/guix/potluck/licenses.scm
@@ -0,0 +1,41 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck licenses)
+  #:use-module ((guix licenses) #:select (license?))
+  #:use-module (ice-9 match)
+  #:export (license-by-name all-potluck-license-names))
+
+(define all-licenses
+  (delay
+    (let ((iface (resolve-interface '(guix licenses)))
+          (by-name (make-hash-table)))
+      (module-for-each (lambda (k var)
+                         (let ((val (variable-ref var)))
+                           (when (license? val)
+                             (hashq-set! by-name k val))))
+                       (resolve-interface '(guix licenses)))
+      by-name)))
+
+(define (all-potluck-license-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-licenses))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (license-by-name name)
+  (hashq-ref (force all-licenses) name))
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
new file mode 100644
index 000000000..c7dae3791
--- /dev/null
+++ b/guix/potluck/packages.scm
@@ -0,0 +1,399 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Court=C3=
=A8s <ludo@HIDDEN>
+;;; Copyright =C2=A9 2014, 2015 Mark H Weaver <mhw@HIDDEN>
+;;; Copyright =C2=A9 2015 Eric Bavier <bavier@HIDDEN>
+;;; Copyright =C2=A9 2016 Alex Kost <alezost@HIDDEN>
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck packages)
+  #:use-module (gnu packages)
+  #:use-module (guix base32)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (web uri)
+  #:export (potluck-source
+            potluck-source?
+            potluck-source-git-uri
+            potluck-source-git-commit
+            potluck-source-sha256
+            potluck-source-snippet
+
+            potluck-package
+            potluck-package?
+            potluck-package-name
+            potluck-package-version
+            potluck-package-source
+            potluck-package-build-system
+            potluck-package-arguments
+            potluck-package-inputs
+            potluck-package-native-inputs
+            potluck-package-propagated-inputs
+            potluck-package-synopsis
+            potluck-package-description
+            potluck-package-license
+            potluck-package-home-page
+            potluck-package-location
+            potluck-package-field-location
+
+            pretty-print-potluck-source
+            pretty-print-potluck-package
+
+            validate-potluck-package
+
+            lower-potluck-source
+            lower-potluck-package))
+
+;;; Commentary:
+;;;
+;;; This module provides a facility to define "potluck packages" in a
+;;; Guix-based distribution, and a facility to translate those packages =
to
+;;; "normal" Guix packages.
+;;;
+;;; Code:
+
+(define-record-type* <potluck-source>
+  potluck-source make-potluck-source
+  potluck-source?
+  (git-uri    potluck-source-git-uri)               ; uri string
+  (git-commit potluck-source-git-commit)            ; git sha1 string
+  (sha256     potluck-source-sha256)                ; base32 string
+  (snippet    potluck-source-snippet (default #f))) ; sexp or #f
+
+(define-record-type* <potluck-package>
+  potluck-package make-potluck-package
+  potluck-package?
+  (name               potluck-package-name)         ; string
+  (version            potluck-package-version)      ; string
+  (source             potluck-package-source)       ; <potluck-source>
+                                                    ; instance
+  (build-system       potluck-package-build-system) ; build system name =
as
+                                                    ; symbol
+  (arguments          potluck-package-arguments     ; arguments for the =
build
+                                                    ; method
+                      (default '()))
+  (inputs             potluck-package-inputs        ; input packages or
+                                                    ; derivations
+                      (default '()))
+  (propagated-inputs  potluck-package-propagated-inputs ; same, but prop=
agated
+                      (default '()))
+  (native-inputs      potluck-package-native-inputs ; native input packa=
ges or
+                                                    ; derivations
+                      (default '()))
+  (synopsis           potluck-package-synopsis)     ; one-line descripti=
on
+  (description        potluck-package-description)  ; one or two paragra=
phs
+  (license            potluck-package-license)
+  (home-page          potluck-package-home-page)
+  (location           potluck-package-location
+                      (default (and=3D> (current-source-location)
+                                      source-properties->location))
+                      (innate)))
+
+;; Printers.
+
+(define (print-potluck-source potluck-source port)
+  "Write a concise representation of POTLUCK-SOURCE to PORT."
+  (match potluck-source
+    (($ <potluck-source> git-uri git-commit sha256 snippet)
+     (simple-format port "#<potluck-source ~a@~a ~a ~a>"
+                    git-uri git-commit sha256
+                    (number->string (object-address potluck-source) 16))=
)))
+
+(define (print-potluck-package package port)
+  (let ((loc    (potluck-package-location package))
+        (format simple-format))
+    (format port "#<potluck-package ~a@~a ~a~a>"
+            (potluck-package-name package)
+            (potluck-package-version package)
+            (if loc
+                (format #f "~a:~a "
+                        (location-file loc)
+                        (location-line loc))
+                "")
+            (number->string (object-address
+                             package)
+                            16))))
+
+(set-record-type-printer! <potluck-source> print-potluck-source)
+(set-record-type-printer! <potluck-package> print-potluck-package)
+
+;; Pretty-printers.
+
+(define* (pretty-print-potluck-source port source #:key (prefix "")
+                                      (suffix "\n"))
+  (let ((uri (potluck-source-git-uri source))
+        (commit (potluck-source-git-commit source))
+        (sha256 (potluck-source-sha256 source))
+        (snippet (potluck-source-snippet source)))
+    (format port "~a(potluck-source" prefix)
+    (format port "\n~a  (git-uri ~s)" prefix uri)
+    (format port "\n~a  (git-commit ~s)" prefix commit)
+    (format port "\n~a  (sha256 ~s)" prefix sha256)
+    (when snippet
+      (format port "\n~a  (snippet '~s)" prefix snippet))
+    (format port ")~a" suffix)))
+
+(define* (pretty-print-potluck-package port pkg #:key (prefix ""))
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (format port "~a(potluck-package\n" prefix)
+    (format port "~a  (name ~s)\n" prefix name)
+    (format port "~a  (version ~s)\n" prefix version)
+    (format port "~a  (source\n" prefix)
+    (pretty-print-potluck-source port source #:prefix
+                                 (string-append prefix "    ")
+                                 #:suffix ")\n")
+    (format port "~a  (build-system '~s)\n" prefix build-system)
+    (format port "~a  (inputs '~s)\n" prefix inputs)
+    (format port "~a  (native-inputs '~s)\n" prefix native-inputs)
+    (format port "~a  (propagated-inputs '~s)\n" prefix propagated-input=
s)
+    (match arguments
+      (()
+       (format port "~a  (arguments '())\n" prefix))
+      (arguments
+       (pretty-print `(arguments ',arguments) port
+                     #:per-line-prefix (format #f "~a  " prefix))))
+    (format port "~a  (home-page ~s)\n" prefix home-page)
+    (format port "~a  (synopsis ~s)\n" prefix synopsis)
+    (format port "~a  (description ~s)\n" prefix description)
+    (format port "~a  (license '~s))\n" prefix license)))
+
+;; Editing.
+
+(define (potluck-package-field-location package field)
+  "Return the source code location of the definition of FIELD for PACKAG=
E, or
+#f if it could not be determined."
+  (define (goto port line column)
+    (unless (and (=3D (port-column port) (- column 1))
+                 (=3D (port-line port) (- line 1)))
+      (unless (eof-object? (read-char port))
+        (goto port line column))))
+
+  (match (potluck-package-location package)
+    (($ <location> file line column)
+     (catch 'system
+       (lambda ()
+         ;; In general we want to keep relative file names for modules.
+         (with-fluids ((%file-port-name-canonicalization 'relative))
+           (call-with-input-file (search-path %load-path file)
+             (lambda (port)
+               (goto port line column)
+               (match (read port)
+                 (('potluck-package inits ...)
+                  (let ((field (assoc field inits)))
+                    (match field
+                      ((_ value)
+                       ;; Put the `or' here, and not in the first argume=
nt of
+                       ;; `and=3D>', to work around a compiler bug in 2.=
0.5.
+                       (or (and=3D> (source-properties value)
+                                  source-properties->location)
+                           (and=3D> (source-properties field)
+                                  source-properties->location)))
+                      (_
+                       #f))))
+                 (_
+                  #f))))))
+       (lambda _
+         #f)))
+    (_ #f)))
+
+;; Lower potluck packages to Guix packages.
+
+(define-condition-type &potluck-package-error &error
+  potluck-package-error?
+  (potluck-package potluck-package-error-potluck-package))
+
+(define-condition-type &potluck-package-validation-error &potluck-packag=
e-error
+  potluck-package-validation-error?
+  (field-name potluck-package-validation-error-field-name)
+  (assertion potluck-package-validation-error-assertion)
+  (value potluck-package-validation-error-value))
+
+(define (assertion-failed pkg field-name assertion value)
+  (raise (condition (&potluck-package-validation-error
+                     (potluck-package pkg)
+                     (field-name field-name)
+                     (assertion assertion)
+                     (value value)))))
+
+(define* (validate-public-uri pkg field-name str #:key (schemes '(http h=
ttps)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (assertion-failed pkg field-name "public URI" str))))
+
+(define (validate-git-commit pkg field-name commit)
+  (unless (and (string? commit)
+               (=3D (string-length commit) 40)
+               (string-every (string->char-set "abcdef0123456789") commi=
t))
+    (assertion-failed pkg field-name "full git commit SHA1 hash" commit)=
))
+
+(define (validate-base32-sha256 pkg field-name str)
+  (unless (and (string? str)
+               (=3D (string-length str) 52)
+               (false-if-exception (nix-base32-string->bytevector str)))
+    (assertion-failed pkg field-name "sha256 hash as a base32 string" st=
r)))
+
+(define (validate-potluck-source pkg field-name source)
+  (validate-public-uri pkg field-name (potluck-source-git-uri source)
+                       #:schemes '(git http https))
+  (validate-git-commit pkg field-name (potluck-source-git-commit source)=
)
+  (validate-base32-sha256 pkg field-name (potluck-source-sha256 source))
+  (validate-snippet pkg field-name (potluck-source-snippet source)))
+
+(define (validate-snippet pkg field-name snippet)
+  (match snippet
+    (#f #t)
+    ((_ ...) #t)
+    (_ (assertion-failed pkg field-name "valid snippet" snippet))))
+
+(define (validate-non-empty-string pkg field-name str)
+  (unless (and (string? str)
+               (not (string-null? str)))
+    (assertion-failed pkg field-name "non-empty string" str)))
+
+(define (validate-build-system pkg field-name sym)
+  (unless (build-system-by-name sym)
+    (assertion-failed pkg field-name "build system name as symbol" sym))=
)
+
+(define (validate-package-list pkg field-name l)
+  (unless (and (list? l) (and-map string? l))
+    (assertion-failed pkg field-name
+                      "list of package or package@version strings" l)))
+
+(define* (validate-keyword-arguments pkg field-name l #:optional (valid-=
kw? (const #t)))
+  (define validate-1
+    (case-lambda
+      (() #t)
+      ((k v . rest)
+       (unless (and (keyword? k) (valid-kw? k))
+         (assertion-failed pkg field-name "keyword" k))
+       (apply validate-1 rest))
+      (_ (assertion-failed pkg field-name "keyword argument list" l))))
+  (apply validate-1 l))
+
+(define (validate-arguments pkg field-name arguments)
+  (validate-keyword-arguments pkg field-name arguments))
+
+(define (validate-synopsis pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The synopsis set by "guix potluck init".
+  (when (equal? str "Declarative synopsis here")
+    (assertion-failed pkg field-name "updated synopsis" str)))
+
+(define (validate-description pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The description set by "guix potluck init".
+  (when (string-suffix? "..." str)
+    (assertion-failed pkg field-name "updated description" str)))
+
+(define (validate-license pkg field-name sym)
+  (unless (license-by-name sym)
+    (assertion-failed pkg field-name "license name as symbol" sym)))
+
+(define (validate-potluck-package pkg)
+  (validate-non-empty-string pkg 'name (potluck-package-name pkg))
+  (validate-non-empty-string pkg 'version (potluck-package-version pkg))
+  (validate-potluck-source pkg 'source (potluck-package-source pkg))
+  (validate-build-system pkg 'build-system (potluck-package-build-system=
 pkg))
+  (validate-package-list pkg 'inputs (potluck-package-inputs pkg))
+  (validate-package-list pkg 'native-inputs
+                         (potluck-package-native-inputs pkg))
+  (validate-package-list pkg 'propagated-inputs
+                         (potluck-package-propagated-inputs pkg))
+  (validate-arguments pkg 'arguments (potluck-package-arguments pkg))
+  (validate-public-uri pkg 'home-page (potluck-package-home-page pkg))
+  (validate-synopsis pkg 'synopsis (potluck-package-synopsis pkg))
+  (validate-description pkg 'description (potluck-package-description pk=
g))
+  (validate-license pkg 'license (potluck-package-license pkg)))
+
+(define (lower-potluck-source o)
+  (let ((uri (potluck-source-git-uri o))
+        (commit (potluck-source-git-commit o))
+        (sha256 (potluck-source-sha256 o))
+        (snippet (potluck-source-snippet o)))
+    (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url uri)
+            (commit commit)))
+      (snippet snippet)
+      (sha256 (base32 sha256)))))
+
+(define (lower-input input)
+  (call-with-values (lambda () (specification->package+output input))
+    (lambda (pkg output)
+      (cons* (package-name pkg) pkg
+             (if (equal? output "out")
+                 '()
+                 (list output))))))
+
+(define (lower-inputs inputs)
+  (map lower-input inputs))
+
+(define (lower-potluck-package pkg)
+  (validate-potluck-package pkg)
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (package
+      (name name)
+      (version version)
+      (source (lower-potluck-source source))
+      (build-system (build-system-by-name build-system))
+      (inputs (lower-inputs inputs))
+      (native-inputs (lower-inputs native-inputs))
+      (propagated-inputs (lower-inputs propagated-inputs))
+      (arguments arguments)
+      (home-page home-page)
+      (synopsis synopsis)
+      (description description)
+      (license (license-by-name license)))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 6bb1f72eb..be26f63c9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix potluck packages)
   #:use-module (guix grafts)
=20
   ;; Use the procedure that destructures "NAME-VERSION" forms.
@@ -582,11 +583,20 @@ must be one of 'package', 'all', or 'transitive'~%"=
)
          (append %transformation-options
                  %standard-build-options)))
=20
+(define (load-package-or-derivation-from-file file)
+  (let ((mod (make-user-module '())))
+    ;; Expose potluck-package and potluck-source to the file.
+    (module-use! mod (resolve-interface
+                      '(guix potluck packages)
+                      #:select '(potluck-package potluck-source)))
+    (load* file mod)))
+
 (define (options->things-to-build opts)
   "Read the arguments from OPTS and return a list of high-level objects =
to
 build---packages, gexps, derivations, and so on."
   (define (validate-type x)
-    (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+    (unless (or (package? x) (potluck-package? x)
+                (derivation? x) (gexp? x) (procedure? x))
       (leave (_ "~s: not something we can build~%") x)))
=20
   (define (ensure-list x)
@@ -606,7 +616,7 @@ build---packages, gexps, derivations, and so on."
                        (else
                         (list (specification->package spec)))))
                 (('file . file)
-                 (ensure-list (load* file (make-user-module '()))))
+                 (ensure-list (load-package-or-derivation-from-file file=
)))
                 (('expression . str)
                  (ensure-list (read/eval str)))
                 (('argument . (? derivation? drv))
@@ -630,27 +640,31 @@ build."
   (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
=20
+  (define (package->derivation-list p)
+    (let ((p (or (and graft? (package-replacement p)) p)))
+      (match src
+        (#f
+         (list (package->derivation store p system)))
+        (#t
+         (match (package-source p)
+           (#f
+            (format (current-error-port)
+                    (_ "~a: warning: package '~a' has no source~%")
+                    (location->string (package-location p))
+                    (package-name p))
+            '())
+           (s
+            (list (package-source-derivation store s)))))
+        (proc
+         (map (cut package-source-derivation store <>)
+              (proc p))))))
+
   (parameterize ((%graft? graft?))
     (append-map (match-lambda
                   ((? package? p)
-                   (let ((p (or (and graft? (package-replacement p)) p))=
)
-                     (match src
-                       (#f
-                        (list (package->derivation store p system)))
-                       (#t
-                        (match (package-source p)
-                          (#f
-                           (format (current-error-port)
-                                   (_ "~a: warning: \
-package '~a' has no source~%")
-                                   (location->string (package-location p=
))
-                                   (package-name p))
-                           '())
-                          (s
-                           (list (package-source-derivation store s)))))
-                       (proc
-                        (map (cut package-source-derivation store <>)
-                             (proc p))))))
+                   (package->derivation-list p))
+                  ((? potluck-package? p)
+                   (package->derivation-list (lower-potluck-package p)))
                   ((? derivation? drv)
                    (list drv))
                   ((? procedure? proc)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:08 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:04:08 2017
Received: from localhost ([127.0.0.1]:38557 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l9O-0004kl-Vo
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:04:08 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:56370
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l9E-0004jC-Vo
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:03:57 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 0DBCC74D27
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=m8jRC6JiZFmt
 G7XyB8O6Z6i8XjY=; b=sYuEH0D3sasxCT1F596qLWgCiPjSoMyo72RSn8PaRA/3
 DB0GEebPqQHLsf5n7VbxlGRudIr7veeuR502DcUVQmYiHWX4dILldkBbhAstGbZw
 dN0PfaWUUOD1/B85gAeNIPN7iwicxnuk+yv/YyR5yhUBndYx08eOn1SFrvyYkNI=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 0412774D26
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 168C574D1C
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:44 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 8/9] potluck: Add host-channel subcommand.
Date: Mon, 24 Apr 2017 22:59:22 +0200
Message-Id: <20170424205923.27726-8-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F1F31400-2930-11E7-B7B2-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/host.scm: New file.
* Makefile.am (MODULES): Add new file.
* guix/scripts/potluck.scm: Add host-channel command.
---
 Makefile.am              |   1 +
 guix/potluck/host.scm    | 304 +++++++++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/potluck.scm | 137 +++++++++++++++++++--
 3 files changed, 430 insertions(+), 12 deletions(-)
 create mode 100644 guix/potluck/host.scm

diff --git a/Makefile.am b/Makefile.am
index 628283b57..94fa05d5b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -129,6 +129,7 @@ MODULES =3D					\
   guix/git.scm					\
   guix/potluck/build-systems.scm		\
   guix/potluck/environment.scm			\
+  guix/potluck/host.scm				\
   guix/potluck/licenses.scm			\
   guix/potluck/packages.scm			\
   guix/import/utils.scm				\
diff --git a/guix/potluck/host.scm b/guix/potluck/host.scm
new file mode 100644
index 000000000..5ac8e0f5f
--- /dev/null
+++ b/guix/potluck/host.scm
@@ -0,0 +1,304 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck host)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module (guix ui)
+  #:use-module ((guix build utils)
+                #:select (mkdir-p
+                          delete-file-recursively
+                          with-directory-excursion))
+  #:use-module (guix git)
+  #:use-module (guix utils)
+  #:use-module (guix potluck packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 q)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 threads)
+  #:use-module (json)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (web uri)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web server)
+  #:export (host-potluck))
+
+=0C
+;;;
+;;; async queues
+;;;
+
+(define-record-type <async-queue>
+  (make-aq mutex condvar q)
+  async-queue?
+  (mutex aq-mutex)
+  (condvar aq-condvar)
+  (q aq-q))
+
+(set-record-type-printer!
+ <async-queue>
+ (lambda (aq port)
+   (format port "<async-queue ~a ~a>" (object-address aq)
+           (q-length (aq-q aq)))))
+
+(define* (make-async-queue)
+  (make-aq (make-mutex)
+           (make-condition-variable)
+           (make-q)))
+
+(define* (async-queue-push! aq item)
+  (with-mutex (aq-mutex aq)
+    (enq! (aq-q aq) item)
+    (signal-condition-variable (aq-condvar aq))))
+
+(define* (async-queue-pop! aq)
+  (with-mutex (aq-mutex aq)
+    (let lp ()
+      (cond
+       ((q-empty? (aq-q aq))
+        (wait-condition-variable (aq-condvar aq) (aq-mutex aq))
+        (lp))
+       (else
+        (q-pop! (aq-q aq)))))))
+
+=0C
+;;;
+;;; backend
+;;;
+
+(define (bytes-free-on-fs filename)
+  (let* ((p (open-pipe* "r" "df" "-B1" "--output=3Davail" filename))
+         (l1 (read-line p))
+         (l2 (read-line p))
+         (l3 (read-line p)))
+    (close-pipe p)
+    (cond
+     ((and (string? l1) (string? l2) (eof-object? l3)
+           (equal? (string-trim-both l1) "Avail"))
+      (string->number l2))
+     (else
+      (error "could not get free space for file system containing" filen=
ame)))))
+
+(define (delete-directory-contents-recursively working-dir)
+  (for-each (lambda (file)
+              (delete-file-recursively (in-vicinity working-dir file)))
+            (scandir working-dir
+                     (lambda (file)
+                       (and (string<> "." file)
+                            (string<> ".." file))))))
+
+;; 1GB minimum free space.
+(define *mininum-free-space* #e1e9)
+
+(define (scm-files-in-dir dir)
+  (map (lambda (file)
+         (in-vicinity dir file))
+       (scandir dir
+                (lambda (file)
+                  (and (not (file-is-directory? (in-vicinity dir file)))
+                       (string-suffix? ".scm" file))))))
+
+(define (copy-header-comments port file)
+  (call-with-input-file file
+    (lambda (in)
+      (let lp ()
+        (let ((line (read-line in)))
+          (unless (eof-object? line)
+            (let ((trimmed (string-trim line)))
+              (when (or (string-null? trimmed) (string-prefix? ";" trimm=
ed))
+                (display trimmed port)
+                (newline port)
+                (lp)))))))))
+
+(define (process-update host working-dir source-checkout target-checkout
+                        remote-git-url branch)
+  (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+    (delete-directory-contents-recursively working-dir)
+    (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+      (error "not enough free space")))
+  (chdir working-dir)
+  (let* ((repo-dir (uri-encode remote-git-url))
+         (repo+branch-dir (in-vicinity repo-dir (uri-encode branch))))
+    (cond
+     ((file-exists? repo-dir)
+      (chdir repo-dir)
+      (git-fetch))
+     (else
+      (git-clone remote-git-url repo-dir)
+      (chdir repo-dir)))
+    (git-reset #:ref (string-append "origin/" branch) #:mode 'hard)
+    (unless (file-is-directory? "guix-potluck")
+      (error "repo+branch has no guix-potluck dir" remote-git-url branch=
))
+    (let* ((files (scm-files-in-dir "guix-potluck"))
+           ;; This step safely loads and validates the potluck package
+           ;; definitions.
+           (packages (map load-potluck-package files))
+           (source-dir (in-vicinity source-checkout repo+branch-dir))
+           (target-dir (in-vicinity target-checkout
+                                    (in-vicinity "gnu/packages/potluck"
+                                                 repo+branch-dir))))
+      ;; Clear source and target repo entries.
+      (define (ensure-empty-dir filename)
+        (when (file-exists? filename)
+          (delete-file-recursively filename))
+        (mkdir-p filename))
+      (define (commit-dir dir)
+        (with-directory-excursion dir
+          (git-add ".")
+          (git-commit #:message
+                      (format #f "Update ~a branch ~a."
+                              remote-git-url branch)
+                      #:author-name "Guix potluck host"
+                      #:author-email (string-append "host@" host))
+          (git-push)))
+      (ensure-empty-dir source-dir)
+      (ensure-empty-dir target-dir)
+      ;; Add potluck files to source repo.
+      (for-each (lambda (file)
+                  (copy-file file (in-vicinity source-dir (basename file=
))))
+                files)
+      (commit-dir source-dir)
+      ;; Add transformed files to target repo.
+      (for-each (lambda (file package)
+                  (call-with-output-file
+                      (in-vicinity target-dir (basename file))
+                    (lambda (port)
+                      (define module-name
+                        `(gnu packages potluck
+                              ,repo-dir
+                              ,(uri-encode branch)
+                              ,(substring (basename file) 0
+                                          (- (string-length (basename fi=
le))
+                                             (string-length ".scm")))))
+                      ;; Preserve copyright notices if possible.
+                      (copy-header-comments port file)
+                      (lower-potluck-package-to-module port module-name
+                                                       package))))
+                files packages)
+      (commit-dir target-dir)))
+  ;; 8. post success message
+  (pk 'success target-checkout remote-git-url branch))
+
+(define (service-queue host working-dir source-checkout target-checkout =
queue)
+  (let lp ()
+    (match (async-queue-pop! queue)
+      ((remote-git-url . branch)
+       (format (current-error-port) "log: handling ~a / ~a\n"
+               remote-git-url branch)
+       (catch #t
+         (lambda ()
+           (process-update host working-dir
+                           source-checkout target-checkout
+                           remote-git-url branch)
+           (format (current-error-port) "log: success ~a / ~a\n"
+                   remote-git-url branch))
+         (lambda (k . args)
+           (format (current-error-port) "log: failure ~a / ~a\n"
+                   remote-git-url branch)
+           (print-exception (current-error-port) #f k args)))
+       (lp)))))
+
+=0C
+;;;
+;;; frontend
+;;;
+
+(define* (validate-public-uri str #:key (schemes '(http https)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (error "expected a public URI" str))))
+
+(define (validate-branch-name str)
+  (unless (git-check-ref-format str #:allow-onelevel? #t)
+    (error "expected a valid git branch name" str)))
+
+(define (enqueue-update params queue)
+  (let ((remote-git-url (hash-ref params "git-url"))
+        (branch-name (hash-ref params "branch")))
+    (validate-public-uri remote-git-url)
+    (validate-branch-name branch-name)
+    (async-queue-push! queue (cons remote-git-url branch-name))))
+
+(define (request-body-json request body)
+  (cond
+   ((string? body) (json-string->scm body))
+   ((bytevector? body)
+    (let* ((content-type (request-content-type request))
+           (charset (or (assoc-ref (cdr content-type) "charset")
+                        "utf-8")))
+      (json-string->scm (bytevector->string body charset))))
+   ((port? body) (json->scm body))
+   (else (error "unexpected body" body))))
+
+(define (handler request body queue)
+  (match (cons (request-method request)
+               (split-and-decode-uri-path (uri-path (request-uri request=
))))
+    (('GET)
+     (values (build-response #:code 200)
+             "todo: show work queue"))
+    (('POST "api" "enqueue-update")
+     ;; An exception will cause error 500.
+     (enqueue-update (request-body-json request body) queue)
+     (values (build-response #:code 200)
+             ""))
+    (_
+     (values (build-response #:code 404)
+             ""))))
+
+(define (host-potluck host local-port working-dir source-checkout
+                      target-checkout)
+  (let ((worker-thread #f)
+        (queue (make-async-queue)))
+    (dynamic-wind (lambda ()
+                    (set! worker-thread
+                      (make-thread
+                       (service-queue host working-dir
+                                      source-checkout target-checkout
+                                      queue))))
+                  (lambda ()
+                    (run-server
+                     (lambda (request body)
+                       (handler request body queue))
+                     ;; Always listen on localhost.
+                     'http `(#:port ,local-port)))
+                  (lambda ()
+                    (cancel-thread worker-thread)))))
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
index f9cd40bd0..ec306cae6 100644
--- a/guix/scripts/potluck.scm
+++ b/guix/scripts/potluck.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck host)
   #:use-module (guix potluck licenses)
   #:use-module (guix potluck packages)
   #:use-module (guix scripts)
@@ -47,12 +48,12 @@
 ;;; guix potluck init
 ;;;
=20
-(define* (init-potluck remote-git-url #:key
+(define* (init-potluck host remote-git-url #:key
                        (build-system 'gnu) (autoreconf? #f)
                        (license 'gplv3+))
   (let* ((cwd (getcwd))
          (dot-git (in-vicinity cwd ".git"))
-         (potluck-dir (in-vicinity cwd "potluck"))
+         (potluck-dir (in-vicinity cwd "guix-potluck"))
          (package-name (basename cwd)))
     (unless (and (file-exists? dot-git)
                  (file-is-directory? dot-git))
@@ -74,17 +75,17 @@
            ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
            ;; here.
            (pkg-sha256 (guix-hash-git-checkout cwd)))
-      (format #t (_ "Creating potluck/~%"))
+      (format #t (_ "Creating guix-potluck/~%"))
       (mkdir potluck-dir)
-      (format #t (_ "Creating potluck/README.md~%"))
+      (format #t (_ "Creating guix-potluck/README.md~%"))
       (call-with-output-file (in-vicinity potluck-dir "README.md")
         (lambda (port)
           (format port
                   "\
 This directory defines potluck packages.  Each file in this directory sh=
ould
-define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+define one package.  See https://guix-potluck.org/ for more information.
 ")))
-      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (format #t (_ "Creating guix-potluck/~a.scm~%") package-name)
       (call-with-output-file (in-vicinity potluck-dir
                                           (string-append package-name ".=
scm"))
         (lambda (port)
@@ -133,16 +134,39 @@ define one package.  See https://potluck.guixsd.org=
/ for more information.
                             " is a ..."))
             (license license)))))
       (format #t (_ "
-Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
-\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+Done.  Now open guix-potluck/~a.scm in your editor, fill out its \"synop=
sis\"
+and \"description\" fields, add dependencies to the 'inputs' field, and =
try to
 build with
=20
-  guix build --file=3Dpotluck/~a.scm
+  guix build --file=3Dguix-potluck/~a.scm
=20
 When you get that working, commit your results to git via:
=20
   git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
-") pkg-name pkg-name))))
+
+Once you push them out, add your dish to the communal potluck by running=
:
+
+  guix potluck update ~a
+") pkg-name pkg-name remote-git-url))))
+
+;;;
+;;; guix potluck update
+;;;
+
+(define (request-potluck-update host git-url branch)
+  (call-with-values (lambda ()
+                      (http-post (build-uri 'https
+                                            #:host host
+                                            #:path "/api/enqueue-update"=
)
+                                 #:body (scm->json-string
+                                         `((git-url . ,git-url)
+                                           (branch . ,branch)))))
+    (lambda (response body)
+      (unless (eqv? (response-code response) 200)
+        (error "request failed"
+               (response-code response)
+               (response-reason-phrase response)
+               body)))))
=20
 =0C
 ;;;
@@ -159,10 +183,33 @@ ARGS.\n"))
   (newline)
   (display (_ "\
    init             create potluck recipe for current working directory\=
n"))
+  (display (_ "\
+   update           ask potluck host to add or update a potluck package\=
n"))
+  (display (_ "\
+   host-channel     run web service providing potluck packages as Guix c=
hannel\n"))
=20
   (newline)
   (display (_ "The available OPTION flags are:\n"))
   (display (_ "
+      --host=3DHOST        for 'update' and 'host-channel', the name of =
the
+                         channel host
+                         (default: guix-potluck.org)"))
+  (display (_ "
+      --port=3DPORT        for 'host-channel', the local TCP port on whi=
ch to
+                         listen for HTTP connections
+                         (default: 8080)"))
+  (display (_ "
+      --scratch=3DDIR      for 'host-channel', the path to a local direc=
tory
+                         that will be used as a scratch space to check o=
ut
+                         remote git repositories"))
+  (display (_ "
+      --source=3DDIR       for 'host-channel', the path to a local check=
out
+                         of guix potluck source packages to be managed b=
y
+                         host-channel"))
+  (display (_ "
+      --target=3DDIR       for 'host-channel', the path to a local check=
out
+                         of a guix channel to be managed by host-channel=
"))
+  (display (_ "
       --build-system=3DSYS for 'init', specify the build system.  Use
                          --build-system=3Dhelp for all available options=
."))
   (display (_ "
@@ -201,19 +248,56 @@ ARGS.\n"))
         (option '("license") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'license arg result)))
+        (option '("host") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'host arg result)))
+        (option '("port") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'port arg result)))
+        (option '("scratch") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'scratch arg result)))
+        (option '("source") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'source arg result)))
+        (option '("target") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'target arg result)))
         (option '("verbosity") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'verbosity (string->number arg) result))))=
)
=20
 (define %default-options
   ;; Alist of default option values.
-  `((verbosity . 0)))
+  `((host . "guix-potluck.org")
+    (port . "8080")
+    (verbosity . 0)))
+
+(define (parse-host host-str)
+  ;; Will throw if the host is invalid somehow.
+  (build-uri 'https #:host host-str)
+  host-str)
=20
 (define (parse-url url-str)
   (unless (string->uri url-str)
     (leave (_ "invalid url: ~a~%") url-str))
   url-str)
=20
+(define (parse-port port-str)
+  (let ((port (string->number port-str)))
+    (cond
+     ((and port (exact-integer? port) (<=3D 0 port #xffff))
+      port)
+     (else
+      (leave (_ "invalid port: ~a~%") port-str)))))
+
+(define (parse-absolute-directory-name str)
+  (unless (and (absolute-file-name? str)
+               (file-exists? str)
+               (file-is-directory? str))
+    (leave (_ "invalid absolute directory name: ~a~%") str))
+  str)
+
 (define (parse-build-system sys-str)
   (unless sys-str
     (leave (_ "\
@@ -297,7 +381,8 @@ If your package's license is not in this list, add it=
 to Guix first.~%")
         ('init
          (match args
            ((remote-git-url)
-            (init-potluck (parse-url remote-git-url)
+            (init-potluck (parse-host (assoc-ref opts 'host))
+                          (parse-url remote-git-url)
                           #:build-system (parse-build-system
                                           (assoc-ref opts 'build-system)=
)
                           #:autoreconf? (assoc-ref opts 'autoreconf?)
@@ -306,5 +391,33 @@ If your package's license is not in this list, add i=
t to Guix first.~%")
            (args
             (wrong-number-of-args
              (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        ('update
+         (match args
+           ((remote-git-url branch)
+            (request-potluck-update (parse-host (assoc-ref opts 'host))
+                                    (parse-url remote-git-url)
+                                    branch))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck update REMOTE-GIT-URL BRANCH-NAME")=
))))
+        ('host-channel
+         (match args
+           (()
+            (host-potluck (parse-host (assoc-ref opts 'host))
+                          (parse-port (assoc-ref opts 'port))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'scratch)
+                               (leave (_ "missing --scratch argument~%")=
)))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'source)
+                               (leave (_ "missing --source argument~%"))=
))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'target)
+                               (leave (_ "missing --target argument~%"))=
))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck host-channel --scratch=3DDIR \
+--source=3DDIR --target=3DDIR"))
+            (exit 1))))
         (action
          (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:02 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:04:02 2017
Received: from localhost ([127.0.0.1]:38552 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l9N-0004kL-Sw
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:04:02 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:56781
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l9G-0004jL-HK
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:03:55 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 8EAF774D5E
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:53 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=l4NC9HTIUcDN
 MZ41kSKW8U3bPi4=; b=ZgsoGeMv/YP77iRozjDJ2rWe/7+c8lbPbJzY6Lo9f9lB
 exv3zyh61ahfW8mUvOYr4jZ7Seq/tUw8bsaJPFjpqKNsC3Mw5GJIDcNQ07ZQ3L1R
 Dp7DlD4nmJ7EScZSagerp9tPOz49IgAaVcAtR74x8vDk/iM3KSzTM9fotpIWvXM=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 86E2574D5D
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:53 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 688B474D50
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:52 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox.
Date: Mon, 24 Apr 2017 22:59:19 +0200
Message-Id: <20170424205923.27726-5-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F64DB640-2930-11E7-B805-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/environment.scm: New file.
* Makefile.am (MODULES): Add new files.
* guix/potluck/packages.scm (make-potluck-sandbox-module)
  (eval-in-sandbox): New helpers.
  (load-potluck-package): New public function.
---
 Makefile.am                  |   1 +
 guix/potluck/environment.scm | 538 +++++++++++++++++++++++++++++++++++++=
++++++
 guix/potluck/packages.scm    |  59 +++++
 3 files changed, 598 insertions(+)
 create mode 100644 guix/potluck/environment.scm

diff --git a/Makefile.am b/Makefile.am
index 295d7b3a6..628283b57 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -128,6 +128,7 @@ MODULES =3D					\
   guix/packages.scm				\
   guix/git.scm					\
   guix/potluck/build-systems.scm		\
+  guix/potluck/environment.scm			\
   guix/potluck/licenses.scm			\
   guix/potluck/packages.scm			\
   guix/import/utils.scm				\
diff --git a/guix/potluck/environment.scm b/guix/potluck/environment.scm
new file mode 100644
index 000000000..f28ca11d5
--- /dev/null
+++ b/guix/potluck/environment.scm
@@ -0,0 +1,538 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck environment))
+
+;;; Commentary:
+;;;
+;;; This module's public interface forms a safe set of stable bindings
+;;; available to Guix potluck package definition files.
+;;;
+;;; Code:
+
+(define-syntax-rule (define-bindings module-name binding ...)
+  (module-use! (module-public-interface (current-module))
+               (resolve-interface 'module-name #:select '(binding ...)))=
)
+
+;; Core bindings.
+(define-bindings (guile)
+  and
+  begin
+  apply
+  call-with-values
+  values
+  case
+  case-lambda
+  case-lambda*
+  cond
+  define
+  define*
+  define-values
+  do
+  if
+  lambda
+  lambda*
+  let
+  let*
+  letrec
+  letrec*
+  or
+  quasiquote
+  quote
+  ;; Can't allow mutation to globals.
+  ;; set!
+  unless
+  unquote
+  unquote-splicing
+  when
+  while
+  =CE=BB)
+
+;; Macro bindings.
+(define-bindings (guile)
+  ;; Although these have "current" in their name, they are lexically
+  ;; scoped, not dynamically scoped.
+  current-filename
+  current-source-location
+  ;; A subset of Guile's macro capabilities, for simplicity.
+  define-syntax
+  define-syntax-parameter
+  define-syntax-rule
+  identifier-syntax
+  let-syntax
+  letrec-syntax
+  syntax-error
+  syntax-rules)
+
+;; Iteration bindings.
+(define-bindings (guile)
+  compose
+  for-each
+  identity
+  iota
+  map
+  map-in-order
+  const
+  noop)
+
+;; Unspecified bindings.
+(define-bindings (guile)
+  unspecified?
+  *unspecified*)
+
+;; Predicate bindings.
+(define-bindings (guile)
+  ->bool
+  and-map
+  and=3D>
+  boolean?
+  eq?
+  equal?
+  eqv?
+  negate
+  not
+  or-map)
+
+;; The current ports (current-input-port et al) are dynamically scoped,
+;; which is a footgun from a sandboxing perspective.  It's too easy for
+;; a procedure that is the result of a sandboxed evaluation to be later
+;; invoked in a different context and thereby be implicitly granted
+;; capabilities to whatever port is then current.  This is compounded by
+;; the fact that most Scheme i/o primitives allow the port to be omitted
+;; and thereby default to whatever's current.  For now, sadly, we avoid
+;; exposing any i/o primitive to the sandbox.
+
+;; Error bindings.
+(define-bindings (guile)
+  error
+  throw
+  with-throw-handler
+  catch
+  ;; false-if-exception can cause i/o if the #:warning arg is passed.
+  ;; false-if-exception
+  strerror
+  scm-error)
+
+;;  Sort bindings.
+(define-bindings (guile)
+  sort
+  sorted?
+  stable-sort
+  sort-list)
+
+;; Alist bindings.
+(define-bindings (guile)
+  acons
+  assoc
+  assoc-ref
+  assq
+  assq-ref
+  assv
+  assv-ref
+  sloppy-assoc
+  sloppy-assq
+  sloppy-assv)
+
+;; Number bindings.
+(define-bindings (guile)
+  *
+  +
+  -
+  /
+  1+
+  1-
+  <
+  <=3D
+  =3D
+  >
+  >=3D
+  abs
+  acos
+  acosh
+  angle
+  asin
+  asinh
+  atan
+  atanh
+  ceiling
+  ceiling-quotient
+  ceiling-remainder
+  ceiling/
+  centered-quotient
+  centered-remainder
+  centered/
+  complex?
+  cos
+  cosh
+  denominator
+  euclidean-quotient
+  euclidean-remainder
+  euclidean/
+  even?
+  exact->inexact
+  exact-integer-sqrt
+  exact-integer?
+  exact?
+  exp
+  expt
+  finite?
+  floor
+  floor-quotient
+  floor-remainder
+  floor/
+  gcd
+  imag-part
+  inf
+  inf?
+  integer-expt
+  integer-length
+  integer?
+  lcm
+  log
+  log10
+  magnitude
+  make-polar
+  make-rectangular
+  max
+  min
+  modulo
+  modulo-expt
+  most-negative-fixnum
+  most-positive-fixnum
+  nan
+  nan?
+  negative?
+  numerator
+  odd?
+  positive?
+  quotient
+  rational?
+  rationalize
+  real-part
+  real?
+  remainder
+  round
+  round-quotient
+  round-remainder
+  round/
+  sin
+  sinh
+  sqrt
+  tan
+  tanh
+  truncate
+  truncate-quotient
+  truncate-remainder
+  truncate/
+  zero?
+  number?
+  number->string
+  string->number)
+
+;; Charset bindings.
+(define-bindings (guile)
+  ->char-set
+  char-set
+  char-set->list
+  char-set->string
+  char-set-adjoin
+  char-set-any
+  char-set-complement
+  char-set-contains?
+  char-set-copy
+  char-set-count
+  char-set-cursor
+  char-set-cursor-next
+  char-set-delete
+  char-set-diff+intersection
+  char-set-difference
+  char-set-every
+  char-set-filter
+  char-set-fold
+  char-set-for-each
+  char-set-hash
+  char-set-intersection
+  char-set-map
+  char-set-ref
+  char-set-size
+  char-set-unfold
+  char-set-union
+  char-set-xor
+  char-set:ascii
+  char-set:blank
+  char-set:designated
+  char-set:digit
+  char-set:empty
+  char-set:full
+  char-set:graphic
+  char-set:hex-digit
+  char-set:iso-control
+  char-set:letter
+  char-set:letter+digit
+  char-set:lower-case
+  char-set:printing
+  char-set:punctuation
+  char-set:symbol
+  char-set:title-case
+  char-set:upper-case
+  char-set:whitespace
+  char-set<=3D
+  char-set=3D
+  char-set?
+  end-of-char-set?
+  list->char-set
+  string->char-set
+  ucs-range->char-set)
+
+;; String bindings.
+(define-bindings (guile)
+  absolute-file-name?
+  file-name-separator-string
+  file-name-separator?
+  in-vicinity
+  basename
+  dirname
+
+  list->string
+  make-string
+  reverse-list->string
+  string
+  string->list
+  string-any
+  string-any-c-code
+  string-append
+  string-append/shared
+  string-capitalize
+  string-ci<
+  string-ci<=3D
+  string-ci<=3D?
+  string-ci<>
+  string-ci<?
+  string-ci=3D
+  string-ci=3D?
+  string-ci>
+  string-ci>=3D
+  string-ci>=3D?
+  string-ci>?
+  string-compare
+  string-compare-ci
+  string-concatenate
+  string-concatenate-reverse
+  string-concatenate-reverse/shared
+  string-concatenate/shared
+  string-contains
+  string-contains-ci
+  string-copy
+  string-count
+  string-delete
+  string-downcase
+  string-drop
+  string-drop-right
+  string-every
+  string-filter
+  string-fold
+  string-fold-right
+  string-for-each
+  string-for-each-index
+  string-hash
+  string-hash-ci
+  string-index
+  string-index-right
+  string-join
+  string-length
+  string-map
+  string-normalize-nfc
+  string-normalize-nfd
+  string-normalize-nfkc
+  string-normalize-nfkd
+  string-null?
+  string-pad
+  string-pad-right
+  string-prefix-ci?
+  string-prefix-length
+  string-prefix-length-ci
+  string-prefix?
+  string-ref
+  string-replace
+  string-reverse
+  string-rindex
+  string-skip
+  string-skip-right
+  string-split
+  string-suffix-ci?
+  string-suffix-length
+  string-suffix-length-ci
+  string-suffix?
+  string-tabulate
+  string-take
+  string-take-right
+  string-titlecase
+  string-tokenize
+  string-trim
+  string-trim-both
+  string-trim-right
+  string-unfold
+  string-unfold-right
+  string-upcase
+  string-utf8-length
+  string<
+  string<=3D
+  string<=3D?
+  string<>
+  string<?
+  string=3D
+  string=3D?
+  string>
+  string>=3D
+  string>=3D?
+  string>?
+  string?
+  substring
+  substring/copy
+  substring/read-only
+  substring/shared
+  xsubstring)
+
+;; Symbol bindings.
+(define-bindings (guile)
+  string->symbol
+  string-ci->symbol
+  symbol->string
+  list->symbol
+  make-symbol
+  symbol
+  symbol-append
+  symbol-interned?
+  symbol?)
+
+;; Keyword bindings.
+(define-bindings (guile)
+  keyword?
+  keyword->symbol
+  symbol->keyword)
+
+;; Bit bindings.
+(define-bindings (guile)
+  ash
+  round-ash
+  logand
+  logcount
+  logior
+  lognot
+  logtest
+  logxor
+  logbit?)
+
+;; Char bindings.
+(define-bindings (guile)
+  char-alphabetic?
+  char-ci<=3D?
+  char-ci<?
+  char-ci=3D?
+  char-ci>=3D?
+  char-ci>?
+  char-downcase
+  char-general-category
+  char-is-both?
+  char-lower-case?
+  char-numeric?
+  char-titlecase
+  char-upcase
+  char-upper-case?
+  char-whitespace?
+  char<=3D?
+  char<?
+  char=3D?
+  char>=3D?
+  char>?
+  char?
+  char->integer
+  integer->char)
+
+;; List bindings.
+(define-bindings (guile)
+  list
+  list-cdr-ref
+  list-copy
+  list-head
+  list-index
+  list-ref
+  list-tail
+  list?
+  null?
+  make-list
+  append
+  delete
+  delq
+  delv
+  filter
+  length
+  member
+  memq
+  memv
+  merge
+  reverse)
+
+;; Pair bindings.
+(define-bindings (guile)
+  last-pair
+  pair?
+  caaaar
+  caaadr
+  caaar
+  caadar
+  caaddr
+  caadr
+  caar
+  cadaar
+  cadadr
+  cadar
+  caddar
+  cadddr
+  caddr
+  cadr
+  car
+  cdaaar
+  cdaadr
+  cdaar
+  cdadar
+  cdaddr
+  cdadr
+  cdar
+  cddaar
+  cddadr
+  cddar
+  cdddar
+  cddddr
+  cdddr
+  cddr
+  cdr
+  cons
+  cons*)
+
+;; Promise bindings.
+(define-bindings (guile)
+  force
+  delay
+  make-promise
+  promise?)
+
+;; Finally, the potluck bindings.
+(define-bindings (guix potluck packages)
+  potluck-package
+  potluck-source)
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
index c7dae3791..3bf2d67c1 100644
--- a/guix/potluck/packages.scm
+++ b/guix/potluck/packages.scm
@@ -62,6 +62,8 @@
             pretty-print-potluck-source
             pretty-print-potluck-package
=20
+            load-potluck-package
+
             validate-potluck-package
=20
             lower-potluck-source
@@ -191,6 +193,63 @@
     (format port "~a  (description ~s)\n" prefix description)
     (format port "~a  (license '~s))\n" prefix license)))
=20
+;; Safely loading potluck files.
+(define (make-potluck-sandbox-module)
+  "Return a fresh module that only imports the potluck environment."
+  (let ((m (make-fresh-user-module)))
+    (purify-module! m)
+    (module-use! m (resolve-interface '(guix potluck environment)))
+    m))
+
+(define eval-in-sandbox
+  (delay
+    (cond
+     ((false-if-exception (resolve-interface '(ice-9 sandbox)))
+      =3D> (lambda (m)
+           (module-ref m 'eval-in-sandbox)))
+     ((getenv "GUIX_POTLUCK_NO_SANDBOX")
+      (warn "No sandbox available; be warned!!!")
+      (lambda* (exp #:key time-limit allocation-limit module)
+        (eval exp module)))
+     (else
+      (error "sandbox facility unavailable")))))
+
+;; Because potluck package definitions come from untrusted parties, they=
 need
+;; to be sandboxed to prevent them from harming the host system.
+(define* (load-potluck-package file #:key
+                               (time-limit 1)
+                               (allocation-limit 50e6))
+  "Read a sequence of Scheme expressions from @var{file} and evaluate th=
em in
+a potluck sandbox.  The result of evaluating that expression sequence sh=
ould
+be a potluck package.  Any syntax error reading the expressions or run-t=
ime
+error evaluating the expressions will throw an exception.  The resulting
+potluck package will be validated with @code{validate-potluck-package}."
+  (define (read-expressions port)
+    (match (read port)
+      ((? eof-object?) '())
+      (exp (cons exp (read-expressions port)))))
+  (call-with-input-file file
+    (lambda (port)
+      (let ((exp (match (read-expressions port)
+                   (() (error "no expressions in file" file))
+                   (exps (cons 'begin exps))))
+            (mod (make-potluck-sandbox-module)))
+        (call-with-values
+            (lambda ()
+              ((force eval-in-sandbox) exp
+               #:time-limit time-limit
+               #:allocation-limit allocation-limit
+               #:module mod))
+          (lambda vals
+            (match vals
+              (() (error "no return values"))
+              ((val)
+               (unless (potluck-package? val)
+                 (error "not a potluck package" val))
+               (validate-potluck-package val)
+               val)
+              (_ (error "too many return values" vals)))))))))
+
 ;; Editing.
=20
 (define (potluck-package-field-location package field)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:02 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:04:01 2017
Received: from localhost ([127.0.0.1]:38550 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l9N-0004k9-Cq
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:04:01 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:52311
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l9F-0004jH-W2
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:03:54 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id E045974D49
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:51 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=TXXD
 1VVFOjWyygecr2OlqzBbiII=; b=NSU4qvaepukUgdolXz/HCWcXC+rbqh4+osQO
 4tp8jRtZ9wgi0VAaMdEfrAbpm3fFErwvGmQjrrgzPPyP6rUu7yTM6qBZRO8G33gG
 4S8uYcUSXjrFQuJ7IsaiN8seNrYlgFklUAYm0q++qAA05zu7pRZBX15+u8vYpXsl
 ucMCWzs=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id D9BA874D48
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:51 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 896C174D3A
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:50 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 7/9] potluck: Add ability to lower potluck package to guix
 package.
Date: Mon, 24 Apr 2017 22:59:21 +0200
Message-Id: <20170424205923.27726-7-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: F53261DE-2930-11E7-ABBA-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/packages.scm (lower-potluck-package-to-module): New public
function.
---
 guix/potluck/packages.scm | 118 +++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 117 insertions(+), 1 deletion(-)

diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
index 3bf2d67c1..3c7a1ca49 100644
--- a/guix/potluck/packages.scm
+++ b/guix/potluck/packages.scm
@@ -29,8 +29,10 @@
   #:use-module (guix potluck licenses)
   #:use-module (guix records)
   #:use-module (guix utils)
+  #:use-module ((guix ui) #:select (package-specification->name+version+output))
   #:use-module (ice-9 match)
   #:use-module (ice-9 pretty-print)
+  #:use-module ((srfi srfi-1) #:select (concatenate delete-duplicates))
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -67,7 +69,9 @@
             validate-potluck-package
 
             lower-potluck-source
-            lower-potluck-package))
+            lower-potluck-package
+
+            lower-potluck-package-to-module))
 
 ;;; Commentary:
 ;;;
@@ -456,3 +460,115 @@ potluck package will be validated with @code{validate-potluck-package}."
       (synopsis synopsis)
       (description description)
       (license (license-by-name license)))))
+
+(define (lower-potluck-package-to-module port lowered-module-name pkg)
+  (let ((lowered (lower-potluck-package pkg))
+        ;; specification -> exp
+        (spec->binding (make-hash-table))
+        ;; mod-name -> (sym ...)
+        (imports (make-hash-table))
+        ;; sym -> specification
+        (imported-syms (make-hash-table))
+        (needs-runtime-lookup? #f))
+    (define (add-bindings spec)
+      (unless (hash-ref spec->binding spec)
+        (match (false-if-exception (lower-input spec))
+          ((name pkg . outputs)
+           ;; Given that we found the pkg, surely we should find its binding
+           ;; also.
+           (call-with-values (lambda () (find-package-binding pkg))
+             (lambda (module-name sym)
+               ;; Currently we import these bindings using their original
+               ;; names.  We need to make sure that names don't collide.
+               ;; Ideally we should also ensure that they don't collide with
+               ;; other bindings that we import.
+               (when (hashq-ref imported-syms sym)
+                 (error "duplicate import name" sym))
+               (hashq-set! imported-syms sym spec)
+               (hash-set! spec->binding spec
+                          `(list ,name ,sym . ,outputs))
+               (hash-set! imports module-name
+                          (cons sym (hash-ref imports module-name '()))))))
+          (#f
+           (warn "could not resolve package specification" spec)
+           (call-with-values
+               (lambda ()
+                 (package-specification->name+version+output spec))
+             (lambda (name version . outputs)
+               (hash-set! spec->binding spec
+                          `(list ,name (specification->package ,spec) .
+                                 ,(if (equal? outputs '("out")) '() outputs)))
+               (set! needs-runtime-lookup? #t)))))))
+
+    (for-each add-bindings (potluck-package-inputs pkg))
+    (for-each add-bindings (potluck-package-native-inputs pkg))
+    (for-each add-bindings (potluck-package-propagated-inputs pkg))
+
+    (format port "(define-module ~a" lowered-module-name)
+    (format port "~%  #:pure")
+    ;; Because we're pure, we have to import these.
+    (format port "~%  #:use-module ((guile) #:select (list quote define-public))")
+    (when needs-runtime-lookup?
+      (format port "~%  #:use-module ((gnu packages) #:select (specification->package))"))
+    (format port "~%  #:use-module ((guix packages) #:select (package origin base32))")
+    (format port "~%  #:use-module ((guix git-download) #:select (git-fetch git-reference))")
+    (format port "~%  #:use-module ((guix licenses) #:select ((~a . license:~a)))"
+            (potluck-package-license pkg) (potluck-package-license pkg))
+    (format port "~%  #:use-module ((guix build-system ~a) #:select (~a-build-system))"
+            (potluck-package-build-system pkg) (potluck-package-build-system pkg))
+    (for-each (match-lambda
+                ((module-name . syms)
+                 (format port "~%  #:use-module (~a #:select ~a)"
+                         module-name syms)))
+              (hash-map->list cons imports))
+    (format port ")~%~%")
+
+    (format port "(define-public ~s\n" (string->symbol
+                                        (potluck-package-name pkg)))
+    (format port "  (package\n")
+    (format port "    (name ~s)\n" (potluck-package-name pkg))
+    (format port "    (version ~s)\n" (potluck-package-version pkg))
+    (format port "    (source\n")
+
+    (let ((source (potluck-package-source pkg)))
+      (format port "      (origin\n")
+      (format port "        (method git-fetch)\n")
+      (format port "        (uri (git-reference\n")
+      (format port "              (url ~s)\n" (potluck-source-git-uri source))
+      (format port "              (commit ~s)))\n"
+              (potluck-source-git-commit source))
+      (when (potluck-source-snippet source)
+        (pretty-print `(snippet ',(potluck-source-snippet source)) port
+                      #:per-line-prefix "        "))
+      (format port "        (sha256 (base32 ~s))))\n"
+              (potluck-source-sha256 source)))
+
+    (format port "    (build-system ~s-build-system)\n"
+            (potluck-package-build-system pkg))
+
+    (for-each
+     (match-lambda
+       ((name)
+        ;; No inputs; do nothing.
+        #t)
+       ((name . specs)
+        (pretty-print
+         `(,name (list ,@(map (lambda (spec)
+                                (or (hash-ref spec->binding spec)
+                                    (error "internal error" spec)))
+                              specs)))
+         port #:per-line-prefix "    ")))
+     `((inputs . ,(potluck-package-inputs pkg))
+       (native-inputs . ,(potluck-package-native-inputs pkg))
+       (propagated-inputs . ,(potluck-package-propagated-inputs pkg))))
+
+    (match (potluck-package-arguments pkg)
+      (() #t)
+      (arguments
+       (pretty-print `(arguments ',arguments) port #:per-line-prefix "    ")))
+
+    (format port "    (home-page ~s)\n" (potluck-package-home-page pkg))
+    (format port "    (synopsis ~s)\n" (potluck-package-synopsis pkg))
+    (format port "    (description ~s)\n" (potluck-package-description pkg))
+    (format port "    (license license:~s)))\n" (potluck-package-license pkg))
+    (force-output port)))
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:01 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:04:01 2017
Received: from localhost ([127.0.0.1]:38548 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l9M-0004k1-W2
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:04:01 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:57241
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l9E-0004jD-Vr
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:03:53 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 9A2E474D45
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:51 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=TXXD
 1VVFOjWyygecr2OlqzBbiII=; b=NSU4qvaepukUgdolXz/HCWcXC+rbqh4+osQO
 4tp8jRtZ9wgi0VAaMdEfrAbpm3fFErwvGmQjrrgzPPyP6rUu7yTM6qBZRO8G33gG
 4S8uYcUSXjrFQuJ7IsaiN8seNrYlgFklUAYm0q++qAA05zu7pRZBX15+u8vYpXsl
 ucMCWzs=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 9097C74D44
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:51 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 443DF74D38
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:50 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 7/9] potluck: Add ability to lower potluck package to guix
 package.
Date: Mon, 24 Apr 2017 22:59:21 +0200
Message-Id: <20170424205923.27726-7-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: F507549E-2930-11E7-A424-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/packages.scm (lower-potluck-package-to-module): New public
function.
---
 guix/potluck/packages.scm | 118 +++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 117 insertions(+), 1 deletion(-)

diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
index 3bf2d67c1..3c7a1ca49 100644
--- a/guix/potluck/packages.scm
+++ b/guix/potluck/packages.scm
@@ -29,8 +29,10 @@
   #:use-module (guix potluck licenses)
   #:use-module (guix records)
   #:use-module (guix utils)
+  #:use-module ((guix ui) #:select (package-specification->name+version+output))
   #:use-module (ice-9 match)
   #:use-module (ice-9 pretty-print)
+  #:use-module ((srfi srfi-1) #:select (concatenate delete-duplicates))
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -67,7 +69,9 @@
             validate-potluck-package
 
             lower-potluck-source
-            lower-potluck-package))
+            lower-potluck-package
+
+            lower-potluck-package-to-module))
 
 ;;; Commentary:
 ;;;
@@ -456,3 +460,115 @@ potluck package will be validated with @code{validate-potluck-package}."
       (synopsis synopsis)
       (description description)
       (license (license-by-name license)))))
+
+(define (lower-potluck-package-to-module port lowered-module-name pkg)
+  (let ((lowered (lower-potluck-package pkg))
+        ;; specification -> exp
+        (spec->binding (make-hash-table))
+        ;; mod-name -> (sym ...)
+        (imports (make-hash-table))
+        ;; sym -> specification
+        (imported-syms (make-hash-table))
+        (needs-runtime-lookup? #f))
+    (define (add-bindings spec)
+      (unless (hash-ref spec->binding spec)
+        (match (false-if-exception (lower-input spec))
+          ((name pkg . outputs)
+           ;; Given that we found the pkg, surely we should find its binding
+           ;; also.
+           (call-with-values (lambda () (find-package-binding pkg))
+             (lambda (module-name sym)
+               ;; Currently we import these bindings using their original
+               ;; names.  We need to make sure that names don't collide.
+               ;; Ideally we should also ensure that they don't collide with
+               ;; other bindings that we import.
+               (when (hashq-ref imported-syms sym)
+                 (error "duplicate import name" sym))
+               (hashq-set! imported-syms sym spec)
+               (hash-set! spec->binding spec
+                          `(list ,name ,sym . ,outputs))
+               (hash-set! imports module-name
+                          (cons sym (hash-ref imports module-name '()))))))
+          (#f
+           (warn "could not resolve package specification" spec)
+           (call-with-values
+               (lambda ()
+                 (package-specification->name+version+output spec))
+             (lambda (name version . outputs)
+               (hash-set! spec->binding spec
+                          `(list ,name (specification->package ,spec) .
+                                 ,(if (equal? outputs '("out")) '() outputs)))
+               (set! needs-runtime-lookup? #t)))))))
+
+    (for-each add-bindings (potluck-package-inputs pkg))
+    (for-each add-bindings (potluck-package-native-inputs pkg))
+    (for-each add-bindings (potluck-package-propagated-inputs pkg))
+
+    (format port "(define-module ~a" lowered-module-name)
+    (format port "~%  #:pure")
+    ;; Because we're pure, we have to import these.
+    (format port "~%  #:use-module ((guile) #:select (list quote define-public))")
+    (when needs-runtime-lookup?
+      (format port "~%  #:use-module ((gnu packages) #:select (specification->package))"))
+    (format port "~%  #:use-module ((guix packages) #:select (package origin base32))")
+    (format port "~%  #:use-module ((guix git-download) #:select (git-fetch git-reference))")
+    (format port "~%  #:use-module ((guix licenses) #:select ((~a . license:~a)))"
+            (potluck-package-license pkg) (potluck-package-license pkg))
+    (format port "~%  #:use-module ((guix build-system ~a) #:select (~a-build-system))"
+            (potluck-package-build-system pkg) (potluck-package-build-system pkg))
+    (for-each (match-lambda
+                ((module-name . syms)
+                 (format port "~%  #:use-module (~a #:select ~a)"
+                         module-name syms)))
+              (hash-map->list cons imports))
+    (format port ")~%~%")
+
+    (format port "(define-public ~s\n" (string->symbol
+                                        (potluck-package-name pkg)))
+    (format port "  (package\n")
+    (format port "    (name ~s)\n" (potluck-package-name pkg))
+    (format port "    (version ~s)\n" (potluck-package-version pkg))
+    (format port "    (source\n")
+
+    (let ((source (potluck-package-source pkg)))
+      (format port "      (origin\n")
+      (format port "        (method git-fetch)\n")
+      (format port "        (uri (git-reference\n")
+      (format port "              (url ~s)\n" (potluck-source-git-uri source))
+      (format port "              (commit ~s)))\n"
+              (potluck-source-git-commit source))
+      (when (potluck-source-snippet source)
+        (pretty-print `(snippet ',(potluck-source-snippet source)) port
+                      #:per-line-prefix "        "))
+      (format port "        (sha256 (base32 ~s))))\n"
+              (potluck-source-sha256 source)))
+
+    (format port "    (build-system ~s-build-system)\n"
+            (potluck-package-build-system pkg))
+
+    (for-each
+     (match-lambda
+       ((name)
+        ;; No inputs; do nothing.
+        #t)
+       ((name . specs)
+        (pretty-print
+         `(,name (list ,@(map (lambda (spec)
+                                (or (hash-ref spec->binding spec)
+                                    (error "internal error" spec)))
+                              specs)))
+         port #:per-line-prefix "    ")))
+     `((inputs . ,(potluck-package-inputs pkg))
+       (native-inputs . ,(potluck-package-native-inputs pkg))
+       (propagated-inputs . ,(potluck-package-propagated-inputs pkg))))
+
+    (match (potluck-package-arguments pkg)
+      (() #t)
+      (arguments
+       (pretty-print `(arguments ',arguments) port #:per-line-prefix "    ")))
+
+    (format port "    (home-page ~s)\n" (potluck-package-home-page pkg))
+    (format port "    (synopsis ~s)\n" (potluck-package-synopsis pkg))
+    (format port "    (description ~s)\n" (potluck-package-description pkg))
+    (format port "    (license license:~s)))\n" (potluck-package-license pkg))
+    (force-output port)))
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:01 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:04:00 2017
Received: from localhost ([127.0.0.1]:38546 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l9H-0004jf-UY
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:04:00 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:56773
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l9E-0004jB-Ua
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:03:53 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id A05B774D2E
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:mime-version:content-type
 :content-transfer-encoding; s=sasl; bh=/U7YvCWRRtgTKxEHLu0Z1p51m
 q8=; b=ZJLLE08bbd2ZgXgLzNshldrM7FvCboEfoC/MF00t2JlZjsUEK3c6lXXOK
 aofa0nahKRpjAztIMsHViUZKj1V7K+ms1vX1//3pzaK9yVnM1jch70hgkc5vXpsg
 vZw0QF4ob1bVGZSwbFsJOYqrAL41e0nAh5mtCDXZKxuiNyZFxc=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 990D074D2C
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 9BC1B74D14
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:43 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 1/9] guix: Add "potluck" packages.
Date: Mon, 24 Apr 2017 22:59:15 +0200
Message-Id: <20170424205923.27726-1-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F115B010-2930-11E7-9E84-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/build-systems.scm:
* guix/potluck/licenses.scm:
* guix/potluck/packages.scm: New files.
* guix/scripts/build.scm (load-package-or-derivation-from-file):
(options->things-to-build, options->derivations): Add "potluck-package" a=
nd
"potluck-source" to environment of file.  Lower potluck packages to Guix
packages.
---
 Makefile.am                    |   3 +
 guix/potluck/build-systems.scm |  55 ++++++
 guix/potluck/licenses.scm      |  41 +++++
 guix/potluck/packages.scm      | 399 +++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/build.scm         |  54 +++---
 5 files changed, 532 insertions(+), 20 deletions(-)
 create mode 100644 guix/potluck/build-systems.scm
 create mode 100644 guix/potluck/licenses.scm
 create mode 100644 guix/potluck/packages.scm

diff --git a/Makefile.am b/Makefile.am
index db4ebe04d..22ba00e90 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,9 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/potluck/build-systems.scm		\
+  guix/potluck/licenses.scm			\
+  guix/potluck/packages.scm			\
   guix/import/utils.scm				\
   guix/import/gnu.scm				\
   guix/import/snix.scm				\
diff --git a/guix/potluck/build-systems.scm b/guix/potluck/build-systems.=
scm
new file mode 100644
index 000000000..1f6aa1fe3
--- /dev/null
+++ b/guix/potluck/build-systems.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck build-systems)
+  #:use-module ((guix build-system) #:select (build-system?))
+  #:use-module ((gnu packages) #:select (scheme-modules))
+  #:use-module (ice-9 match)
+  #:export (build-system-by-name all-potluck-build-system-names))
+
+(define all-build-systems
+  (delay
+    (let* ((gbs (or (search-path %load-path "guix/build-system.scm")
+                    (error "can't find (guix build-system)")))
+           (root (dirname (dirname gbs)))
+           (by-name (make-hash-table)))
+      (for-each (lambda (iface)
+                  (module-for-each
+                   (lambda (k var)
+                     (let* ((str (symbol->string k))
+                            (pos (string-contains str "-build-system"))
+                            (val (variable-ref var)))
+                       (when (and pos (build-system? val))
+                         (let* ((head (substring str 0 pos))
+                                (tail (substring str
+                                                 (+ pos (string-length
+                                                         "-build-system"=
))))
+                                (name (string->symbol
+                                       (string-append head tail))))
+                           (hashq-set! by-name name val)))))
+                   iface))
+                (scheme-modules root "guix/build-system"))
+      by-name)))
+
+(define (all-potluck-build-system-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-build-systems))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (build-system-by-name name)
+  (hashq-ref (force all-build-systems) name))
diff --git a/guix/potluck/licenses.scm b/guix/potluck/licenses.scm
new file mode 100644
index 000000000..6efeee21a
--- /dev/null
+++ b/guix/potluck/licenses.scm
@@ -0,0 +1,41 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck licenses)
+  #:use-module ((guix licenses) #:select (license?))
+  #:use-module (ice-9 match)
+  #:export (license-by-name all-potluck-license-names))
+
+(define all-licenses
+  (delay
+    (let ((iface (resolve-interface '(guix licenses)))
+          (by-name (make-hash-table)))
+      (module-for-each (lambda (k var)
+                         (let ((val (variable-ref var)))
+                           (when (license? val)
+                             (hashq-set! by-name k val))))
+                       (resolve-interface '(guix licenses)))
+      by-name)))
+
+(define (all-potluck-license-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-licenses))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (license-by-name name)
+  (hashq-ref (force all-licenses) name))
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
new file mode 100644
index 000000000..c7dae3791
--- /dev/null
+++ b/guix/potluck/packages.scm
@@ -0,0 +1,399 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Court=C3=
=A8s <ludo@HIDDEN>
+;;; Copyright =C2=A9 2014, 2015 Mark H Weaver <mhw@HIDDEN>
+;;; Copyright =C2=A9 2015 Eric Bavier <bavier@HIDDEN>
+;;; Copyright =C2=A9 2016 Alex Kost <alezost@HIDDEN>
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck packages)
+  #:use-module (gnu packages)
+  #:use-module (guix base32)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (web uri)
+  #:export (potluck-source
+            potluck-source?
+            potluck-source-git-uri
+            potluck-source-git-commit
+            potluck-source-sha256
+            potluck-source-snippet
+
+            potluck-package
+            potluck-package?
+            potluck-package-name
+            potluck-package-version
+            potluck-package-source
+            potluck-package-build-system
+            potluck-package-arguments
+            potluck-package-inputs
+            potluck-package-native-inputs
+            potluck-package-propagated-inputs
+            potluck-package-synopsis
+            potluck-package-description
+            potluck-package-license
+            potluck-package-home-page
+            potluck-package-location
+            potluck-package-field-location
+
+            pretty-print-potluck-source
+            pretty-print-potluck-package
+
+            validate-potluck-package
+
+            lower-potluck-source
+            lower-potluck-package))
+
+;;; Commentary:
+;;;
+;;; This module provides a facility to define "potluck packages" in a
+;;; Guix-based distribution, and a facility to translate those packages =
to
+;;; "normal" Guix packages.
+;;;
+;;; Code:
+
+(define-record-type* <potluck-source>
+  potluck-source make-potluck-source
+  potluck-source?
+  (git-uri    potluck-source-git-uri)               ; uri string
+  (git-commit potluck-source-git-commit)            ; git sha1 string
+  (sha256     potluck-source-sha256)                ; base32 string
+  (snippet    potluck-source-snippet (default #f))) ; sexp or #f
+
+(define-record-type* <potluck-package>
+  potluck-package make-potluck-package
+  potluck-package?
+  (name               potluck-package-name)         ; string
+  (version            potluck-package-version)      ; string
+  (source             potluck-package-source)       ; <potluck-source>
+                                                    ; instance
+  (build-system       potluck-package-build-system) ; build system name =
as
+                                                    ; symbol
+  (arguments          potluck-package-arguments     ; arguments for the =
build
+                                                    ; method
+                      (default '()))
+  (inputs             potluck-package-inputs        ; input packages or
+                                                    ; derivations
+                      (default '()))
+  (propagated-inputs  potluck-package-propagated-inputs ; same, but prop=
agated
+                      (default '()))
+  (native-inputs      potluck-package-native-inputs ; native input packa=
ges or
+                                                    ; derivations
+                      (default '()))
+  (synopsis           potluck-package-synopsis)     ; one-line descripti=
on
+  (description        potluck-package-description)  ; one or two paragra=
phs
+  (license            potluck-package-license)
+  (home-page          potluck-package-home-page)
+  (location           potluck-package-location
+                      (default (and=3D> (current-source-location)
+                                      source-properties->location))
+                      (innate)))
+
+;; Printers.
+
+(define (print-potluck-source potluck-source port)
+  "Write a concise representation of POTLUCK-SOURCE to PORT."
+  (match potluck-source
+    (($ <potluck-source> git-uri git-commit sha256 snippet)
+     (simple-format port "#<potluck-source ~a@~a ~a ~a>"
+                    git-uri git-commit sha256
+                    (number->string (object-address potluck-source) 16))=
)))
+
+(define (print-potluck-package package port)
+  (let ((loc    (potluck-package-location package))
+        (format simple-format))
+    (format port "#<potluck-package ~a@~a ~a~a>"
+            (potluck-package-name package)
+            (potluck-package-version package)
+            (if loc
+                (format #f "~a:~a "
+                        (location-file loc)
+                        (location-line loc))
+                "")
+            (number->string (object-address
+                             package)
+                            16))))
+
+(set-record-type-printer! <potluck-source> print-potluck-source)
+(set-record-type-printer! <potluck-package> print-potluck-package)
+
+;; Pretty-printers.
+
+(define* (pretty-print-potluck-source port source #:key (prefix "")
+                                      (suffix "\n"))
+  (let ((uri (potluck-source-git-uri source))
+        (commit (potluck-source-git-commit source))
+        (sha256 (potluck-source-sha256 source))
+        (snippet (potluck-source-snippet source)))
+    (format port "~a(potluck-source" prefix)
+    (format port "\n~a  (git-uri ~s)" prefix uri)
+    (format port "\n~a  (git-commit ~s)" prefix commit)
+    (format port "\n~a  (sha256 ~s)" prefix sha256)
+    (when snippet
+      (format port "\n~a  (snippet '~s)" prefix snippet))
+    (format port ")~a" suffix)))
+
+(define* (pretty-print-potluck-package port pkg #:key (prefix ""))
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (format port "~a(potluck-package\n" prefix)
+    (format port "~a  (name ~s)\n" prefix name)
+    (format port "~a  (version ~s)\n" prefix version)
+    (format port "~a  (source\n" prefix)
+    (pretty-print-potluck-source port source #:prefix
+                                 (string-append prefix "    ")
+                                 #:suffix ")\n")
+    (format port "~a  (build-system '~s)\n" prefix build-system)
+    (format port "~a  (inputs '~s)\n" prefix inputs)
+    (format port "~a  (native-inputs '~s)\n" prefix native-inputs)
+    (format port "~a  (propagated-inputs '~s)\n" prefix propagated-input=
s)
+    (match arguments
+      (()
+       (format port "~a  (arguments '())\n" prefix))
+      (arguments
+       (pretty-print `(arguments ',arguments) port
+                     #:per-line-prefix (format #f "~a  " prefix))))
+    (format port "~a  (home-page ~s)\n" prefix home-page)
+    (format port "~a  (synopsis ~s)\n" prefix synopsis)
+    (format port "~a  (description ~s)\n" prefix description)
+    (format port "~a  (license '~s))\n" prefix license)))
+
+;; Editing.
+
+(define (potluck-package-field-location package field)
+  "Return the source code location of the definition of FIELD for PACKAG=
E, or
+#f if it could not be determined."
+  (define (goto port line column)
+    (unless (and (=3D (port-column port) (- column 1))
+                 (=3D (port-line port) (- line 1)))
+      (unless (eof-object? (read-char port))
+        (goto port line column))))
+
+  (match (potluck-package-location package)
+    (($ <location> file line column)
+     (catch 'system
+       (lambda ()
+         ;; In general we want to keep relative file names for modules.
+         (with-fluids ((%file-port-name-canonicalization 'relative))
+           (call-with-input-file (search-path %load-path file)
+             (lambda (port)
+               (goto port line column)
+               (match (read port)
+                 (('potluck-package inits ...)
+                  (let ((field (assoc field inits)))
+                    (match field
+                      ((_ value)
+                       ;; Put the `or' here, and not in the first argume=
nt of
+                       ;; `and=3D>', to work around a compiler bug in 2.=
0.5.
+                       (or (and=3D> (source-properties value)
+                                  source-properties->location)
+                           (and=3D> (source-properties field)
+                                  source-properties->location)))
+                      (_
+                       #f))))
+                 (_
+                  #f))))))
+       (lambda _
+         #f)))
+    (_ #f)))
+
+;; Lower potluck packages to Guix packages.
+
+(define-condition-type &potluck-package-error &error
+  potluck-package-error?
+  (potluck-package potluck-package-error-potluck-package))
+
+(define-condition-type &potluck-package-validation-error &potluck-packag=
e-error
+  potluck-package-validation-error?
+  (field-name potluck-package-validation-error-field-name)
+  (assertion potluck-package-validation-error-assertion)
+  (value potluck-package-validation-error-value))
+
+(define (assertion-failed pkg field-name assertion value)
+  (raise (condition (&potluck-package-validation-error
+                     (potluck-package pkg)
+                     (field-name field-name)
+                     (assertion assertion)
+                     (value value)))))
+
+(define* (validate-public-uri pkg field-name str #:key (schemes '(http h=
ttps)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (assertion-failed pkg field-name "public URI" str))))
+
+(define (validate-git-commit pkg field-name commit)
+  (unless (and (string? commit)
+               (=3D (string-length commit) 40)
+               (string-every (string->char-set "abcdef0123456789") commi=
t))
+    (assertion-failed pkg field-name "full git commit SHA1 hash" commit)=
))
+
+(define (validate-base32-sha256 pkg field-name str)
+  (unless (and (string? str)
+               (=3D (string-length str) 52)
+               (false-if-exception (nix-base32-string->bytevector str)))
+    (assertion-failed pkg field-name "sha256 hash as a base32 string" st=
r)))
+
+(define (validate-potluck-source pkg field-name source)
+  (validate-public-uri pkg field-name (potluck-source-git-uri source)
+                       #:schemes '(git http https))
+  (validate-git-commit pkg field-name (potluck-source-git-commit source)=
)
+  (validate-base32-sha256 pkg field-name (potluck-source-sha256 source))
+  (validate-snippet pkg field-name (potluck-source-snippet source)))
+
+(define (validate-snippet pkg field-name snippet)
+  (match snippet
+    (#f #t)
+    ((_ ...) #t)
+    (_ (assertion-failed pkg field-name "valid snippet" snippet))))
+
+(define (validate-non-empty-string pkg field-name str)
+  (unless (and (string? str)
+               (not (string-null? str)))
+    (assertion-failed pkg field-name "non-empty string" str)))
+
+(define (validate-build-system pkg field-name sym)
+  (unless (build-system-by-name sym)
+    (assertion-failed pkg field-name "build system name as symbol" sym))=
)
+
+(define (validate-package-list pkg field-name l)
+  (unless (and (list? l) (and-map string? l))
+    (assertion-failed pkg field-name
+                      "list of package or package@version strings" l)))
+
+(define* (validate-keyword-arguments pkg field-name l #:optional (valid-=
kw? (const #t)))
+  (define validate-1
+    (case-lambda
+      (() #t)
+      ((k v . rest)
+       (unless (and (keyword? k) (valid-kw? k))
+         (assertion-failed pkg field-name "keyword" k))
+       (apply validate-1 rest))
+      (_ (assertion-failed pkg field-name "keyword argument list" l))))
+  (apply validate-1 l))
+
+(define (validate-arguments pkg field-name arguments)
+  (validate-keyword-arguments pkg field-name arguments))
+
+(define (validate-synopsis pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The synopsis set by "guix potluck init".
+  (when (equal? str "Declarative synopsis here")
+    (assertion-failed pkg field-name "updated synopsis" str)))
+
+(define (validate-description pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The description set by "guix potluck init".
+  (when (string-suffix? "..." str)
+    (assertion-failed pkg field-name "updated description" str)))
+
+(define (validate-license pkg field-name sym)
+  (unless (license-by-name sym)
+    (assertion-failed pkg field-name "license name as symbol" sym)))
+
+(define (validate-potluck-package pkg)
+  (validate-non-empty-string pkg 'name (potluck-package-name pkg))
+  (validate-non-empty-string pkg 'version (potluck-package-version pkg))
+  (validate-potluck-source pkg 'source (potluck-package-source pkg))
+  (validate-build-system pkg 'build-system (potluck-package-build-system=
 pkg))
+  (validate-package-list pkg 'inputs (potluck-package-inputs pkg))
+  (validate-package-list pkg 'native-inputs
+                         (potluck-package-native-inputs pkg))
+  (validate-package-list pkg 'propagated-inputs
+                         (potluck-package-propagated-inputs pkg))
+  (validate-arguments pkg 'arguments (potluck-package-arguments pkg))
+  (validate-public-uri pkg 'home-page (potluck-package-home-page pkg))
+  (validate-synopsis pkg 'synopsis (potluck-package-synopsis pkg))
+  (validate-description pkg 'description (potluck-package-description pk=
g))
+  (validate-license pkg 'license (potluck-package-license pkg)))
+
+(define (lower-potluck-source o)
+  (let ((uri (potluck-source-git-uri o))
+        (commit (potluck-source-git-commit o))
+        (sha256 (potluck-source-sha256 o))
+        (snippet (potluck-source-snippet o)))
+    (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url uri)
+            (commit commit)))
+      (snippet snippet)
+      (sha256 (base32 sha256)))))
+
+(define (lower-input input)
+  (call-with-values (lambda () (specification->package+output input))
+    (lambda (pkg output)
+      (cons* (package-name pkg) pkg
+             (if (equal? output "out")
+                 '()
+                 (list output))))))
+
+(define (lower-inputs inputs)
+  (map lower-input inputs))
+
+(define (lower-potluck-package pkg)
+  (validate-potluck-package pkg)
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (package
+      (name name)
+      (version version)
+      (source (lower-potluck-source source))
+      (build-system (build-system-by-name build-system))
+      (inputs (lower-inputs inputs))
+      (native-inputs (lower-inputs native-inputs))
+      (propagated-inputs (lower-inputs propagated-inputs))
+      (arguments arguments)
+      (home-page home-page)
+      (synopsis synopsis)
+      (description description)
+      (license (license-by-name license)))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 6bb1f72eb..be26f63c9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix potluck packages)
   #:use-module (guix grafts)
=20
   ;; Use the procedure that destructures "NAME-VERSION" forms.
@@ -582,11 +583,20 @@ must be one of 'package', 'all', or 'transitive'~%"=
)
          (append %transformation-options
                  %standard-build-options)))
=20
+(define (load-package-or-derivation-from-file file)
+  (let ((mod (make-user-module '())))
+    ;; Expose potluck-package and potluck-source to the file.
+    (module-use! mod (resolve-interface
+                      '(guix potluck packages)
+                      #:select '(potluck-package potluck-source)))
+    (load* file mod)))
+
 (define (options->things-to-build opts)
   "Read the arguments from OPTS and return a list of high-level objects =
to
 build---packages, gexps, derivations, and so on."
   (define (validate-type x)
-    (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+    (unless (or (package? x) (potluck-package? x)
+                (derivation? x) (gexp? x) (procedure? x))
       (leave (_ "~s: not something we can build~%") x)))
=20
   (define (ensure-list x)
@@ -606,7 +616,7 @@ build---packages, gexps, derivations, and so on."
                        (else
                         (list (specification->package spec)))))
                 (('file . file)
-                 (ensure-list (load* file (make-user-module '()))))
+                 (ensure-list (load-package-or-derivation-from-file file=
)))
                 (('expression . str)
                  (ensure-list (read/eval str)))
                 (('argument . (? derivation? drv))
@@ -630,27 +640,31 @@ build."
   (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
=20
+  (define (package->derivation-list p)
+    (let ((p (or (and graft? (package-replacement p)) p)))
+      (match src
+        (#f
+         (list (package->derivation store p system)))
+        (#t
+         (match (package-source p)
+           (#f
+            (format (current-error-port)
+                    (_ "~a: warning: package '~a' has no source~%")
+                    (location->string (package-location p))
+                    (package-name p))
+            '())
+           (s
+            (list (package-source-derivation store s)))))
+        (proc
+         (map (cut package-source-derivation store <>)
+              (proc p))))))
+
   (parameterize ((%graft? graft?))
     (append-map (match-lambda
                   ((? package? p)
-                   (let ((p (or (and graft? (package-replacement p)) p))=
)
-                     (match src
-                       (#f
-                        (list (package->derivation store p system)))
-                       (#t
-                        (match (package-source p)
-                          (#f
-                           (format (current-error-port)
-                                   (_ "~a: warning: \
-package '~a' has no source~%")
-                                   (location->string (package-location p=
))
-                                   (package-name p))
-                           '())
-                          (s
-                           (list (package-source-derivation store s)))))
-                       (proc
-                        (map (cut package-source-derivation store <>)
-                             (proc p))))))
+                   (package->derivation-list p))
+                  ((? potluck-package? p)
+                   (package->derivation-list (lower-potluck-package p)))
                   ((? derivation? drv)
                    (list drv))
                   ((? procedure? proc)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:40 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:40 2017
Received: from localhost ([127.0.0.1]:38531 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l70-0004fW-N8
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:40 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:58341
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5O-0004Pi-B9
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:15 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 702B974D54
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:52 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=m8jRC6JiZFmt
 G7XyB8O6Z6i8XjY=; b=sYuEH0D3sasxCT1F596qLWgCiPjSoMyo72RSn8PaRA/3
 DB0GEebPqQHLsf5n7VbxlGRudIr7veeuR502DcUVQmYiHWX4dILldkBbhAstGbZw
 dN0PfaWUUOD1/B85gAeNIPN7iwicxnuk+yv/YyR5yhUBndYx08eOn1SFrvyYkNI=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 6937274D52
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:52 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id AE75874D35
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:49 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 8/9] potluck: Add host-channel subcommand.
Date: Mon, 24 Apr 2017 22:59:22 +0200
Message-Id: <20170424205923.27726-8-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F4B2D7FC-2930-11E7-8011-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/host.scm: New file.
* Makefile.am (MODULES): Add new file.
* guix/scripts/potluck.scm: Add host-channel command.
---
 Makefile.am              |   1 +
 guix/potluck/host.scm    | 304 +++++++++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/potluck.scm | 137 +++++++++++++++++++--
 3 files changed, 430 insertions(+), 12 deletions(-)
 create mode 100644 guix/potluck/host.scm

diff --git a/Makefile.am b/Makefile.am
index 628283b57..94fa05d5b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -129,6 +129,7 @@ MODULES =3D					\
   guix/git.scm					\
   guix/potluck/build-systems.scm		\
   guix/potluck/environment.scm			\
+  guix/potluck/host.scm				\
   guix/potluck/licenses.scm			\
   guix/potluck/packages.scm			\
   guix/import/utils.scm				\
diff --git a/guix/potluck/host.scm b/guix/potluck/host.scm
new file mode 100644
index 000000000..5ac8e0f5f
--- /dev/null
+++ b/guix/potluck/host.scm
@@ -0,0 +1,304 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck host)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module (guix ui)
+  #:use-module ((guix build utils)
+                #:select (mkdir-p
+                          delete-file-recursively
+                          with-directory-excursion))
+  #:use-module (guix git)
+  #:use-module (guix utils)
+  #:use-module (guix potluck packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 q)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 threads)
+  #:use-module (json)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (web uri)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web server)
+  #:export (host-potluck))
+
+=0C
+;;;
+;;; async queues
+;;;
+
+(define-record-type <async-queue>
+  (make-aq mutex condvar q)
+  async-queue?
+  (mutex aq-mutex)
+  (condvar aq-condvar)
+  (q aq-q))
+
+(set-record-type-printer!
+ <async-queue>
+ (lambda (aq port)
+   (format port "<async-queue ~a ~a>" (object-address aq)
+           (q-length (aq-q aq)))))
+
+(define* (make-async-queue)
+  (make-aq (make-mutex)
+           (make-condition-variable)
+           (make-q)))
+
+(define* (async-queue-push! aq item)
+  (with-mutex (aq-mutex aq)
+    (enq! (aq-q aq) item)
+    (signal-condition-variable (aq-condvar aq))))
+
+(define* (async-queue-pop! aq)
+  (with-mutex (aq-mutex aq)
+    (let lp ()
+      (cond
+       ((q-empty? (aq-q aq))
+        (wait-condition-variable (aq-condvar aq) (aq-mutex aq))
+        (lp))
+       (else
+        (q-pop! (aq-q aq)))))))
+
+=0C
+;;;
+;;; backend
+;;;
+
+(define (bytes-free-on-fs filename)
+  (let* ((p (open-pipe* "r" "df" "-B1" "--output=3Davail" filename))
+         (l1 (read-line p))
+         (l2 (read-line p))
+         (l3 (read-line p)))
+    (close-pipe p)
+    (cond
+     ((and (string? l1) (string? l2) (eof-object? l3)
+           (equal? (string-trim-both l1) "Avail"))
+      (string->number l2))
+     (else
+      (error "could not get free space for file system containing" filen=
ame)))))
+
+(define (delete-directory-contents-recursively working-dir)
+  (for-each (lambda (file)
+              (delete-file-recursively (in-vicinity working-dir file)))
+            (scandir working-dir
+                     (lambda (file)
+                       (and (string<> "." file)
+                            (string<> ".." file))))))
+
+;; 1GB minimum free space.
+(define *mininum-free-space* #e1e9)
+
+(define (scm-files-in-dir dir)
+  (map (lambda (file)
+         (in-vicinity dir file))
+       (scandir dir
+                (lambda (file)
+                  (and (not (file-is-directory? (in-vicinity dir file)))
+                       (string-suffix? ".scm" file))))))
+
+(define (copy-header-comments port file)
+  (call-with-input-file file
+    (lambda (in)
+      (let lp ()
+        (let ((line (read-line in)))
+          (unless (eof-object? line)
+            (let ((trimmed (string-trim line)))
+              (when (or (string-null? trimmed) (string-prefix? ";" trimm=
ed))
+                (display trimmed port)
+                (newline port)
+                (lp)))))))))
+
+(define (process-update host working-dir source-checkout target-checkout
+                        remote-git-url branch)
+  (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+    (delete-directory-contents-recursively working-dir)
+    (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+      (error "not enough free space")))
+  (chdir working-dir)
+  (let* ((repo-dir (uri-encode remote-git-url))
+         (repo+branch-dir (in-vicinity repo-dir (uri-encode branch))))
+    (cond
+     ((file-exists? repo-dir)
+      (chdir repo-dir)
+      (git-fetch))
+     (else
+      (git-clone remote-git-url repo-dir)
+      (chdir repo-dir)))
+    (git-reset #:ref (string-append "origin/" branch) #:mode 'hard)
+    (unless (file-is-directory? "guix-potluck")
+      (error "repo+branch has no guix-potluck dir" remote-git-url branch=
))
+    (let* ((files (scm-files-in-dir "guix-potluck"))
+           ;; This step safely loads and validates the potluck package
+           ;; definitions.
+           (packages (map load-potluck-package files))
+           (source-dir (in-vicinity source-checkout repo+branch-dir))
+           (target-dir (in-vicinity target-checkout
+                                    (in-vicinity "gnu/packages/potluck"
+                                                 repo+branch-dir))))
+      ;; Clear source and target repo entries.
+      (define (ensure-empty-dir filename)
+        (when (file-exists? filename)
+          (delete-file-recursively filename))
+        (mkdir-p filename))
+      (define (commit-dir dir)
+        (with-directory-excursion dir
+          (git-add ".")
+          (git-commit #:message
+                      (format #f "Update ~a branch ~a."
+                              remote-git-url branch)
+                      #:author-name "Guix potluck host"
+                      #:author-email (string-append "host@" host))
+          (git-push)))
+      (ensure-empty-dir source-dir)
+      (ensure-empty-dir target-dir)
+      ;; Add potluck files to source repo.
+      (for-each (lambda (file)
+                  (copy-file file (in-vicinity source-dir (basename file=
))))
+                files)
+      (commit-dir source-dir)
+      ;; Add transformed files to target repo.
+      (for-each (lambda (file package)
+                  (call-with-output-file
+                      (in-vicinity target-dir (basename file))
+                    (lambda (port)
+                      (define module-name
+                        `(gnu packages potluck
+                              ,repo-dir
+                              ,(uri-encode branch)
+                              ,(substring (basename file) 0
+                                          (- (string-length (basename fi=
le))
+                                             (string-length ".scm")))))
+                      ;; Preserve copyright notices if possible.
+                      (copy-header-comments port file)
+                      (lower-potluck-package-to-module port module-name
+                                                       package))))
+                files packages)
+      (commit-dir target-dir)))
+  ;; 8. post success message
+  (pk 'success target-checkout remote-git-url branch))
+
+(define (service-queue host working-dir source-checkout target-checkout =
queue)
+  (let lp ()
+    (match (async-queue-pop! queue)
+      ((remote-git-url . branch)
+       (format (current-error-port) "log: handling ~a / ~a\n"
+               remote-git-url branch)
+       (catch #t
+         (lambda ()
+           (process-update host working-dir
+                           source-checkout target-checkout
+                           remote-git-url branch)
+           (format (current-error-port) "log: success ~a / ~a\n"
+                   remote-git-url branch))
+         (lambda (k . args)
+           (format (current-error-port) "log: failure ~a / ~a\n"
+                   remote-git-url branch)
+           (print-exception (current-error-port) #f k args)))
+       (lp)))))
+
+=0C
+;;;
+;;; frontend
+;;;
+
+(define* (validate-public-uri str #:key (schemes '(http https)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (error "expected a public URI" str))))
+
+(define (validate-branch-name str)
+  (unless (git-check-ref-format str #:allow-onelevel? #t)
+    (error "expected a valid git branch name" str)))
+
+(define (enqueue-update params queue)
+  (let ((remote-git-url (hash-ref params "git-url"))
+        (branch-name (hash-ref params "branch")))
+    (validate-public-uri remote-git-url)
+    (validate-branch-name branch-name)
+    (async-queue-push! queue (cons remote-git-url branch-name))))
+
+(define (request-body-json request body)
+  (cond
+   ((string? body) (json-string->scm body))
+   ((bytevector? body)
+    (let* ((content-type (request-content-type request))
+           (charset (or (assoc-ref (cdr content-type) "charset")
+                        "utf-8")))
+      (json-string->scm (bytevector->string body charset))))
+   ((port? body) (json->scm body))
+   (else (error "unexpected body" body))))
+
+(define (handler request body queue)
+  (match (cons (request-method request)
+               (split-and-decode-uri-path (uri-path (request-uri request=
))))
+    (('GET)
+     (values (build-response #:code 200)
+             "todo: show work queue"))
+    (('POST "api" "enqueue-update")
+     ;; An exception will cause error 500.
+     (enqueue-update (request-body-json request body) queue)
+     (values (build-response #:code 200)
+             ""))
+    (_
+     (values (build-response #:code 404)
+             ""))))
+
+(define (host-potluck host local-port working-dir source-checkout
+                      target-checkout)
+  (let ((worker-thread #f)
+        (queue (make-async-queue)))
+    (dynamic-wind (lambda ()
+                    (set! worker-thread
+                      (make-thread
+                       (service-queue host working-dir
+                                      source-checkout target-checkout
+                                      queue))))
+                  (lambda ()
+                    (run-server
+                     (lambda (request body)
+                       (handler request body queue))
+                     ;; Always listen on localhost.
+                     'http `(#:port ,local-port)))
+                  (lambda ()
+                    (cancel-thread worker-thread)))))
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
index f9cd40bd0..ec306cae6 100644
--- a/guix/scripts/potluck.scm
+++ b/guix/scripts/potluck.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck host)
   #:use-module (guix potluck licenses)
   #:use-module (guix potluck packages)
   #:use-module (guix scripts)
@@ -47,12 +48,12 @@
 ;;; guix potluck init
 ;;;
=20
-(define* (init-potluck remote-git-url #:key
+(define* (init-potluck host remote-git-url #:key
                        (build-system 'gnu) (autoreconf? #f)
                        (license 'gplv3+))
   (let* ((cwd (getcwd))
          (dot-git (in-vicinity cwd ".git"))
-         (potluck-dir (in-vicinity cwd "potluck"))
+         (potluck-dir (in-vicinity cwd "guix-potluck"))
          (package-name (basename cwd)))
     (unless (and (file-exists? dot-git)
                  (file-is-directory? dot-git))
@@ -74,17 +75,17 @@
            ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
            ;; here.
            (pkg-sha256 (guix-hash-git-checkout cwd)))
-      (format #t (_ "Creating potluck/~%"))
+      (format #t (_ "Creating guix-potluck/~%"))
       (mkdir potluck-dir)
-      (format #t (_ "Creating potluck/README.md~%"))
+      (format #t (_ "Creating guix-potluck/README.md~%"))
       (call-with-output-file (in-vicinity potluck-dir "README.md")
         (lambda (port)
           (format port
                   "\
 This directory defines potluck packages.  Each file in this directory sh=
ould
-define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+define one package.  See https://guix-potluck.org/ for more information.
 ")))
-      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (format #t (_ "Creating guix-potluck/~a.scm~%") package-name)
       (call-with-output-file (in-vicinity potluck-dir
                                           (string-append package-name ".=
scm"))
         (lambda (port)
@@ -133,16 +134,39 @@ define one package.  See https://potluck.guixsd.org=
/ for more information.
                             " is a ..."))
             (license license)))))
       (format #t (_ "
-Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
-\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+Done.  Now open guix-potluck/~a.scm in your editor, fill out its \"synop=
sis\"
+and \"description\" fields, add dependencies to the 'inputs' field, and =
try to
 build with
=20
-  guix build --file=3Dpotluck/~a.scm
+  guix build --file=3Dguix-potluck/~a.scm
=20
 When you get that working, commit your results to git via:
=20
   git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
-") pkg-name pkg-name))))
+
+Once you push them out, add your dish to the communal potluck by running=
:
+
+  guix potluck update ~a
+") pkg-name pkg-name remote-git-url))))
+
+;;;
+;;; guix potluck update
+;;;
+
+(define (request-potluck-update host git-url branch)
+  (call-with-values (lambda ()
+                      (http-post (build-uri 'https
+                                            #:host host
+                                            #:path "/api/enqueue-update"=
)
+                                 #:body (scm->json-string
+                                         `((git-url . ,git-url)
+                                           (branch . ,branch)))))
+    (lambda (response body)
+      (unless (eqv? (response-code response) 200)
+        (error "request failed"
+               (response-code response)
+               (response-reason-phrase response)
+               body)))))
=20
 =0C
 ;;;
@@ -159,10 +183,33 @@ ARGS.\n"))
   (newline)
   (display (_ "\
    init             create potluck recipe for current working directory\=
n"))
+  (display (_ "\
+   update           ask potluck host to add or update a potluck package\=
n"))
+  (display (_ "\
+   host-channel     run web service providing potluck packages as Guix c=
hannel\n"))
=20
   (newline)
   (display (_ "The available OPTION flags are:\n"))
   (display (_ "
+      --host=3DHOST        for 'update' and 'host-channel', the name of =
the
+                         channel host
+                         (default: guix-potluck.org)"))
+  (display (_ "
+      --port=3DPORT        for 'host-channel', the local TCP port on whi=
ch to
+                         listen for HTTP connections
+                         (default: 8080)"))
+  (display (_ "
+      --scratch=3DDIR      for 'host-channel', the path to a local direc=
tory
+                         that will be used as a scratch space to check o=
ut
+                         remote git repositories"))
+  (display (_ "
+      --source=3DDIR       for 'host-channel', the path to a local check=
out
+                         of guix potluck source packages to be managed b=
y
+                         host-channel"))
+  (display (_ "
+      --target=3DDIR       for 'host-channel', the path to a local check=
out
+                         of a guix channel to be managed by host-channel=
"))
+  (display (_ "
       --build-system=3DSYS for 'init', specify the build system.  Use
                          --build-system=3Dhelp for all available options=
."))
   (display (_ "
@@ -201,19 +248,56 @@ ARGS.\n"))
         (option '("license") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'license arg result)))
+        (option '("host") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'host arg result)))
+        (option '("port") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'port arg result)))
+        (option '("scratch") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'scratch arg result)))
+        (option '("source") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'source arg result)))
+        (option '("target") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'target arg result)))
         (option '("verbosity") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'verbosity (string->number arg) result))))=
)
=20
 (define %default-options
   ;; Alist of default option values.
-  `((verbosity . 0)))
+  `((host . "guix-potluck.org")
+    (port . "8080")
+    (verbosity . 0)))
+
+(define (parse-host host-str)
+  ;; Will throw if the host is invalid somehow.
+  (build-uri 'https #:host host-str)
+  host-str)
=20
 (define (parse-url url-str)
   (unless (string->uri url-str)
     (leave (_ "invalid url: ~a~%") url-str))
   url-str)
=20
+(define (parse-port port-str)
+  (let ((port (string->number port-str)))
+    (cond
+     ((and port (exact-integer? port) (<=3D 0 port #xffff))
+      port)
+     (else
+      (leave (_ "invalid port: ~a~%") port-str)))))
+
+(define (parse-absolute-directory-name str)
+  (unless (and (absolute-file-name? str)
+               (file-exists? str)
+               (file-is-directory? str))
+    (leave (_ "invalid absolute directory name: ~a~%") str))
+  str)
+
 (define (parse-build-system sys-str)
   (unless sys-str
     (leave (_ "\
@@ -297,7 +381,8 @@ If your package's license is not in this list, add it=
 to Guix first.~%")
         ('init
          (match args
            ((remote-git-url)
-            (init-potluck (parse-url remote-git-url)
+            (init-potluck (parse-host (assoc-ref opts 'host))
+                          (parse-url remote-git-url)
                           #:build-system (parse-build-system
                                           (assoc-ref opts 'build-system)=
)
                           #:autoreconf? (assoc-ref opts 'autoreconf?)
@@ -306,5 +391,33 @@ If your package's license is not in this list, add i=
t to Guix first.~%")
            (args
             (wrong-number-of-args
              (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        ('update
+         (match args
+           ((remote-git-url branch)
+            (request-potluck-update (parse-host (assoc-ref opts 'host))
+                                    (parse-url remote-git-url)
+                                    branch))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck update REMOTE-GIT-URL BRANCH-NAME")=
))))
+        ('host-channel
+         (match args
+           (()
+            (host-potluck (parse-host (assoc-ref opts 'host))
+                          (parse-port (assoc-ref opts 'port))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'scratch)
+                               (leave (_ "missing --scratch argument~%")=
)))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'source)
+                               (leave (_ "missing --source argument~%"))=
))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'target)
+                               (leave (_ "missing --target argument~%"))=
))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck host-channel --scratch=3DDIR \
+--source=3DDIR --target=3DDIR"))
+            (exit 1))))
         (action
          (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:34 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:34 2017
Received: from localhost ([127.0.0.1]:38529 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6v-0004fM-PP
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:34 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:50191
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5N-0004OW-NW
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:15 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 0081C74D4E
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:52 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=m8jRC6JiZFmt
 G7XyB8O6Z6i8XjY=; b=sYuEH0D3sasxCT1F596qLWgCiPjSoMyo72RSn8PaRA/3
 DB0GEebPqQHLsf5n7VbxlGRudIr7veeuR502DcUVQmYiHWX4dILldkBbhAstGbZw
 dN0PfaWUUOD1/B85gAeNIPN7iwicxnuk+yv/YyR5yhUBndYx08eOn1SFrvyYkNI=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id EB3BB74D4D
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:51 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 913F274D34
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:49 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 8/9] potluck: Add host-channel subcommand.
Date: Mon, 24 Apr 2017 22:59:22 +0200
Message-Id: <20170424205923.27726-8-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F49DAC92-2930-11E7-BA7C-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/host.scm: New file.
* Makefile.am (MODULES): Add new file.
* guix/scripts/potluck.scm: Add host-channel command.
---
 Makefile.am              |   1 +
 guix/potluck/host.scm    | 304 +++++++++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/potluck.scm | 137 +++++++++++++++++++--
 3 files changed, 430 insertions(+), 12 deletions(-)
 create mode 100644 guix/potluck/host.scm

diff --git a/Makefile.am b/Makefile.am
index 628283b57..94fa05d5b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -129,6 +129,7 @@ MODULES =3D					\
   guix/git.scm					\
   guix/potluck/build-systems.scm		\
   guix/potluck/environment.scm			\
+  guix/potluck/host.scm				\
   guix/potluck/licenses.scm			\
   guix/potluck/packages.scm			\
   guix/import/utils.scm				\
diff --git a/guix/potluck/host.scm b/guix/potluck/host.scm
new file mode 100644
index 000000000..5ac8e0f5f
--- /dev/null
+++ b/guix/potluck/host.scm
@@ -0,0 +1,304 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck host)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module (guix ui)
+  #:use-module ((guix build utils)
+                #:select (mkdir-p
+                          delete-file-recursively
+                          with-directory-excursion))
+  #:use-module (guix git)
+  #:use-module (guix utils)
+  #:use-module (guix potluck packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 q)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 threads)
+  #:use-module (json)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (web uri)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web server)
+  #:export (host-potluck))
+
+=0C
+;;;
+;;; async queues
+;;;
+
+(define-record-type <async-queue>
+  (make-aq mutex condvar q)
+  async-queue?
+  (mutex aq-mutex)
+  (condvar aq-condvar)
+  (q aq-q))
+
+(set-record-type-printer!
+ <async-queue>
+ (lambda (aq port)
+   (format port "<async-queue ~a ~a>" (object-address aq)
+           (q-length (aq-q aq)))))
+
+(define* (make-async-queue)
+  (make-aq (make-mutex)
+           (make-condition-variable)
+           (make-q)))
+
+(define* (async-queue-push! aq item)
+  (with-mutex (aq-mutex aq)
+    (enq! (aq-q aq) item)
+    (signal-condition-variable (aq-condvar aq))))
+
+(define* (async-queue-pop! aq)
+  (with-mutex (aq-mutex aq)
+    (let lp ()
+      (cond
+       ((q-empty? (aq-q aq))
+        (wait-condition-variable (aq-condvar aq) (aq-mutex aq))
+        (lp))
+       (else
+        (q-pop! (aq-q aq)))))))
+
+=0C
+;;;
+;;; backend
+;;;
+
+(define (bytes-free-on-fs filename)
+  (let* ((p (open-pipe* "r" "df" "-B1" "--output=3Davail" filename))
+         (l1 (read-line p))
+         (l2 (read-line p))
+         (l3 (read-line p)))
+    (close-pipe p)
+    (cond
+     ((and (string? l1) (string? l2) (eof-object? l3)
+           (equal? (string-trim-both l1) "Avail"))
+      (string->number l2))
+     (else
+      (error "could not get free space for file system containing" filen=
ame)))))
+
+(define (delete-directory-contents-recursively working-dir)
+  (for-each (lambda (file)
+              (delete-file-recursively (in-vicinity working-dir file)))
+            (scandir working-dir
+                     (lambda (file)
+                       (and (string<> "." file)
+                            (string<> ".." file))))))
+
+;; 1GB minimum free space.
+(define *mininum-free-space* #e1e9)
+
+(define (scm-files-in-dir dir)
+  (map (lambda (file)
+         (in-vicinity dir file))
+       (scandir dir
+                (lambda (file)
+                  (and (not (file-is-directory? (in-vicinity dir file)))
+                       (string-suffix? ".scm" file))))))
+
+(define (copy-header-comments port file)
+  (call-with-input-file file
+    (lambda (in)
+      (let lp ()
+        (let ((line (read-line in)))
+          (unless (eof-object? line)
+            (let ((trimmed (string-trim line)))
+              (when (or (string-null? trimmed) (string-prefix? ";" trimm=
ed))
+                (display trimmed port)
+                (newline port)
+                (lp)))))))))
+
+(define (process-update host working-dir source-checkout target-checkout
+                        remote-git-url branch)
+  (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+    (delete-directory-contents-recursively working-dir)
+    (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+      (error "not enough free space")))
+  (chdir working-dir)
+  (let* ((repo-dir (uri-encode remote-git-url))
+         (repo+branch-dir (in-vicinity repo-dir (uri-encode branch))))
+    (cond
+     ((file-exists? repo-dir)
+      (chdir repo-dir)
+      (git-fetch))
+     (else
+      (git-clone remote-git-url repo-dir)
+      (chdir repo-dir)))
+    (git-reset #:ref (string-append "origin/" branch) #:mode 'hard)
+    (unless (file-is-directory? "guix-potluck")
+      (error "repo+branch has no guix-potluck dir" remote-git-url branch=
))
+    (let* ((files (scm-files-in-dir "guix-potluck"))
+           ;; This step safely loads and validates the potluck package
+           ;; definitions.
+           (packages (map load-potluck-package files))
+           (source-dir (in-vicinity source-checkout repo+branch-dir))
+           (target-dir (in-vicinity target-checkout
+                                    (in-vicinity "gnu/packages/potluck"
+                                                 repo+branch-dir))))
+      ;; Clear source and target repo entries.
+      (define (ensure-empty-dir filename)
+        (when (file-exists? filename)
+          (delete-file-recursively filename))
+        (mkdir-p filename))
+      (define (commit-dir dir)
+        (with-directory-excursion dir
+          (git-add ".")
+          (git-commit #:message
+                      (format #f "Update ~a branch ~a."
+                              remote-git-url branch)
+                      #:author-name "Guix potluck host"
+                      #:author-email (string-append "host@" host))
+          (git-push)))
+      (ensure-empty-dir source-dir)
+      (ensure-empty-dir target-dir)
+      ;; Add potluck files to source repo.
+      (for-each (lambda (file)
+                  (copy-file file (in-vicinity source-dir (basename file=
))))
+                files)
+      (commit-dir source-dir)
+      ;; Add transformed files to target repo.
+      (for-each (lambda (file package)
+                  (call-with-output-file
+                      (in-vicinity target-dir (basename file))
+                    (lambda (port)
+                      (define module-name
+                        `(gnu packages potluck
+                              ,repo-dir
+                              ,(uri-encode branch)
+                              ,(substring (basename file) 0
+                                          (- (string-length (basename fi=
le))
+                                             (string-length ".scm")))))
+                      ;; Preserve copyright notices if possible.
+                      (copy-header-comments port file)
+                      (lower-potluck-package-to-module port module-name
+                                                       package))))
+                files packages)
+      (commit-dir target-dir)))
+  ;; 8. post success message
+  (pk 'success target-checkout remote-git-url branch))
+
+(define (service-queue host working-dir source-checkout target-checkout =
queue)
+  (let lp ()
+    (match (async-queue-pop! queue)
+      ((remote-git-url . branch)
+       (format (current-error-port) "log: handling ~a / ~a\n"
+               remote-git-url branch)
+       (catch #t
+         (lambda ()
+           (process-update host working-dir
+                           source-checkout target-checkout
+                           remote-git-url branch)
+           (format (current-error-port) "log: success ~a / ~a\n"
+                   remote-git-url branch))
+         (lambda (k . args)
+           (format (current-error-port) "log: failure ~a / ~a\n"
+                   remote-git-url branch)
+           (print-exception (current-error-port) #f k args)))
+       (lp)))))
+
+=0C
+;;;
+;;; frontend
+;;;
+
+(define* (validate-public-uri str #:key (schemes '(http https)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (error "expected a public URI" str))))
+
+(define (validate-branch-name str)
+  (unless (git-check-ref-format str #:allow-onelevel? #t)
+    (error "expected a valid git branch name" str)))
+
+(define (enqueue-update params queue)
+  (let ((remote-git-url (hash-ref params "git-url"))
+        (branch-name (hash-ref params "branch")))
+    (validate-public-uri remote-git-url)
+    (validate-branch-name branch-name)
+    (async-queue-push! queue (cons remote-git-url branch-name))))
+
+(define (request-body-json request body)
+  (cond
+   ((string? body) (json-string->scm body))
+   ((bytevector? body)
+    (let* ((content-type (request-content-type request))
+           (charset (or (assoc-ref (cdr content-type) "charset")
+                        "utf-8")))
+      (json-string->scm (bytevector->string body charset))))
+   ((port? body) (json->scm body))
+   (else (error "unexpected body" body))))
+
+(define (handler request body queue)
+  (match (cons (request-method request)
+               (split-and-decode-uri-path (uri-path (request-uri request=
))))
+    (('GET)
+     (values (build-response #:code 200)
+             "todo: show work queue"))
+    (('POST "api" "enqueue-update")
+     ;; An exception will cause error 500.
+     (enqueue-update (request-body-json request body) queue)
+     (values (build-response #:code 200)
+             ""))
+    (_
+     (values (build-response #:code 404)
+             ""))))
+
+(define (host-potluck host local-port working-dir source-checkout
+                      target-checkout)
+  (let ((worker-thread #f)
+        (queue (make-async-queue)))
+    (dynamic-wind (lambda ()
+                    (set! worker-thread
+                      (make-thread
+                       (service-queue host working-dir
+                                      source-checkout target-checkout
+                                      queue))))
+                  (lambda ()
+                    (run-server
+                     (lambda (request body)
+                       (handler request body queue))
+                     ;; Always listen on localhost.
+                     'http `(#:port ,local-port)))
+                  (lambda ()
+                    (cancel-thread worker-thread)))))
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
index f9cd40bd0..ec306cae6 100644
--- a/guix/scripts/potluck.scm
+++ b/guix/scripts/potluck.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck host)
   #:use-module (guix potluck licenses)
   #:use-module (guix potluck packages)
   #:use-module (guix scripts)
@@ -47,12 +48,12 @@
 ;;; guix potluck init
 ;;;
=20
-(define* (init-potluck remote-git-url #:key
+(define* (init-potluck host remote-git-url #:key
                        (build-system 'gnu) (autoreconf? #f)
                        (license 'gplv3+))
   (let* ((cwd (getcwd))
          (dot-git (in-vicinity cwd ".git"))
-         (potluck-dir (in-vicinity cwd "potluck"))
+         (potluck-dir (in-vicinity cwd "guix-potluck"))
          (package-name (basename cwd)))
     (unless (and (file-exists? dot-git)
                  (file-is-directory? dot-git))
@@ -74,17 +75,17 @@
            ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
            ;; here.
            (pkg-sha256 (guix-hash-git-checkout cwd)))
-      (format #t (_ "Creating potluck/~%"))
+      (format #t (_ "Creating guix-potluck/~%"))
       (mkdir potluck-dir)
-      (format #t (_ "Creating potluck/README.md~%"))
+      (format #t (_ "Creating guix-potluck/README.md~%"))
       (call-with-output-file (in-vicinity potluck-dir "README.md")
         (lambda (port)
           (format port
                   "\
 This directory defines potluck packages.  Each file in this directory sh=
ould
-define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+define one package.  See https://guix-potluck.org/ for more information.
 ")))
-      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (format #t (_ "Creating guix-potluck/~a.scm~%") package-name)
       (call-with-output-file (in-vicinity potluck-dir
                                           (string-append package-name ".=
scm"))
         (lambda (port)
@@ -133,16 +134,39 @@ define one package.  See https://potluck.guixsd.org=
/ for more information.
                             " is a ..."))
             (license license)))))
       (format #t (_ "
-Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
-\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+Done.  Now open guix-potluck/~a.scm in your editor, fill out its \"synop=
sis\"
+and \"description\" fields, add dependencies to the 'inputs' field, and =
try to
 build with
=20
-  guix build --file=3Dpotluck/~a.scm
+  guix build --file=3Dguix-potluck/~a.scm
=20
 When you get that working, commit your results to git via:
=20
   git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
-") pkg-name pkg-name))))
+
+Once you push them out, add your dish to the communal potluck by running=
:
+
+  guix potluck update ~a
+") pkg-name pkg-name remote-git-url))))
+
+;;;
+;;; guix potluck update
+;;;
+
+(define (request-potluck-update host git-url branch)
+  (call-with-values (lambda ()
+                      (http-post (build-uri 'https
+                                            #:host host
+                                            #:path "/api/enqueue-update"=
)
+                                 #:body (scm->json-string
+                                         `((git-url . ,git-url)
+                                           (branch . ,branch)))))
+    (lambda (response body)
+      (unless (eqv? (response-code response) 200)
+        (error "request failed"
+               (response-code response)
+               (response-reason-phrase response)
+               body)))))
=20
 =0C
 ;;;
@@ -159,10 +183,33 @@ ARGS.\n"))
   (newline)
   (display (_ "\
    init             create potluck recipe for current working directory\=
n"))
+  (display (_ "\
+   update           ask potluck host to add or update a potluck package\=
n"))
+  (display (_ "\
+   host-channel     run web service providing potluck packages as Guix c=
hannel\n"))
=20
   (newline)
   (display (_ "The available OPTION flags are:\n"))
   (display (_ "
+      --host=3DHOST        for 'update' and 'host-channel', the name of =
the
+                         channel host
+                         (default: guix-potluck.org)"))
+  (display (_ "
+      --port=3DPORT        for 'host-channel', the local TCP port on whi=
ch to
+                         listen for HTTP connections
+                         (default: 8080)"))
+  (display (_ "
+      --scratch=3DDIR      for 'host-channel', the path to a local direc=
tory
+                         that will be used as a scratch space to check o=
ut
+                         remote git repositories"))
+  (display (_ "
+      --source=3DDIR       for 'host-channel', the path to a local check=
out
+                         of guix potluck source packages to be managed b=
y
+                         host-channel"))
+  (display (_ "
+      --target=3DDIR       for 'host-channel', the path to a local check=
out
+                         of a guix channel to be managed by host-channel=
"))
+  (display (_ "
       --build-system=3DSYS for 'init', specify the build system.  Use
                          --build-system=3Dhelp for all available options=
."))
   (display (_ "
@@ -201,19 +248,56 @@ ARGS.\n"))
         (option '("license") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'license arg result)))
+        (option '("host") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'host arg result)))
+        (option '("port") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'port arg result)))
+        (option '("scratch") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'scratch arg result)))
+        (option '("source") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'source arg result)))
+        (option '("target") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'target arg result)))
         (option '("verbosity") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'verbosity (string->number arg) result))))=
)
=20
 (define %default-options
   ;; Alist of default option values.
-  `((verbosity . 0)))
+  `((host . "guix-potluck.org")
+    (port . "8080")
+    (verbosity . 0)))
+
+(define (parse-host host-str)
+  ;; Will throw if the host is invalid somehow.
+  (build-uri 'https #:host host-str)
+  host-str)
=20
 (define (parse-url url-str)
   (unless (string->uri url-str)
     (leave (_ "invalid url: ~a~%") url-str))
   url-str)
=20
+(define (parse-port port-str)
+  (let ((port (string->number port-str)))
+    (cond
+     ((and port (exact-integer? port) (<=3D 0 port #xffff))
+      port)
+     (else
+      (leave (_ "invalid port: ~a~%") port-str)))))
+
+(define (parse-absolute-directory-name str)
+  (unless (and (absolute-file-name? str)
+               (file-exists? str)
+               (file-is-directory? str))
+    (leave (_ "invalid absolute directory name: ~a~%") str))
+  str)
+
 (define (parse-build-system sys-str)
   (unless sys-str
     (leave (_ "\
@@ -297,7 +381,8 @@ If your package's license is not in this list, add it=
 to Guix first.~%")
         ('init
          (match args
            ((remote-git-url)
-            (init-potluck (parse-url remote-git-url)
+            (init-potluck (parse-host (assoc-ref opts 'host))
+                          (parse-url remote-git-url)
                           #:build-system (parse-build-system
                                           (assoc-ref opts 'build-system)=
)
                           #:autoreconf? (assoc-ref opts 'autoreconf?)
@@ -306,5 +391,33 @@ If your package's license is not in this list, add i=
t to Guix first.~%")
            (args
             (wrong-number-of-args
              (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        ('update
+         (match args
+           ((remote-git-url branch)
+            (request-potluck-update (parse-host (assoc-ref opts 'host))
+                                    (parse-url remote-git-url)
+                                    branch))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck update REMOTE-GIT-URL BRANCH-NAME")=
))))
+        ('host-channel
+         (match args
+           (()
+            (host-potluck (parse-host (assoc-ref opts 'host))
+                          (parse-port (assoc-ref opts 'port))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'scratch)
+                               (leave (_ "missing --scratch argument~%")=
)))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'source)
+                               (leave (_ "missing --source argument~%"))=
))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'target)
+                               (leave (_ "missing --target argument~%"))=
))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck host-channel --scratch=3DDIR \
+--source=3DDIR --target=3DDIR"))
+            (exit 1))))
         (action
          (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:29 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:29 2017
Received: from localhost ([127.0.0.1]:38527 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6v-0004fC-Bf
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:29 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:57905
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5N-0004Oc-Kh
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:11 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id EA19874D4C
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:51 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=TXXD
 1VVFOjWyygecr2OlqzBbiII=; b=NSU4qvaepukUgdolXz/HCWcXC+rbqh4+osQO
 4tp8jRtZ9wgi0VAaMdEfrAbpm3fFErwvGmQjrrgzPPyP6rUu7yTM6qBZRO8G33gG
 4S8uYcUSXjrFQuJ7IsaiN8seNrYlgFklUAYm0q++qAA05zu7pRZBX15+u8vYpXsl
 ucMCWzs=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id E31F874D4B
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:51 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id B466374D3C
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:50 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 7/9] potluck: Add ability to lower potluck package to guix
 package.
Date: Mon, 24 Apr 2017 22:59:21 +0200
Message-Id: <20170424205923.27726-7-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: F54D445E-2930-11E7-A7E8-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/packages.scm (lower-potluck-package-to-module): New public
function.
---
 guix/potluck/packages.scm | 118 +++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 117 insertions(+), 1 deletion(-)

diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
index 3bf2d67c1..3c7a1ca49 100644
--- a/guix/potluck/packages.scm
+++ b/guix/potluck/packages.scm
@@ -29,8 +29,10 @@
   #:use-module (guix potluck licenses)
   #:use-module (guix records)
   #:use-module (guix utils)
+  #:use-module ((guix ui) #:select (package-specification->name+version+output))
   #:use-module (ice-9 match)
   #:use-module (ice-9 pretty-print)
+  #:use-module ((srfi srfi-1) #:select (concatenate delete-duplicates))
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -67,7 +69,9 @@
             validate-potluck-package
 
             lower-potluck-source
-            lower-potluck-package))
+            lower-potluck-package
+
+            lower-potluck-package-to-module))
 
 ;;; Commentary:
 ;;;
@@ -456,3 +460,115 @@ potluck package will be validated with @code{validate-potluck-package}."
       (synopsis synopsis)
       (description description)
       (license (license-by-name license)))))
+
+(define (lower-potluck-package-to-module port lowered-module-name pkg)
+  (let ((lowered (lower-potluck-package pkg))
+        ;; specification -> exp
+        (spec->binding (make-hash-table))
+        ;; mod-name -> (sym ...)
+        (imports (make-hash-table))
+        ;; sym -> specification
+        (imported-syms (make-hash-table))
+        (needs-runtime-lookup? #f))
+    (define (add-bindings spec)
+      (unless (hash-ref spec->binding spec)
+        (match (false-if-exception (lower-input spec))
+          ((name pkg . outputs)
+           ;; Given that we found the pkg, surely we should find its binding
+           ;; also.
+           (call-with-values (lambda () (find-package-binding pkg))
+             (lambda (module-name sym)
+               ;; Currently we import these bindings using their original
+               ;; names.  We need to make sure that names don't collide.
+               ;; Ideally we should also ensure that they don't collide with
+               ;; other bindings that we import.
+               (when (hashq-ref imported-syms sym)
+                 (error "duplicate import name" sym))
+               (hashq-set! imported-syms sym spec)
+               (hash-set! spec->binding spec
+                          `(list ,name ,sym . ,outputs))
+               (hash-set! imports module-name
+                          (cons sym (hash-ref imports module-name '()))))))
+          (#f
+           (warn "could not resolve package specification" spec)
+           (call-with-values
+               (lambda ()
+                 (package-specification->name+version+output spec))
+             (lambda (name version . outputs)
+               (hash-set! spec->binding spec
+                          `(list ,name (specification->package ,spec) .
+                                 ,(if (equal? outputs '("out")) '() outputs)))
+               (set! needs-runtime-lookup? #t)))))))
+
+    (for-each add-bindings (potluck-package-inputs pkg))
+    (for-each add-bindings (potluck-package-native-inputs pkg))
+    (for-each add-bindings (potluck-package-propagated-inputs pkg))
+
+    (format port "(define-module ~a" lowered-module-name)
+    (format port "~%  #:pure")
+    ;; Because we're pure, we have to import these.
+    (format port "~%  #:use-module ((guile) #:select (list quote define-public))")
+    (when needs-runtime-lookup?
+      (format port "~%  #:use-module ((gnu packages) #:select (specification->package))"))
+    (format port "~%  #:use-module ((guix packages) #:select (package origin base32))")
+    (format port "~%  #:use-module ((guix git-download) #:select (git-fetch git-reference))")
+    (format port "~%  #:use-module ((guix licenses) #:select ((~a . license:~a)))"
+            (potluck-package-license pkg) (potluck-package-license pkg))
+    (format port "~%  #:use-module ((guix build-system ~a) #:select (~a-build-system))"
+            (potluck-package-build-system pkg) (potluck-package-build-system pkg))
+    (for-each (match-lambda
+                ((module-name . syms)
+                 (format port "~%  #:use-module (~a #:select ~a)"
+                         module-name syms)))
+              (hash-map->list cons imports))
+    (format port ")~%~%")
+
+    (format port "(define-public ~s\n" (string->symbol
+                                        (potluck-package-name pkg)))
+    (format port "  (package\n")
+    (format port "    (name ~s)\n" (potluck-package-name pkg))
+    (format port "    (version ~s)\n" (potluck-package-version pkg))
+    (format port "    (source\n")
+
+    (let ((source (potluck-package-source pkg)))
+      (format port "      (origin\n")
+      (format port "        (method git-fetch)\n")
+      (format port "        (uri (git-reference\n")
+      (format port "              (url ~s)\n" (potluck-source-git-uri source))
+      (format port "              (commit ~s)))\n"
+              (potluck-source-git-commit source))
+      (when (potluck-source-snippet source)
+        (pretty-print `(snippet ',(potluck-source-snippet source)) port
+                      #:per-line-prefix "        "))
+      (format port "        (sha256 (base32 ~s))))\n"
+              (potluck-source-sha256 source)))
+
+    (format port "    (build-system ~s-build-system)\n"
+            (potluck-package-build-system pkg))
+
+    (for-each
+     (match-lambda
+       ((name)
+        ;; No inputs; do nothing.
+        #t)
+       ((name . specs)
+        (pretty-print
+         `(,name (list ,@(map (lambda (spec)
+                                (or (hash-ref spec->binding spec)
+                                    (error "internal error" spec)))
+                              specs)))
+         port #:per-line-prefix "    ")))
+     `((inputs . ,(potluck-package-inputs pkg))
+       (native-inputs . ,(potluck-package-native-inputs pkg))
+       (propagated-inputs . ,(potluck-package-propagated-inputs pkg))))
+
+    (match (potluck-package-arguments pkg)
+      (() #t)
+      (arguments
+       (pretty-print `(arguments ',arguments) port #:per-line-prefix "    ")))
+
+    (format port "    (home-page ~s)\n" (potluck-package-home-page pkg))
+    (format port "    (synopsis ~s)\n" (potluck-package-synopsis pkg))
+    (format port "    (description ~s)\n" (potluck-package-description pkg))
+    (format port "    (license license:~s)))\n" (potluck-package-license pkg))
+    (force-output port)))
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:29 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:29 2017
Received: from localhost ([127.0.0.1]:38525 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6v-0004f7-0E
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:29 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:64165
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5N-0004Ow-Hj
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:10 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id B13F674D47
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:51 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=TXXD
 1VVFOjWyygecr2OlqzBbiII=; b=NSU4qvaepukUgdolXz/HCWcXC+rbqh4+osQO
 4tp8jRtZ9wgi0VAaMdEfrAbpm3fFErwvGmQjrrgzPPyP6rUu7yTM6qBZRO8G33gG
 4S8uYcUSXjrFQuJ7IsaiN8seNrYlgFklUAYm0q++qAA05zu7pRZBX15+u8vYpXsl
 ucMCWzs=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id A905A74D46
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:51 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 50C3074D39
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:50 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 7/9] potluck: Add ability to lower potluck package to guix
 package.
Date: Mon, 24 Apr 2017 22:59:21 +0200
Message-Id: <20170424205923.27726-7-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: F50F453C-2930-11E7-A9A8-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/packages.scm (lower-potluck-package-to-module): New public
function.
---
 guix/potluck/packages.scm | 118 +++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 117 insertions(+), 1 deletion(-)

diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
index 3bf2d67c1..3c7a1ca49 100644
--- a/guix/potluck/packages.scm
+++ b/guix/potluck/packages.scm
@@ -29,8 +29,10 @@
   #:use-module (guix potluck licenses)
   #:use-module (guix records)
   #:use-module (guix utils)
+  #:use-module ((guix ui) #:select (package-specification->name+version+output))
   #:use-module (ice-9 match)
   #:use-module (ice-9 pretty-print)
+  #:use-module ((srfi srfi-1) #:select (concatenate delete-duplicates))
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -67,7 +69,9 @@
             validate-potluck-package
 
             lower-potluck-source
-            lower-potluck-package))
+            lower-potluck-package
+
+            lower-potluck-package-to-module))
 
 ;;; Commentary:
 ;;;
@@ -456,3 +460,115 @@ potluck package will be validated with @code{validate-potluck-package}."
       (synopsis synopsis)
       (description description)
       (license (license-by-name license)))))
+
+(define (lower-potluck-package-to-module port lowered-module-name pkg)
+  (let ((lowered (lower-potluck-package pkg))
+        ;; specification -> exp
+        (spec->binding (make-hash-table))
+        ;; mod-name -> (sym ...)
+        (imports (make-hash-table))
+        ;; sym -> specification
+        (imported-syms (make-hash-table))
+        (needs-runtime-lookup? #f))
+    (define (add-bindings spec)
+      (unless (hash-ref spec->binding spec)
+        (match (false-if-exception (lower-input spec))
+          ((name pkg . outputs)
+           ;; Given that we found the pkg, surely we should find its binding
+           ;; also.
+           (call-with-values (lambda () (find-package-binding pkg))
+             (lambda (module-name sym)
+               ;; Currently we import these bindings using their original
+               ;; names.  We need to make sure that names don't collide.
+               ;; Ideally we should also ensure that they don't collide with
+               ;; other bindings that we import.
+               (when (hashq-ref imported-syms sym)
+                 (error "duplicate import name" sym))
+               (hashq-set! imported-syms sym spec)
+               (hash-set! spec->binding spec
+                          `(list ,name ,sym . ,outputs))
+               (hash-set! imports module-name
+                          (cons sym (hash-ref imports module-name '()))))))
+          (#f
+           (warn "could not resolve package specification" spec)
+           (call-with-values
+               (lambda ()
+                 (package-specification->name+version+output spec))
+             (lambda (name version . outputs)
+               (hash-set! spec->binding spec
+                          `(list ,name (specification->package ,spec) .
+                                 ,(if (equal? outputs '("out")) '() outputs)))
+               (set! needs-runtime-lookup? #t)))))))
+
+    (for-each add-bindings (potluck-package-inputs pkg))
+    (for-each add-bindings (potluck-package-native-inputs pkg))
+    (for-each add-bindings (potluck-package-propagated-inputs pkg))
+
+    (format port "(define-module ~a" lowered-module-name)
+    (format port "~%  #:pure")
+    ;; Because we're pure, we have to import these.
+    (format port "~%  #:use-module ((guile) #:select (list quote define-public))")
+    (when needs-runtime-lookup?
+      (format port "~%  #:use-module ((gnu packages) #:select (specification->package))"))
+    (format port "~%  #:use-module ((guix packages) #:select (package origin base32))")
+    (format port "~%  #:use-module ((guix git-download) #:select (git-fetch git-reference))")
+    (format port "~%  #:use-module ((guix licenses) #:select ((~a . license:~a)))"
+            (potluck-package-license pkg) (potluck-package-license pkg))
+    (format port "~%  #:use-module ((guix build-system ~a) #:select (~a-build-system))"
+            (potluck-package-build-system pkg) (potluck-package-build-system pkg))
+    (for-each (match-lambda
+                ((module-name . syms)
+                 (format port "~%  #:use-module (~a #:select ~a)"
+                         module-name syms)))
+              (hash-map->list cons imports))
+    (format port ")~%~%")
+
+    (format port "(define-public ~s\n" (string->symbol
+                                        (potluck-package-name pkg)))
+    (format port "  (package\n")
+    (format port "    (name ~s)\n" (potluck-package-name pkg))
+    (format port "    (version ~s)\n" (potluck-package-version pkg))
+    (format port "    (source\n")
+
+    (let ((source (potluck-package-source pkg)))
+      (format port "      (origin\n")
+      (format port "        (method git-fetch)\n")
+      (format port "        (uri (git-reference\n")
+      (format port "              (url ~s)\n" (potluck-source-git-uri source))
+      (format port "              (commit ~s)))\n"
+              (potluck-source-git-commit source))
+      (when (potluck-source-snippet source)
+        (pretty-print `(snippet ',(potluck-source-snippet source)) port
+                      #:per-line-prefix "        "))
+      (format port "        (sha256 (base32 ~s))))\n"
+              (potluck-source-sha256 source)))
+
+    (format port "    (build-system ~s-build-system)\n"
+            (potluck-package-build-system pkg))
+
+    (for-each
+     (match-lambda
+       ((name)
+        ;; No inputs; do nothing.
+        #t)
+       ((name . specs)
+        (pretty-print
+         `(,name (list ,@(map (lambda (spec)
+                                (or (hash-ref spec->binding spec)
+                                    (error "internal error" spec)))
+                              specs)))
+         port #:per-line-prefix "    ")))
+     `((inputs . ,(potluck-package-inputs pkg))
+       (native-inputs . ,(potluck-package-native-inputs pkg))
+       (propagated-inputs . ,(potluck-package-propagated-inputs pkg))))
+
+    (match (potluck-package-arguments pkg)
+      (() #t)
+      (arguments
+       (pretty-print `(arguments ',arguments) port #:per-line-prefix "    ")))
+
+    (format port "    (home-page ~s)\n" (potluck-package-home-page pkg))
+    (format port "    (synopsis ~s)\n" (potluck-package-synopsis pkg))
+    (format port "    (description ~s)\n" (potluck-package-description pkg))
+    (format port "    (license license:~s)))\n" (potluck-package-license pkg))
+    (force-output port)))
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:29 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:28 2017
Received: from localhost ([127.0.0.1]:38523 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6q-0004es-Bv
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:28 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:64288
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5M-0004PP-Cp
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:10 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id CA9A074D3E
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:50 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=m8jRC6JiZFmt
 G7XyB8O6Z6i8XjY=; b=sYuEH0D3sasxCT1F596qLWgCiPjSoMyo72RSn8PaRA/3
 DB0GEebPqQHLsf5n7VbxlGRudIr7veeuR502DcUVQmYiHWX4dILldkBbhAstGbZw
 dN0PfaWUUOD1/B85gAeNIPN7iwicxnuk+yv/YyR5yhUBndYx08eOn1SFrvyYkNI=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id C3F8A74D3D
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:50 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 490EE74D33
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:49 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 8/9] potluck: Add host-channel subcommand.
Date: Mon, 24 Apr 2017 22:59:22 +0200
Message-Id: <20170424205923.27726-8-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F46FE7F8-2930-11E7-8B2D-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/host.scm: New file.
* Makefile.am (MODULES): Add new file.
* guix/scripts/potluck.scm: Add host-channel command.
---
 Makefile.am              |   1 +
 guix/potluck/host.scm    | 304 +++++++++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/potluck.scm | 137 +++++++++++++++++++--
 3 files changed, 430 insertions(+), 12 deletions(-)
 create mode 100644 guix/potluck/host.scm

diff --git a/Makefile.am b/Makefile.am
index 628283b57..94fa05d5b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -129,6 +129,7 @@ MODULES =3D					\
   guix/git.scm					\
   guix/potluck/build-systems.scm		\
   guix/potluck/environment.scm			\
+  guix/potluck/host.scm				\
   guix/potluck/licenses.scm			\
   guix/potluck/packages.scm			\
   guix/import/utils.scm				\
diff --git a/guix/potluck/host.scm b/guix/potluck/host.scm
new file mode 100644
index 000000000..5ac8e0f5f
--- /dev/null
+++ b/guix/potluck/host.scm
@@ -0,0 +1,304 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck host)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module (guix ui)
+  #:use-module ((guix build utils)
+                #:select (mkdir-p
+                          delete-file-recursively
+                          with-directory-excursion))
+  #:use-module (guix git)
+  #:use-module (guix utils)
+  #:use-module (guix potluck packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 q)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 threads)
+  #:use-module (json)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (web uri)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web server)
+  #:export (host-potluck))
+
+=0C
+;;;
+;;; async queues
+;;;
+
+(define-record-type <async-queue>
+  (make-aq mutex condvar q)
+  async-queue?
+  (mutex aq-mutex)
+  (condvar aq-condvar)
+  (q aq-q))
+
+(set-record-type-printer!
+ <async-queue>
+ (lambda (aq port)
+   (format port "<async-queue ~a ~a>" (object-address aq)
+           (q-length (aq-q aq)))))
+
+(define* (make-async-queue)
+  (make-aq (make-mutex)
+           (make-condition-variable)
+           (make-q)))
+
+(define* (async-queue-push! aq item)
+  (with-mutex (aq-mutex aq)
+    (enq! (aq-q aq) item)
+    (signal-condition-variable (aq-condvar aq))))
+
+(define* (async-queue-pop! aq)
+  (with-mutex (aq-mutex aq)
+    (let lp ()
+      (cond
+       ((q-empty? (aq-q aq))
+        (wait-condition-variable (aq-condvar aq) (aq-mutex aq))
+        (lp))
+       (else
+        (q-pop! (aq-q aq)))))))
+
+=0C
+;;;
+;;; backend
+;;;
+
+(define (bytes-free-on-fs filename)
+  (let* ((p (open-pipe* "r" "df" "-B1" "--output=3Davail" filename))
+         (l1 (read-line p))
+         (l2 (read-line p))
+         (l3 (read-line p)))
+    (close-pipe p)
+    (cond
+     ((and (string? l1) (string? l2) (eof-object? l3)
+           (equal? (string-trim-both l1) "Avail"))
+      (string->number l2))
+     (else
+      (error "could not get free space for file system containing" filen=
ame)))))
+
+(define (delete-directory-contents-recursively working-dir)
+  (for-each (lambda (file)
+              (delete-file-recursively (in-vicinity working-dir file)))
+            (scandir working-dir
+                     (lambda (file)
+                       (and (string<> "." file)
+                            (string<> ".." file))))))
+
+;; 1GB minimum free space.
+(define *mininum-free-space* #e1e9)
+
+(define (scm-files-in-dir dir)
+  (map (lambda (file)
+         (in-vicinity dir file))
+       (scandir dir
+                (lambda (file)
+                  (and (not (file-is-directory? (in-vicinity dir file)))
+                       (string-suffix? ".scm" file))))))
+
+(define (copy-header-comments port file)
+  (call-with-input-file file
+    (lambda (in)
+      (let lp ()
+        (let ((line (read-line in)))
+          (unless (eof-object? line)
+            (let ((trimmed (string-trim line)))
+              (when (or (string-null? trimmed) (string-prefix? ";" trimm=
ed))
+                (display trimmed port)
+                (newline port)
+                (lp)))))))))
+
+(define (process-update host working-dir source-checkout target-checkout
+                        remote-git-url branch)
+  (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+    (delete-directory-contents-recursively working-dir)
+    (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+      (error "not enough free space")))
+  (chdir working-dir)
+  (let* ((repo-dir (uri-encode remote-git-url))
+         (repo+branch-dir (in-vicinity repo-dir (uri-encode branch))))
+    (cond
+     ((file-exists? repo-dir)
+      (chdir repo-dir)
+      (git-fetch))
+     (else
+      (git-clone remote-git-url repo-dir)
+      (chdir repo-dir)))
+    (git-reset #:ref (string-append "origin/" branch) #:mode 'hard)
+    (unless (file-is-directory? "guix-potluck")
+      (error "repo+branch has no guix-potluck dir" remote-git-url branch=
))
+    (let* ((files (scm-files-in-dir "guix-potluck"))
+           ;; This step safely loads and validates the potluck package
+           ;; definitions.
+           (packages (map load-potluck-package files))
+           (source-dir (in-vicinity source-checkout repo+branch-dir))
+           (target-dir (in-vicinity target-checkout
+                                    (in-vicinity "gnu/packages/potluck"
+                                                 repo+branch-dir))))
+      ;; Clear source and target repo entries.
+      (define (ensure-empty-dir filename)
+        (when (file-exists? filename)
+          (delete-file-recursively filename))
+        (mkdir-p filename))
+      (define (commit-dir dir)
+        (with-directory-excursion dir
+          (git-add ".")
+          (git-commit #:message
+                      (format #f "Update ~a branch ~a."
+                              remote-git-url branch)
+                      #:author-name "Guix potluck host"
+                      #:author-email (string-append "host@" host))
+          (git-push)))
+      (ensure-empty-dir source-dir)
+      (ensure-empty-dir target-dir)
+      ;; Add potluck files to source repo.
+      (for-each (lambda (file)
+                  (copy-file file (in-vicinity source-dir (basename file=
))))
+                files)
+      (commit-dir source-dir)
+      ;; Add transformed files to target repo.
+      (for-each (lambda (file package)
+                  (call-with-output-file
+                      (in-vicinity target-dir (basename file))
+                    (lambda (port)
+                      (define module-name
+                        `(gnu packages potluck
+                              ,repo-dir
+                              ,(uri-encode branch)
+                              ,(substring (basename file) 0
+                                          (- (string-length (basename fi=
le))
+                                             (string-length ".scm")))))
+                      ;; Preserve copyright notices if possible.
+                      (copy-header-comments port file)
+                      (lower-potluck-package-to-module port module-name
+                                                       package))))
+                files packages)
+      (commit-dir target-dir)))
+  ;; 8. post success message
+  (pk 'success target-checkout remote-git-url branch))
+
+(define (service-queue host working-dir source-checkout target-checkout =
queue)
+  (let lp ()
+    (match (async-queue-pop! queue)
+      ((remote-git-url . branch)
+       (format (current-error-port) "log: handling ~a / ~a\n"
+               remote-git-url branch)
+       (catch #t
+         (lambda ()
+           (process-update host working-dir
+                           source-checkout target-checkout
+                           remote-git-url branch)
+           (format (current-error-port) "log: success ~a / ~a\n"
+                   remote-git-url branch))
+         (lambda (k . args)
+           (format (current-error-port) "log: failure ~a / ~a\n"
+                   remote-git-url branch)
+           (print-exception (current-error-port) #f k args)))
+       (lp)))))
+
+=0C
+;;;
+;;; frontend
+;;;
+
+(define* (validate-public-uri str #:key (schemes '(http https)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (error "expected a public URI" str))))
+
+(define (validate-branch-name str)
+  (unless (git-check-ref-format str #:allow-onelevel? #t)
+    (error "expected a valid git branch name" str)))
+
+(define (enqueue-update params queue)
+  (let ((remote-git-url (hash-ref params "git-url"))
+        (branch-name (hash-ref params "branch")))
+    (validate-public-uri remote-git-url)
+    (validate-branch-name branch-name)
+    (async-queue-push! queue (cons remote-git-url branch-name))))
+
+(define (request-body-json request body)
+  (cond
+   ((string? body) (json-string->scm body))
+   ((bytevector? body)
+    (let* ((content-type (request-content-type request))
+           (charset (or (assoc-ref (cdr content-type) "charset")
+                        "utf-8")))
+      (json-string->scm (bytevector->string body charset))))
+   ((port? body) (json->scm body))
+   (else (error "unexpected body" body))))
+
+(define (handler request body queue)
+  (match (cons (request-method request)
+               (split-and-decode-uri-path (uri-path (request-uri request=
))))
+    (('GET)
+     (values (build-response #:code 200)
+             "todo: show work queue"))
+    (('POST "api" "enqueue-update")
+     ;; An exception will cause error 500.
+     (enqueue-update (request-body-json request body) queue)
+     (values (build-response #:code 200)
+             ""))
+    (_
+     (values (build-response #:code 404)
+             ""))))
+
+(define (host-potluck host local-port working-dir source-checkout
+                      target-checkout)
+  (let ((worker-thread #f)
+        (queue (make-async-queue)))
+    (dynamic-wind (lambda ()
+                    (set! worker-thread
+                      (make-thread
+                       (service-queue host working-dir
+                                      source-checkout target-checkout
+                                      queue))))
+                  (lambda ()
+                    (run-server
+                     (lambda (request body)
+                       (handler request body queue))
+                     ;; Always listen on localhost.
+                     'http `(#:port ,local-port)))
+                  (lambda ()
+                    (cancel-thread worker-thread)))))
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
index f9cd40bd0..ec306cae6 100644
--- a/guix/scripts/potluck.scm
+++ b/guix/scripts/potluck.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck host)
   #:use-module (guix potluck licenses)
   #:use-module (guix potluck packages)
   #:use-module (guix scripts)
@@ -47,12 +48,12 @@
 ;;; guix potluck init
 ;;;
=20
-(define* (init-potluck remote-git-url #:key
+(define* (init-potluck host remote-git-url #:key
                        (build-system 'gnu) (autoreconf? #f)
                        (license 'gplv3+))
   (let* ((cwd (getcwd))
          (dot-git (in-vicinity cwd ".git"))
-         (potluck-dir (in-vicinity cwd "potluck"))
+         (potluck-dir (in-vicinity cwd "guix-potluck"))
          (package-name (basename cwd)))
     (unless (and (file-exists? dot-git)
                  (file-is-directory? dot-git))
@@ -74,17 +75,17 @@
            ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
            ;; here.
            (pkg-sha256 (guix-hash-git-checkout cwd)))
-      (format #t (_ "Creating potluck/~%"))
+      (format #t (_ "Creating guix-potluck/~%"))
       (mkdir potluck-dir)
-      (format #t (_ "Creating potluck/README.md~%"))
+      (format #t (_ "Creating guix-potluck/README.md~%"))
       (call-with-output-file (in-vicinity potluck-dir "README.md")
         (lambda (port)
           (format port
                   "\
 This directory defines potluck packages.  Each file in this directory sh=
ould
-define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+define one package.  See https://guix-potluck.org/ for more information.
 ")))
-      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (format #t (_ "Creating guix-potluck/~a.scm~%") package-name)
       (call-with-output-file (in-vicinity potluck-dir
                                           (string-append package-name ".=
scm"))
         (lambda (port)
@@ -133,16 +134,39 @@ define one package.  See https://potluck.guixsd.org=
/ for more information.
                             " is a ..."))
             (license license)))))
       (format #t (_ "
-Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
-\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+Done.  Now open guix-potluck/~a.scm in your editor, fill out its \"synop=
sis\"
+and \"description\" fields, add dependencies to the 'inputs' field, and =
try to
 build with
=20
-  guix build --file=3Dpotluck/~a.scm
+  guix build --file=3Dguix-potluck/~a.scm
=20
 When you get that working, commit your results to git via:
=20
   git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
-") pkg-name pkg-name))))
+
+Once you push them out, add your dish to the communal potluck by running=
:
+
+  guix potluck update ~a
+") pkg-name pkg-name remote-git-url))))
+
+;;;
+;;; guix potluck update
+;;;
+
+(define (request-potluck-update host git-url branch)
+  (call-with-values (lambda ()
+                      (http-post (build-uri 'https
+                                            #:host host
+                                            #:path "/api/enqueue-update"=
)
+                                 #:body (scm->json-string
+                                         `((git-url . ,git-url)
+                                           (branch . ,branch)))))
+    (lambda (response body)
+      (unless (eqv? (response-code response) 200)
+        (error "request failed"
+               (response-code response)
+               (response-reason-phrase response)
+               body)))))
=20
 =0C
 ;;;
@@ -159,10 +183,33 @@ ARGS.\n"))
   (newline)
   (display (_ "\
    init             create potluck recipe for current working directory\=
n"))
+  (display (_ "\
+   update           ask potluck host to add or update a potluck package\=
n"))
+  (display (_ "\
+   host-channel     run web service providing potluck packages as Guix c=
hannel\n"))
=20
   (newline)
   (display (_ "The available OPTION flags are:\n"))
   (display (_ "
+      --host=3DHOST        for 'update' and 'host-channel', the name of =
the
+                         channel host
+                         (default: guix-potluck.org)"))
+  (display (_ "
+      --port=3DPORT        for 'host-channel', the local TCP port on whi=
ch to
+                         listen for HTTP connections
+                         (default: 8080)"))
+  (display (_ "
+      --scratch=3DDIR      for 'host-channel', the path to a local direc=
tory
+                         that will be used as a scratch space to check o=
ut
+                         remote git repositories"))
+  (display (_ "
+      --source=3DDIR       for 'host-channel', the path to a local check=
out
+                         of guix potluck source packages to be managed b=
y
+                         host-channel"))
+  (display (_ "
+      --target=3DDIR       for 'host-channel', the path to a local check=
out
+                         of a guix channel to be managed by host-channel=
"))
+  (display (_ "
       --build-system=3DSYS for 'init', specify the build system.  Use
                          --build-system=3Dhelp for all available options=
."))
   (display (_ "
@@ -201,19 +248,56 @@ ARGS.\n"))
         (option '("license") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'license arg result)))
+        (option '("host") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'host arg result)))
+        (option '("port") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'port arg result)))
+        (option '("scratch") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'scratch arg result)))
+        (option '("source") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'source arg result)))
+        (option '("target") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'target arg result)))
         (option '("verbosity") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'verbosity (string->number arg) result))))=
)
=20
 (define %default-options
   ;; Alist of default option values.
-  `((verbosity . 0)))
+  `((host . "guix-potluck.org")
+    (port . "8080")
+    (verbosity . 0)))
+
+(define (parse-host host-str)
+  ;; Will throw if the host is invalid somehow.
+  (build-uri 'https #:host host-str)
+  host-str)
=20
 (define (parse-url url-str)
   (unless (string->uri url-str)
     (leave (_ "invalid url: ~a~%") url-str))
   url-str)
=20
+(define (parse-port port-str)
+  (let ((port (string->number port-str)))
+    (cond
+     ((and port (exact-integer? port) (<=3D 0 port #xffff))
+      port)
+     (else
+      (leave (_ "invalid port: ~a~%") port-str)))))
+
+(define (parse-absolute-directory-name str)
+  (unless (and (absolute-file-name? str)
+               (file-exists? str)
+               (file-is-directory? str))
+    (leave (_ "invalid absolute directory name: ~a~%") str))
+  str)
+
 (define (parse-build-system sys-str)
   (unless sys-str
     (leave (_ "\
@@ -297,7 +381,8 @@ If your package's license is not in this list, add it=
 to Guix first.~%")
         ('init
          (match args
            ((remote-git-url)
-            (init-potluck (parse-url remote-git-url)
+            (init-potluck (parse-host (assoc-ref opts 'host))
+                          (parse-url remote-git-url)
                           #:build-system (parse-build-system
                                           (assoc-ref opts 'build-system)=
)
                           #:autoreconf? (assoc-ref opts 'autoreconf?)
@@ -306,5 +391,33 @@ If your package's license is not in this list, add i=
t to Guix first.~%")
            (args
             (wrong-number-of-args
              (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        ('update
+         (match args
+           ((remote-git-url branch)
+            (request-potluck-update (parse-host (assoc-ref opts 'host))
+                                    (parse-url remote-git-url)
+                                    branch))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck update REMOTE-GIT-URL BRANCH-NAME")=
))))
+        ('host-channel
+         (match args
+           (()
+            (host-potluck (parse-host (assoc-ref opts 'host))
+                          (parse-port (assoc-ref opts 'port))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'scratch)
+                               (leave (_ "missing --scratch argument~%")=
)))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'source)
+                               (leave (_ "missing --source argument~%"))=
))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'target)
+                               (leave (_ "missing --target argument~%"))=
))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck host-channel --scratch=3DDIR \
+--source=3DDIR --target=3DDIR"))
+            (exit 1))))
         (action
          (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:24 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:24 2017
Received: from localhost ([127.0.0.1]:38517 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6l-0004eB-Gu
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:24 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:53817
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5M-0004OX-5O
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:09 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id DA08A74D30
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=m8jRC6JiZFmt
 G7XyB8O6Z6i8XjY=; b=sYuEH0D3sasxCT1F596qLWgCiPjSoMyo72RSn8PaRA/3
 DB0GEebPqQHLsf5n7VbxlGRudIr7veeuR502DcUVQmYiHWX4dILldkBbhAstGbZw
 dN0PfaWUUOD1/B85gAeNIPN7iwicxnuk+yv/YyR5yhUBndYx08eOn1SFrvyYkNI=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id D266074D2F
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 6A01674D1F
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:47 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 8/9] potluck: Add host-channel subcommand.
Date: Mon, 24 Apr 2017 22:59:22 +0200
Message-Id: <20170424205923.27726-8-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F35789D4-2930-11E7-8139-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/host.scm: New file.
* Makefile.am (MODULES): Add new file.
* guix/scripts/potluck.scm: Add host-channel command.
---
 Makefile.am              |   1 +
 guix/potluck/host.scm    | 304 +++++++++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/potluck.scm | 137 +++++++++++++++++++--
 3 files changed, 430 insertions(+), 12 deletions(-)
 create mode 100644 guix/potluck/host.scm

diff --git a/Makefile.am b/Makefile.am
index 628283b57..94fa05d5b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -129,6 +129,7 @@ MODULES =3D					\
   guix/git.scm					\
   guix/potluck/build-systems.scm		\
   guix/potluck/environment.scm			\
+  guix/potluck/host.scm				\
   guix/potluck/licenses.scm			\
   guix/potluck/packages.scm			\
   guix/import/utils.scm				\
diff --git a/guix/potluck/host.scm b/guix/potluck/host.scm
new file mode 100644
index 000000000..5ac8e0f5f
--- /dev/null
+++ b/guix/potluck/host.scm
@@ -0,0 +1,304 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck host)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module (guix ui)
+  #:use-module ((guix build utils)
+                #:select (mkdir-p
+                          delete-file-recursively
+                          with-directory-excursion))
+  #:use-module (guix git)
+  #:use-module (guix utils)
+  #:use-module (guix potluck packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 q)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 threads)
+  #:use-module (json)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (web uri)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web server)
+  #:export (host-potluck))
+
+=0C
+;;;
+;;; async queues
+;;;
+
+(define-record-type <async-queue>
+  (make-aq mutex condvar q)
+  async-queue?
+  (mutex aq-mutex)
+  (condvar aq-condvar)
+  (q aq-q))
+
+(set-record-type-printer!
+ <async-queue>
+ (lambda (aq port)
+   (format port "<async-queue ~a ~a>" (object-address aq)
+           (q-length (aq-q aq)))))
+
+(define* (make-async-queue)
+  (make-aq (make-mutex)
+           (make-condition-variable)
+           (make-q)))
+
+(define* (async-queue-push! aq item)
+  (with-mutex (aq-mutex aq)
+    (enq! (aq-q aq) item)
+    (signal-condition-variable (aq-condvar aq))))
+
+(define* (async-queue-pop! aq)
+  (with-mutex (aq-mutex aq)
+    (let lp ()
+      (cond
+       ((q-empty? (aq-q aq))
+        (wait-condition-variable (aq-condvar aq) (aq-mutex aq))
+        (lp))
+       (else
+        (q-pop! (aq-q aq)))))))
+
+=0C
+;;;
+;;; backend
+;;;
+
+(define (bytes-free-on-fs filename)
+  (let* ((p (open-pipe* "r" "df" "-B1" "--output=3Davail" filename))
+         (l1 (read-line p))
+         (l2 (read-line p))
+         (l3 (read-line p)))
+    (close-pipe p)
+    (cond
+     ((and (string? l1) (string? l2) (eof-object? l3)
+           (equal? (string-trim-both l1) "Avail"))
+      (string->number l2))
+     (else
+      (error "could not get free space for file system containing" filen=
ame)))))
+
+(define (delete-directory-contents-recursively working-dir)
+  (for-each (lambda (file)
+              (delete-file-recursively (in-vicinity working-dir file)))
+            (scandir working-dir
+                     (lambda (file)
+                       (and (string<> "." file)
+                            (string<> ".." file))))))
+
+;; 1GB minimum free space.
+(define *mininum-free-space* #e1e9)
+
+(define (scm-files-in-dir dir)
+  (map (lambda (file)
+         (in-vicinity dir file))
+       (scandir dir
+                (lambda (file)
+                  (and (not (file-is-directory? (in-vicinity dir file)))
+                       (string-suffix? ".scm" file))))))
+
+(define (copy-header-comments port file)
+  (call-with-input-file file
+    (lambda (in)
+      (let lp ()
+        (let ((line (read-line in)))
+          (unless (eof-object? line)
+            (let ((trimmed (string-trim line)))
+              (when (or (string-null? trimmed) (string-prefix? ";" trimm=
ed))
+                (display trimmed port)
+                (newline port)
+                (lp)))))))))
+
+(define (process-update host working-dir source-checkout target-checkout
+                        remote-git-url branch)
+  (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+    (delete-directory-contents-recursively working-dir)
+    (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+      (error "not enough free space")))
+  (chdir working-dir)
+  (let* ((repo-dir (uri-encode remote-git-url))
+         (repo+branch-dir (in-vicinity repo-dir (uri-encode branch))))
+    (cond
+     ((file-exists? repo-dir)
+      (chdir repo-dir)
+      (git-fetch))
+     (else
+      (git-clone remote-git-url repo-dir)
+      (chdir repo-dir)))
+    (git-reset #:ref (string-append "origin/" branch) #:mode 'hard)
+    (unless (file-is-directory? "guix-potluck")
+      (error "repo+branch has no guix-potluck dir" remote-git-url branch=
))
+    (let* ((files (scm-files-in-dir "guix-potluck"))
+           ;; This step safely loads and validates the potluck package
+           ;; definitions.
+           (packages (map load-potluck-package files))
+           (source-dir (in-vicinity source-checkout repo+branch-dir))
+           (target-dir (in-vicinity target-checkout
+                                    (in-vicinity "gnu/packages/potluck"
+                                                 repo+branch-dir))))
+      ;; Clear source and target repo entries.
+      (define (ensure-empty-dir filename)
+        (when (file-exists? filename)
+          (delete-file-recursively filename))
+        (mkdir-p filename))
+      (define (commit-dir dir)
+        (with-directory-excursion dir
+          (git-add ".")
+          (git-commit #:message
+                      (format #f "Update ~a branch ~a."
+                              remote-git-url branch)
+                      #:author-name "Guix potluck host"
+                      #:author-email (string-append "host@" host))
+          (git-push)))
+      (ensure-empty-dir source-dir)
+      (ensure-empty-dir target-dir)
+      ;; Add potluck files to source repo.
+      (for-each (lambda (file)
+                  (copy-file file (in-vicinity source-dir (basename file=
))))
+                files)
+      (commit-dir source-dir)
+      ;; Add transformed files to target repo.
+      (for-each (lambda (file package)
+                  (call-with-output-file
+                      (in-vicinity target-dir (basename file))
+                    (lambda (port)
+                      (define module-name
+                        `(gnu packages potluck
+                              ,repo-dir
+                              ,(uri-encode branch)
+                              ,(substring (basename file) 0
+                                          (- (string-length (basename fi=
le))
+                                             (string-length ".scm")))))
+                      ;; Preserve copyright notices if possible.
+                      (copy-header-comments port file)
+                      (lower-potluck-package-to-module port module-name
+                                                       package))))
+                files packages)
+      (commit-dir target-dir)))
+  ;; 8. post success message
+  (pk 'success target-checkout remote-git-url branch))
+
+(define (service-queue host working-dir source-checkout target-checkout =
queue)
+  (let lp ()
+    (match (async-queue-pop! queue)
+      ((remote-git-url . branch)
+       (format (current-error-port) "log: handling ~a / ~a\n"
+               remote-git-url branch)
+       (catch #t
+         (lambda ()
+           (process-update host working-dir
+                           source-checkout target-checkout
+                           remote-git-url branch)
+           (format (current-error-port) "log: success ~a / ~a\n"
+                   remote-git-url branch))
+         (lambda (k . args)
+           (format (current-error-port) "log: failure ~a / ~a\n"
+                   remote-git-url branch)
+           (print-exception (current-error-port) #f k args)))
+       (lp)))))
+
+=0C
+;;;
+;;; frontend
+;;;
+
+(define* (validate-public-uri str #:key (schemes '(http https)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (error "expected a public URI" str))))
+
+(define (validate-branch-name str)
+  (unless (git-check-ref-format str #:allow-onelevel? #t)
+    (error "expected a valid git branch name" str)))
+
+(define (enqueue-update params queue)
+  (let ((remote-git-url (hash-ref params "git-url"))
+        (branch-name (hash-ref params "branch")))
+    (validate-public-uri remote-git-url)
+    (validate-branch-name branch-name)
+    (async-queue-push! queue (cons remote-git-url branch-name))))
+
+(define (request-body-json request body)
+  (cond
+   ((string? body) (json-string->scm body))
+   ((bytevector? body)
+    (let* ((content-type (request-content-type request))
+           (charset (or (assoc-ref (cdr content-type) "charset")
+                        "utf-8")))
+      (json-string->scm (bytevector->string body charset))))
+   ((port? body) (json->scm body))
+   (else (error "unexpected body" body))))
+
+(define (handler request body queue)
+  (match (cons (request-method request)
+               (split-and-decode-uri-path (uri-path (request-uri request=
))))
+    (('GET)
+     (values (build-response #:code 200)
+             "todo: show work queue"))
+    (('POST "api" "enqueue-update")
+     ;; An exception will cause error 500.
+     (enqueue-update (request-body-json request body) queue)
+     (values (build-response #:code 200)
+             ""))
+    (_
+     (values (build-response #:code 404)
+             ""))))
+
+(define (host-potluck host local-port working-dir source-checkout
+                      target-checkout)
+  (let ((worker-thread #f)
+        (queue (make-async-queue)))
+    (dynamic-wind (lambda ()
+                    (set! worker-thread
+                      (make-thread
+                       (service-queue host working-dir
+                                      source-checkout target-checkout
+                                      queue))))
+                  (lambda ()
+                    (run-server
+                     (lambda (request body)
+                       (handler request body queue))
+                     ;; Always listen on localhost.
+                     'http `(#:port ,local-port)))
+                  (lambda ()
+                    (cancel-thread worker-thread)))))
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
index f9cd40bd0..ec306cae6 100644
--- a/guix/scripts/potluck.scm
+++ b/guix/scripts/potluck.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck host)
   #:use-module (guix potluck licenses)
   #:use-module (guix potluck packages)
   #:use-module (guix scripts)
@@ -47,12 +48,12 @@
 ;;; guix potluck init
 ;;;
=20
-(define* (init-potluck remote-git-url #:key
+(define* (init-potluck host remote-git-url #:key
                        (build-system 'gnu) (autoreconf? #f)
                        (license 'gplv3+))
   (let* ((cwd (getcwd))
          (dot-git (in-vicinity cwd ".git"))
-         (potluck-dir (in-vicinity cwd "potluck"))
+         (potluck-dir (in-vicinity cwd "guix-potluck"))
          (package-name (basename cwd)))
     (unless (and (file-exists? dot-git)
                  (file-is-directory? dot-git))
@@ -74,17 +75,17 @@
            ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
            ;; here.
            (pkg-sha256 (guix-hash-git-checkout cwd)))
-      (format #t (_ "Creating potluck/~%"))
+      (format #t (_ "Creating guix-potluck/~%"))
       (mkdir potluck-dir)
-      (format #t (_ "Creating potluck/README.md~%"))
+      (format #t (_ "Creating guix-potluck/README.md~%"))
       (call-with-output-file (in-vicinity potluck-dir "README.md")
         (lambda (port)
           (format port
                   "\
 This directory defines potluck packages.  Each file in this directory sh=
ould
-define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+define one package.  See https://guix-potluck.org/ for more information.
 ")))
-      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (format #t (_ "Creating guix-potluck/~a.scm~%") package-name)
       (call-with-output-file (in-vicinity potluck-dir
                                           (string-append package-name ".=
scm"))
         (lambda (port)
@@ -133,16 +134,39 @@ define one package.  See https://potluck.guixsd.org=
/ for more information.
                             " is a ..."))
             (license license)))))
       (format #t (_ "
-Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
-\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+Done.  Now open guix-potluck/~a.scm in your editor, fill out its \"synop=
sis\"
+and \"description\" fields, add dependencies to the 'inputs' field, and =
try to
 build with
=20
-  guix build --file=3Dpotluck/~a.scm
+  guix build --file=3Dguix-potluck/~a.scm
=20
 When you get that working, commit your results to git via:
=20
   git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
-") pkg-name pkg-name))))
+
+Once you push them out, add your dish to the communal potluck by running=
:
+
+  guix potluck update ~a
+") pkg-name pkg-name remote-git-url))))
+
+;;;
+;;; guix potluck update
+;;;
+
+(define (request-potluck-update host git-url branch)
+  (call-with-values (lambda ()
+                      (http-post (build-uri 'https
+                                            #:host host
+                                            #:path "/api/enqueue-update"=
)
+                                 #:body (scm->json-string
+                                         `((git-url . ,git-url)
+                                           (branch . ,branch)))))
+    (lambda (response body)
+      (unless (eqv? (response-code response) 200)
+        (error "request failed"
+               (response-code response)
+               (response-reason-phrase response)
+               body)))))
=20
 =0C
 ;;;
@@ -159,10 +183,33 @@ ARGS.\n"))
   (newline)
   (display (_ "\
    init             create potluck recipe for current working directory\=
n"))
+  (display (_ "\
+   update           ask potluck host to add or update a potluck package\=
n"))
+  (display (_ "\
+   host-channel     run web service providing potluck packages as Guix c=
hannel\n"))
=20
   (newline)
   (display (_ "The available OPTION flags are:\n"))
   (display (_ "
+      --host=3DHOST        for 'update' and 'host-channel', the name of =
the
+                         channel host
+                         (default: guix-potluck.org)"))
+  (display (_ "
+      --port=3DPORT        for 'host-channel', the local TCP port on whi=
ch to
+                         listen for HTTP connections
+                         (default: 8080)"))
+  (display (_ "
+      --scratch=3DDIR      for 'host-channel', the path to a local direc=
tory
+                         that will be used as a scratch space to check o=
ut
+                         remote git repositories"))
+  (display (_ "
+      --source=3DDIR       for 'host-channel', the path to a local check=
out
+                         of guix potluck source packages to be managed b=
y
+                         host-channel"))
+  (display (_ "
+      --target=3DDIR       for 'host-channel', the path to a local check=
out
+                         of a guix channel to be managed by host-channel=
"))
+  (display (_ "
       --build-system=3DSYS for 'init', specify the build system.  Use
                          --build-system=3Dhelp for all available options=
."))
   (display (_ "
@@ -201,19 +248,56 @@ ARGS.\n"))
         (option '("license") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'license arg result)))
+        (option '("host") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'host arg result)))
+        (option '("port") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'port arg result)))
+        (option '("scratch") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'scratch arg result)))
+        (option '("source") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'source arg result)))
+        (option '("target") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'target arg result)))
         (option '("verbosity") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'verbosity (string->number arg) result))))=
)
=20
 (define %default-options
   ;; Alist of default option values.
-  `((verbosity . 0)))
+  `((host . "guix-potluck.org")
+    (port . "8080")
+    (verbosity . 0)))
+
+(define (parse-host host-str)
+  ;; Will throw if the host is invalid somehow.
+  (build-uri 'https #:host host-str)
+  host-str)
=20
 (define (parse-url url-str)
   (unless (string->uri url-str)
     (leave (_ "invalid url: ~a~%") url-str))
   url-str)
=20
+(define (parse-port port-str)
+  (let ((port (string->number port-str)))
+    (cond
+     ((and port (exact-integer? port) (<=3D 0 port #xffff))
+      port)
+     (else
+      (leave (_ "invalid port: ~a~%") port-str)))))
+
+(define (parse-absolute-directory-name str)
+  (unless (and (absolute-file-name? str)
+               (file-exists? str)
+               (file-is-directory? str))
+    (leave (_ "invalid absolute directory name: ~a~%") str))
+  str)
+
 (define (parse-build-system sys-str)
   (unless sys-str
     (leave (_ "\
@@ -297,7 +381,8 @@ If your package's license is not in this list, add it=
 to Guix first.~%")
         ('init
          (match args
            ((remote-git-url)
-            (init-potluck (parse-url remote-git-url)
+            (init-potluck (parse-host (assoc-ref opts 'host))
+                          (parse-url remote-git-url)
                           #:build-system (parse-build-system
                                           (assoc-ref opts 'build-system)=
)
                           #:autoreconf? (assoc-ref opts 'autoreconf?)
@@ -306,5 +391,33 @@ If your package's license is not in this list, add i=
t to Guix first.~%")
            (args
             (wrong-number-of-args
              (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        ('update
+         (match args
+           ((remote-git-url branch)
+            (request-potluck-update (parse-host (assoc-ref opts 'host))
+                                    (parse-url remote-git-url)
+                                    branch))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck update REMOTE-GIT-URL BRANCH-NAME")=
))))
+        ('host-channel
+         (match args
+           (()
+            (host-potluck (parse-host (assoc-ref opts 'host))
+                          (parse-port (assoc-ref opts 'port))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'scratch)
+                               (leave (_ "missing --scratch argument~%")=
)))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'source)
+                               (leave (_ "missing --source argument~%"))=
))
+                          (parse-absolute-directory-name
+                           (or (assoc-ref opts 'target)
+                               (leave (_ "missing --target argument~%"))=
))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck host-channel --scratch=3DDIR \
+--source=3DDIR --target=3DDIR"))
+            (exit 1))))
         (action
          (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:19 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:19 2017
Received: from localhost ([127.0.0.1]:38505 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6g-0004cr-Ro
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:19 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:58181
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5L-0004PJ-JH
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:09 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 7546A74D2B
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:mime-version:content-type
 :content-transfer-encoding; s=sasl; bh=/U7YvCWRRtgTKxEHLu0Z1p51m
 q8=; b=ZJLLE08bbd2ZgXgLzNshldrM7FvCboEfoC/MF00t2JlZjsUEK3c6lXXOK
 aofa0nahKRpjAztIMsHViUZKj1V7K+ms1vX1//3pzaK9yVnM1jch70hgkc5vXpsg
 vZw0QF4ob1bVGZSwbFsJOYqrAL41e0nAh5mtCDXZKxuiNyZFxc=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 6D80E74D2A
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 0BDDD74D19
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:43 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 1/9] guix: Add "potluck" packages.
Date: Mon, 24 Apr 2017 22:59:15 +0200
Message-Id: <20170424205923.27726-1-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F157D2C4-2930-11E7-810D-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/build-systems.scm:
* guix/potluck/licenses.scm:
* guix/potluck/packages.scm: New files.
* guix/scripts/build.scm (load-package-or-derivation-from-file):
(options->things-to-build, options->derivations): Add "potluck-package" a=
nd
"potluck-source" to environment of file.  Lower potluck packages to Guix
packages.
---
 Makefile.am                    |   3 +
 guix/potluck/build-systems.scm |  55 ++++++
 guix/potluck/licenses.scm      |  41 +++++
 guix/potluck/packages.scm      | 399 +++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/build.scm         |  54 +++---
 5 files changed, 532 insertions(+), 20 deletions(-)
 create mode 100644 guix/potluck/build-systems.scm
 create mode 100644 guix/potluck/licenses.scm
 create mode 100644 guix/potluck/packages.scm

diff --git a/Makefile.am b/Makefile.am
index db4ebe04d..22ba00e90 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,9 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/potluck/build-systems.scm		\
+  guix/potluck/licenses.scm			\
+  guix/potluck/packages.scm			\
   guix/import/utils.scm				\
   guix/import/gnu.scm				\
   guix/import/snix.scm				\
diff --git a/guix/potluck/build-systems.scm b/guix/potluck/build-systems.=
scm
new file mode 100644
index 000000000..1f6aa1fe3
--- /dev/null
+++ b/guix/potluck/build-systems.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck build-systems)
+  #:use-module ((guix build-system) #:select (build-system?))
+  #:use-module ((gnu packages) #:select (scheme-modules))
+  #:use-module (ice-9 match)
+  #:export (build-system-by-name all-potluck-build-system-names))
+
+(define all-build-systems
+  (delay
+    (let* ((gbs (or (search-path %load-path "guix/build-system.scm")
+                    (error "can't find (guix build-system)")))
+           (root (dirname (dirname gbs)))
+           (by-name (make-hash-table)))
+      (for-each (lambda (iface)
+                  (module-for-each
+                   (lambda (k var)
+                     (let* ((str (symbol->string k))
+                            (pos (string-contains str "-build-system"))
+                            (val (variable-ref var)))
+                       (when (and pos (build-system? val))
+                         (let* ((head (substring str 0 pos))
+                                (tail (substring str
+                                                 (+ pos (string-length
+                                                         "-build-system"=
))))
+                                (name (string->symbol
+                                       (string-append head tail))))
+                           (hashq-set! by-name name val)))))
+                   iface))
+                (scheme-modules root "guix/build-system"))
+      by-name)))
+
+(define (all-potluck-build-system-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-build-systems))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (build-system-by-name name)
+  (hashq-ref (force all-build-systems) name))
diff --git a/guix/potluck/licenses.scm b/guix/potluck/licenses.scm
new file mode 100644
index 000000000..6efeee21a
--- /dev/null
+++ b/guix/potluck/licenses.scm
@@ -0,0 +1,41 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck licenses)
+  #:use-module ((guix licenses) #:select (license?))
+  #:use-module (ice-9 match)
+  #:export (license-by-name all-potluck-license-names))
+
+(define all-licenses
+  (delay
+    (let ((iface (resolve-interface '(guix licenses)))
+          (by-name (make-hash-table)))
+      (module-for-each (lambda (k var)
+                         (let ((val (variable-ref var)))
+                           (when (license? val)
+                             (hashq-set! by-name k val))))
+                       (resolve-interface '(guix licenses)))
+      by-name)))
+
+(define (all-potluck-license-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-licenses))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (license-by-name name)
+  (hashq-ref (force all-licenses) name))
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
new file mode 100644
index 000000000..c7dae3791
--- /dev/null
+++ b/guix/potluck/packages.scm
@@ -0,0 +1,399 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Court=C3=
=A8s <ludo@HIDDEN>
+;;; Copyright =C2=A9 2014, 2015 Mark H Weaver <mhw@HIDDEN>
+;;; Copyright =C2=A9 2015 Eric Bavier <bavier@HIDDEN>
+;;; Copyright =C2=A9 2016 Alex Kost <alezost@HIDDEN>
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck packages)
+  #:use-module (gnu packages)
+  #:use-module (guix base32)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (web uri)
+  #:export (potluck-source
+            potluck-source?
+            potluck-source-git-uri
+            potluck-source-git-commit
+            potluck-source-sha256
+            potluck-source-snippet
+
+            potluck-package
+            potluck-package?
+            potluck-package-name
+            potluck-package-version
+            potluck-package-source
+            potluck-package-build-system
+            potluck-package-arguments
+            potluck-package-inputs
+            potluck-package-native-inputs
+            potluck-package-propagated-inputs
+            potluck-package-synopsis
+            potluck-package-description
+            potluck-package-license
+            potluck-package-home-page
+            potluck-package-location
+            potluck-package-field-location
+
+            pretty-print-potluck-source
+            pretty-print-potluck-package
+
+            validate-potluck-package
+
+            lower-potluck-source
+            lower-potluck-package))
+
+;;; Commentary:
+;;;
+;;; This module provides a facility to define "potluck packages" in a
+;;; Guix-based distribution, and a facility to translate those packages =
to
+;;; "normal" Guix packages.
+;;;
+;;; Code:
+
+(define-record-type* <potluck-source>
+  potluck-source make-potluck-source
+  potluck-source?
+  (git-uri    potluck-source-git-uri)               ; uri string
+  (git-commit potluck-source-git-commit)            ; git sha1 string
+  (sha256     potluck-source-sha256)                ; base32 string
+  (snippet    potluck-source-snippet (default #f))) ; sexp or #f
+
+(define-record-type* <potluck-package>
+  potluck-package make-potluck-package
+  potluck-package?
+  (name               potluck-package-name)         ; string
+  (version            potluck-package-version)      ; string
+  (source             potluck-package-source)       ; <potluck-source>
+                                                    ; instance
+  (build-system       potluck-package-build-system) ; build system name =
as
+                                                    ; symbol
+  (arguments          potluck-package-arguments     ; arguments for the =
build
+                                                    ; method
+                      (default '()))
+  (inputs             potluck-package-inputs        ; input packages or
+                                                    ; derivations
+                      (default '()))
+  (propagated-inputs  potluck-package-propagated-inputs ; same, but prop=
agated
+                      (default '()))
+  (native-inputs      potluck-package-native-inputs ; native input packa=
ges or
+                                                    ; derivations
+                      (default '()))
+  (synopsis           potluck-package-synopsis)     ; one-line descripti=
on
+  (description        potluck-package-description)  ; one or two paragra=
phs
+  (license            potluck-package-license)
+  (home-page          potluck-package-home-page)
+  (location           potluck-package-location
+                      (default (and=3D> (current-source-location)
+                                      source-properties->location))
+                      (innate)))
+
+;; Printers.
+
+(define (print-potluck-source potluck-source port)
+  "Write a concise representation of POTLUCK-SOURCE to PORT."
+  (match potluck-source
+    (($ <potluck-source> git-uri git-commit sha256 snippet)
+     (simple-format port "#<potluck-source ~a@~a ~a ~a>"
+                    git-uri git-commit sha256
+                    (number->string (object-address potluck-source) 16))=
)))
+
+(define (print-potluck-package package port)
+  (let ((loc    (potluck-package-location package))
+        (format simple-format))
+    (format port "#<potluck-package ~a@~a ~a~a>"
+            (potluck-package-name package)
+            (potluck-package-version package)
+            (if loc
+                (format #f "~a:~a "
+                        (location-file loc)
+                        (location-line loc))
+                "")
+            (number->string (object-address
+                             package)
+                            16))))
+
+(set-record-type-printer! <potluck-source> print-potluck-source)
+(set-record-type-printer! <potluck-package> print-potluck-package)
+
+;; Pretty-printers.
+
+(define* (pretty-print-potluck-source port source #:key (prefix "")
+                                      (suffix "\n"))
+  (let ((uri (potluck-source-git-uri source))
+        (commit (potluck-source-git-commit source))
+        (sha256 (potluck-source-sha256 source))
+        (snippet (potluck-source-snippet source)))
+    (format port "~a(potluck-source" prefix)
+    (format port "\n~a  (git-uri ~s)" prefix uri)
+    (format port "\n~a  (git-commit ~s)" prefix commit)
+    (format port "\n~a  (sha256 ~s)" prefix sha256)
+    (when snippet
+      (format port "\n~a  (snippet '~s)" prefix snippet))
+    (format port ")~a" suffix)))
+
+(define* (pretty-print-potluck-package port pkg #:key (prefix ""))
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (format port "~a(potluck-package\n" prefix)
+    (format port "~a  (name ~s)\n" prefix name)
+    (format port "~a  (version ~s)\n" prefix version)
+    (format port "~a  (source\n" prefix)
+    (pretty-print-potluck-source port source #:prefix
+                                 (string-append prefix "    ")
+                                 #:suffix ")\n")
+    (format port "~a  (build-system '~s)\n" prefix build-system)
+    (format port "~a  (inputs '~s)\n" prefix inputs)
+    (format port "~a  (native-inputs '~s)\n" prefix native-inputs)
+    (format port "~a  (propagated-inputs '~s)\n" prefix propagated-input=
s)
+    (match arguments
+      (()
+       (format port "~a  (arguments '())\n" prefix))
+      (arguments
+       (pretty-print `(arguments ',arguments) port
+                     #:per-line-prefix (format #f "~a  " prefix))))
+    (format port "~a  (home-page ~s)\n" prefix home-page)
+    (format port "~a  (synopsis ~s)\n" prefix synopsis)
+    (format port "~a  (description ~s)\n" prefix description)
+    (format port "~a  (license '~s))\n" prefix license)))
+
+;; Editing.
+
+(define (potluck-package-field-location package field)
+  "Return the source code location of the definition of FIELD for PACKAG=
E, or
+#f if it could not be determined."
+  (define (goto port line column)
+    (unless (and (=3D (port-column port) (- column 1))
+                 (=3D (port-line port) (- line 1)))
+      (unless (eof-object? (read-char port))
+        (goto port line column))))
+
+  (match (potluck-package-location package)
+    (($ <location> file line column)
+     (catch 'system
+       (lambda ()
+         ;; In general we want to keep relative file names for modules.
+         (with-fluids ((%file-port-name-canonicalization 'relative))
+           (call-with-input-file (search-path %load-path file)
+             (lambda (port)
+               (goto port line column)
+               (match (read port)
+                 (('potluck-package inits ...)
+                  (let ((field (assoc field inits)))
+                    (match field
+                      ((_ value)
+                       ;; Put the `or' here, and not in the first argume=
nt of
+                       ;; `and=3D>', to work around a compiler bug in 2.=
0.5.
+                       (or (and=3D> (source-properties value)
+                                  source-properties->location)
+                           (and=3D> (source-properties field)
+                                  source-properties->location)))
+                      (_
+                       #f))))
+                 (_
+                  #f))))))
+       (lambda _
+         #f)))
+    (_ #f)))
+
+;; Lower potluck packages to Guix packages.
+
+(define-condition-type &potluck-package-error &error
+  potluck-package-error?
+  (potluck-package potluck-package-error-potluck-package))
+
+(define-condition-type &potluck-package-validation-error &potluck-packag=
e-error
+  potluck-package-validation-error?
+  (field-name potluck-package-validation-error-field-name)
+  (assertion potluck-package-validation-error-assertion)
+  (value potluck-package-validation-error-value))
+
+(define (assertion-failed pkg field-name assertion value)
+  (raise (condition (&potluck-package-validation-error
+                     (potluck-package pkg)
+                     (field-name field-name)
+                     (assertion assertion)
+                     (value value)))))
+
+(define* (validate-public-uri pkg field-name str #:key (schemes '(http h=
ttps)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (assertion-failed pkg field-name "public URI" str))))
+
+(define (validate-git-commit pkg field-name commit)
+  (unless (and (string? commit)
+               (=3D (string-length commit) 40)
+               (string-every (string->char-set "abcdef0123456789") commi=
t))
+    (assertion-failed pkg field-name "full git commit SHA1 hash" commit)=
))
+
+(define (validate-base32-sha256 pkg field-name str)
+  (unless (and (string? str)
+               (=3D (string-length str) 52)
+               (false-if-exception (nix-base32-string->bytevector str)))
+    (assertion-failed pkg field-name "sha256 hash as a base32 string" st=
r)))
+
+(define (validate-potluck-source pkg field-name source)
+  (validate-public-uri pkg field-name (potluck-source-git-uri source)
+                       #:schemes '(git http https))
+  (validate-git-commit pkg field-name (potluck-source-git-commit source)=
)
+  (validate-base32-sha256 pkg field-name (potluck-source-sha256 source))
+  (validate-snippet pkg field-name (potluck-source-snippet source)))
+
+(define (validate-snippet pkg field-name snippet)
+  (match snippet
+    (#f #t)
+    ((_ ...) #t)
+    (_ (assertion-failed pkg field-name "valid snippet" snippet))))
+
+(define (validate-non-empty-string pkg field-name str)
+  (unless (and (string? str)
+               (not (string-null? str)))
+    (assertion-failed pkg field-name "non-empty string" str)))
+
+(define (validate-build-system pkg field-name sym)
+  (unless (build-system-by-name sym)
+    (assertion-failed pkg field-name "build system name as symbol" sym))=
)
+
+(define (validate-package-list pkg field-name l)
+  (unless (and (list? l) (and-map string? l))
+    (assertion-failed pkg field-name
+                      "list of package or package@version strings" l)))
+
+(define* (validate-keyword-arguments pkg field-name l #:optional (valid-=
kw? (const #t)))
+  (define validate-1
+    (case-lambda
+      (() #t)
+      ((k v . rest)
+       (unless (and (keyword? k) (valid-kw? k))
+         (assertion-failed pkg field-name "keyword" k))
+       (apply validate-1 rest))
+      (_ (assertion-failed pkg field-name "keyword argument list" l))))
+  (apply validate-1 l))
+
+(define (validate-arguments pkg field-name arguments)
+  (validate-keyword-arguments pkg field-name arguments))
+
+(define (validate-synopsis pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The synopsis set by "guix potluck init".
+  (when (equal? str "Declarative synopsis here")
+    (assertion-failed pkg field-name "updated synopsis" str)))
+
+(define (validate-description pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The description set by "guix potluck init".
+  (when (string-suffix? "..." str)
+    (assertion-failed pkg field-name "updated description" str)))
+
+(define (validate-license pkg field-name sym)
+  (unless (license-by-name sym)
+    (assertion-failed pkg field-name "license name as symbol" sym)))
+
+(define (validate-potluck-package pkg)
+  (validate-non-empty-string pkg 'name (potluck-package-name pkg))
+  (validate-non-empty-string pkg 'version (potluck-package-version pkg))
+  (validate-potluck-source pkg 'source (potluck-package-source pkg))
+  (validate-build-system pkg 'build-system (potluck-package-build-system=
 pkg))
+  (validate-package-list pkg 'inputs (potluck-package-inputs pkg))
+  (validate-package-list pkg 'native-inputs
+                         (potluck-package-native-inputs pkg))
+  (validate-package-list pkg 'propagated-inputs
+                         (potluck-package-propagated-inputs pkg))
+  (validate-arguments pkg 'arguments (potluck-package-arguments pkg))
+  (validate-public-uri pkg 'home-page (potluck-package-home-page pkg))
+  (validate-synopsis pkg 'synopsis (potluck-package-synopsis pkg))
+  (validate-description pkg 'description (potluck-package-description pk=
g))
+  (validate-license pkg 'license (potluck-package-license pkg)))
+
+(define (lower-potluck-source o)
+  (let ((uri (potluck-source-git-uri o))
+        (commit (potluck-source-git-commit o))
+        (sha256 (potluck-source-sha256 o))
+        (snippet (potluck-source-snippet o)))
+    (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url uri)
+            (commit commit)))
+      (snippet snippet)
+      (sha256 (base32 sha256)))))
+
+(define (lower-input input)
+  (call-with-values (lambda () (specification->package+output input))
+    (lambda (pkg output)
+      (cons* (package-name pkg) pkg
+             (if (equal? output "out")
+                 '()
+                 (list output))))))
+
+(define (lower-inputs inputs)
+  (map lower-input inputs))
+
+(define (lower-potluck-package pkg)
+  (validate-potluck-package pkg)
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (package
+      (name name)
+      (version version)
+      (source (lower-potluck-source source))
+      (build-system (build-system-by-name build-system))
+      (inputs (lower-inputs inputs))
+      (native-inputs (lower-inputs native-inputs))
+      (propagated-inputs (lower-inputs propagated-inputs))
+      (arguments arguments)
+      (home-page home-page)
+      (synopsis synopsis)
+      (description description)
+      (license (license-by-name license)))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 6bb1f72eb..be26f63c9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix potluck packages)
   #:use-module (guix grafts)
=20
   ;; Use the procedure that destructures "NAME-VERSION" forms.
@@ -582,11 +583,20 @@ must be one of 'package', 'all', or 'transitive'~%"=
)
          (append %transformation-options
                  %standard-build-options)))
=20
+(define (load-package-or-derivation-from-file file)
+  (let ((mod (make-user-module '())))
+    ;; Expose potluck-package and potluck-source to the file.
+    (module-use! mod (resolve-interface
+                      '(guix potluck packages)
+                      #:select '(potluck-package potluck-source)))
+    (load* file mod)))
+
 (define (options->things-to-build opts)
   "Read the arguments from OPTS and return a list of high-level objects =
to
 build---packages, gexps, derivations, and so on."
   (define (validate-type x)
-    (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+    (unless (or (package? x) (potluck-package? x)
+                (derivation? x) (gexp? x) (procedure? x))
       (leave (_ "~s: not something we can build~%") x)))
=20
   (define (ensure-list x)
@@ -606,7 +616,7 @@ build---packages, gexps, derivations, and so on."
                        (else
                         (list (specification->package spec)))))
                 (('file . file)
-                 (ensure-list (load* file (make-user-module '()))))
+                 (ensure-list (load-package-or-derivation-from-file file=
)))
                 (('expression . str)
                  (ensure-list (read/eval str)))
                 (('argument . (? derivation? drv))
@@ -630,27 +640,31 @@ build."
   (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
=20
+  (define (package->derivation-list p)
+    (let ((p (or (and graft? (package-replacement p)) p)))
+      (match src
+        (#f
+         (list (package->derivation store p system)))
+        (#t
+         (match (package-source p)
+           (#f
+            (format (current-error-port)
+                    (_ "~a: warning: package '~a' has no source~%")
+                    (location->string (package-location p))
+                    (package-name p))
+            '())
+           (s
+            (list (package-source-derivation store s)))))
+        (proc
+         (map (cut package-source-derivation store <>)
+              (proc p))))))
+
   (parameterize ((%graft? graft?))
     (append-map (match-lambda
                   ((? package? p)
-                   (let ((p (or (and graft? (package-replacement p)) p))=
)
-                     (match src
-                       (#f
-                        (list (package->derivation store p system)))
-                       (#t
-                        (match (package-source p)
-                          (#f
-                           (format (current-error-port)
-                                   (_ "~a: warning: \
-package '~a' has no source~%")
-                                   (location->string (package-location p=
))
-                                   (package-name p))
-                           '())
-                          (s
-                           (list (package-source-derivation store s)))))
-                       (proc
-                        (map (cut package-source-derivation store <>)
-                             (proc p))))))
+                   (package->derivation-list p))
+                  ((? potluck-package? p)
+                   (package->derivation-list (lower-potluck-package p)))
                   ((? derivation? drv)
                    (list drv))
                   ((? procedure? proc)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:15 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:14 2017
Received: from localhost ([127.0.0.1]:38495 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6d-0004bs-CP
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:14 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:54696
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5L-0004OU-Bu
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:08 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 2979D74D29
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:mime-version:content-type
 :content-transfer-encoding; s=sasl; bh=/U7YvCWRRtgTKxEHLu0Z1p51m
 q8=; b=ZJLLE08bbd2ZgXgLzNshldrM7FvCboEfoC/MF00t2JlZjsUEK3c6lXXOK
 aofa0nahKRpjAztIMsHViUZKj1V7K+ms1vX1//3pzaK9yVnM1jch70hgkc5vXpsg
 vZw0QF4ob1bVGZSwbFsJOYqrAL41e0nAh5mtCDXZKxuiNyZFxc=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 206D474D28
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:48 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 3E95874D1B
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:44 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 1/9] guix: Add "potluck" packages.
Date: Mon, 24 Apr 2017 22:59:15 +0200
Message-Id: <20170424205923.27726-1-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F172CCD2-2930-11E7-BD9D-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/build-systems.scm:
* guix/potluck/licenses.scm:
* guix/potluck/packages.scm: New files.
* guix/scripts/build.scm (load-package-or-derivation-from-file):
(options->things-to-build, options->derivations): Add "potluck-package" a=
nd
"potluck-source" to environment of file.  Lower potluck packages to Guix
packages.
---
 Makefile.am                    |   3 +
 guix/potluck/build-systems.scm |  55 ++++++
 guix/potluck/licenses.scm      |  41 +++++
 guix/potluck/packages.scm      | 399 +++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/build.scm         |  54 +++---
 5 files changed, 532 insertions(+), 20 deletions(-)
 create mode 100644 guix/potluck/build-systems.scm
 create mode 100644 guix/potluck/licenses.scm
 create mode 100644 guix/potluck/packages.scm

diff --git a/Makefile.am b/Makefile.am
index db4ebe04d..22ba00e90 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,9 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/potluck/build-systems.scm		\
+  guix/potluck/licenses.scm			\
+  guix/potluck/packages.scm			\
   guix/import/utils.scm				\
   guix/import/gnu.scm				\
   guix/import/snix.scm				\
diff --git a/guix/potluck/build-systems.scm b/guix/potluck/build-systems.=
scm
new file mode 100644
index 000000000..1f6aa1fe3
--- /dev/null
+++ b/guix/potluck/build-systems.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck build-systems)
+  #:use-module ((guix build-system) #:select (build-system?))
+  #:use-module ((gnu packages) #:select (scheme-modules))
+  #:use-module (ice-9 match)
+  #:export (build-system-by-name all-potluck-build-system-names))
+
+(define all-build-systems
+  (delay
+    (let* ((gbs (or (search-path %load-path "guix/build-system.scm")
+                    (error "can't find (guix build-system)")))
+           (root (dirname (dirname gbs)))
+           (by-name (make-hash-table)))
+      (for-each (lambda (iface)
+                  (module-for-each
+                   (lambda (k var)
+                     (let* ((str (symbol->string k))
+                            (pos (string-contains str "-build-system"))
+                            (val (variable-ref var)))
+                       (when (and pos (build-system? val))
+                         (let* ((head (substring str 0 pos))
+                                (tail (substring str
+                                                 (+ pos (string-length
+                                                         "-build-system"=
))))
+                                (name (string->symbol
+                                       (string-append head tail))))
+                           (hashq-set! by-name name val)))))
+                   iface))
+                (scheme-modules root "guix/build-system"))
+      by-name)))
+
+(define (all-potluck-build-system-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-build-systems))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (build-system-by-name name)
+  (hashq-ref (force all-build-systems) name))
diff --git a/guix/potluck/licenses.scm b/guix/potluck/licenses.scm
new file mode 100644
index 000000000..6efeee21a
--- /dev/null
+++ b/guix/potluck/licenses.scm
@@ -0,0 +1,41 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck licenses)
+  #:use-module ((guix licenses) #:select (license?))
+  #:use-module (ice-9 match)
+  #:export (license-by-name all-potluck-license-names))
+
+(define all-licenses
+  (delay
+    (let ((iface (resolve-interface '(guix licenses)))
+          (by-name (make-hash-table)))
+      (module-for-each (lambda (k var)
+                         (let ((val (variable-ref var)))
+                           (when (license? val)
+                             (hashq-set! by-name k val))))
+                       (resolve-interface '(guix licenses)))
+      by-name)))
+
+(define (all-potluck-license-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-licenses))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (license-by-name name)
+  (hashq-ref (force all-licenses) name))
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
new file mode 100644
index 000000000..c7dae3791
--- /dev/null
+++ b/guix/potluck/packages.scm
@@ -0,0 +1,399 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Court=C3=
=A8s <ludo@HIDDEN>
+;;; Copyright =C2=A9 2014, 2015 Mark H Weaver <mhw@HIDDEN>
+;;; Copyright =C2=A9 2015 Eric Bavier <bavier@HIDDEN>
+;;; Copyright =C2=A9 2016 Alex Kost <alezost@HIDDEN>
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck packages)
+  #:use-module (gnu packages)
+  #:use-module (guix base32)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (web uri)
+  #:export (potluck-source
+            potluck-source?
+            potluck-source-git-uri
+            potluck-source-git-commit
+            potluck-source-sha256
+            potluck-source-snippet
+
+            potluck-package
+            potluck-package?
+            potluck-package-name
+            potluck-package-version
+            potluck-package-source
+            potluck-package-build-system
+            potluck-package-arguments
+            potluck-package-inputs
+            potluck-package-native-inputs
+            potluck-package-propagated-inputs
+            potluck-package-synopsis
+            potluck-package-description
+            potluck-package-license
+            potluck-package-home-page
+            potluck-package-location
+            potluck-package-field-location
+
+            pretty-print-potluck-source
+            pretty-print-potluck-package
+
+            validate-potluck-package
+
+            lower-potluck-source
+            lower-potluck-package))
+
+;;; Commentary:
+;;;
+;;; This module provides a facility to define "potluck packages" in a
+;;; Guix-based distribution, and a facility to translate those packages =
to
+;;; "normal" Guix packages.
+;;;
+;;; Code:
+
+(define-record-type* <potluck-source>
+  potluck-source make-potluck-source
+  potluck-source?
+  (git-uri    potluck-source-git-uri)               ; uri string
+  (git-commit potluck-source-git-commit)            ; git sha1 string
+  (sha256     potluck-source-sha256)                ; base32 string
+  (snippet    potluck-source-snippet (default #f))) ; sexp or #f
+
+(define-record-type* <potluck-package>
+  potluck-package make-potluck-package
+  potluck-package?
+  (name               potluck-package-name)         ; string
+  (version            potluck-package-version)      ; string
+  (source             potluck-package-source)       ; <potluck-source>
+                                                    ; instance
+  (build-system       potluck-package-build-system) ; build system name =
as
+                                                    ; symbol
+  (arguments          potluck-package-arguments     ; arguments for the =
build
+                                                    ; method
+                      (default '()))
+  (inputs             potluck-package-inputs        ; input packages or
+                                                    ; derivations
+                      (default '()))
+  (propagated-inputs  potluck-package-propagated-inputs ; same, but prop=
agated
+                      (default '()))
+  (native-inputs      potluck-package-native-inputs ; native input packa=
ges or
+                                                    ; derivations
+                      (default '()))
+  (synopsis           potluck-package-synopsis)     ; one-line descripti=
on
+  (description        potluck-package-description)  ; one or two paragra=
phs
+  (license            potluck-package-license)
+  (home-page          potluck-package-home-page)
+  (location           potluck-package-location
+                      (default (and=3D> (current-source-location)
+                                      source-properties->location))
+                      (innate)))
+
+;; Printers.
+
+(define (print-potluck-source potluck-source port)
+  "Write a concise representation of POTLUCK-SOURCE to PORT."
+  (match potluck-source
+    (($ <potluck-source> git-uri git-commit sha256 snippet)
+     (simple-format port "#<potluck-source ~a@~a ~a ~a>"
+                    git-uri git-commit sha256
+                    (number->string (object-address potluck-source) 16))=
)))
+
+(define (print-potluck-package package port)
+  (let ((loc    (potluck-package-location package))
+        (format simple-format))
+    (format port "#<potluck-package ~a@~a ~a~a>"
+            (potluck-package-name package)
+            (potluck-package-version package)
+            (if loc
+                (format #f "~a:~a "
+                        (location-file loc)
+                        (location-line loc))
+                "")
+            (number->string (object-address
+                             package)
+                            16))))
+
+(set-record-type-printer! <potluck-source> print-potluck-source)
+(set-record-type-printer! <potluck-package> print-potluck-package)
+
+;; Pretty-printers.
+
+(define* (pretty-print-potluck-source port source #:key (prefix "")
+                                      (suffix "\n"))
+  (let ((uri (potluck-source-git-uri source))
+        (commit (potluck-source-git-commit source))
+        (sha256 (potluck-source-sha256 source))
+        (snippet (potluck-source-snippet source)))
+    (format port "~a(potluck-source" prefix)
+    (format port "\n~a  (git-uri ~s)" prefix uri)
+    (format port "\n~a  (git-commit ~s)" prefix commit)
+    (format port "\n~a  (sha256 ~s)" prefix sha256)
+    (when snippet
+      (format port "\n~a  (snippet '~s)" prefix snippet))
+    (format port ")~a" suffix)))
+
+(define* (pretty-print-potluck-package port pkg #:key (prefix ""))
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (format port "~a(potluck-package\n" prefix)
+    (format port "~a  (name ~s)\n" prefix name)
+    (format port "~a  (version ~s)\n" prefix version)
+    (format port "~a  (source\n" prefix)
+    (pretty-print-potluck-source port source #:prefix
+                                 (string-append prefix "    ")
+                                 #:suffix ")\n")
+    (format port "~a  (build-system '~s)\n" prefix build-system)
+    (format port "~a  (inputs '~s)\n" prefix inputs)
+    (format port "~a  (native-inputs '~s)\n" prefix native-inputs)
+    (format port "~a  (propagated-inputs '~s)\n" prefix propagated-input=
s)
+    (match arguments
+      (()
+       (format port "~a  (arguments '())\n" prefix))
+      (arguments
+       (pretty-print `(arguments ',arguments) port
+                     #:per-line-prefix (format #f "~a  " prefix))))
+    (format port "~a  (home-page ~s)\n" prefix home-page)
+    (format port "~a  (synopsis ~s)\n" prefix synopsis)
+    (format port "~a  (description ~s)\n" prefix description)
+    (format port "~a  (license '~s))\n" prefix license)))
+
+;; Editing.
+
+(define (potluck-package-field-location package field)
+  "Return the source code location of the definition of FIELD for PACKAG=
E, or
+#f if it could not be determined."
+  (define (goto port line column)
+    (unless (and (=3D (port-column port) (- column 1))
+                 (=3D (port-line port) (- line 1)))
+      (unless (eof-object? (read-char port))
+        (goto port line column))))
+
+  (match (potluck-package-location package)
+    (($ <location> file line column)
+     (catch 'system
+       (lambda ()
+         ;; In general we want to keep relative file names for modules.
+         (with-fluids ((%file-port-name-canonicalization 'relative))
+           (call-with-input-file (search-path %load-path file)
+             (lambda (port)
+               (goto port line column)
+               (match (read port)
+                 (('potluck-package inits ...)
+                  (let ((field (assoc field inits)))
+                    (match field
+                      ((_ value)
+                       ;; Put the `or' here, and not in the first argume=
nt of
+                       ;; `and=3D>', to work around a compiler bug in 2.=
0.5.
+                       (or (and=3D> (source-properties value)
+                                  source-properties->location)
+                           (and=3D> (source-properties field)
+                                  source-properties->location)))
+                      (_
+                       #f))))
+                 (_
+                  #f))))))
+       (lambda _
+         #f)))
+    (_ #f)))
+
+;; Lower potluck packages to Guix packages.
+
+(define-condition-type &potluck-package-error &error
+  potluck-package-error?
+  (potluck-package potluck-package-error-potluck-package))
+
+(define-condition-type &potluck-package-validation-error &potluck-packag=
e-error
+  potluck-package-validation-error?
+  (field-name potluck-package-validation-error-field-name)
+  (assertion potluck-package-validation-error-assertion)
+  (value potluck-package-validation-error-value))
+
+(define (assertion-failed pkg field-name assertion value)
+  (raise (condition (&potluck-package-validation-error
+                     (potluck-package pkg)
+                     (field-name field-name)
+                     (assertion assertion)
+                     (value value)))))
+
+(define* (validate-public-uri pkg field-name str #:key (schemes '(http h=
ttps)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (assertion-failed pkg field-name "public URI" str))))
+
+(define (validate-git-commit pkg field-name commit)
+  (unless (and (string? commit)
+               (=3D (string-length commit) 40)
+               (string-every (string->char-set "abcdef0123456789") commi=
t))
+    (assertion-failed pkg field-name "full git commit SHA1 hash" commit)=
))
+
+(define (validate-base32-sha256 pkg field-name str)
+  (unless (and (string? str)
+               (=3D (string-length str) 52)
+               (false-if-exception (nix-base32-string->bytevector str)))
+    (assertion-failed pkg field-name "sha256 hash as a base32 string" st=
r)))
+
+(define (validate-potluck-source pkg field-name source)
+  (validate-public-uri pkg field-name (potluck-source-git-uri source)
+                       #:schemes '(git http https))
+  (validate-git-commit pkg field-name (potluck-source-git-commit source)=
)
+  (validate-base32-sha256 pkg field-name (potluck-source-sha256 source))
+  (validate-snippet pkg field-name (potluck-source-snippet source)))
+
+(define (validate-snippet pkg field-name snippet)
+  (match snippet
+    (#f #t)
+    ((_ ...) #t)
+    (_ (assertion-failed pkg field-name "valid snippet" snippet))))
+
+(define (validate-non-empty-string pkg field-name str)
+  (unless (and (string? str)
+               (not (string-null? str)))
+    (assertion-failed pkg field-name "non-empty string" str)))
+
+(define (validate-build-system pkg field-name sym)
+  (unless (build-system-by-name sym)
+    (assertion-failed pkg field-name "build system name as symbol" sym))=
)
+
+(define (validate-package-list pkg field-name l)
+  (unless (and (list? l) (and-map string? l))
+    (assertion-failed pkg field-name
+                      "list of package or package@version strings" l)))
+
+(define* (validate-keyword-arguments pkg field-name l #:optional (valid-=
kw? (const #t)))
+  (define validate-1
+    (case-lambda
+      (() #t)
+      ((k v . rest)
+       (unless (and (keyword? k) (valid-kw? k))
+         (assertion-failed pkg field-name "keyword" k))
+       (apply validate-1 rest))
+      (_ (assertion-failed pkg field-name "keyword argument list" l))))
+  (apply validate-1 l))
+
+(define (validate-arguments pkg field-name arguments)
+  (validate-keyword-arguments pkg field-name arguments))
+
+(define (validate-synopsis pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The synopsis set by "guix potluck init".
+  (when (equal? str "Declarative synopsis here")
+    (assertion-failed pkg field-name "updated synopsis" str)))
+
+(define (validate-description pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The description set by "guix potluck init".
+  (when (string-suffix? "..." str)
+    (assertion-failed pkg field-name "updated description" str)))
+
+(define (validate-license pkg field-name sym)
+  (unless (license-by-name sym)
+    (assertion-failed pkg field-name "license name as symbol" sym)))
+
+(define (validate-potluck-package pkg)
+  (validate-non-empty-string pkg 'name (potluck-package-name pkg))
+  (validate-non-empty-string pkg 'version (potluck-package-version pkg))
+  (validate-potluck-source pkg 'source (potluck-package-source pkg))
+  (validate-build-system pkg 'build-system (potluck-package-build-system=
 pkg))
+  (validate-package-list pkg 'inputs (potluck-package-inputs pkg))
+  (validate-package-list pkg 'native-inputs
+                         (potluck-package-native-inputs pkg))
+  (validate-package-list pkg 'propagated-inputs
+                         (potluck-package-propagated-inputs pkg))
+  (validate-arguments pkg 'arguments (potluck-package-arguments pkg))
+  (validate-public-uri pkg 'home-page (potluck-package-home-page pkg))
+  (validate-synopsis pkg 'synopsis (potluck-package-synopsis pkg))
+  (validate-description pkg 'description (potluck-package-description pk=
g))
+  (validate-license pkg 'license (potluck-package-license pkg)))
+
+(define (lower-potluck-source o)
+  (let ((uri (potluck-source-git-uri o))
+        (commit (potluck-source-git-commit o))
+        (sha256 (potluck-source-sha256 o))
+        (snippet (potluck-source-snippet o)))
+    (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url uri)
+            (commit commit)))
+      (snippet snippet)
+      (sha256 (base32 sha256)))))
+
+(define (lower-input input)
+  (call-with-values (lambda () (specification->package+output input))
+    (lambda (pkg output)
+      (cons* (package-name pkg) pkg
+             (if (equal? output "out")
+                 '()
+                 (list output))))))
+
+(define (lower-inputs inputs)
+  (map lower-input inputs))
+
+(define (lower-potluck-package pkg)
+  (validate-potluck-package pkg)
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (package
+      (name name)
+      (version version)
+      (source (lower-potluck-source source))
+      (build-system (build-system-by-name build-system))
+      (inputs (lower-inputs inputs))
+      (native-inputs (lower-inputs native-inputs))
+      (propagated-inputs (lower-inputs propagated-inputs))
+      (arguments arguments)
+      (home-page home-page)
+      (synopsis synopsis)
+      (description description)
+      (license (license-by-name license)))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 6bb1f72eb..be26f63c9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix potluck packages)
   #:use-module (guix grafts)
=20
   ;; Use the procedure that destructures "NAME-VERSION" forms.
@@ -582,11 +583,20 @@ must be one of 'package', 'all', or 'transitive'~%"=
)
          (append %transformation-options
                  %standard-build-options)))
=20
+(define (load-package-or-derivation-from-file file)
+  (let ((mod (make-user-module '())))
+    ;; Expose potluck-package and potluck-source to the file.
+    (module-use! mod (resolve-interface
+                      '(guix potluck packages)
+                      #:select '(potluck-package potluck-source)))
+    (load* file mod)))
+
 (define (options->things-to-build opts)
   "Read the arguments from OPTS and return a list of high-level objects =
to
 build---packages, gexps, derivations, and so on."
   (define (validate-type x)
-    (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+    (unless (or (package? x) (potluck-package? x)
+                (derivation? x) (gexp? x) (procedure? x))
       (leave (_ "~s: not something we can build~%") x)))
=20
   (define (ensure-list x)
@@ -606,7 +616,7 @@ build---packages, gexps, derivations, and so on."
                        (else
                         (list (specification->package spec)))))
                 (('file . file)
-                 (ensure-list (load* file (make-user-module '()))))
+                 (ensure-list (load-package-or-derivation-from-file file=
)))
                 (('expression . str)
                  (ensure-list (read/eval str)))
                 (('argument . (? derivation? drv))
@@ -630,27 +640,31 @@ build."
   (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
=20
+  (define (package->derivation-list p)
+    (let ((p (or (and graft? (package-replacement p)) p)))
+      (match src
+        (#f
+         (list (package->derivation store p system)))
+        (#t
+         (match (package-source p)
+           (#f
+            (format (current-error-port)
+                    (_ "~a: warning: package '~a' has no source~%")
+                    (location->string (package-location p))
+                    (package-name p))
+            '())
+           (s
+            (list (package-source-derivation store s)))))
+        (proc
+         (map (cut package-source-derivation store <>)
+              (proc p))))))
+
   (parameterize ((%graft? graft?))
     (append-map (match-lambda
                   ((? package? p)
-                   (let ((p (or (and graft? (package-replacement p)) p))=
)
-                     (match src
-                       (#f
-                        (list (package->derivation store p system)))
-                       (#t
-                        (match (package-source p)
-                          (#f
-                           (format (current-error-port)
-                                   (_ "~a: warning: \
-package '~a' has no source~%")
-                                   (location->string (package-location p=
))
-                                   (package-name p))
-                           '())
-                          (s
-                           (list (package-source-derivation store s)))))
-                       (proc
-                        (map (cut package-source-derivation store <>)
-                             (proc p))))))
+                   (package->derivation-list p))
+                  ((? potluck-package? p)
+                   (package->derivation-list (lower-potluck-package p)))
                   ((? derivation? drv)
                    (list drv))
                   ((? procedure? proc)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:11 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:11 2017
Received: from localhost ([127.0.0.1]:38492 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6d-0004bf-0K
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:11 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:58648
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5N-0004Pd-Fn
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:08 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 2956B74D42
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:51 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=TXXD
 1VVFOjWyygecr2OlqzBbiII=; b=NSU4qvaepukUgdolXz/HCWcXC+rbqh4+osQO
 4tp8jRtZ9wgi0VAaMdEfrAbpm3fFErwvGmQjrrgzPPyP6rUu7yTM6qBZRO8G33gG
 4S8uYcUSXjrFQuJ7IsaiN8seNrYlgFklUAYm0q++qAA05zu7pRZBX15+u8vYpXsl
 ucMCWzs=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 22C8974D41
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:51 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id EAD0574D37
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:49 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 7/9] potluck: Add ability to lower potluck package to guix
 package.
Date: Mon, 24 Apr 2017 22:59:21 +0200
Message-Id: <20170424205923.27726-7-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: F4DACF28-2930-11E7-94E7-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/packages.scm (lower-potluck-package-to-module): New public
function.
---
 guix/potluck/packages.scm | 118 +++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 117 insertions(+), 1 deletion(-)

diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
index 3bf2d67c1..3c7a1ca49 100644
--- a/guix/potluck/packages.scm
+++ b/guix/potluck/packages.scm
@@ -29,8 +29,10 @@
   #:use-module (guix potluck licenses)
   #:use-module (guix records)
   #:use-module (guix utils)
+  #:use-module ((guix ui) #:select (package-specification->name+version+output))
   #:use-module (ice-9 match)
   #:use-module (ice-9 pretty-print)
+  #:use-module ((srfi srfi-1) #:select (concatenate delete-duplicates))
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -67,7 +69,9 @@
             validate-potluck-package
 
             lower-potluck-source
-            lower-potluck-package))
+            lower-potluck-package
+
+            lower-potluck-package-to-module))
 
 ;;; Commentary:
 ;;;
@@ -456,3 +460,115 @@ potluck package will be validated with @code{validate-potluck-package}."
       (synopsis synopsis)
       (description description)
       (license (license-by-name license)))))
+
+(define (lower-potluck-package-to-module port lowered-module-name pkg)
+  (let ((lowered (lower-potluck-package pkg))
+        ;; specification -> exp
+        (spec->binding (make-hash-table))
+        ;; mod-name -> (sym ...)
+        (imports (make-hash-table))
+        ;; sym -> specification
+        (imported-syms (make-hash-table))
+        (needs-runtime-lookup? #f))
+    (define (add-bindings spec)
+      (unless (hash-ref spec->binding spec)
+        (match (false-if-exception (lower-input spec))
+          ((name pkg . outputs)
+           ;; Given that we found the pkg, surely we should find its binding
+           ;; also.
+           (call-with-values (lambda () (find-package-binding pkg))
+             (lambda (module-name sym)
+               ;; Currently we import these bindings using their original
+               ;; names.  We need to make sure that names don't collide.
+               ;; Ideally we should also ensure that they don't collide with
+               ;; other bindings that we import.
+               (when (hashq-ref imported-syms sym)
+                 (error "duplicate import name" sym))
+               (hashq-set! imported-syms sym spec)
+               (hash-set! spec->binding spec
+                          `(list ,name ,sym . ,outputs))
+               (hash-set! imports module-name
+                          (cons sym (hash-ref imports module-name '()))))))
+          (#f
+           (warn "could not resolve package specification" spec)
+           (call-with-values
+               (lambda ()
+                 (package-specification->name+version+output spec))
+             (lambda (name version . outputs)
+               (hash-set! spec->binding spec
+                          `(list ,name (specification->package ,spec) .
+                                 ,(if (equal? outputs '("out")) '() outputs)))
+               (set! needs-runtime-lookup? #t)))))))
+
+    (for-each add-bindings (potluck-package-inputs pkg))
+    (for-each add-bindings (potluck-package-native-inputs pkg))
+    (for-each add-bindings (potluck-package-propagated-inputs pkg))
+
+    (format port "(define-module ~a" lowered-module-name)
+    (format port "~%  #:pure")
+    ;; Because we're pure, we have to import these.
+    (format port "~%  #:use-module ((guile) #:select (list quote define-public))")
+    (when needs-runtime-lookup?
+      (format port "~%  #:use-module ((gnu packages) #:select (specification->package))"))
+    (format port "~%  #:use-module ((guix packages) #:select (package origin base32))")
+    (format port "~%  #:use-module ((guix git-download) #:select (git-fetch git-reference))")
+    (format port "~%  #:use-module ((guix licenses) #:select ((~a . license:~a)))"
+            (potluck-package-license pkg) (potluck-package-license pkg))
+    (format port "~%  #:use-module ((guix build-system ~a) #:select (~a-build-system))"
+            (potluck-package-build-system pkg) (potluck-package-build-system pkg))
+    (for-each (match-lambda
+                ((module-name . syms)
+                 (format port "~%  #:use-module (~a #:select ~a)"
+                         module-name syms)))
+              (hash-map->list cons imports))
+    (format port ")~%~%")
+
+    (format port "(define-public ~s\n" (string->symbol
+                                        (potluck-package-name pkg)))
+    (format port "  (package\n")
+    (format port "    (name ~s)\n" (potluck-package-name pkg))
+    (format port "    (version ~s)\n" (potluck-package-version pkg))
+    (format port "    (source\n")
+
+    (let ((source (potluck-package-source pkg)))
+      (format port "      (origin\n")
+      (format port "        (method git-fetch)\n")
+      (format port "        (uri (git-reference\n")
+      (format port "              (url ~s)\n" (potluck-source-git-uri source))
+      (format port "              (commit ~s)))\n"
+              (potluck-source-git-commit source))
+      (when (potluck-source-snippet source)
+        (pretty-print `(snippet ',(potluck-source-snippet source)) port
+                      #:per-line-prefix "        "))
+      (format port "        (sha256 (base32 ~s))))\n"
+              (potluck-source-sha256 source)))
+
+    (format port "    (build-system ~s-build-system)\n"
+            (potluck-package-build-system pkg))
+
+    (for-each
+     (match-lambda
+       ((name)
+        ;; No inputs; do nothing.
+        #t)
+       ((name . specs)
+        (pretty-print
+         `(,name (list ,@(map (lambda (spec)
+                                (or (hash-ref spec->binding spec)
+                                    (error "internal error" spec)))
+                              specs)))
+         port #:per-line-prefix "    ")))
+     `((inputs . ,(potluck-package-inputs pkg))
+       (native-inputs . ,(potluck-package-native-inputs pkg))
+       (propagated-inputs . ,(potluck-package-propagated-inputs pkg))))
+
+    (match (potluck-package-arguments pkg)
+      (() #t)
+      (arguments
+       (pretty-print `(arguments ',arguments) port #:per-line-prefix "    ")))
+
+    (format port "    (home-page ~s)\n" (potluck-package-home-page pkg))
+    (format port "    (synopsis ~s)\n" (potluck-package-synopsis pkg))
+    (format port "    (description ~s)\n" (potluck-package-description pkg))
+    (format port "    (license license:~s)))\n" (potluck-package-license pkg))
+    (force-output port)))
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:11 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:11 2017
Received: from localhost ([127.0.0.1]:38489 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6c-0004bT-Hx
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:10 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:63999
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5M-0004PY-PQ
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:05 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id ECC6574D40
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:50 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=TXXD
 1VVFOjWyygecr2OlqzBbiII=; b=NSU4qvaepukUgdolXz/HCWcXC+rbqh4+osQO
 4tp8jRtZ9wgi0VAaMdEfrAbpm3fFErwvGmQjrrgzPPyP6rUu7yTM6qBZRO8G33gG
 4S8uYcUSXjrFQuJ7IsaiN8seNrYlgFklUAYm0q++qAA05zu7pRZBX15+u8vYpXsl
 ucMCWzs=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id E677174D3F
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:50 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id AFBB374D36
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:49 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 7/9] potluck: Add ability to lower potluck package to guix
 package.
Date: Mon, 24 Apr 2017 22:59:21 +0200
Message-Id: <20170424205923.27726-7-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: F4B4078A-2930-11E7-85F5-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/packages.scm (lower-potluck-package-to-module): New public
function.
---
 guix/potluck/packages.scm | 118 +++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 117 insertions(+), 1 deletion(-)

diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
index 3bf2d67c1..3c7a1ca49 100644
--- a/guix/potluck/packages.scm
+++ b/guix/potluck/packages.scm
@@ -29,8 +29,10 @@
   #:use-module (guix potluck licenses)
   #:use-module (guix records)
   #:use-module (guix utils)
+  #:use-module ((guix ui) #:select (package-specification->name+version+output))
   #:use-module (ice-9 match)
   #:use-module (ice-9 pretty-print)
+  #:use-module ((srfi srfi-1) #:select (concatenate delete-duplicates))
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -67,7 +69,9 @@
             validate-potluck-package
 
             lower-potluck-source
-            lower-potluck-package))
+            lower-potluck-package
+
+            lower-potluck-package-to-module))
 
 ;;; Commentary:
 ;;;
@@ -456,3 +460,115 @@ potluck package will be validated with @code{validate-potluck-package}."
       (synopsis synopsis)
       (description description)
       (license (license-by-name license)))))
+
+(define (lower-potluck-package-to-module port lowered-module-name pkg)
+  (let ((lowered (lower-potluck-package pkg))
+        ;; specification -> exp
+        (spec->binding (make-hash-table))
+        ;; mod-name -> (sym ...)
+        (imports (make-hash-table))
+        ;; sym -> specification
+        (imported-syms (make-hash-table))
+        (needs-runtime-lookup? #f))
+    (define (add-bindings spec)
+      (unless (hash-ref spec->binding spec)
+        (match (false-if-exception (lower-input spec))
+          ((name pkg . outputs)
+           ;; Given that we found the pkg, surely we should find its binding
+           ;; also.
+           (call-with-values (lambda () (find-package-binding pkg))
+             (lambda (module-name sym)
+               ;; Currently we import these bindings using their original
+               ;; names.  We need to make sure that names don't collide.
+               ;; Ideally we should also ensure that they don't collide with
+               ;; other bindings that we import.
+               (when (hashq-ref imported-syms sym)
+                 (error "duplicate import name" sym))
+               (hashq-set! imported-syms sym spec)
+               (hash-set! spec->binding spec
+                          `(list ,name ,sym . ,outputs))
+               (hash-set! imports module-name
+                          (cons sym (hash-ref imports module-name '()))))))
+          (#f
+           (warn "could not resolve package specification" spec)
+           (call-with-values
+               (lambda ()
+                 (package-specification->name+version+output spec))
+             (lambda (name version . outputs)
+               (hash-set! spec->binding spec
+                          `(list ,name (specification->package ,spec) .
+                                 ,(if (equal? outputs '("out")) '() outputs)))
+               (set! needs-runtime-lookup? #t)))))))
+
+    (for-each add-bindings (potluck-package-inputs pkg))
+    (for-each add-bindings (potluck-package-native-inputs pkg))
+    (for-each add-bindings (potluck-package-propagated-inputs pkg))
+
+    (format port "(define-module ~a" lowered-module-name)
+    (format port "~%  #:pure")
+    ;; Because we're pure, we have to import these.
+    (format port "~%  #:use-module ((guile) #:select (list quote define-public))")
+    (when needs-runtime-lookup?
+      (format port "~%  #:use-module ((gnu packages) #:select (specification->package))"))
+    (format port "~%  #:use-module ((guix packages) #:select (package origin base32))")
+    (format port "~%  #:use-module ((guix git-download) #:select (git-fetch git-reference))")
+    (format port "~%  #:use-module ((guix licenses) #:select ((~a . license:~a)))"
+            (potluck-package-license pkg) (potluck-package-license pkg))
+    (format port "~%  #:use-module ((guix build-system ~a) #:select (~a-build-system))"
+            (potluck-package-build-system pkg) (potluck-package-build-system pkg))
+    (for-each (match-lambda
+                ((module-name . syms)
+                 (format port "~%  #:use-module (~a #:select ~a)"
+                         module-name syms)))
+              (hash-map->list cons imports))
+    (format port ")~%~%")
+
+    (format port "(define-public ~s\n" (string->symbol
+                                        (potluck-package-name pkg)))
+    (format port "  (package\n")
+    (format port "    (name ~s)\n" (potluck-package-name pkg))
+    (format port "    (version ~s)\n" (potluck-package-version pkg))
+    (format port "    (source\n")
+
+    (let ((source (potluck-package-source pkg)))
+      (format port "      (origin\n")
+      (format port "        (method git-fetch)\n")
+      (format port "        (uri (git-reference\n")
+      (format port "              (url ~s)\n" (potluck-source-git-uri source))
+      (format port "              (commit ~s)))\n"
+              (potluck-source-git-commit source))
+      (when (potluck-source-snippet source)
+        (pretty-print `(snippet ',(potluck-source-snippet source)) port
+                      #:per-line-prefix "        "))
+      (format port "        (sha256 (base32 ~s))))\n"
+              (potluck-source-sha256 source)))
+
+    (format port "    (build-system ~s-build-system)\n"
+            (potluck-package-build-system pkg))
+
+    (for-each
+     (match-lambda
+       ((name)
+        ;; No inputs; do nothing.
+        #t)
+       ((name . specs)
+        (pretty-print
+         `(,name (list ,@(map (lambda (spec)
+                                (or (hash-ref spec->binding spec)
+                                    (error "internal error" spec)))
+                              specs)))
+         port #:per-line-prefix "    ")))
+     `((inputs . ,(potluck-package-inputs pkg))
+       (native-inputs . ,(potluck-package-native-inputs pkg))
+       (propagated-inputs . ,(potluck-package-propagated-inputs pkg))))
+
+    (match (potluck-package-arguments pkg)
+      (() #t)
+      (arguments
+       (pretty-print `(arguments ',arguments) port #:per-line-prefix "    ")))
+
+    (format port "    (home-page ~s)\n" (potluck-package-home-page pkg))
+    (format port "    (synopsis ~s)\n" (potluck-package-synopsis pkg))
+    (format port "    (description ~s)\n" (potluck-package-description pkg))
+    (format port "    (license license:~s)))\n" (potluck-package-license pkg))
+    (force-output port)))
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:10 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:10 2017
Received: from localhost ([127.0.0.1]:38480 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6X-0004aS-VB
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:10 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:62387
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5J-0004Q7-CP
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:00 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 8F45C74D1E
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:45 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:mime-version:content-type
 :content-transfer-encoding; s=sasl; bh=/U7YvCWRRtgTKxEHLu0Z1p51m
 q8=; b=ZJLLE08bbd2ZgXgLzNshldrM7FvCboEfoC/MF00t2JlZjsUEK3c6lXXOK
 aofa0nahKRpjAztIMsHViUZKj1V7K+ms1vX1//3pzaK9yVnM1jch70hgkc5vXpsg
 vZw0QF4ob1bVGZSwbFsJOYqrAL41e0nAh5mtCDXZKxuiNyZFxc=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 8892B74D1D
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:45 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 33E1074D10
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:43 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 1/9] guix: Add "potluck" packages.
Date: Mon, 24 Apr 2017 22:59:15 +0200
Message-Id: <20170424205923.27726-1-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F0CF6BD2-2930-11E7-AE62-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/build-systems.scm:
* guix/potluck/licenses.scm:
* guix/potluck/packages.scm: New files.
* guix/scripts/build.scm (load-package-or-derivation-from-file):
(options->things-to-build, options->derivations): Add "potluck-package" a=
nd
"potluck-source" to environment of file.  Lower potluck packages to Guix
packages.
---
 Makefile.am                    |   3 +
 guix/potluck/build-systems.scm |  55 ++++++
 guix/potluck/licenses.scm      |  41 +++++
 guix/potluck/packages.scm      | 399 +++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/build.scm         |  54 +++---
 5 files changed, 532 insertions(+), 20 deletions(-)
 create mode 100644 guix/potluck/build-systems.scm
 create mode 100644 guix/potluck/licenses.scm
 create mode 100644 guix/potluck/packages.scm

diff --git a/Makefile.am b/Makefile.am
index db4ebe04d..22ba00e90 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,9 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/potluck/build-systems.scm		\
+  guix/potluck/licenses.scm			\
+  guix/potluck/packages.scm			\
   guix/import/utils.scm				\
   guix/import/gnu.scm				\
   guix/import/snix.scm				\
diff --git a/guix/potluck/build-systems.scm b/guix/potluck/build-systems.=
scm
new file mode 100644
index 000000000..1f6aa1fe3
--- /dev/null
+++ b/guix/potluck/build-systems.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck build-systems)
+  #:use-module ((guix build-system) #:select (build-system?))
+  #:use-module ((gnu packages) #:select (scheme-modules))
+  #:use-module (ice-9 match)
+  #:export (build-system-by-name all-potluck-build-system-names))
+
+(define all-build-systems
+  (delay
+    (let* ((gbs (or (search-path %load-path "guix/build-system.scm")
+                    (error "can't find (guix build-system)")))
+           (root (dirname (dirname gbs)))
+           (by-name (make-hash-table)))
+      (for-each (lambda (iface)
+                  (module-for-each
+                   (lambda (k var)
+                     (let* ((str (symbol->string k))
+                            (pos (string-contains str "-build-system"))
+                            (val (variable-ref var)))
+                       (when (and pos (build-system? val))
+                         (let* ((head (substring str 0 pos))
+                                (tail (substring str
+                                                 (+ pos (string-length
+                                                         "-build-system"=
))))
+                                (name (string->symbol
+                                       (string-append head tail))))
+                           (hashq-set! by-name name val)))))
+                   iface))
+                (scheme-modules root "guix/build-system"))
+      by-name)))
+
+(define (all-potluck-build-system-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-build-systems))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (build-system-by-name name)
+  (hashq-ref (force all-build-systems) name))
diff --git a/guix/potluck/licenses.scm b/guix/potluck/licenses.scm
new file mode 100644
index 000000000..6efeee21a
--- /dev/null
+++ b/guix/potluck/licenses.scm
@@ -0,0 +1,41 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck licenses)
+  #:use-module ((guix licenses) #:select (license?))
+  #:use-module (ice-9 match)
+  #:export (license-by-name all-potluck-license-names))
+
+(define all-licenses
+  (delay
+    (let ((iface (resolve-interface '(guix licenses)))
+          (by-name (make-hash-table)))
+      (module-for-each (lambda (k var)
+                         (let ((val (variable-ref var)))
+                           (when (license? val)
+                             (hashq-set! by-name k val))))
+                       (resolve-interface '(guix licenses)))
+      by-name)))
+
+(define (all-potluck-license-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-licenses))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (license-by-name name)
+  (hashq-ref (force all-licenses) name))
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
new file mode 100644
index 000000000..c7dae3791
--- /dev/null
+++ b/guix/potluck/packages.scm
@@ -0,0 +1,399 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Court=C3=
=A8s <ludo@HIDDEN>
+;;; Copyright =C2=A9 2014, 2015 Mark H Weaver <mhw@HIDDEN>
+;;; Copyright =C2=A9 2015 Eric Bavier <bavier@HIDDEN>
+;;; Copyright =C2=A9 2016 Alex Kost <alezost@HIDDEN>
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck packages)
+  #:use-module (gnu packages)
+  #:use-module (guix base32)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (web uri)
+  #:export (potluck-source
+            potluck-source?
+            potluck-source-git-uri
+            potluck-source-git-commit
+            potluck-source-sha256
+            potluck-source-snippet
+
+            potluck-package
+            potluck-package?
+            potluck-package-name
+            potluck-package-version
+            potluck-package-source
+            potluck-package-build-system
+            potluck-package-arguments
+            potluck-package-inputs
+            potluck-package-native-inputs
+            potluck-package-propagated-inputs
+            potluck-package-synopsis
+            potluck-package-description
+            potluck-package-license
+            potluck-package-home-page
+            potluck-package-location
+            potluck-package-field-location
+
+            pretty-print-potluck-source
+            pretty-print-potluck-package
+
+            validate-potluck-package
+
+            lower-potluck-source
+            lower-potluck-package))
+
+;;; Commentary:
+;;;
+;;; This module provides a facility to define "potluck packages" in a
+;;; Guix-based distribution, and a facility to translate those packages =
to
+;;; "normal" Guix packages.
+;;;
+;;; Code:
+
+(define-record-type* <potluck-source>
+  potluck-source make-potluck-source
+  potluck-source?
+  (git-uri    potluck-source-git-uri)               ; uri string
+  (git-commit potluck-source-git-commit)            ; git sha1 string
+  (sha256     potluck-source-sha256)                ; base32 string
+  (snippet    potluck-source-snippet (default #f))) ; sexp or #f
+
+(define-record-type* <potluck-package>
+  potluck-package make-potluck-package
+  potluck-package?
+  (name               potluck-package-name)         ; string
+  (version            potluck-package-version)      ; string
+  (source             potluck-package-source)       ; <potluck-source>
+                                                    ; instance
+  (build-system       potluck-package-build-system) ; build system name =
as
+                                                    ; symbol
+  (arguments          potluck-package-arguments     ; arguments for the =
build
+                                                    ; method
+                      (default '()))
+  (inputs             potluck-package-inputs        ; input packages or
+                                                    ; derivations
+                      (default '()))
+  (propagated-inputs  potluck-package-propagated-inputs ; same, but prop=
agated
+                      (default '()))
+  (native-inputs      potluck-package-native-inputs ; native input packa=
ges or
+                                                    ; derivations
+                      (default '()))
+  (synopsis           potluck-package-synopsis)     ; one-line descripti=
on
+  (description        potluck-package-description)  ; one or two paragra=
phs
+  (license            potluck-package-license)
+  (home-page          potluck-package-home-page)
+  (location           potluck-package-location
+                      (default (and=3D> (current-source-location)
+                                      source-properties->location))
+                      (innate)))
+
+;; Printers.
+
+(define (print-potluck-source potluck-source port)
+  "Write a concise representation of POTLUCK-SOURCE to PORT."
+  (match potluck-source
+    (($ <potluck-source> git-uri git-commit sha256 snippet)
+     (simple-format port "#<potluck-source ~a@~a ~a ~a>"
+                    git-uri git-commit sha256
+                    (number->string (object-address potluck-source) 16))=
)))
+
+(define (print-potluck-package package port)
+  (let ((loc    (potluck-package-location package))
+        (format simple-format))
+    (format port "#<potluck-package ~a@~a ~a~a>"
+            (potluck-package-name package)
+            (potluck-package-version package)
+            (if loc
+                (format #f "~a:~a "
+                        (location-file loc)
+                        (location-line loc))
+                "")
+            (number->string (object-address
+                             package)
+                            16))))
+
+(set-record-type-printer! <potluck-source> print-potluck-source)
+(set-record-type-printer! <potluck-package> print-potluck-package)
+
+;; Pretty-printers.
+
+(define* (pretty-print-potluck-source port source #:key (prefix "")
+                                      (suffix "\n"))
+  (let ((uri (potluck-source-git-uri source))
+        (commit (potluck-source-git-commit source))
+        (sha256 (potluck-source-sha256 source))
+        (snippet (potluck-source-snippet source)))
+    (format port "~a(potluck-source" prefix)
+    (format port "\n~a  (git-uri ~s)" prefix uri)
+    (format port "\n~a  (git-commit ~s)" prefix commit)
+    (format port "\n~a  (sha256 ~s)" prefix sha256)
+    (when snippet
+      (format port "\n~a  (snippet '~s)" prefix snippet))
+    (format port ")~a" suffix)))
+
+(define* (pretty-print-potluck-package port pkg #:key (prefix ""))
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (format port "~a(potluck-package\n" prefix)
+    (format port "~a  (name ~s)\n" prefix name)
+    (format port "~a  (version ~s)\n" prefix version)
+    (format port "~a  (source\n" prefix)
+    (pretty-print-potluck-source port source #:prefix
+                                 (string-append prefix "    ")
+                                 #:suffix ")\n")
+    (format port "~a  (build-system '~s)\n" prefix build-system)
+    (format port "~a  (inputs '~s)\n" prefix inputs)
+    (format port "~a  (native-inputs '~s)\n" prefix native-inputs)
+    (format port "~a  (propagated-inputs '~s)\n" prefix propagated-input=
s)
+    (match arguments
+      (()
+       (format port "~a  (arguments '())\n" prefix))
+      (arguments
+       (pretty-print `(arguments ',arguments) port
+                     #:per-line-prefix (format #f "~a  " prefix))))
+    (format port "~a  (home-page ~s)\n" prefix home-page)
+    (format port "~a  (synopsis ~s)\n" prefix synopsis)
+    (format port "~a  (description ~s)\n" prefix description)
+    (format port "~a  (license '~s))\n" prefix license)))
+
+;; Editing.
+
+(define (potluck-package-field-location package field)
+  "Return the source code location of the definition of FIELD for PACKAG=
E, or
+#f if it could not be determined."
+  (define (goto port line column)
+    (unless (and (=3D (port-column port) (- column 1))
+                 (=3D (port-line port) (- line 1)))
+      (unless (eof-object? (read-char port))
+        (goto port line column))))
+
+  (match (potluck-package-location package)
+    (($ <location> file line column)
+     (catch 'system
+       (lambda ()
+         ;; In general we want to keep relative file names for modules.
+         (with-fluids ((%file-port-name-canonicalization 'relative))
+           (call-with-input-file (search-path %load-path file)
+             (lambda (port)
+               (goto port line column)
+               (match (read port)
+                 (('potluck-package inits ...)
+                  (let ((field (assoc field inits)))
+                    (match field
+                      ((_ value)
+                       ;; Put the `or' here, and not in the first argume=
nt of
+                       ;; `and=3D>', to work around a compiler bug in 2.=
0.5.
+                       (or (and=3D> (source-properties value)
+                                  source-properties->location)
+                           (and=3D> (source-properties field)
+                                  source-properties->location)))
+                      (_
+                       #f))))
+                 (_
+                  #f))))))
+       (lambda _
+         #f)))
+    (_ #f)))
+
+;; Lower potluck packages to Guix packages.
+
+(define-condition-type &potluck-package-error &error
+  potluck-package-error?
+  (potluck-package potluck-package-error-potluck-package))
+
+(define-condition-type &potluck-package-validation-error &potluck-packag=
e-error
+  potluck-package-validation-error?
+  (field-name potluck-package-validation-error-field-name)
+  (assertion potluck-package-validation-error-assertion)
+  (value potluck-package-validation-error-value))
+
+(define (assertion-failed pkg field-name assertion value)
+  (raise (condition (&potluck-package-validation-error
+                     (potluck-package pkg)
+                     (field-name field-name)
+                     (assertion assertion)
+                     (value value)))))
+
+(define* (validate-public-uri pkg field-name str #:key (schemes '(http h=
ttps)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (assertion-failed pkg field-name "public URI" str))))
+
+(define (validate-git-commit pkg field-name commit)
+  (unless (and (string? commit)
+               (=3D (string-length commit) 40)
+               (string-every (string->char-set "abcdef0123456789") commi=
t))
+    (assertion-failed pkg field-name "full git commit SHA1 hash" commit)=
))
+
+(define (validate-base32-sha256 pkg field-name str)
+  (unless (and (string? str)
+               (=3D (string-length str) 52)
+               (false-if-exception (nix-base32-string->bytevector str)))
+    (assertion-failed pkg field-name "sha256 hash as a base32 string" st=
r)))
+
+(define (validate-potluck-source pkg field-name source)
+  (validate-public-uri pkg field-name (potluck-source-git-uri source)
+                       #:schemes '(git http https))
+  (validate-git-commit pkg field-name (potluck-source-git-commit source)=
)
+  (validate-base32-sha256 pkg field-name (potluck-source-sha256 source))
+  (validate-snippet pkg field-name (potluck-source-snippet source)))
+
+(define (validate-snippet pkg field-name snippet)
+  (match snippet
+    (#f #t)
+    ((_ ...) #t)
+    (_ (assertion-failed pkg field-name "valid snippet" snippet))))
+
+(define (validate-non-empty-string pkg field-name str)
+  (unless (and (string? str)
+               (not (string-null? str)))
+    (assertion-failed pkg field-name "non-empty string" str)))
+
+(define (validate-build-system pkg field-name sym)
+  (unless (build-system-by-name sym)
+    (assertion-failed pkg field-name "build system name as symbol" sym))=
)
+
+(define (validate-package-list pkg field-name l)
+  (unless (and (list? l) (and-map string? l))
+    (assertion-failed pkg field-name
+                      "list of package or package@version strings" l)))
+
+(define* (validate-keyword-arguments pkg field-name l #:optional (valid-=
kw? (const #t)))
+  (define validate-1
+    (case-lambda
+      (() #t)
+      ((k v . rest)
+       (unless (and (keyword? k) (valid-kw? k))
+         (assertion-failed pkg field-name "keyword" k))
+       (apply validate-1 rest))
+      (_ (assertion-failed pkg field-name "keyword argument list" l))))
+  (apply validate-1 l))
+
+(define (validate-arguments pkg field-name arguments)
+  (validate-keyword-arguments pkg field-name arguments))
+
+(define (validate-synopsis pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The synopsis set by "guix potluck init".
+  (when (equal? str "Declarative synopsis here")
+    (assertion-failed pkg field-name "updated synopsis" str)))
+
+(define (validate-description pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The description set by "guix potluck init".
+  (when (string-suffix? "..." str)
+    (assertion-failed pkg field-name "updated description" str)))
+
+(define (validate-license pkg field-name sym)
+  (unless (license-by-name sym)
+    (assertion-failed pkg field-name "license name as symbol" sym)))
+
+(define (validate-potluck-package pkg)
+  (validate-non-empty-string pkg 'name (potluck-package-name pkg))
+  (validate-non-empty-string pkg 'version (potluck-package-version pkg))
+  (validate-potluck-source pkg 'source (potluck-package-source pkg))
+  (validate-build-system pkg 'build-system (potluck-package-build-system=
 pkg))
+  (validate-package-list pkg 'inputs (potluck-package-inputs pkg))
+  (validate-package-list pkg 'native-inputs
+                         (potluck-package-native-inputs pkg))
+  (validate-package-list pkg 'propagated-inputs
+                         (potluck-package-propagated-inputs pkg))
+  (validate-arguments pkg 'arguments (potluck-package-arguments pkg))
+  (validate-public-uri pkg 'home-page (potluck-package-home-page pkg))
+  (validate-synopsis pkg 'synopsis (potluck-package-synopsis pkg))
+  (validate-description pkg 'description (potluck-package-description pk=
g))
+  (validate-license pkg 'license (potluck-package-license pkg)))
+
+(define (lower-potluck-source o)
+  (let ((uri (potluck-source-git-uri o))
+        (commit (potluck-source-git-commit o))
+        (sha256 (potluck-source-sha256 o))
+        (snippet (potluck-source-snippet o)))
+    (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url uri)
+            (commit commit)))
+      (snippet snippet)
+      (sha256 (base32 sha256)))))
+
+(define (lower-input input)
+  (call-with-values (lambda () (specification->package+output input))
+    (lambda (pkg output)
+      (cons* (package-name pkg) pkg
+             (if (equal? output "out")
+                 '()
+                 (list output))))))
+
+(define (lower-inputs inputs)
+  (map lower-input inputs))
+
+(define (lower-potluck-package pkg)
+  (validate-potluck-package pkg)
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (package
+      (name name)
+      (version version)
+      (source (lower-potluck-source source))
+      (build-system (build-system-by-name build-system))
+      (inputs (lower-inputs inputs))
+      (native-inputs (lower-inputs native-inputs))
+      (propagated-inputs (lower-inputs propagated-inputs))
+      (arguments arguments)
+      (home-page home-page)
+      (synopsis synopsis)
+      (description description)
+      (license (license-by-name license)))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 6bb1f72eb..be26f63c9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix potluck packages)
   #:use-module (guix grafts)
=20
   ;; Use the procedure that destructures "NAME-VERSION" forms.
@@ -582,11 +583,20 @@ must be one of 'package', 'all', or 'transitive'~%"=
)
          (append %transformation-options
                  %standard-build-options)))
=20
+(define (load-package-or-derivation-from-file file)
+  (let ((mod (make-user-module '())))
+    ;; Expose potluck-package and potluck-source to the file.
+    (module-use! mod (resolve-interface
+                      '(guix potluck packages)
+                      #:select '(potluck-package potluck-source)))
+    (load* file mod)))
+
 (define (options->things-to-build opts)
   "Read the arguments from OPTS and return a list of high-level objects =
to
 build---packages, gexps, derivations, and so on."
   (define (validate-type x)
-    (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+    (unless (or (package? x) (potluck-package? x)
+                (derivation? x) (gexp? x) (procedure? x))
       (leave (_ "~s: not something we can build~%") x)))
=20
   (define (ensure-list x)
@@ -606,7 +616,7 @@ build---packages, gexps, derivations, and so on."
                        (else
                         (list (specification->package spec)))))
                 (('file . file)
-                 (ensure-list (load* file (make-user-module '()))))
+                 (ensure-list (load-package-or-derivation-from-file file=
)))
                 (('expression . str)
                  (ensure-list (read/eval str)))
                 (('argument . (? derivation? drv))
@@ -630,27 +640,31 @@ build."
   (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
=20
+  (define (package->derivation-list p)
+    (let ((p (or (and graft? (package-replacement p)) p)))
+      (match src
+        (#f
+         (list (package->derivation store p system)))
+        (#t
+         (match (package-source p)
+           (#f
+            (format (current-error-port)
+                    (_ "~a: warning: package '~a' has no source~%")
+                    (location->string (package-location p))
+                    (package-name p))
+            '())
+           (s
+            (list (package-source-derivation store s)))))
+        (proc
+         (map (cut package-source-derivation store <>)
+              (proc p))))))
+
   (parameterize ((%graft? graft?))
     (append-map (match-lambda
                   ((? package? p)
-                   (let ((p (or (and graft? (package-replacement p)) p))=
)
-                     (match src
-                       (#f
-                        (list (package->derivation store p system)))
-                       (#t
-                        (match (package-source p)
-                          (#f
-                           (format (current-error-port)
-                                   (_ "~a: warning: \
-package '~a' has no source~%")
-                                   (location->string (package-location p=
))
-                                   (package-name p))
-                           '())
-                          (s
-                           (list (package-source-derivation store s)))))
-                       (proc
-                        (map (cut package-source-derivation store <>)
-                             (proc p))))))
+                   (package->derivation-list p))
+                  ((? potluck-package? p)
+                   (package->derivation-list (lower-potluck-package p)))
                   ((? derivation? drv)
                    (list drv))
                   ((? procedure? proc)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:06 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:05 2017
Received: from localhost ([127.0.0.1]:38472 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6U-0004ZY-79
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:05 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:54280
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5J-0004Oz-AE
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:00 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 7F06D74D13
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:43 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:mime-version:content-type
 :content-transfer-encoding; s=sasl; bh=/U7YvCWRRtgTKxEHLu0Z1p51m
 q8=; b=ZJLLE08bbd2ZgXgLzNshldrM7FvCboEfoC/MF00t2JlZjsUEK3c6lXXOK
 aofa0nahKRpjAztIMsHViUZKj1V7K+ms1vX1//3pzaK9yVnM1jch70hgkc5vXpsg
 vZw0QF4ob1bVGZSwbFsJOYqrAL41e0nAh5mtCDXZKxuiNyZFxc=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 7557474D11
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:43 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 1A4C874D01
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:41 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 1/9] guix: Add "potluck" packages.
Date: Mon, 24 Apr 2017 22:59:15 +0200
Message-Id: <20170424205923.27726-1-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F0276662-2930-11E7-A193-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/build-systems.scm:
* guix/potluck/licenses.scm:
* guix/potluck/packages.scm: New files.
* guix/scripts/build.scm (load-package-or-derivation-from-file):
(options->things-to-build, options->derivations): Add "potluck-package" a=
nd
"potluck-source" to environment of file.  Lower potluck packages to Guix
packages.
---
 Makefile.am                    |   3 +
 guix/potluck/build-systems.scm |  55 ++++++
 guix/potluck/licenses.scm      |  41 +++++
 guix/potluck/packages.scm      | 399 +++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/build.scm         |  54 +++---
 5 files changed, 532 insertions(+), 20 deletions(-)
 create mode 100644 guix/potluck/build-systems.scm
 create mode 100644 guix/potluck/licenses.scm
 create mode 100644 guix/potluck/packages.scm

diff --git a/Makefile.am b/Makefile.am
index db4ebe04d..22ba00e90 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,9 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/potluck/build-systems.scm		\
+  guix/potluck/licenses.scm			\
+  guix/potluck/packages.scm			\
   guix/import/utils.scm				\
   guix/import/gnu.scm				\
   guix/import/snix.scm				\
diff --git a/guix/potluck/build-systems.scm b/guix/potluck/build-systems.=
scm
new file mode 100644
index 000000000..1f6aa1fe3
--- /dev/null
+++ b/guix/potluck/build-systems.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck build-systems)
+  #:use-module ((guix build-system) #:select (build-system?))
+  #:use-module ((gnu packages) #:select (scheme-modules))
+  #:use-module (ice-9 match)
+  #:export (build-system-by-name all-potluck-build-system-names))
+
+(define all-build-systems
+  (delay
+    (let* ((gbs (or (search-path %load-path "guix/build-system.scm")
+                    (error "can't find (guix build-system)")))
+           (root (dirname (dirname gbs)))
+           (by-name (make-hash-table)))
+      (for-each (lambda (iface)
+                  (module-for-each
+                   (lambda (k var)
+                     (let* ((str (symbol->string k))
+                            (pos (string-contains str "-build-system"))
+                            (val (variable-ref var)))
+                       (when (and pos (build-system? val))
+                         (let* ((head (substring str 0 pos))
+                                (tail (substring str
+                                                 (+ pos (string-length
+                                                         "-build-system"=
))))
+                                (name (string->symbol
+                                       (string-append head tail))))
+                           (hashq-set! by-name name val)))))
+                   iface))
+                (scheme-modules root "guix/build-system"))
+      by-name)))
+
+(define (all-potluck-build-system-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-build-systems))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (build-system-by-name name)
+  (hashq-ref (force all-build-systems) name))
diff --git a/guix/potluck/licenses.scm b/guix/potluck/licenses.scm
new file mode 100644
index 000000000..6efeee21a
--- /dev/null
+++ b/guix/potluck/licenses.scm
@@ -0,0 +1,41 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck licenses)
+  #:use-module ((guix licenses) #:select (license?))
+  #:use-module (ice-9 match)
+  #:export (license-by-name all-potluck-license-names))
+
+(define all-licenses
+  (delay
+    (let ((iface (resolve-interface '(guix licenses)))
+          (by-name (make-hash-table)))
+      (module-for-each (lambda (k var)
+                         (let ((val (variable-ref var)))
+                           (when (license? val)
+                             (hashq-set! by-name k val))))
+                       (resolve-interface '(guix licenses)))
+      by-name)))
+
+(define (all-potluck-license-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-licenses))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (license-by-name name)
+  (hashq-ref (force all-licenses) name))
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
new file mode 100644
index 000000000..c7dae3791
--- /dev/null
+++ b/guix/potluck/packages.scm
@@ -0,0 +1,399 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Court=C3=
=A8s <ludo@HIDDEN>
+;;; Copyright =C2=A9 2014, 2015 Mark H Weaver <mhw@HIDDEN>
+;;; Copyright =C2=A9 2015 Eric Bavier <bavier@HIDDEN>
+;;; Copyright =C2=A9 2016 Alex Kost <alezost@HIDDEN>
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck packages)
+  #:use-module (gnu packages)
+  #:use-module (guix base32)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (web uri)
+  #:export (potluck-source
+            potluck-source?
+            potluck-source-git-uri
+            potluck-source-git-commit
+            potluck-source-sha256
+            potluck-source-snippet
+
+            potluck-package
+            potluck-package?
+            potluck-package-name
+            potluck-package-version
+            potluck-package-source
+            potluck-package-build-system
+            potluck-package-arguments
+            potluck-package-inputs
+            potluck-package-native-inputs
+            potluck-package-propagated-inputs
+            potluck-package-synopsis
+            potluck-package-description
+            potluck-package-license
+            potluck-package-home-page
+            potluck-package-location
+            potluck-package-field-location
+
+            pretty-print-potluck-source
+            pretty-print-potluck-package
+
+            validate-potluck-package
+
+            lower-potluck-source
+            lower-potluck-package))
+
+;;; Commentary:
+;;;
+;;; This module provides a facility to define "potluck packages" in a
+;;; Guix-based distribution, and a facility to translate those packages =
to
+;;; "normal" Guix packages.
+;;;
+;;; Code:
+
+(define-record-type* <potluck-source>
+  potluck-source make-potluck-source
+  potluck-source?
+  (git-uri    potluck-source-git-uri)               ; uri string
+  (git-commit potluck-source-git-commit)            ; git sha1 string
+  (sha256     potluck-source-sha256)                ; base32 string
+  (snippet    potluck-source-snippet (default #f))) ; sexp or #f
+
+(define-record-type* <potluck-package>
+  potluck-package make-potluck-package
+  potluck-package?
+  (name               potluck-package-name)         ; string
+  (version            potluck-package-version)      ; string
+  (source             potluck-package-source)       ; <potluck-source>
+                                                    ; instance
+  (build-system       potluck-package-build-system) ; build system name =
as
+                                                    ; symbol
+  (arguments          potluck-package-arguments     ; arguments for the =
build
+                                                    ; method
+                      (default '()))
+  (inputs             potluck-package-inputs        ; input packages or
+                                                    ; derivations
+                      (default '()))
+  (propagated-inputs  potluck-package-propagated-inputs ; same, but prop=
agated
+                      (default '()))
+  (native-inputs      potluck-package-native-inputs ; native input packa=
ges or
+                                                    ; derivations
+                      (default '()))
+  (synopsis           potluck-package-synopsis)     ; one-line descripti=
on
+  (description        potluck-package-description)  ; one or two paragra=
phs
+  (license            potluck-package-license)
+  (home-page          potluck-package-home-page)
+  (location           potluck-package-location
+                      (default (and=3D> (current-source-location)
+                                      source-properties->location))
+                      (innate)))
+
+;; Printers.
+
+(define (print-potluck-source potluck-source port)
+  "Write a concise representation of POTLUCK-SOURCE to PORT."
+  (match potluck-source
+    (($ <potluck-source> git-uri git-commit sha256 snippet)
+     (simple-format port "#<potluck-source ~a@~a ~a ~a>"
+                    git-uri git-commit sha256
+                    (number->string (object-address potluck-source) 16))=
)))
+
+(define (print-potluck-package package port)
+  (let ((loc    (potluck-package-location package))
+        (format simple-format))
+    (format port "#<potluck-package ~a@~a ~a~a>"
+            (potluck-package-name package)
+            (potluck-package-version package)
+            (if loc
+                (format #f "~a:~a "
+                        (location-file loc)
+                        (location-line loc))
+                "")
+            (number->string (object-address
+                             package)
+                            16))))
+
+(set-record-type-printer! <potluck-source> print-potluck-source)
+(set-record-type-printer! <potluck-package> print-potluck-package)
+
+;; Pretty-printers.
+
+(define* (pretty-print-potluck-source port source #:key (prefix "")
+                                      (suffix "\n"))
+  (let ((uri (potluck-source-git-uri source))
+        (commit (potluck-source-git-commit source))
+        (sha256 (potluck-source-sha256 source))
+        (snippet (potluck-source-snippet source)))
+    (format port "~a(potluck-source" prefix)
+    (format port "\n~a  (git-uri ~s)" prefix uri)
+    (format port "\n~a  (git-commit ~s)" prefix commit)
+    (format port "\n~a  (sha256 ~s)" prefix sha256)
+    (when snippet
+      (format port "\n~a  (snippet '~s)" prefix snippet))
+    (format port ")~a" suffix)))
+
+(define* (pretty-print-potluck-package port pkg #:key (prefix ""))
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (format port "~a(potluck-package\n" prefix)
+    (format port "~a  (name ~s)\n" prefix name)
+    (format port "~a  (version ~s)\n" prefix version)
+    (format port "~a  (source\n" prefix)
+    (pretty-print-potluck-source port source #:prefix
+                                 (string-append prefix "    ")
+                                 #:suffix ")\n")
+    (format port "~a  (build-system '~s)\n" prefix build-system)
+    (format port "~a  (inputs '~s)\n" prefix inputs)
+    (format port "~a  (native-inputs '~s)\n" prefix native-inputs)
+    (format port "~a  (propagated-inputs '~s)\n" prefix propagated-input=
s)
+    (match arguments
+      (()
+       (format port "~a  (arguments '())\n" prefix))
+      (arguments
+       (pretty-print `(arguments ',arguments) port
+                     #:per-line-prefix (format #f "~a  " prefix))))
+    (format port "~a  (home-page ~s)\n" prefix home-page)
+    (format port "~a  (synopsis ~s)\n" prefix synopsis)
+    (format port "~a  (description ~s)\n" prefix description)
+    (format port "~a  (license '~s))\n" prefix license)))
+
+;; Editing.
+
+(define (potluck-package-field-location package field)
+  "Return the source code location of the definition of FIELD for PACKAG=
E, or
+#f if it could not be determined."
+  (define (goto port line column)
+    (unless (and (=3D (port-column port) (- column 1))
+                 (=3D (port-line port) (- line 1)))
+      (unless (eof-object? (read-char port))
+        (goto port line column))))
+
+  (match (potluck-package-location package)
+    (($ <location> file line column)
+     (catch 'system
+       (lambda ()
+         ;; In general we want to keep relative file names for modules.
+         (with-fluids ((%file-port-name-canonicalization 'relative))
+           (call-with-input-file (search-path %load-path file)
+             (lambda (port)
+               (goto port line column)
+               (match (read port)
+                 (('potluck-package inits ...)
+                  (let ((field (assoc field inits)))
+                    (match field
+                      ((_ value)
+                       ;; Put the `or' here, and not in the first argume=
nt of
+                       ;; `and=3D>', to work around a compiler bug in 2.=
0.5.
+                       (or (and=3D> (source-properties value)
+                                  source-properties->location)
+                           (and=3D> (source-properties field)
+                                  source-properties->location)))
+                      (_
+                       #f))))
+                 (_
+                  #f))))))
+       (lambda _
+         #f)))
+    (_ #f)))
+
+;; Lower potluck packages to Guix packages.
+
+(define-condition-type &potluck-package-error &error
+  potluck-package-error?
+  (potluck-package potluck-package-error-potluck-package))
+
+(define-condition-type &potluck-package-validation-error &potluck-packag=
e-error
+  potluck-package-validation-error?
+  (field-name potluck-package-validation-error-field-name)
+  (assertion potluck-package-validation-error-assertion)
+  (value potluck-package-validation-error-value))
+
+(define (assertion-failed pkg field-name assertion value)
+  (raise (condition (&potluck-package-validation-error
+                     (potluck-package pkg)
+                     (field-name field-name)
+                     (assertion assertion)
+                     (value value)))))
+
+(define* (validate-public-uri pkg field-name str #:key (schemes '(http h=
ttps)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (assertion-failed pkg field-name "public URI" str))))
+
+(define (validate-git-commit pkg field-name commit)
+  (unless (and (string? commit)
+               (=3D (string-length commit) 40)
+               (string-every (string->char-set "abcdef0123456789") commi=
t))
+    (assertion-failed pkg field-name "full git commit SHA1 hash" commit)=
))
+
+(define (validate-base32-sha256 pkg field-name str)
+  (unless (and (string? str)
+               (=3D (string-length str) 52)
+               (false-if-exception (nix-base32-string->bytevector str)))
+    (assertion-failed pkg field-name "sha256 hash as a base32 string" st=
r)))
+
+(define (validate-potluck-source pkg field-name source)
+  (validate-public-uri pkg field-name (potluck-source-git-uri source)
+                       #:schemes '(git http https))
+  (validate-git-commit pkg field-name (potluck-source-git-commit source)=
)
+  (validate-base32-sha256 pkg field-name (potluck-source-sha256 source))
+  (validate-snippet pkg field-name (potluck-source-snippet source)))
+
+(define (validate-snippet pkg field-name snippet)
+  (match snippet
+    (#f #t)
+    ((_ ...) #t)
+    (_ (assertion-failed pkg field-name "valid snippet" snippet))))
+
+(define (validate-non-empty-string pkg field-name str)
+  (unless (and (string? str)
+               (not (string-null? str)))
+    (assertion-failed pkg field-name "non-empty string" str)))
+
+(define (validate-build-system pkg field-name sym)
+  (unless (build-system-by-name sym)
+    (assertion-failed pkg field-name "build system name as symbol" sym))=
)
+
+(define (validate-package-list pkg field-name l)
+  (unless (and (list? l) (and-map string? l))
+    (assertion-failed pkg field-name
+                      "list of package or package@version strings" l)))
+
+(define* (validate-keyword-arguments pkg field-name l #:optional (valid-=
kw? (const #t)))
+  (define validate-1
+    (case-lambda
+      (() #t)
+      ((k v . rest)
+       (unless (and (keyword? k) (valid-kw? k))
+         (assertion-failed pkg field-name "keyword" k))
+       (apply validate-1 rest))
+      (_ (assertion-failed pkg field-name "keyword argument list" l))))
+  (apply validate-1 l))
+
+(define (validate-arguments pkg field-name arguments)
+  (validate-keyword-arguments pkg field-name arguments))
+
+(define (validate-synopsis pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The synopsis set by "guix potluck init".
+  (when (equal? str "Declarative synopsis here")
+    (assertion-failed pkg field-name "updated synopsis" str)))
+
+(define (validate-description pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The description set by "guix potluck init".
+  (when (string-suffix? "..." str)
+    (assertion-failed pkg field-name "updated description" str)))
+
+(define (validate-license pkg field-name sym)
+  (unless (license-by-name sym)
+    (assertion-failed pkg field-name "license name as symbol" sym)))
+
+(define (validate-potluck-package pkg)
+  (validate-non-empty-string pkg 'name (potluck-package-name pkg))
+  (validate-non-empty-string pkg 'version (potluck-package-version pkg))
+  (validate-potluck-source pkg 'source (potluck-package-source pkg))
+  (validate-build-system pkg 'build-system (potluck-package-build-system=
 pkg))
+  (validate-package-list pkg 'inputs (potluck-package-inputs pkg))
+  (validate-package-list pkg 'native-inputs
+                         (potluck-package-native-inputs pkg))
+  (validate-package-list pkg 'propagated-inputs
+                         (potluck-package-propagated-inputs pkg))
+  (validate-arguments pkg 'arguments (potluck-package-arguments pkg))
+  (validate-public-uri pkg 'home-page (potluck-package-home-page pkg))
+  (validate-synopsis pkg 'synopsis (potluck-package-synopsis pkg))
+  (validate-description pkg 'description (potluck-package-description pk=
g))
+  (validate-license pkg 'license (potluck-package-license pkg)))
+
+(define (lower-potluck-source o)
+  (let ((uri (potluck-source-git-uri o))
+        (commit (potluck-source-git-commit o))
+        (sha256 (potluck-source-sha256 o))
+        (snippet (potluck-source-snippet o)))
+    (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url uri)
+            (commit commit)))
+      (snippet snippet)
+      (sha256 (base32 sha256)))))
+
+(define (lower-input input)
+  (call-with-values (lambda () (specification->package+output input))
+    (lambda (pkg output)
+      (cons* (package-name pkg) pkg
+             (if (equal? output "out")
+                 '()
+                 (list output))))))
+
+(define (lower-inputs inputs)
+  (map lower-input inputs))
+
+(define (lower-potluck-package pkg)
+  (validate-potluck-package pkg)
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (package
+      (name name)
+      (version version)
+      (source (lower-potluck-source source))
+      (build-system (build-system-by-name build-system))
+      (inputs (lower-inputs inputs))
+      (native-inputs (lower-inputs native-inputs))
+      (propagated-inputs (lower-inputs propagated-inputs))
+      (arguments arguments)
+      (home-page home-page)
+      (synopsis synopsis)
+      (description description)
+      (license (license-by-name license)))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 6bb1f72eb..be26f63c9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix potluck packages)
   #:use-module (guix grafts)
=20
   ;; Use the procedure that destructures "NAME-VERSION" forms.
@@ -582,11 +583,20 @@ must be one of 'package', 'all', or 'transitive'~%"=
)
          (append %transformation-options
                  %standard-build-options)))
=20
+(define (load-package-or-derivation-from-file file)
+  (let ((mod (make-user-module '())))
+    ;; Expose potluck-package and potluck-source to the file.
+    (module-use! mod (resolve-interface
+                      '(guix potluck packages)
+                      #:select '(potluck-package potluck-source)))
+    (load* file mod)))
+
 (define (options->things-to-build opts)
   "Read the arguments from OPTS and return a list of high-level objects =
to
 build---packages, gexps, derivations, and so on."
   (define (validate-type x)
-    (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+    (unless (or (package? x) (potluck-package? x)
+                (derivation? x) (gexp? x) (procedure? x))
       (leave (_ "~s: not something we can build~%") x)))
=20
   (define (ensure-list x)
@@ -606,7 +616,7 @@ build---packages, gexps, derivations, and so on."
                        (else
                         (list (specification->package spec)))))
                 (('file . file)
-                 (ensure-list (load* file (make-user-module '()))))
+                 (ensure-list (load-package-or-derivation-from-file file=
)))
                 (('expression . str)
                  (ensure-list (read/eval str)))
                 (('argument . (? derivation? drv))
@@ -630,27 +640,31 @@ build."
   (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
=20
+  (define (package->derivation-list p)
+    (let ((p (or (and graft? (package-replacement p)) p)))
+      (match src
+        (#f
+         (list (package->derivation store p system)))
+        (#t
+         (match (package-source p)
+           (#f
+            (format (current-error-port)
+                    (_ "~a: warning: package '~a' has no source~%")
+                    (location->string (package-location p))
+                    (package-name p))
+            '())
+           (s
+            (list (package-source-derivation store s)))))
+        (proc
+         (map (cut package-source-derivation store <>)
+              (proc p))))))
+
   (parameterize ((%graft? graft?))
     (append-map (match-lambda
                   ((? package? p)
-                   (let ((p (or (and graft? (package-replacement p)) p))=
)
-                     (match src
-                       (#f
-                        (list (package->derivation store p system)))
-                       (#t
-                        (match (package-source p)
-                          (#f
-                           (format (current-error-port)
-                                   (_ "~a: warning: \
-package '~a' has no source~%")
-                                   (location->string (package-location p=
))
-                                   (package-name p))
-                           '())
-                          (s
-                           (list (package-source-derivation store s)))))
-                       (proc
-                        (map (cut package-source-derivation store <>)
-                             (proc p))))))
+                   (package->derivation-list p))
+                  ((? potluck-package? p)
+                   (package->derivation-list (lower-potluck-package p)))
                   ((? derivation? drv)
                    (list drv))
                   ((? procedure? proc)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:02 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:02 2017
Received: from localhost ([127.0.0.1]:38469 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6T-0004Z6-1L
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:02 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:61834
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5K-0004P7-1u
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:00 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id B111B74D21
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:47 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:mime-version:content-type
 :content-transfer-encoding; s=sasl; bh=/U7YvCWRRtgTKxEHLu0Z1p51m
 q8=; b=ZJLLE08bbd2ZgXgLzNshldrM7FvCboEfoC/MF00t2JlZjsUEK3c6lXXOK
 aofa0nahKRpjAztIMsHViUZKj1V7K+ms1vX1//3pzaK9yVnM1jch70hgkc5vXpsg
 vZw0QF4ob1bVGZSwbFsJOYqrAL41e0nAh5mtCDXZKxuiNyZFxc=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id A677574D20
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:47 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id A8E3974D15
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:43 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 1/9] guix: Add "potluck" packages.
Date: Mon, 24 Apr 2017 22:59:15 +0200
Message-Id: <20170424205923.27726-1-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F11A4B20-2930-11E7-A703-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/build-systems.scm:
* guix/potluck/licenses.scm:
* guix/potluck/packages.scm: New files.
* guix/scripts/build.scm (load-package-or-derivation-from-file):
(options->things-to-build, options->derivations): Add "potluck-package" a=
nd
"potluck-source" to environment of file.  Lower potluck packages to Guix
packages.
---
 Makefile.am                    |   3 +
 guix/potluck/build-systems.scm |  55 ++++++
 guix/potluck/licenses.scm      |  41 +++++
 guix/potluck/packages.scm      | 399 +++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/build.scm         |  54 +++---
 5 files changed, 532 insertions(+), 20 deletions(-)
 create mode 100644 guix/potluck/build-systems.scm
 create mode 100644 guix/potluck/licenses.scm
 create mode 100644 guix/potluck/packages.scm

diff --git a/Makefile.am b/Makefile.am
index db4ebe04d..22ba00e90 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,9 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/potluck/build-systems.scm		\
+  guix/potluck/licenses.scm			\
+  guix/potluck/packages.scm			\
   guix/import/utils.scm				\
   guix/import/gnu.scm				\
   guix/import/snix.scm				\
diff --git a/guix/potluck/build-systems.scm b/guix/potluck/build-systems.=
scm
new file mode 100644
index 000000000..1f6aa1fe3
--- /dev/null
+++ b/guix/potluck/build-systems.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck build-systems)
+  #:use-module ((guix build-system) #:select (build-system?))
+  #:use-module ((gnu packages) #:select (scheme-modules))
+  #:use-module (ice-9 match)
+  #:export (build-system-by-name all-potluck-build-system-names))
+
+(define all-build-systems
+  (delay
+    (let* ((gbs (or (search-path %load-path "guix/build-system.scm")
+                    (error "can't find (guix build-system)")))
+           (root (dirname (dirname gbs)))
+           (by-name (make-hash-table)))
+      (for-each (lambda (iface)
+                  (module-for-each
+                   (lambda (k var)
+                     (let* ((str (symbol->string k))
+                            (pos (string-contains str "-build-system"))
+                            (val (variable-ref var)))
+                       (when (and pos (build-system? val))
+                         (let* ((head (substring str 0 pos))
+                                (tail (substring str
+                                                 (+ pos (string-length
+                                                         "-build-system"=
))))
+                                (name (string->symbol
+                                       (string-append head tail))))
+                           (hashq-set! by-name name val)))))
+                   iface))
+                (scheme-modules root "guix/build-system"))
+      by-name)))
+
+(define (all-potluck-build-system-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-build-systems))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (build-system-by-name name)
+  (hashq-ref (force all-build-systems) name))
diff --git a/guix/potluck/licenses.scm b/guix/potluck/licenses.scm
new file mode 100644
index 000000000..6efeee21a
--- /dev/null
+++ b/guix/potluck/licenses.scm
@@ -0,0 +1,41 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck licenses)
+  #:use-module ((guix licenses) #:select (license?))
+  #:use-module (ice-9 match)
+  #:export (license-by-name all-potluck-license-names))
+
+(define all-licenses
+  (delay
+    (let ((iface (resolve-interface '(guix licenses)))
+          (by-name (make-hash-table)))
+      (module-for-each (lambda (k var)
+                         (let ((val (variable-ref var)))
+                           (when (license? val)
+                             (hashq-set! by-name k val))))
+                       (resolve-interface '(guix licenses)))
+      by-name)))
+
+(define (all-potluck-license-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-licenses))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (license-by-name name)
+  (hashq-ref (force all-licenses) name))
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
new file mode 100644
index 000000000..c7dae3791
--- /dev/null
+++ b/guix/potluck/packages.scm
@@ -0,0 +1,399 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Court=C3=
=A8s <ludo@HIDDEN>
+;;; Copyright =C2=A9 2014, 2015 Mark H Weaver <mhw@HIDDEN>
+;;; Copyright =C2=A9 2015 Eric Bavier <bavier@HIDDEN>
+;;; Copyright =C2=A9 2016 Alex Kost <alezost@HIDDEN>
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck packages)
+  #:use-module (gnu packages)
+  #:use-module (guix base32)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (web uri)
+  #:export (potluck-source
+            potluck-source?
+            potluck-source-git-uri
+            potluck-source-git-commit
+            potluck-source-sha256
+            potluck-source-snippet
+
+            potluck-package
+            potluck-package?
+            potluck-package-name
+            potluck-package-version
+            potluck-package-source
+            potluck-package-build-system
+            potluck-package-arguments
+            potluck-package-inputs
+            potluck-package-native-inputs
+            potluck-package-propagated-inputs
+            potluck-package-synopsis
+            potluck-package-description
+            potluck-package-license
+            potluck-package-home-page
+            potluck-package-location
+            potluck-package-field-location
+
+            pretty-print-potluck-source
+            pretty-print-potluck-package
+
+            validate-potluck-package
+
+            lower-potluck-source
+            lower-potluck-package))
+
+;;; Commentary:
+;;;
+;;; This module provides a facility to define "potluck packages" in a
+;;; Guix-based distribution, and a facility to translate those packages =
to
+;;; "normal" Guix packages.
+;;;
+;;; Code:
+
+(define-record-type* <potluck-source>
+  potluck-source make-potluck-source
+  potluck-source?
+  (git-uri    potluck-source-git-uri)               ; uri string
+  (git-commit potluck-source-git-commit)            ; git sha1 string
+  (sha256     potluck-source-sha256)                ; base32 string
+  (snippet    potluck-source-snippet (default #f))) ; sexp or #f
+
+(define-record-type* <potluck-package>
+  potluck-package make-potluck-package
+  potluck-package?
+  (name               potluck-package-name)         ; string
+  (version            potluck-package-version)      ; string
+  (source             potluck-package-source)       ; <potluck-source>
+                                                    ; instance
+  (build-system       potluck-package-build-system) ; build system name =
as
+                                                    ; symbol
+  (arguments          potluck-package-arguments     ; arguments for the =
build
+                                                    ; method
+                      (default '()))
+  (inputs             potluck-package-inputs        ; input packages or
+                                                    ; derivations
+                      (default '()))
+  (propagated-inputs  potluck-package-propagated-inputs ; same, but prop=
agated
+                      (default '()))
+  (native-inputs      potluck-package-native-inputs ; native input packa=
ges or
+                                                    ; derivations
+                      (default '()))
+  (synopsis           potluck-package-synopsis)     ; one-line descripti=
on
+  (description        potluck-package-description)  ; one or two paragra=
phs
+  (license            potluck-package-license)
+  (home-page          potluck-package-home-page)
+  (location           potluck-package-location
+                      (default (and=3D> (current-source-location)
+                                      source-properties->location))
+                      (innate)))
+
+;; Printers.
+
+(define (print-potluck-source potluck-source port)
+  "Write a concise representation of POTLUCK-SOURCE to PORT."
+  (match potluck-source
+    (($ <potluck-source> git-uri git-commit sha256 snippet)
+     (simple-format port "#<potluck-source ~a@~a ~a ~a>"
+                    git-uri git-commit sha256
+                    (number->string (object-address potluck-source) 16))=
)))
+
+(define (print-potluck-package package port)
+  (let ((loc    (potluck-package-location package))
+        (format simple-format))
+    (format port "#<potluck-package ~a@~a ~a~a>"
+            (potluck-package-name package)
+            (potluck-package-version package)
+            (if loc
+                (format #f "~a:~a "
+                        (location-file loc)
+                        (location-line loc))
+                "")
+            (number->string (object-address
+                             package)
+                            16))))
+
+(set-record-type-printer! <potluck-source> print-potluck-source)
+(set-record-type-printer! <potluck-package> print-potluck-package)
+
+;; Pretty-printers.
+
+(define* (pretty-print-potluck-source port source #:key (prefix "")
+                                      (suffix "\n"))
+  (let ((uri (potluck-source-git-uri source))
+        (commit (potluck-source-git-commit source))
+        (sha256 (potluck-source-sha256 source))
+        (snippet (potluck-source-snippet source)))
+    (format port "~a(potluck-source" prefix)
+    (format port "\n~a  (git-uri ~s)" prefix uri)
+    (format port "\n~a  (git-commit ~s)" prefix commit)
+    (format port "\n~a  (sha256 ~s)" prefix sha256)
+    (when snippet
+      (format port "\n~a  (snippet '~s)" prefix snippet))
+    (format port ")~a" suffix)))
+
+(define* (pretty-print-potluck-package port pkg #:key (prefix ""))
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (format port "~a(potluck-package\n" prefix)
+    (format port "~a  (name ~s)\n" prefix name)
+    (format port "~a  (version ~s)\n" prefix version)
+    (format port "~a  (source\n" prefix)
+    (pretty-print-potluck-source port source #:prefix
+                                 (string-append prefix "    ")
+                                 #:suffix ")\n")
+    (format port "~a  (build-system '~s)\n" prefix build-system)
+    (format port "~a  (inputs '~s)\n" prefix inputs)
+    (format port "~a  (native-inputs '~s)\n" prefix native-inputs)
+    (format port "~a  (propagated-inputs '~s)\n" prefix propagated-input=
s)
+    (match arguments
+      (()
+       (format port "~a  (arguments '())\n" prefix))
+      (arguments
+       (pretty-print `(arguments ',arguments) port
+                     #:per-line-prefix (format #f "~a  " prefix))))
+    (format port "~a  (home-page ~s)\n" prefix home-page)
+    (format port "~a  (synopsis ~s)\n" prefix synopsis)
+    (format port "~a  (description ~s)\n" prefix description)
+    (format port "~a  (license '~s))\n" prefix license)))
+
+;; Editing.
+
+(define (potluck-package-field-location package field)
+  "Return the source code location of the definition of FIELD for PACKAG=
E, or
+#f if it could not be determined."
+  (define (goto port line column)
+    (unless (and (=3D (port-column port) (- column 1))
+                 (=3D (port-line port) (- line 1)))
+      (unless (eof-object? (read-char port))
+        (goto port line column))))
+
+  (match (potluck-package-location package)
+    (($ <location> file line column)
+     (catch 'system
+       (lambda ()
+         ;; In general we want to keep relative file names for modules.
+         (with-fluids ((%file-port-name-canonicalization 'relative))
+           (call-with-input-file (search-path %load-path file)
+             (lambda (port)
+               (goto port line column)
+               (match (read port)
+                 (('potluck-package inits ...)
+                  (let ((field (assoc field inits)))
+                    (match field
+                      ((_ value)
+                       ;; Put the `or' here, and not in the first argume=
nt of
+                       ;; `and=3D>', to work around a compiler bug in 2.=
0.5.
+                       (or (and=3D> (source-properties value)
+                                  source-properties->location)
+                           (and=3D> (source-properties field)
+                                  source-properties->location)))
+                      (_
+                       #f))))
+                 (_
+                  #f))))))
+       (lambda _
+         #f)))
+    (_ #f)))
+
+;; Lower potluck packages to Guix packages.
+
+(define-condition-type &potluck-package-error &error
+  potluck-package-error?
+  (potluck-package potluck-package-error-potluck-package))
+
+(define-condition-type &potluck-package-validation-error &potluck-packag=
e-error
+  potluck-package-validation-error?
+  (field-name potluck-package-validation-error-field-name)
+  (assertion potluck-package-validation-error-assertion)
+  (value potluck-package-validation-error-value))
+
+(define (assertion-failed pkg field-name assertion value)
+  (raise (condition (&potluck-package-validation-error
+                     (potluck-package pkg)
+                     (field-name field-name)
+                     (assertion assertion)
+                     (value value)))))
+
+(define* (validate-public-uri pkg field-name str #:key (schemes '(http h=
ttps)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (assertion-failed pkg field-name "public URI" str))))
+
+(define (validate-git-commit pkg field-name commit)
+  (unless (and (string? commit)
+               (=3D (string-length commit) 40)
+               (string-every (string->char-set "abcdef0123456789") commi=
t))
+    (assertion-failed pkg field-name "full git commit SHA1 hash" commit)=
))
+
+(define (validate-base32-sha256 pkg field-name str)
+  (unless (and (string? str)
+               (=3D (string-length str) 52)
+               (false-if-exception (nix-base32-string->bytevector str)))
+    (assertion-failed pkg field-name "sha256 hash as a base32 string" st=
r)))
+
+(define (validate-potluck-source pkg field-name source)
+  (validate-public-uri pkg field-name (potluck-source-git-uri source)
+                       #:schemes '(git http https))
+  (validate-git-commit pkg field-name (potluck-source-git-commit source)=
)
+  (validate-base32-sha256 pkg field-name (potluck-source-sha256 source))
+  (validate-snippet pkg field-name (potluck-source-snippet source)))
+
+(define (validate-snippet pkg field-name snippet)
+  (match snippet
+    (#f #t)
+    ((_ ...) #t)
+    (_ (assertion-failed pkg field-name "valid snippet" snippet))))
+
+(define (validate-non-empty-string pkg field-name str)
+  (unless (and (string? str)
+               (not (string-null? str)))
+    (assertion-failed pkg field-name "non-empty string" str)))
+
+(define (validate-build-system pkg field-name sym)
+  (unless (build-system-by-name sym)
+    (assertion-failed pkg field-name "build system name as symbol" sym))=
)
+
+(define (validate-package-list pkg field-name l)
+  (unless (and (list? l) (and-map string? l))
+    (assertion-failed pkg field-name
+                      "list of package or package@version strings" l)))
+
+(define* (validate-keyword-arguments pkg field-name l #:optional (valid-=
kw? (const #t)))
+  (define validate-1
+    (case-lambda
+      (() #t)
+      ((k v . rest)
+       (unless (and (keyword? k) (valid-kw? k))
+         (assertion-failed pkg field-name "keyword" k))
+       (apply validate-1 rest))
+      (_ (assertion-failed pkg field-name "keyword argument list" l))))
+  (apply validate-1 l))
+
+(define (validate-arguments pkg field-name arguments)
+  (validate-keyword-arguments pkg field-name arguments))
+
+(define (validate-synopsis pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The synopsis set by "guix potluck init".
+  (when (equal? str "Declarative synopsis here")
+    (assertion-failed pkg field-name "updated synopsis" str)))
+
+(define (validate-description pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The description set by "guix potluck init".
+  (when (string-suffix? "..." str)
+    (assertion-failed pkg field-name "updated description" str)))
+
+(define (validate-license pkg field-name sym)
+  (unless (license-by-name sym)
+    (assertion-failed pkg field-name "license name as symbol" sym)))
+
+(define (validate-potluck-package pkg)
+  (validate-non-empty-string pkg 'name (potluck-package-name pkg))
+  (validate-non-empty-string pkg 'version (potluck-package-version pkg))
+  (validate-potluck-source pkg 'source (potluck-package-source pkg))
+  (validate-build-system pkg 'build-system (potluck-package-build-system=
 pkg))
+  (validate-package-list pkg 'inputs (potluck-package-inputs pkg))
+  (validate-package-list pkg 'native-inputs
+                         (potluck-package-native-inputs pkg))
+  (validate-package-list pkg 'propagated-inputs
+                         (potluck-package-propagated-inputs pkg))
+  (validate-arguments pkg 'arguments (potluck-package-arguments pkg))
+  (validate-public-uri pkg 'home-page (potluck-package-home-page pkg))
+  (validate-synopsis pkg 'synopsis (potluck-package-synopsis pkg))
+  (validate-description pkg 'description (potluck-package-description pk=
g))
+  (validate-license pkg 'license (potluck-package-license pkg)))
+
+(define (lower-potluck-source o)
+  (let ((uri (potluck-source-git-uri o))
+        (commit (potluck-source-git-commit o))
+        (sha256 (potluck-source-sha256 o))
+        (snippet (potluck-source-snippet o)))
+    (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url uri)
+            (commit commit)))
+      (snippet snippet)
+      (sha256 (base32 sha256)))))
+
+(define (lower-input input)
+  (call-with-values (lambda () (specification->package+output input))
+    (lambda (pkg output)
+      (cons* (package-name pkg) pkg
+             (if (equal? output "out")
+                 '()
+                 (list output))))))
+
+(define (lower-inputs inputs)
+  (map lower-input inputs))
+
+(define (lower-potluck-package pkg)
+  (validate-potluck-package pkg)
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (package
+      (name name)
+      (version version)
+      (source (lower-potluck-source source))
+      (build-system (build-system-by-name build-system))
+      (inputs (lower-inputs inputs))
+      (native-inputs (lower-inputs native-inputs))
+      (propagated-inputs (lower-inputs propagated-inputs))
+      (arguments arguments)
+      (home-page home-page)
+      (synopsis synopsis)
+      (description description)
+      (license (license-by-name license)))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 6bb1f72eb..be26f63c9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix potluck packages)
   #:use-module (guix grafts)
=20
   ;; Use the procedure that destructures "NAME-VERSION" forms.
@@ -582,11 +583,20 @@ must be one of 'package', 'all', or 'transitive'~%"=
)
          (append %transformation-options
                  %standard-build-options)))
=20
+(define (load-package-or-derivation-from-file file)
+  (let ((mod (make-user-module '())))
+    ;; Expose potluck-package and potluck-source to the file.
+    (module-use! mod (resolve-interface
+                      '(guix potluck packages)
+                      #:select '(potluck-package potluck-source)))
+    (load* file mod)))
+
 (define (options->things-to-build opts)
   "Read the arguments from OPTS and return a list of high-level objects =
to
 build---packages, gexps, derivations, and so on."
   (define (validate-type x)
-    (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+    (unless (or (package? x) (potluck-package? x)
+                (derivation? x) (gexp? x) (procedure? x))
       (leave (_ "~s: not something we can build~%") x)))
=20
   (define (ensure-list x)
@@ -606,7 +616,7 @@ build---packages, gexps, derivations, and so on."
                        (else
                         (list (specification->package spec)))))
                 (('file . file)
-                 (ensure-list (load* file (make-user-module '()))))
+                 (ensure-list (load-package-or-derivation-from-file file=
)))
                 (('expression . str)
                  (ensure-list (read/eval str)))
                 (('argument . (? derivation? drv))
@@ -630,27 +640,31 @@ build."
   (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
=20
+  (define (package->derivation-list p)
+    (let ((p (or (and graft? (package-replacement p)) p)))
+      (match src
+        (#f
+         (list (package->derivation store p system)))
+        (#t
+         (match (package-source p)
+           (#f
+            (format (current-error-port)
+                    (_ "~a: warning: package '~a' has no source~%")
+                    (location->string (package-location p))
+                    (package-name p))
+            '())
+           (s
+            (list (package-source-derivation store s)))))
+        (proc
+         (map (cut package-source-derivation store <>)
+              (proc p))))))
+
   (parameterize ((%graft? graft?))
     (append-map (match-lambda
                   ((? package? p)
-                   (let ((p (or (and graft? (package-replacement p)) p))=
)
-                     (match src
-                       (#f
-                        (list (package->derivation store p system)))
-                       (#t
-                        (match (package-source p)
-                          (#f
-                           (format (current-error-port)
-                                   (_ "~a: warning: \
-package '~a' has no source~%")
-                                   (location->string (package-location p=
))
-                                   (package-name p))
-                           '())
-                          (s
-                           (list (package-source-derivation store s)))))
-                       (proc
-                        (map (cut package-source-derivation store <>)
-                             (proc p))))))
+                   (package->derivation-list p))
+                  ((? potluck-package? p)
+                   (package->derivation-list (lower-potluck-package p)))
                   ((? derivation? drv)
                    (list drv))
                   ((? procedure? proc)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:01 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:01:01 2017
Received: from localhost ([127.0.0.1]:38467 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6P-0004Yx-5V
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:01:00 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:58325
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5K-0004QE-4Z
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:00 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id EC4C474D24
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:47 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:mime-version:content-type
 :content-transfer-encoding; s=sasl; bh=/U7YvCWRRtgTKxEHLu0Z1p51m
 q8=; b=ZJLLE08bbd2ZgXgLzNshldrM7FvCboEfoC/MF00t2JlZjsUEK3c6lXXOK
 aofa0nahKRpjAztIMsHViUZKj1V7K+ms1vX1//3pzaK9yVnM1jch70hgkc5vXpsg
 vZw0QF4ob1bVGZSwbFsJOYqrAL41e0nAh5mtCDXZKxuiNyZFxc=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id E3CE974D22
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:47 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 139DB74D1A
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:43 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 1/9] guix: Add "potluck" packages.
Date: Mon, 24 Apr 2017 22:59:15 +0200
Message-Id: <20170424205923.27726-1-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F15DDF02-2930-11E7-AF0B-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/build-systems.scm:
* guix/potluck/licenses.scm:
* guix/potluck/packages.scm: New files.
* guix/scripts/build.scm (load-package-or-derivation-from-file):
(options->things-to-build, options->derivations): Add "potluck-package" a=
nd
"potluck-source" to environment of file.  Lower potluck packages to Guix
packages.
---
 Makefile.am                    |   3 +
 guix/potluck/build-systems.scm |  55 ++++++
 guix/potluck/licenses.scm      |  41 +++++
 guix/potluck/packages.scm      | 399 +++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/build.scm         |  54 +++---
 5 files changed, 532 insertions(+), 20 deletions(-)
 create mode 100644 guix/potluck/build-systems.scm
 create mode 100644 guix/potluck/licenses.scm
 create mode 100644 guix/potluck/packages.scm

diff --git a/Makefile.am b/Makefile.am
index db4ebe04d..22ba00e90 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,9 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/potluck/build-systems.scm		\
+  guix/potluck/licenses.scm			\
+  guix/potluck/packages.scm			\
   guix/import/utils.scm				\
   guix/import/gnu.scm				\
   guix/import/snix.scm				\
diff --git a/guix/potluck/build-systems.scm b/guix/potluck/build-systems.=
scm
new file mode 100644
index 000000000..1f6aa1fe3
--- /dev/null
+++ b/guix/potluck/build-systems.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck build-systems)
+  #:use-module ((guix build-system) #:select (build-system?))
+  #:use-module ((gnu packages) #:select (scheme-modules))
+  #:use-module (ice-9 match)
+  #:export (build-system-by-name all-potluck-build-system-names))
+
+(define all-build-systems
+  (delay
+    (let* ((gbs (or (search-path %load-path "guix/build-system.scm")
+                    (error "can't find (guix build-system)")))
+           (root (dirname (dirname gbs)))
+           (by-name (make-hash-table)))
+      (for-each (lambda (iface)
+                  (module-for-each
+                   (lambda (k var)
+                     (let* ((str (symbol->string k))
+                            (pos (string-contains str "-build-system"))
+                            (val (variable-ref var)))
+                       (when (and pos (build-system? val))
+                         (let* ((head (substring str 0 pos))
+                                (tail (substring str
+                                                 (+ pos (string-length
+                                                         "-build-system"=
))))
+                                (name (string->symbol
+                                       (string-append head tail))))
+                           (hashq-set! by-name name val)))))
+                   iface))
+                (scheme-modules root "guix/build-system"))
+      by-name)))
+
+(define (all-potluck-build-system-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-build-systems))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (build-system-by-name name)
+  (hashq-ref (force all-build-systems) name))
diff --git a/guix/potluck/licenses.scm b/guix/potluck/licenses.scm
new file mode 100644
index 000000000..6efeee21a
--- /dev/null
+++ b/guix/potluck/licenses.scm
@@ -0,0 +1,41 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck licenses)
+  #:use-module ((guix licenses) #:select (license?))
+  #:use-module (ice-9 match)
+  #:export (license-by-name all-potluck-license-names))
+
+(define all-licenses
+  (delay
+    (let ((iface (resolve-interface '(guix licenses)))
+          (by-name (make-hash-table)))
+      (module-for-each (lambda (k var)
+                         (let ((val (variable-ref var)))
+                           (when (license? val)
+                             (hashq-set! by-name k val))))
+                       (resolve-interface '(guix licenses)))
+      by-name)))
+
+(define (all-potluck-license-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-licenses))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (license-by-name name)
+  (hashq-ref (force all-licenses) name))
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
new file mode 100644
index 000000000..c7dae3791
--- /dev/null
+++ b/guix/potluck/packages.scm
@@ -0,0 +1,399 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Court=C3=
=A8s <ludo@HIDDEN>
+;;; Copyright =C2=A9 2014, 2015 Mark H Weaver <mhw@HIDDEN>
+;;; Copyright =C2=A9 2015 Eric Bavier <bavier@HIDDEN>
+;;; Copyright =C2=A9 2016 Alex Kost <alezost@HIDDEN>
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck packages)
+  #:use-module (gnu packages)
+  #:use-module (guix base32)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (web uri)
+  #:export (potluck-source
+            potluck-source?
+            potluck-source-git-uri
+            potluck-source-git-commit
+            potluck-source-sha256
+            potluck-source-snippet
+
+            potluck-package
+            potluck-package?
+            potluck-package-name
+            potluck-package-version
+            potluck-package-source
+            potluck-package-build-system
+            potluck-package-arguments
+            potluck-package-inputs
+            potluck-package-native-inputs
+            potluck-package-propagated-inputs
+            potluck-package-synopsis
+            potluck-package-description
+            potluck-package-license
+            potluck-package-home-page
+            potluck-package-location
+            potluck-package-field-location
+
+            pretty-print-potluck-source
+            pretty-print-potluck-package
+
+            validate-potluck-package
+
+            lower-potluck-source
+            lower-potluck-package))
+
+;;; Commentary:
+;;;
+;;; This module provides a facility to define "potluck packages" in a
+;;; Guix-based distribution, and a facility to translate those packages =
to
+;;; "normal" Guix packages.
+;;;
+;;; Code:
+
+(define-record-type* <potluck-source>
+  potluck-source make-potluck-source
+  potluck-source?
+  (git-uri    potluck-source-git-uri)               ; uri string
+  (git-commit potluck-source-git-commit)            ; git sha1 string
+  (sha256     potluck-source-sha256)                ; base32 string
+  (snippet    potluck-source-snippet (default #f))) ; sexp or #f
+
+(define-record-type* <potluck-package>
+  potluck-package make-potluck-package
+  potluck-package?
+  (name               potluck-package-name)         ; string
+  (version            potluck-package-version)      ; string
+  (source             potluck-package-source)       ; <potluck-source>
+                                                    ; instance
+  (build-system       potluck-package-build-system) ; build system name =
as
+                                                    ; symbol
+  (arguments          potluck-package-arguments     ; arguments for the =
build
+                                                    ; method
+                      (default '()))
+  (inputs             potluck-package-inputs        ; input packages or
+                                                    ; derivations
+                      (default '()))
+  (propagated-inputs  potluck-package-propagated-inputs ; same, but prop=
agated
+                      (default '()))
+  (native-inputs      potluck-package-native-inputs ; native input packa=
ges or
+                                                    ; derivations
+                      (default '()))
+  (synopsis           potluck-package-synopsis)     ; one-line descripti=
on
+  (description        potluck-package-description)  ; one or two paragra=
phs
+  (license            potluck-package-license)
+  (home-page          potluck-package-home-page)
+  (location           potluck-package-location
+                      (default (and=3D> (current-source-location)
+                                      source-properties->location))
+                      (innate)))
+
+;; Printers.
+
+(define (print-potluck-source potluck-source port)
+  "Write a concise representation of POTLUCK-SOURCE to PORT."
+  (match potluck-source
+    (($ <potluck-source> git-uri git-commit sha256 snippet)
+     (simple-format port "#<potluck-source ~a@~a ~a ~a>"
+                    git-uri git-commit sha256
+                    (number->string (object-address potluck-source) 16))=
)))
+
+(define (print-potluck-package package port)
+  (let ((loc    (potluck-package-location package))
+        (format simple-format))
+    (format port "#<potluck-package ~a@~a ~a~a>"
+            (potluck-package-name package)
+            (potluck-package-version package)
+            (if loc
+                (format #f "~a:~a "
+                        (location-file loc)
+                        (location-line loc))
+                "")
+            (number->string (object-address
+                             package)
+                            16))))
+
+(set-record-type-printer! <potluck-source> print-potluck-source)
+(set-record-type-printer! <potluck-package> print-potluck-package)
+
+;; Pretty-printers.
+
+(define* (pretty-print-potluck-source port source #:key (prefix "")
+                                      (suffix "\n"))
+  (let ((uri (potluck-source-git-uri source))
+        (commit (potluck-source-git-commit source))
+        (sha256 (potluck-source-sha256 source))
+        (snippet (potluck-source-snippet source)))
+    (format port "~a(potluck-source" prefix)
+    (format port "\n~a  (git-uri ~s)" prefix uri)
+    (format port "\n~a  (git-commit ~s)" prefix commit)
+    (format port "\n~a  (sha256 ~s)" prefix sha256)
+    (when snippet
+      (format port "\n~a  (snippet '~s)" prefix snippet))
+    (format port ")~a" suffix)))
+
+(define* (pretty-print-potluck-package port pkg #:key (prefix ""))
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (format port "~a(potluck-package\n" prefix)
+    (format port "~a  (name ~s)\n" prefix name)
+    (format port "~a  (version ~s)\n" prefix version)
+    (format port "~a  (source\n" prefix)
+    (pretty-print-potluck-source port source #:prefix
+                                 (string-append prefix "    ")
+                                 #:suffix ")\n")
+    (format port "~a  (build-system '~s)\n" prefix build-system)
+    (format port "~a  (inputs '~s)\n" prefix inputs)
+    (format port "~a  (native-inputs '~s)\n" prefix native-inputs)
+    (format port "~a  (propagated-inputs '~s)\n" prefix propagated-input=
s)
+    (match arguments
+      (()
+       (format port "~a  (arguments '())\n" prefix))
+      (arguments
+       (pretty-print `(arguments ',arguments) port
+                     #:per-line-prefix (format #f "~a  " prefix))))
+    (format port "~a  (home-page ~s)\n" prefix home-page)
+    (format port "~a  (synopsis ~s)\n" prefix synopsis)
+    (format port "~a  (description ~s)\n" prefix description)
+    (format port "~a  (license '~s))\n" prefix license)))
+
+;; Editing.
+
+(define (potluck-package-field-location package field)
+  "Return the source code location of the definition of FIELD for PACKAG=
E, or
+#f if it could not be determined."
+  (define (goto port line column)
+    (unless (and (=3D (port-column port) (- column 1))
+                 (=3D (port-line port) (- line 1)))
+      (unless (eof-object? (read-char port))
+        (goto port line column))))
+
+  (match (potluck-package-location package)
+    (($ <location> file line column)
+     (catch 'system
+       (lambda ()
+         ;; In general we want to keep relative file names for modules.
+         (with-fluids ((%file-port-name-canonicalization 'relative))
+           (call-with-input-file (search-path %load-path file)
+             (lambda (port)
+               (goto port line column)
+               (match (read port)
+                 (('potluck-package inits ...)
+                  (let ((field (assoc field inits)))
+                    (match field
+                      ((_ value)
+                       ;; Put the `or' here, and not in the first argume=
nt of
+                       ;; `and=3D>', to work around a compiler bug in 2.=
0.5.
+                       (or (and=3D> (source-properties value)
+                                  source-properties->location)
+                           (and=3D> (source-properties field)
+                                  source-properties->location)))
+                      (_
+                       #f))))
+                 (_
+                  #f))))))
+       (lambda _
+         #f)))
+    (_ #f)))
+
+;; Lower potluck packages to Guix packages.
+
+(define-condition-type &potluck-package-error &error
+  potluck-package-error?
+  (potluck-package potluck-package-error-potluck-package))
+
+(define-condition-type &potluck-package-validation-error &potluck-packag=
e-error
+  potluck-package-validation-error?
+  (field-name potluck-package-validation-error-field-name)
+  (assertion potluck-package-validation-error-assertion)
+  (value potluck-package-validation-error-value))
+
+(define (assertion-failed pkg field-name assertion value)
+  (raise (condition (&potluck-package-validation-error
+                     (potluck-package pkg)
+                     (field-name field-name)
+                     (assertion assertion)
+                     (value value)))))
+
+(define* (validate-public-uri pkg field-name str #:key (schemes '(http h=
ttps)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (assertion-failed pkg field-name "public URI" str))))
+
+(define (validate-git-commit pkg field-name commit)
+  (unless (and (string? commit)
+               (=3D (string-length commit) 40)
+               (string-every (string->char-set "abcdef0123456789") commi=
t))
+    (assertion-failed pkg field-name "full git commit SHA1 hash" commit)=
))
+
+(define (validate-base32-sha256 pkg field-name str)
+  (unless (and (string? str)
+               (=3D (string-length str) 52)
+               (false-if-exception (nix-base32-string->bytevector str)))
+    (assertion-failed pkg field-name "sha256 hash as a base32 string" st=
r)))
+
+(define (validate-potluck-source pkg field-name source)
+  (validate-public-uri pkg field-name (potluck-source-git-uri source)
+                       #:schemes '(git http https))
+  (validate-git-commit pkg field-name (potluck-source-git-commit source)=
)
+  (validate-base32-sha256 pkg field-name (potluck-source-sha256 source))
+  (validate-snippet pkg field-name (potluck-source-snippet source)))
+
+(define (validate-snippet pkg field-name snippet)
+  (match snippet
+    (#f #t)
+    ((_ ...) #t)
+    (_ (assertion-failed pkg field-name "valid snippet" snippet))))
+
+(define (validate-non-empty-string pkg field-name str)
+  (unless (and (string? str)
+               (not (string-null? str)))
+    (assertion-failed pkg field-name "non-empty string" str)))
+
+(define (validate-build-system pkg field-name sym)
+  (unless (build-system-by-name sym)
+    (assertion-failed pkg field-name "build system name as symbol" sym))=
)
+
+(define (validate-package-list pkg field-name l)
+  (unless (and (list? l) (and-map string? l))
+    (assertion-failed pkg field-name
+                      "list of package or package@version strings" l)))
+
+(define* (validate-keyword-arguments pkg field-name l #:optional (valid-=
kw? (const #t)))
+  (define validate-1
+    (case-lambda
+      (() #t)
+      ((k v . rest)
+       (unless (and (keyword? k) (valid-kw? k))
+         (assertion-failed pkg field-name "keyword" k))
+       (apply validate-1 rest))
+      (_ (assertion-failed pkg field-name "keyword argument list" l))))
+  (apply validate-1 l))
+
+(define (validate-arguments pkg field-name arguments)
+  (validate-keyword-arguments pkg field-name arguments))
+
+(define (validate-synopsis pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The synopsis set by "guix potluck init".
+  (when (equal? str "Declarative synopsis here")
+    (assertion-failed pkg field-name "updated synopsis" str)))
+
+(define (validate-description pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The description set by "guix potluck init".
+  (when (string-suffix? "..." str)
+    (assertion-failed pkg field-name "updated description" str)))
+
+(define (validate-license pkg field-name sym)
+  (unless (license-by-name sym)
+    (assertion-failed pkg field-name "license name as symbol" sym)))
+
+(define (validate-potluck-package pkg)
+  (validate-non-empty-string pkg 'name (potluck-package-name pkg))
+  (validate-non-empty-string pkg 'version (potluck-package-version pkg))
+  (validate-potluck-source pkg 'source (potluck-package-source pkg))
+  (validate-build-system pkg 'build-system (potluck-package-build-system=
 pkg))
+  (validate-package-list pkg 'inputs (potluck-package-inputs pkg))
+  (validate-package-list pkg 'native-inputs
+                         (potluck-package-native-inputs pkg))
+  (validate-package-list pkg 'propagated-inputs
+                         (potluck-package-propagated-inputs pkg))
+  (validate-arguments pkg 'arguments (potluck-package-arguments pkg))
+  (validate-public-uri pkg 'home-page (potluck-package-home-page pkg))
+  (validate-synopsis pkg 'synopsis (potluck-package-synopsis pkg))
+  (validate-description pkg 'description (potluck-package-description pk=
g))
+  (validate-license pkg 'license (potluck-package-license pkg)))
+
+(define (lower-potluck-source o)
+  (let ((uri (potluck-source-git-uri o))
+        (commit (potluck-source-git-commit o))
+        (sha256 (potluck-source-sha256 o))
+        (snippet (potluck-source-snippet o)))
+    (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url uri)
+            (commit commit)))
+      (snippet snippet)
+      (sha256 (base32 sha256)))))
+
+(define (lower-input input)
+  (call-with-values (lambda () (specification->package+output input))
+    (lambda (pkg output)
+      (cons* (package-name pkg) pkg
+             (if (equal? output "out")
+                 '()
+                 (list output))))))
+
+(define (lower-inputs inputs)
+  (map lower-input inputs))
+
+(define (lower-potluck-package pkg)
+  (validate-potluck-package pkg)
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (package
+      (name name)
+      (version version)
+      (source (lower-potluck-source source))
+      (build-system (build-system-by-name build-system))
+      (inputs (lower-inputs inputs))
+      (native-inputs (lower-inputs native-inputs))
+      (propagated-inputs (lower-inputs propagated-inputs))
+      (arguments arguments)
+      (home-page home-page)
+      (synopsis synopsis)
+      (description description)
+      (license (license-by-name license)))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 6bb1f72eb..be26f63c9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix potluck packages)
   #:use-module (guix grafts)
=20
   ;; Use the procedure that destructures "NAME-VERSION" forms.
@@ -582,11 +583,20 @@ must be one of 'package', 'all', or 'transitive'~%"=
)
          (append %transformation-options
                  %standard-build-options)))
=20
+(define (load-package-or-derivation-from-file file)
+  (let ((mod (make-user-module '())))
+    ;; Expose potluck-package and potluck-source to the file.
+    (module-use! mod (resolve-interface
+                      '(guix potluck packages)
+                      #:select '(potluck-package potluck-source)))
+    (load* file mod)))
+
 (define (options->things-to-build opts)
   "Read the arguments from OPTS and return a list of high-level objects =
to
 build---packages, gexps, derivations, and so on."
   (define (validate-type x)
-    (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+    (unless (or (package? x) (potluck-package? x)
+                (derivation? x) (gexp? x) (procedure? x))
       (leave (_ "~s: not something we can build~%") x)))
=20
   (define (ensure-list x)
@@ -606,7 +616,7 @@ build---packages, gexps, derivations, and so on."
                        (else
                         (list (specification->package spec)))))
                 (('file . file)
-                 (ensure-list (load* file (make-user-module '()))))
+                 (ensure-list (load-package-or-derivation-from-file file=
)))
                 (('expression . str)
                  (ensure-list (read/eval str)))
                 (('argument . (? derivation? drv))
@@ -630,27 +640,31 @@ build."
   (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
=20
+  (define (package->derivation-list p)
+    (let ((p (or (and graft? (package-replacement p)) p)))
+      (match src
+        (#f
+         (list (package->derivation store p system)))
+        (#t
+         (match (package-source p)
+           (#f
+            (format (current-error-port)
+                    (_ "~a: warning: package '~a' has no source~%")
+                    (location->string (package-location p))
+                    (package-name p))
+            '())
+           (s
+            (list (package-source-derivation store s)))))
+        (proc
+         (map (cut package-source-derivation store <>)
+              (proc p))))))
+
   (parameterize ((%graft? graft?))
     (append-map (match-lambda
                   ((? package? p)
-                   (let ((p (or (and graft? (package-replacement p)) p))=
)
-                     (match src
-                       (#f
-                        (list (package->derivation store p system)))
-                       (#t
-                        (match (package-source p)
-                          (#f
-                           (format (current-error-port)
-                                   (_ "~a: warning: \
-package '~a' has no source~%")
-                                   (location->string (package-location p=
))
-                                   (package-name p))
-                           '())
-                          (s
-                           (list (package-source-derivation store s)))))
-                       (proc
-                        (map (cut package-source-derivation store <>)
-                             (proc p))))))
+                   (package->derivation-list p))
+                  ((? potluck-package? p)
+                   (package->derivation-list (lower-potluck-package p)))
                   ((? derivation? drv)
                    (list drv))
                   ((? procedure? proc)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:57 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:57 2017
Received: from localhost ([127.0.0.1]:38465 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6O-0004Yq-2A
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:57 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:63334
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5K-0004P3-Ly
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:00 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id F101174D25
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:47 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:mime-version:content-type
 :content-transfer-encoding; s=sasl; bh=/U7YvCWRRtgTKxEHLu0Z1p51m
 q8=; b=ZJLLE08bbd2ZgXgLzNshldrM7FvCboEfoC/MF00t2JlZjsUEK3c6lXXOK
 aofa0nahKRpjAztIMsHViUZKj1V7K+ms1vX1//3pzaK9yVnM1jch70hgkc5vXpsg
 vZw0QF4ob1bVGZSwbFsJOYqrAL41e0nAh5mtCDXZKxuiNyZFxc=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id E874D74D23
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:47 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id E0FF674D18
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:43 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 1/9] guix: Add "potluck" packages.
Date: Mon, 24 Apr 2017 22:59:15 +0200
Message-Id: <20170424205923.27726-1-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: F13E75F4-2930-11E7-AC7B-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/potluck/build-systems.scm:
* guix/potluck/licenses.scm:
* guix/potluck/packages.scm: New files.
* guix/scripts/build.scm (load-package-or-derivation-from-file):
(options->things-to-build, options->derivations): Add "potluck-package" a=
nd
"potluck-source" to environment of file.  Lower potluck packages to Guix
packages.
---
 Makefile.am                    |   3 +
 guix/potluck/build-systems.scm |  55 ++++++
 guix/potluck/licenses.scm      |  41 +++++
 guix/potluck/packages.scm      | 399 +++++++++++++++++++++++++++++++++++=
++++++
 guix/scripts/build.scm         |  54 +++---
 5 files changed, 532 insertions(+), 20 deletions(-)
 create mode 100644 guix/potluck/build-systems.scm
 create mode 100644 guix/potluck/licenses.scm
 create mode 100644 guix/potluck/packages.scm

diff --git a/Makefile.am b/Makefile.am
index db4ebe04d..22ba00e90 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,9 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/potluck/build-systems.scm		\
+  guix/potluck/licenses.scm			\
+  guix/potluck/packages.scm			\
   guix/import/utils.scm				\
   guix/import/gnu.scm				\
   guix/import/snix.scm				\
diff --git a/guix/potluck/build-systems.scm b/guix/potluck/build-systems.=
scm
new file mode 100644
index 000000000..1f6aa1fe3
--- /dev/null
+++ b/guix/potluck/build-systems.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck build-systems)
+  #:use-module ((guix build-system) #:select (build-system?))
+  #:use-module ((gnu packages) #:select (scheme-modules))
+  #:use-module (ice-9 match)
+  #:export (build-system-by-name all-potluck-build-system-names))
+
+(define all-build-systems
+  (delay
+    (let* ((gbs (or (search-path %load-path "guix/build-system.scm")
+                    (error "can't find (guix build-system)")))
+           (root (dirname (dirname gbs)))
+           (by-name (make-hash-table)))
+      (for-each (lambda (iface)
+                  (module-for-each
+                   (lambda (k var)
+                     (let* ((str (symbol->string k))
+                            (pos (string-contains str "-build-system"))
+                            (val (variable-ref var)))
+                       (when (and pos (build-system? val))
+                         (let* ((head (substring str 0 pos))
+                                (tail (substring str
+                                                 (+ pos (string-length
+                                                         "-build-system"=
))))
+                                (name (string->symbol
+                                       (string-append head tail))))
+                           (hashq-set! by-name name val)))))
+                   iface))
+                (scheme-modules root "guix/build-system"))
+      by-name)))
+
+(define (all-potluck-build-system-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-build-systems))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (build-system-by-name name)
+  (hashq-ref (force all-build-systems) name))
diff --git a/guix/potluck/licenses.scm b/guix/potluck/licenses.scm
new file mode 100644
index 000000000..6efeee21a
--- /dev/null
+++ b/guix/potluck/licenses.scm
@@ -0,0 +1,41 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck licenses)
+  #:use-module ((guix licenses) #:select (license?))
+  #:use-module (ice-9 match)
+  #:export (license-by-name all-potluck-license-names))
+
+(define all-licenses
+  (delay
+    (let ((iface (resolve-interface '(guix licenses)))
+          (by-name (make-hash-table)))
+      (module-for-each (lambda (k var)
+                         (let ((val (variable-ref var)))
+                           (when (license? val)
+                             (hashq-set! by-name k val))))
+                       (resolve-interface '(guix licenses)))
+      by-name)))
+
+(define (all-potluck-license-names)
+  (sort
+   (hash-map->list (lambda (k v) k) (force all-licenses))
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+
+(define (license-by-name name)
+  (hashq-ref (force all-licenses) name))
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
new file mode 100644
index 000000000..c7dae3791
--- /dev/null
+++ b/guix/potluck/packages.scm
@@ -0,0 +1,399 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Court=C3=
=A8s <ludo@HIDDEN>
+;;; Copyright =C2=A9 2014, 2015 Mark H Weaver <mhw@HIDDEN>
+;;; Copyright =C2=A9 2015 Eric Bavier <bavier@HIDDEN>
+;;; Copyright =C2=A9 2016 Alex Kost <alezost@HIDDEN>
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 potluck packages)
+  #:use-module (gnu packages)
+  #:use-module (guix base32)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (web uri)
+  #:export (potluck-source
+            potluck-source?
+            potluck-source-git-uri
+            potluck-source-git-commit
+            potluck-source-sha256
+            potluck-source-snippet
+
+            potluck-package
+            potluck-package?
+            potluck-package-name
+            potluck-package-version
+            potluck-package-source
+            potluck-package-build-system
+            potluck-package-arguments
+            potluck-package-inputs
+            potluck-package-native-inputs
+            potluck-package-propagated-inputs
+            potluck-package-synopsis
+            potluck-package-description
+            potluck-package-license
+            potluck-package-home-page
+            potluck-package-location
+            potluck-package-field-location
+
+            pretty-print-potluck-source
+            pretty-print-potluck-package
+
+            validate-potluck-package
+
+            lower-potluck-source
+            lower-potluck-package))
+
+;;; Commentary:
+;;;
+;;; This module provides a facility to define "potluck packages" in a
+;;; Guix-based distribution, and a facility to translate those packages =
to
+;;; "normal" Guix packages.
+;;;
+;;; Code:
+
+(define-record-type* <potluck-source>
+  potluck-source make-potluck-source
+  potluck-source?
+  (git-uri    potluck-source-git-uri)               ; uri string
+  (git-commit potluck-source-git-commit)            ; git sha1 string
+  (sha256     potluck-source-sha256)                ; base32 string
+  (snippet    potluck-source-snippet (default #f))) ; sexp or #f
+
+(define-record-type* <potluck-package>
+  potluck-package make-potluck-package
+  potluck-package?
+  (name               potluck-package-name)         ; string
+  (version            potluck-package-version)      ; string
+  (source             potluck-package-source)       ; <potluck-source>
+                                                    ; instance
+  (build-system       potluck-package-build-system) ; build system name =
as
+                                                    ; symbol
+  (arguments          potluck-package-arguments     ; arguments for the =
build
+                                                    ; method
+                      (default '()))
+  (inputs             potluck-package-inputs        ; input packages or
+                                                    ; derivations
+                      (default '()))
+  (propagated-inputs  potluck-package-propagated-inputs ; same, but prop=
agated
+                      (default '()))
+  (native-inputs      potluck-package-native-inputs ; native input packa=
ges or
+                                                    ; derivations
+                      (default '()))
+  (synopsis           potluck-package-synopsis)     ; one-line descripti=
on
+  (description        potluck-package-description)  ; one or two paragra=
phs
+  (license            potluck-package-license)
+  (home-page          potluck-package-home-page)
+  (location           potluck-package-location
+                      (default (and=3D> (current-source-location)
+                                      source-properties->location))
+                      (innate)))
+
+;; Printers.
+
+(define (print-potluck-source potluck-source port)
+  "Write a concise representation of POTLUCK-SOURCE to PORT."
+  (match potluck-source
+    (($ <potluck-source> git-uri git-commit sha256 snippet)
+     (simple-format port "#<potluck-source ~a@~a ~a ~a>"
+                    git-uri git-commit sha256
+                    (number->string (object-address potluck-source) 16))=
)))
+
+(define (print-potluck-package package port)
+  (let ((loc    (potluck-package-location package))
+        (format simple-format))
+    (format port "#<potluck-package ~a@~a ~a~a>"
+            (potluck-package-name package)
+            (potluck-package-version package)
+            (if loc
+                (format #f "~a:~a "
+                        (location-file loc)
+                        (location-line loc))
+                "")
+            (number->string (object-address
+                             package)
+                            16))))
+
+(set-record-type-printer! <potluck-source> print-potluck-source)
+(set-record-type-printer! <potluck-package> print-potluck-package)
+
+;; Pretty-printers.
+
+(define* (pretty-print-potluck-source port source #:key (prefix "")
+                                      (suffix "\n"))
+  (let ((uri (potluck-source-git-uri source))
+        (commit (potluck-source-git-commit source))
+        (sha256 (potluck-source-sha256 source))
+        (snippet (potluck-source-snippet source)))
+    (format port "~a(potluck-source" prefix)
+    (format port "\n~a  (git-uri ~s)" prefix uri)
+    (format port "\n~a  (git-commit ~s)" prefix commit)
+    (format port "\n~a  (sha256 ~s)" prefix sha256)
+    (when snippet
+      (format port "\n~a  (snippet '~s)" prefix snippet))
+    (format port ")~a" suffix)))
+
+(define* (pretty-print-potluck-package port pkg #:key (prefix ""))
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (format port "~a(potluck-package\n" prefix)
+    (format port "~a  (name ~s)\n" prefix name)
+    (format port "~a  (version ~s)\n" prefix version)
+    (format port "~a  (source\n" prefix)
+    (pretty-print-potluck-source port source #:prefix
+                                 (string-append prefix "    ")
+                                 #:suffix ")\n")
+    (format port "~a  (build-system '~s)\n" prefix build-system)
+    (format port "~a  (inputs '~s)\n" prefix inputs)
+    (format port "~a  (native-inputs '~s)\n" prefix native-inputs)
+    (format port "~a  (propagated-inputs '~s)\n" prefix propagated-input=
s)
+    (match arguments
+      (()
+       (format port "~a  (arguments '())\n" prefix))
+      (arguments
+       (pretty-print `(arguments ',arguments) port
+                     #:per-line-prefix (format #f "~a  " prefix))))
+    (format port "~a  (home-page ~s)\n" prefix home-page)
+    (format port "~a  (synopsis ~s)\n" prefix synopsis)
+    (format port "~a  (description ~s)\n" prefix description)
+    (format port "~a  (license '~s))\n" prefix license)))
+
+;; Editing.
+
+(define (potluck-package-field-location package field)
+  "Return the source code location of the definition of FIELD for PACKAG=
E, or
+#f if it could not be determined."
+  (define (goto port line column)
+    (unless (and (=3D (port-column port) (- column 1))
+                 (=3D (port-line port) (- line 1)))
+      (unless (eof-object? (read-char port))
+        (goto port line column))))
+
+  (match (potluck-package-location package)
+    (($ <location> file line column)
+     (catch 'system
+       (lambda ()
+         ;; In general we want to keep relative file names for modules.
+         (with-fluids ((%file-port-name-canonicalization 'relative))
+           (call-with-input-file (search-path %load-path file)
+             (lambda (port)
+               (goto port line column)
+               (match (read port)
+                 (('potluck-package inits ...)
+                  (let ((field (assoc field inits)))
+                    (match field
+                      ((_ value)
+                       ;; Put the `or' here, and not in the first argume=
nt of
+                       ;; `and=3D>', to work around a compiler bug in 2.=
0.5.
+                       (or (and=3D> (source-properties value)
+                                  source-properties->location)
+                           (and=3D> (source-properties field)
+                                  source-properties->location)))
+                      (_
+                       #f))))
+                 (_
+                  #f))))))
+       (lambda _
+         #f)))
+    (_ #f)))
+
+;; Lower potluck packages to Guix packages.
+
+(define-condition-type &potluck-package-error &error
+  potluck-package-error?
+  (potluck-package potluck-package-error-potluck-package))
+
+(define-condition-type &potluck-package-validation-error &potluck-packag=
e-error
+  potluck-package-validation-error?
+  (field-name potluck-package-validation-error-field-name)
+  (assertion potluck-package-validation-error-assertion)
+  (value potluck-package-validation-error-value))
+
+(define (assertion-failed pkg field-name assertion value)
+  (raise (condition (&potluck-package-validation-error
+                     (potluck-package pkg)
+                     (field-name field-name)
+                     (assertion assertion)
+                     (value value)))))
+
+(define* (validate-public-uri pkg field-name str #:key (schemes '(http h=
ttps)))
+  (define (public-host? host)
+    ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+    ;; addresses; this is just a sanity check.
+    (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+  (let ((uri (and (string? str) (string->uri str))))
+    (unless (and uri
+                 (memq (uri-scheme uri) schemes)
+                 (not (uri-fragment uri))
+                 (public-host? (uri-host uri)))
+      (assertion-failed pkg field-name "public URI" str))))
+
+(define (validate-git-commit pkg field-name commit)
+  (unless (and (string? commit)
+               (=3D (string-length commit) 40)
+               (string-every (string->char-set "abcdef0123456789") commi=
t))
+    (assertion-failed pkg field-name "full git commit SHA1 hash" commit)=
))
+
+(define (validate-base32-sha256 pkg field-name str)
+  (unless (and (string? str)
+               (=3D (string-length str) 52)
+               (false-if-exception (nix-base32-string->bytevector str)))
+    (assertion-failed pkg field-name "sha256 hash as a base32 string" st=
r)))
+
+(define (validate-potluck-source pkg field-name source)
+  (validate-public-uri pkg field-name (potluck-source-git-uri source)
+                       #:schemes '(git http https))
+  (validate-git-commit pkg field-name (potluck-source-git-commit source)=
)
+  (validate-base32-sha256 pkg field-name (potluck-source-sha256 source))
+  (validate-snippet pkg field-name (potluck-source-snippet source)))
+
+(define (validate-snippet pkg field-name snippet)
+  (match snippet
+    (#f #t)
+    ((_ ...) #t)
+    (_ (assertion-failed pkg field-name "valid snippet" snippet))))
+
+(define (validate-non-empty-string pkg field-name str)
+  (unless (and (string? str)
+               (not (string-null? str)))
+    (assertion-failed pkg field-name "non-empty string" str)))
+
+(define (validate-build-system pkg field-name sym)
+  (unless (build-system-by-name sym)
+    (assertion-failed pkg field-name "build system name as symbol" sym))=
)
+
+(define (validate-package-list pkg field-name l)
+  (unless (and (list? l) (and-map string? l))
+    (assertion-failed pkg field-name
+                      "list of package or package@version strings" l)))
+
+(define* (validate-keyword-arguments pkg field-name l #:optional (valid-=
kw? (const #t)))
+  (define validate-1
+    (case-lambda
+      (() #t)
+      ((k v . rest)
+       (unless (and (keyword? k) (valid-kw? k))
+         (assertion-failed pkg field-name "keyword" k))
+       (apply validate-1 rest))
+      (_ (assertion-failed pkg field-name "keyword argument list" l))))
+  (apply validate-1 l))
+
+(define (validate-arguments pkg field-name arguments)
+  (validate-keyword-arguments pkg field-name arguments))
+
+(define (validate-synopsis pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The synopsis set by "guix potluck init".
+  (when (equal? str "Declarative synopsis here")
+    (assertion-failed pkg field-name "updated synopsis" str)))
+
+(define (validate-description pkg field-name str)
+  (validate-non-empty-string pkg field-name str)
+  ;; The description set by "guix potluck init".
+  (when (string-suffix? "..." str)
+    (assertion-failed pkg field-name "updated description" str)))
+
+(define (validate-license pkg field-name sym)
+  (unless (license-by-name sym)
+    (assertion-failed pkg field-name "license name as symbol" sym)))
+
+(define (validate-potluck-package pkg)
+  (validate-non-empty-string pkg 'name (potluck-package-name pkg))
+  (validate-non-empty-string pkg 'version (potluck-package-version pkg))
+  (validate-potluck-source pkg 'source (potluck-package-source pkg))
+  (validate-build-system pkg 'build-system (potluck-package-build-system=
 pkg))
+  (validate-package-list pkg 'inputs (potluck-package-inputs pkg))
+  (validate-package-list pkg 'native-inputs
+                         (potluck-package-native-inputs pkg))
+  (validate-package-list pkg 'propagated-inputs
+                         (potluck-package-propagated-inputs pkg))
+  (validate-arguments pkg 'arguments (potluck-package-arguments pkg))
+  (validate-public-uri pkg 'home-page (potluck-package-home-page pkg))
+  (validate-synopsis pkg 'synopsis (potluck-package-synopsis pkg))
+  (validate-description pkg 'description (potluck-package-description pk=
g))
+  (validate-license pkg 'license (potluck-package-license pkg)))
+
+(define (lower-potluck-source o)
+  (let ((uri (potluck-source-git-uri o))
+        (commit (potluck-source-git-commit o))
+        (sha256 (potluck-source-sha256 o))
+        (snippet (potluck-source-snippet o)))
+    (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url uri)
+            (commit commit)))
+      (snippet snippet)
+      (sha256 (base32 sha256)))))
+
+(define (lower-input input)
+  (call-with-values (lambda () (specification->package+output input))
+    (lambda (pkg output)
+      (cons* (package-name pkg) pkg
+             (if (equal? output "out")
+                 '()
+                 (list output))))))
+
+(define (lower-inputs inputs)
+  (map lower-input inputs))
+
+(define (lower-potluck-package pkg)
+  (validate-potluck-package pkg)
+  (let ((name (potluck-package-name pkg))
+        (version (potluck-package-version pkg))
+        (source (potluck-package-source pkg))
+        (build-system (potluck-package-build-system pkg))
+        (inputs (potluck-package-inputs pkg))
+        (native-inputs (potluck-package-native-inputs pkg))
+        (propagated-inputs (potluck-package-propagated-inputs pkg))
+        (arguments (potluck-package-arguments pkg))
+        (home-page (potluck-package-home-page pkg))
+        (synopsis (potluck-package-synopsis pkg))
+        (description (potluck-package-description pkg))
+        (license (potluck-package-license pkg)))
+    (package
+      (name name)
+      (version version)
+      (source (lower-potluck-source source))
+      (build-system (build-system-by-name build-system))
+      (inputs (lower-inputs inputs))
+      (native-inputs (lower-inputs native-inputs))
+      (propagated-inputs (lower-inputs propagated-inputs))
+      (arguments arguments)
+      (home-page home-page)
+      (synopsis synopsis)
+      (description description)
+      (license (license-by-name license)))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 6bb1f72eb..be26f63c9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix potluck packages)
   #:use-module (guix grafts)
=20
   ;; Use the procedure that destructures "NAME-VERSION" forms.
@@ -582,11 +583,20 @@ must be one of 'package', 'all', or 'transitive'~%"=
)
          (append %transformation-options
                  %standard-build-options)))
=20
+(define (load-package-or-derivation-from-file file)
+  (let ((mod (make-user-module '())))
+    ;; Expose potluck-package and potluck-source to the file.
+    (module-use! mod (resolve-interface
+                      '(guix potluck packages)
+                      #:select '(potluck-package potluck-source)))
+    (load* file mod)))
+
 (define (options->things-to-build opts)
   "Read the arguments from OPTS and return a list of high-level objects =
to
 build---packages, gexps, derivations, and so on."
   (define (validate-type x)
-    (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+    (unless (or (package? x) (potluck-package? x)
+                (derivation? x) (gexp? x) (procedure? x))
       (leave (_ "~s: not something we can build~%") x)))
=20
   (define (ensure-list x)
@@ -606,7 +616,7 @@ build---packages, gexps, derivations, and so on."
                        (else
                         (list (specification->package spec)))))
                 (('file . file)
-                 (ensure-list (load* file (make-user-module '()))))
+                 (ensure-list (load-package-or-derivation-from-file file=
)))
                 (('expression . str)
                  (ensure-list (read/eval str)))
                 (('argument . (? derivation? drv))
@@ -630,27 +640,31 @@ build."
   (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
=20
+  (define (package->derivation-list p)
+    (let ((p (or (and graft? (package-replacement p)) p)))
+      (match src
+        (#f
+         (list (package->derivation store p system)))
+        (#t
+         (match (package-source p)
+           (#f
+            (format (current-error-port)
+                    (_ "~a: warning: package '~a' has no source~%")
+                    (location->string (package-location p))
+                    (package-name p))
+            '())
+           (s
+            (list (package-source-derivation store s)))))
+        (proc
+         (map (cut package-source-derivation store <>)
+              (proc p))))))
+
   (parameterize ((%graft? graft?))
     (append-map (match-lambda
                   ((? package? p)
-                   (let ((p (or (and graft? (package-replacement p)) p))=
)
-                     (match src
-                       (#f
-                        (list (package->derivation store p system)))
-                       (#t
-                        (match (package-source p)
-                          (#f
-                           (format (current-error-port)
-                                   (_ "~a: warning: \
-package '~a' has no source~%")
-                                   (location->string (package-location p=
))
-                                   (package-name p))
-                           '())
-                          (s
-                           (list (package-source-derivation store s)))))
-                       (proc
-                        (map (cut package-source-derivation store <>)
-                             (proc p))))))
+                   (package->derivation-list p))
+                  ((? potluck-package? p)
+                   (package->derivation-list (lower-potluck-package p)))
                   ((? derivation? drv)
                    (list drv))
                   ((? procedure? proc)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:56 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:56 2017
Received: from localhost ([127.0.0.1]:38463 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6N-0004Yg-Kb
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:55 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:57998
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5J-0004Q3-8A
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:55 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id A7AE874D0E
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=vuIy
 kyZV+GLSy3VaSk/3TUGbcyE=; b=umPGOfBqT0ef1fCihleola79tK2OaQUe14gC
 1CUdc/URQTkXDSzQxdrxWahRR6Sd5z5f0yxvPLBuvZBc8WhkEd1zSkc/2Q9tU//A
 e0Ak6uWIyvkbKfg4Osb6C3XS3k5FlRbxPPZKk/qnYSha8vnOEPJZYCuti0GPR3tp
 Lq+iOrY=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 9FAC674D0D
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 17F8974CFC
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:40 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Date: Mon, 24 Apr 2017 22:59:16 +0200
Message-Id: <20170424205923.27726-2-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EF8CEEF2-2930-11E7-A5FC-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/hash.scm (show-help, %options): Add -g option.
(vcs-file?): Pull out to top.
(guix-hash-git-checkout): New function.
(guix-hash): Support hashing of Git URLs.
* doc/guix.texi (Invoking guix hash): Document guix hash --git.
---
 doc/guix.texi         | 17 +++++++++++++
 guix/scripts/hash.scm | 67 ++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 65 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0d334e302..7f1074f9d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5384,6 +5384,23 @@ $ git clone http://example.org/foo.git
 $ cd foo
 $ guix hash -rx .
 @end example
+
+Hashing a git checkout is so common that it has its own alias:
+
+@item --git
+@itemx -g
+Clones the git repository at @var{file} into a temporary directory and
+recursively hashes it, excluding the @file{.git} subdirectory.  This is
+mainly useful if you want to get the Guix hash of the current Git
+checkout:
+
+@example
+$ git clone http://example.org/foo.git
+$ cd foo
+# Hack a bunch of things, make some commits
+$ guix hash -g .
+@end example
+
 @end table
 
 @node Invoking guix import
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index a048b5346..f1ac3c38a 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix base16)
+  #:use-module (guix utils)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs files)
   #:use-module (ice-9 match)
@@ -32,7 +33,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
-  #:export (guix-hash))
+  #:export (guix-hash-git-checkout
+            guix-hash))
 
 
 ;;;
@@ -52,6 +54,9 @@ and 'hexadecimal' can be used as well).\n"))
   (format #t (_ "
   -x, --exclude-vcs      exclude version control directories"))
   (format #t (_ "
+  -g, --git              clone the git repository at FILE and hash it
+                         (implies -r)"))
+  (format #t (_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (_ "
   -r, --recursive        compute the hash on FILE recursively"))
@@ -68,6 +73,10 @@ and 'hexadecimal' can be used as well).\n"))
   (list (option '(#\x "exclude-vcs") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'exclude-vcs? #t result)))
+        (option '(#\g "git") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git? #t
+                              (alist-cons 'exclude-vcs? #t result))))
         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (define fmt-proc
@@ -98,6 +107,35 @@ and 'hexadecimal' can be used as well).\n"))
 
 
 ;;;
+;;; Helpers.
+;;;
+
+(define (vcs-file? file stat)
+  (case (stat:type stat)
+    ((directory)
+     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+    ((regular)
+     ;; Git sub-modules have a '.git' file that is a regular text file.
+     (string=? (basename file) ".git"))
+    (else
+     #f)))
+
+(define* (recursive-hash file #:key (select? (const #t)))
+  (let-values (((port get-hash) (open-sha256-port)))
+    (write-file file port #:select? select?)
+    (force-output port)
+    (get-hash)))
+
+(define (guix-hash-git-checkout directory)
+  (call-with-temporary-directory
+   (lambda (dir)
+     (let ((checkout (in-vicinity dir "git-checkout")))
+       (unless (zero? (system* "git" "clone" "--" directory checkout))
+         (leave (_ "git clone failed~%")))
+       (recursive-hash checkout #:select? (negate vcs-file?))))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -112,16 +150,6 @@ and 'hexadecimal' can be used as well).\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
-  (define (vcs-file? file stat)
-    (case (stat:type stat)
-      ((directory)
-       (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-      ((regular)
-       ;; Git sub-modules have a '.git' file that is a regular text file.
-       (string=? (basename file) ".git"))
-      (else
-       #f)))
-
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
@@ -137,14 +165,15 @@ and 'hexadecimal' can be used as well).\n"))
       ;; Compute the hash of FILE.
       ;; Catch and gracefully report possible '&nar-error' conditions.
       (with-error-handling
-        (if (assoc-ref opts 'recursive?)
-            (let-values (((port get-hash) (open-sha256-port)))
-              (write-file file port #:select? select?)
-              (force-output port)
-              (get-hash))
-            (match file
-              ("-" (port-sha256 (current-input-port)))
-              (_   (call-with-input-file file port-sha256))))))
+        (cond
+         ((assoc-ref opts 'git?)
+          (guix-hash-git-checkout file))
+         ((assoc-ref opts 'recursive?)
+          (recursive-hash file #:select? select))
+         (else
+          (match file
+            ("-" (port-sha256 (current-input-port)))
+            (_   (call-with-input-file file port-sha256)))))))
 
     (match args
       ((file)
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:55 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:55 2017
Received: from localhost ([127.0.0.1]:38461 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6N-0004YZ-5c
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:55 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:51480
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5J-0004Px-7G
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:55 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 9883C74D0C
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=vuIy
 kyZV+GLSy3VaSk/3TUGbcyE=; b=umPGOfBqT0ef1fCihleola79tK2OaQUe14gC
 1CUdc/URQTkXDSzQxdrxWahRR6Sd5z5f0yxvPLBuvZBc8WhkEd1zSkc/2Q9tU//A
 e0Ak6uWIyvkbKfg4Osb6C3XS3k5FlRbxPPZKk/qnYSha8vnOEPJZYCuti0GPR3tp
 Lq+iOrY=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 90A8474D0B
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id DCF7374CF9
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:40 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Date: Mon, 24 Apr 2017 22:59:16 +0200
Message-Id: <20170424205923.27726-2-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EF6FB58A-2930-11E7-B1F6-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/hash.scm (show-help, %options): Add -g option.
(vcs-file?): Pull out to top.
(guix-hash-git-checkout): New function.
(guix-hash): Support hashing of Git URLs.
* doc/guix.texi (Invoking guix hash): Document guix hash --git.
---
 doc/guix.texi         | 17 +++++++++++++
 guix/scripts/hash.scm | 67 ++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 65 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0d334e302..7f1074f9d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5384,6 +5384,23 @@ $ git clone http://example.org/foo.git
 $ cd foo
 $ guix hash -rx .
 @end example
+
+Hashing a git checkout is so common that it has its own alias:
+
+@item --git
+@itemx -g
+Clones the git repository at @var{file} into a temporary directory and
+recursively hashes it, excluding the @file{.git} subdirectory.  This is
+mainly useful if you want to get the Guix hash of the current Git
+checkout:
+
+@example
+$ git clone http://example.org/foo.git
+$ cd foo
+# Hack a bunch of things, make some commits
+$ guix hash -g .
+@end example
+
 @end table
 
 @node Invoking guix import
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index a048b5346..f1ac3c38a 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix base16)
+  #:use-module (guix utils)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs files)
   #:use-module (ice-9 match)
@@ -32,7 +33,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
-  #:export (guix-hash))
+  #:export (guix-hash-git-checkout
+            guix-hash))
 
 
 ;;;
@@ -52,6 +54,9 @@ and 'hexadecimal' can be used as well).\n"))
   (format #t (_ "
   -x, --exclude-vcs      exclude version control directories"))
   (format #t (_ "
+  -g, --git              clone the git repository at FILE and hash it
+                         (implies -r)"))
+  (format #t (_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (_ "
   -r, --recursive        compute the hash on FILE recursively"))
@@ -68,6 +73,10 @@ and 'hexadecimal' can be used as well).\n"))
   (list (option '(#\x "exclude-vcs") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'exclude-vcs? #t result)))
+        (option '(#\g "git") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git? #t
+                              (alist-cons 'exclude-vcs? #t result))))
         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (define fmt-proc
@@ -98,6 +107,35 @@ and 'hexadecimal' can be used as well).\n"))
 
 
 ;;;
+;;; Helpers.
+;;;
+
+(define (vcs-file? file stat)
+  (case (stat:type stat)
+    ((directory)
+     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+    ((regular)
+     ;; Git sub-modules have a '.git' file that is a regular text file.
+     (string=? (basename file) ".git"))
+    (else
+     #f)))
+
+(define* (recursive-hash file #:key (select? (const #t)))
+  (let-values (((port get-hash) (open-sha256-port)))
+    (write-file file port #:select? select?)
+    (force-output port)
+    (get-hash)))
+
+(define (guix-hash-git-checkout directory)
+  (call-with-temporary-directory
+   (lambda (dir)
+     (let ((checkout (in-vicinity dir "git-checkout")))
+       (unless (zero? (system* "git" "clone" "--" directory checkout))
+         (leave (_ "git clone failed~%")))
+       (recursive-hash checkout #:select? (negate vcs-file?))))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -112,16 +150,6 @@ and 'hexadecimal' can be used as well).\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
-  (define (vcs-file? file stat)
-    (case (stat:type stat)
-      ((directory)
-       (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-      ((regular)
-       ;; Git sub-modules have a '.git' file that is a regular text file.
-       (string=? (basename file) ".git"))
-      (else
-       #f)))
-
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
@@ -137,14 +165,15 @@ and 'hexadecimal' can be used as well).\n"))
       ;; Compute the hash of FILE.
       ;; Catch and gracefully report possible '&nar-error' conditions.
       (with-error-handling
-        (if (assoc-ref opts 'recursive?)
-            (let-values (((port get-hash) (open-sha256-port)))
-              (write-file file port #:select? select?)
-              (force-output port)
-              (get-hash))
-            (match file
-              ("-" (port-sha256 (current-input-port)))
-              (_   (call-with-input-file file port-sha256))))))
+        (cond
+         ((assoc-ref opts 'git?)
+          (guix-hash-git-checkout file))
+         ((assoc-ref opts 'recursive?)
+          (recursive-hash file #:select? select))
+         (else
+          (match file
+            ("-" (port-sha256 (current-input-port)))
+            (_   (call-with-input-file file port-sha256)))))))
 
     (match args
       ((file)
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:55 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:55 2017
Received: from localhost ([127.0.0.1]:38459 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6M-0004YS-Pv
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:55 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:63878
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5J-0004Op-5K
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:55 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 8938F74D0A
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=vuIy
 kyZV+GLSy3VaSk/3TUGbcyE=; b=umPGOfBqT0ef1fCihleola79tK2OaQUe14gC
 1CUdc/URQTkXDSzQxdrxWahRR6Sd5z5f0yxvPLBuvZBc8WhkEd1zSkc/2Q9tU//A
 e0Ak6uWIyvkbKfg4Osb6C3XS3k5FlRbxPPZKk/qnYSha8vnOEPJZYCuti0GPR3tp
 Lq+iOrY=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 818D374D09
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id D5CFE74CF8
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:40 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Date: Mon, 24 Apr 2017 22:59:16 +0200
Message-Id: <20170424205923.27726-2-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EF6A8CA4-2930-11E7-AD64-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/hash.scm (show-help, %options): Add -g option.
(vcs-file?): Pull out to top.
(guix-hash-git-checkout): New function.
(guix-hash): Support hashing of Git URLs.
* doc/guix.texi (Invoking guix hash): Document guix hash --git.
---
 doc/guix.texi         | 17 +++++++++++++
 guix/scripts/hash.scm | 67 ++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 65 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0d334e302..7f1074f9d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5384,6 +5384,23 @@ $ git clone http://example.org/foo.git
 $ cd foo
 $ guix hash -rx .
 @end example
+
+Hashing a git checkout is so common that it has its own alias:
+
+@item --git
+@itemx -g
+Clones the git repository at @var{file} into a temporary directory and
+recursively hashes it, excluding the @file{.git} subdirectory.  This is
+mainly useful if you want to get the Guix hash of the current Git
+checkout:
+
+@example
+$ git clone http://example.org/foo.git
+$ cd foo
+# Hack a bunch of things, make some commits
+$ guix hash -g .
+@end example
+
 @end table
 
 @node Invoking guix import
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index a048b5346..f1ac3c38a 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix base16)
+  #:use-module (guix utils)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs files)
   #:use-module (ice-9 match)
@@ -32,7 +33,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
-  #:export (guix-hash))
+  #:export (guix-hash-git-checkout
+            guix-hash))
 
 
 ;;;
@@ -52,6 +54,9 @@ and 'hexadecimal' can be used as well).\n"))
   (format #t (_ "
   -x, --exclude-vcs      exclude version control directories"))
   (format #t (_ "
+  -g, --git              clone the git repository at FILE and hash it
+                         (implies -r)"))
+  (format #t (_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (_ "
   -r, --recursive        compute the hash on FILE recursively"))
@@ -68,6 +73,10 @@ and 'hexadecimal' can be used as well).\n"))
   (list (option '(#\x "exclude-vcs") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'exclude-vcs? #t result)))
+        (option '(#\g "git") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git? #t
+                              (alist-cons 'exclude-vcs? #t result))))
         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (define fmt-proc
@@ -98,6 +107,35 @@ and 'hexadecimal' can be used as well).\n"))
 
 
 ;;;
+;;; Helpers.
+;;;
+
+(define (vcs-file? file stat)
+  (case (stat:type stat)
+    ((directory)
+     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+    ((regular)
+     ;; Git sub-modules have a '.git' file that is a regular text file.
+     (string=? (basename file) ".git"))
+    (else
+     #f)))
+
+(define* (recursive-hash file #:key (select? (const #t)))
+  (let-values (((port get-hash) (open-sha256-port)))
+    (write-file file port #:select? select?)
+    (force-output port)
+    (get-hash)))
+
+(define (guix-hash-git-checkout directory)
+  (call-with-temporary-directory
+   (lambda (dir)
+     (let ((checkout (in-vicinity dir "git-checkout")))
+       (unless (zero? (system* "git" "clone" "--" directory checkout))
+         (leave (_ "git clone failed~%")))
+       (recursive-hash checkout #:select? (negate vcs-file?))))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -112,16 +150,6 @@ and 'hexadecimal' can be used as well).\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
-  (define (vcs-file? file stat)
-    (case (stat:type stat)
-      ((directory)
-       (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-      ((regular)
-       ;; Git sub-modules have a '.git' file that is a regular text file.
-       (string=? (basename file) ".git"))
-      (else
-       #f)))
-
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
@@ -137,14 +165,15 @@ and 'hexadecimal' can be used as well).\n"))
       ;; Compute the hash of FILE.
       ;; Catch and gracefully report possible '&nar-error' conditions.
       (with-error-handling
-        (if (assoc-ref opts 'recursive?)
-            (let-values (((port get-hash) (open-sha256-port)))
-              (write-file file port #:select? select?)
-              (force-output port)
-              (get-hash))
-            (match file
-              ("-" (port-sha256 (current-input-port)))
-              (_   (call-with-input-file file port-sha256))))))
+        (cond
+         ((assoc-ref opts 'git?)
+          (guix-hash-git-checkout file))
+         ((assoc-ref opts 'recursive?)
+          (recursive-hash file #:select? select))
+         (else
+          (match file
+            ("-" (port-sha256 (current-input-port)))
+            (_   (call-with-input-file file port-sha256)))))))
 
     (match args
       ((file)
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:54 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:54 2017
Received: from localhost ([127.0.0.1]:38457 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6M-0004YJ-Au
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:54 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:56924
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5J-0004Ou-4K
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:55 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 4364874D08
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=vuIy
 kyZV+GLSy3VaSk/3TUGbcyE=; b=umPGOfBqT0ef1fCihleola79tK2OaQUe14gC
 1CUdc/URQTkXDSzQxdrxWahRR6Sd5z5f0yxvPLBuvZBc8WhkEd1zSkc/2Q9tU//A
 e0Ak6uWIyvkbKfg4Osb6C3XS3k5FlRbxPPZKk/qnYSha8vnOEPJZYCuti0GPR3tp
 Lq+iOrY=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 3A45174D07
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 5AD9874CFE
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:41 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Date: Mon, 24 Apr 2017 22:59:16 +0200
Message-Id: <20170424205923.27726-2-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EFB870AE-2930-11E7-A327-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/hash.scm (show-help, %options): Add -g option.
(vcs-file?): Pull out to top.
(guix-hash-git-checkout): New function.
(guix-hash): Support hashing of Git URLs.
* doc/guix.texi (Invoking guix hash): Document guix hash --git.
---
 doc/guix.texi         | 17 +++++++++++++
 guix/scripts/hash.scm | 67 ++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 65 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0d334e302..7f1074f9d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5384,6 +5384,23 @@ $ git clone http://example.org/foo.git
 $ cd foo
 $ guix hash -rx .
 @end example
+
+Hashing a git checkout is so common that it has its own alias:
+
+@item --git
+@itemx -g
+Clones the git repository at @var{file} into a temporary directory and
+recursively hashes it, excluding the @file{.git} subdirectory.  This is
+mainly useful if you want to get the Guix hash of the current Git
+checkout:
+
+@example
+$ git clone http://example.org/foo.git
+$ cd foo
+# Hack a bunch of things, make some commits
+$ guix hash -g .
+@end example
+
 @end table
 
 @node Invoking guix import
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index a048b5346..f1ac3c38a 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix base16)
+  #:use-module (guix utils)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs files)
   #:use-module (ice-9 match)
@@ -32,7 +33,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
-  #:export (guix-hash))
+  #:export (guix-hash-git-checkout
+            guix-hash))
 
 
 ;;;
@@ -52,6 +54,9 @@ and 'hexadecimal' can be used as well).\n"))
   (format #t (_ "
   -x, --exclude-vcs      exclude version control directories"))
   (format #t (_ "
+  -g, --git              clone the git repository at FILE and hash it
+                         (implies -r)"))
+  (format #t (_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (_ "
   -r, --recursive        compute the hash on FILE recursively"))
@@ -68,6 +73,10 @@ and 'hexadecimal' can be used as well).\n"))
   (list (option '(#\x "exclude-vcs") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'exclude-vcs? #t result)))
+        (option '(#\g "git") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git? #t
+                              (alist-cons 'exclude-vcs? #t result))))
         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (define fmt-proc
@@ -98,6 +107,35 @@ and 'hexadecimal' can be used as well).\n"))
 
 
 ;;;
+;;; Helpers.
+;;;
+
+(define (vcs-file? file stat)
+  (case (stat:type stat)
+    ((directory)
+     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+    ((regular)
+     ;; Git sub-modules have a '.git' file that is a regular text file.
+     (string=? (basename file) ".git"))
+    (else
+     #f)))
+
+(define* (recursive-hash file #:key (select? (const #t)))
+  (let-values (((port get-hash) (open-sha256-port)))
+    (write-file file port #:select? select?)
+    (force-output port)
+    (get-hash)))
+
+(define (guix-hash-git-checkout directory)
+  (call-with-temporary-directory
+   (lambda (dir)
+     (let ((checkout (in-vicinity dir "git-checkout")))
+       (unless (zero? (system* "git" "clone" "--" directory checkout))
+         (leave (_ "git clone failed~%")))
+       (recursive-hash checkout #:select? (negate vcs-file?))))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -112,16 +150,6 @@ and 'hexadecimal' can be used as well).\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
-  (define (vcs-file? file stat)
-    (case (stat:type stat)
-      ((directory)
-       (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-      ((regular)
-       ;; Git sub-modules have a '.git' file that is a regular text file.
-       (string=? (basename file) ".git"))
-      (else
-       #f)))
-
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
@@ -137,14 +165,15 @@ and 'hexadecimal' can be used as well).\n"))
       ;; Compute the hash of FILE.
       ;; Catch and gracefully report possible '&nar-error' conditions.
       (with-error-handling
-        (if (assoc-ref opts 'recursive?)
-            (let-values (((port get-hash) (open-sha256-port)))
-              (write-file file port #:select? select?)
-              (force-output port)
-              (get-hash))
-            (match file
-              ("-" (port-sha256 (current-input-port)))
-              (_   (call-with-input-file file port-sha256))))))
+        (cond
+         ((assoc-ref opts 'git?)
+          (guix-hash-git-checkout file))
+         ((assoc-ref opts 'recursive?)
+          (recursive-hash file #:select? select))
+         (else
+          (match file
+            ("-" (port-sha256 (current-input-port)))
+            (_   (call-with-input-file file port-sha256)))))))
 
     (match args
       ((file)
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:54 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:54 2017
Received: from localhost ([127.0.0.1]:38455 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6L-0004YD-WB
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:54 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:58341
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5I-0004Pi-43
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:54 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 30C5A74D06
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=vuIy
 kyZV+GLSy3VaSk/3TUGbcyE=; b=umPGOfBqT0ef1fCihleola79tK2OaQUe14gC
 1CUdc/URQTkXDSzQxdrxWahRR6Sd5z5f0yxvPLBuvZBc8WhkEd1zSkc/2Q9tU//A
 e0Ak6uWIyvkbKfg4Osb6C3XS3k5FlRbxPPZKk/qnYSha8vnOEPJZYCuti0GPR3tp
 Lq+iOrY=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 2892474D05
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id F2FD674CFB
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:40 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Date: Mon, 24 Apr 2017 22:59:16 +0200
Message-Id: <20170424205923.27726-2-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EF7DB504-2930-11E7-AE57-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/hash.scm (show-help, %options): Add -g option.
(vcs-file?): Pull out to top.
(guix-hash-git-checkout): New function.
(guix-hash): Support hashing of Git URLs.
* doc/guix.texi (Invoking guix hash): Document guix hash --git.
---
 doc/guix.texi         | 17 +++++++++++++
 guix/scripts/hash.scm | 67 ++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 65 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0d334e302..7f1074f9d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5384,6 +5384,23 @@ $ git clone http://example.org/foo.git
 $ cd foo
 $ guix hash -rx .
 @end example
+
+Hashing a git checkout is so common that it has its own alias:
+
+@item --git
+@itemx -g
+Clones the git repository at @var{file} into a temporary directory and
+recursively hashes it, excluding the @file{.git} subdirectory.  This is
+mainly useful if you want to get the Guix hash of the current Git
+checkout:
+
+@example
+$ git clone http://example.org/foo.git
+$ cd foo
+# Hack a bunch of things, make some commits
+$ guix hash -g .
+@end example
+
 @end table
 
 @node Invoking guix import
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index a048b5346..f1ac3c38a 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix base16)
+  #:use-module (guix utils)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs files)
   #:use-module (ice-9 match)
@@ -32,7 +33,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
-  #:export (guix-hash))
+  #:export (guix-hash-git-checkout
+            guix-hash))
 
 
 ;;;
@@ -52,6 +54,9 @@ and 'hexadecimal' can be used as well).\n"))
   (format #t (_ "
   -x, --exclude-vcs      exclude version control directories"))
   (format #t (_ "
+  -g, --git              clone the git repository at FILE and hash it
+                         (implies -r)"))
+  (format #t (_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (_ "
   -r, --recursive        compute the hash on FILE recursively"))
@@ -68,6 +73,10 @@ and 'hexadecimal' can be used as well).\n"))
   (list (option '(#\x "exclude-vcs") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'exclude-vcs? #t result)))
+        (option '(#\g "git") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git? #t
+                              (alist-cons 'exclude-vcs? #t result))))
         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (define fmt-proc
@@ -98,6 +107,35 @@ and 'hexadecimal' can be used as well).\n"))
 
 
 ;;;
+;;; Helpers.
+;;;
+
+(define (vcs-file? file stat)
+  (case (stat:type stat)
+    ((directory)
+     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+    ((regular)
+     ;; Git sub-modules have a '.git' file that is a regular text file.
+     (string=? (basename file) ".git"))
+    (else
+     #f)))
+
+(define* (recursive-hash file #:key (select? (const #t)))
+  (let-values (((port get-hash) (open-sha256-port)))
+    (write-file file port #:select? select?)
+    (force-output port)
+    (get-hash)))
+
+(define (guix-hash-git-checkout directory)
+  (call-with-temporary-directory
+   (lambda (dir)
+     (let ((checkout (in-vicinity dir "git-checkout")))
+       (unless (zero? (system* "git" "clone" "--" directory checkout))
+         (leave (_ "git clone failed~%")))
+       (recursive-hash checkout #:select? (negate vcs-file?))))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -112,16 +150,6 @@ and 'hexadecimal' can be used as well).\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
-  (define (vcs-file? file stat)
-    (case (stat:type stat)
-      ((directory)
-       (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-      ((regular)
-       ;; Git sub-modules have a '.git' file that is a regular text file.
-       (string=? (basename file) ".git"))
-      (else
-       #f)))
-
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
@@ -137,14 +165,15 @@ and 'hexadecimal' can be used as well).\n"))
       ;; Compute the hash of FILE.
       ;; Catch and gracefully report possible '&nar-error' conditions.
       (with-error-handling
-        (if (assoc-ref opts 'recursive?)
-            (let-values (((port get-hash) (open-sha256-port)))
-              (write-file file port #:select? select?)
-              (force-output port)
-              (get-hash))
-            (match file
-              ("-" (port-sha256 (current-input-port)))
-              (_   (call-with-input-file file port-sha256))))))
+        (cond
+         ((assoc-ref opts 'git?)
+          (guix-hash-git-checkout file))
+         ((assoc-ref opts 'recursive?)
+          (recursive-hash file #:select? select))
+         (else
+          (match file
+            ("-" (port-sha256 (current-input-port)))
+            (_   (call-with-input-file file port-sha256)))))))
 
     (match args
       ((file)
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:54 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:53 2017
Received: from localhost ([127.0.0.1]:38453 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6L-0004Y4-Ii
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:53 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:50191
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5I-0004OW-14
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:53 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 2888B74D04
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=vuIy
 kyZV+GLSy3VaSk/3TUGbcyE=; b=umPGOfBqT0ef1fCihleola79tK2OaQUe14gC
 1CUdc/URQTkXDSzQxdrxWahRR6Sd5z5f0yxvPLBuvZBc8WhkEd1zSkc/2Q9tU//A
 e0Ak6uWIyvkbKfg4Osb6C3XS3k5FlRbxPPZKk/qnYSha8vnOEPJZYCuti0GPR3tp
 Lq+iOrY=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 1F94E74D02
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 1C21574CFD
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:41 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Date: Mon, 24 Apr 2017 22:59:16 +0200
Message-Id: <20170424205923.27726-2-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EF8FD914-2930-11E7-A4C7-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/hash.scm (show-help, %options): Add -g option.
(vcs-file?): Pull out to top.
(guix-hash-git-checkout): New function.
(guix-hash): Support hashing of Git URLs.
* doc/guix.texi (Invoking guix hash): Document guix hash --git.
---
 doc/guix.texi         | 17 +++++++++++++
 guix/scripts/hash.scm | 67 ++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 65 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0d334e302..7f1074f9d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5384,6 +5384,23 @@ $ git clone http://example.org/foo.git
 $ cd foo
 $ guix hash -rx .
 @end example
+
+Hashing a git checkout is so common that it has its own alias:
+
+@item --git
+@itemx -g
+Clones the git repository at @var{file} into a temporary directory and
+recursively hashes it, excluding the @file{.git} subdirectory.  This is
+mainly useful if you want to get the Guix hash of the current Git
+checkout:
+
+@example
+$ git clone http://example.org/foo.git
+$ cd foo
+# Hack a bunch of things, make some commits
+$ guix hash -g .
+@end example
+
 @end table
 
 @node Invoking guix import
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index a048b5346..f1ac3c38a 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix base16)
+  #:use-module (guix utils)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs files)
   #:use-module (ice-9 match)
@@ -32,7 +33,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
-  #:export (guix-hash))
+  #:export (guix-hash-git-checkout
+            guix-hash))
 
 
 ;;;
@@ -52,6 +54,9 @@ and 'hexadecimal' can be used as well).\n"))
   (format #t (_ "
   -x, --exclude-vcs      exclude version control directories"))
   (format #t (_ "
+  -g, --git              clone the git repository at FILE and hash it
+                         (implies -r)"))
+  (format #t (_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (_ "
   -r, --recursive        compute the hash on FILE recursively"))
@@ -68,6 +73,10 @@ and 'hexadecimal' can be used as well).\n"))
   (list (option '(#\x "exclude-vcs") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'exclude-vcs? #t result)))
+        (option '(#\g "git") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git? #t
+                              (alist-cons 'exclude-vcs? #t result))))
         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (define fmt-proc
@@ -98,6 +107,35 @@ and 'hexadecimal' can be used as well).\n"))
 
 
 ;;;
+;;; Helpers.
+;;;
+
+(define (vcs-file? file stat)
+  (case (stat:type stat)
+    ((directory)
+     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+    ((regular)
+     ;; Git sub-modules have a '.git' file that is a regular text file.
+     (string=? (basename file) ".git"))
+    (else
+     #f)))
+
+(define* (recursive-hash file #:key (select? (const #t)))
+  (let-values (((port get-hash) (open-sha256-port)))
+    (write-file file port #:select? select?)
+    (force-output port)
+    (get-hash)))
+
+(define (guix-hash-git-checkout directory)
+  (call-with-temporary-directory
+   (lambda (dir)
+     (let ((checkout (in-vicinity dir "git-checkout")))
+       (unless (zero? (system* "git" "clone" "--" directory checkout))
+         (leave (_ "git clone failed~%")))
+       (recursive-hash checkout #:select? (negate vcs-file?))))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -112,16 +150,6 @@ and 'hexadecimal' can be used as well).\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
-  (define (vcs-file? file stat)
-    (case (stat:type stat)
-      ((directory)
-       (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-      ((regular)
-       ;; Git sub-modules have a '.git' file that is a regular text file.
-       (string=? (basename file) ".git"))
-      (else
-       #f)))
-
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
@@ -137,14 +165,15 @@ and 'hexadecimal' can be used as well).\n"))
       ;; Compute the hash of FILE.
       ;; Catch and gracefully report possible '&nar-error' conditions.
       (with-error-handling
-        (if (assoc-ref opts 'recursive?)
-            (let-values (((port get-hash) (open-sha256-port)))
-              (write-file file port #:select? select?)
-              (force-output port)
-              (get-hash))
-            (match file
-              ("-" (port-sha256 (current-input-port)))
-              (_   (call-with-input-file file port-sha256))))))
+        (cond
+         ((assoc-ref opts 'git?)
+          (guix-hash-git-checkout file))
+         ((assoc-ref opts 'recursive?)
+          (recursive-hash file #:select? select))
+         (else
+          (match file
+            ("-" (port-sha256 (current-input-port)))
+            (_   (call-with-input-file file port-sha256)))))))
 
     (match args
       ((file)
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:53 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:53 2017
Received: from localhost ([127.0.0.1]:38451 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6K-0004Xx-O8
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:53 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:57905
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5H-0004Oc-Di
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:53 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 06DB274CF3
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:40 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=dap2
 9653BGrSWdSbYQB14G6nL+0=; b=URKj0KWlQU3fdrFA0qnacAdWkJeQvOd0Z2eV
 sQVca9WcWfznkFhxG/4nyfXrU7iXjemm1w08VBm83PpwyexxHBTJ9mHk1sbFLNF1
 kqIw2q0OWGLwICsL4mDnOgERVEjJi1vBg2m1hNiHnDoApqiZWXt0VJYCwAhzkzSN
 ETyEQrM=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id F39E374CF1
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 1838C74CD3
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:35 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 9/9] doc: Document guix potluck.
Date: Mon, 24 Apr 2017 22:59:23 +0200
Message-Id: <20170424205923.27726-9-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EC929D0A-2930-11E7-BB0C-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* doc/guix.texi (potluck-package Reference):
(Invoking guix potluck): New sections.
---
 doc/guix.texi | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 231 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7f1074f9d..f2aa52653 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -58,6 +58,7 @@ Documentation License''.
 * guix environment: (guix)Invoking guix environment. Building development environments with Guix.
 * guix build: (guix)Invoking guix build.      Building packages.
 * guix pack: (guix)Invoking guix pack.        Creating binary bundles.
+* guix potluck: (guix)Invoking guix potluck.  Publishing package definitions.
 @end direntry
 
 @titlepage
@@ -137,6 +138,7 @@ Defining Packages
 
 * package Reference::           The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 
 Utilities
 
@@ -154,6 +156,7 @@ Utilities
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Simple, decoupled package development.
 
 Invoking @command{guix build}
 
@@ -2976,6 +2979,7 @@ when @var{cut?} returns true for a given package.
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 @end menu
 
 
@@ -3192,6 +3196,115 @@ this is @code{#f}, a sensible default is used.
 @end table
 @end deftp
 
+@node potluck-package Reference
+@subsection @code{potluck-package} Reference
+
+This section defines all the options available in @code{potluck-package}
+declarations.  @xref{Invoking guix potluck}, for more background and for
+information on how to work with potluck packages from the command-line
+interface.
+
+@deftp {Data Type} potluck-package
+This is the data type representing a potluck package recipe.
+
+@table @asis
+@item @code{name}
+The name of the package, as a string.
+
+@item @code{version}
+The version of the package, as a string.
+
+@item @code{source}
+An object telling how the source code for the package should be
+acquired.  This is a @code{potluck-source} object, which itself is its
+own data type:
+
+@deftp {Data Type} potluck-source
+This is the data type representing a potluck package's source code.
+
+@table @asis
+@item @code{git-uri}
+An object containing the URI of the source git repository.  Currently
+potluck packages all come from Git.  Use the ``normal'' Guix packages if
+you need to build from some other source.
+
+@item @code{git-commit}
+The given git commit for the source, for example as a sha1 string.
+
+@item @code{sha256}
+A bytevector containing the SHA-256 hash of the source, as a base32
+string.  Note that the explicit @code{base32} wrapper that is needed for
+normal Guix packages is not present in a potluck package source.
+
+You can obtain this information using @code{guix hash -g}
+(@pxref{Invoking guix hash}).
+
+@item @code{snippet} (default: @code{#f})
+An S-expression that will be run in the source directory.  This is a
+convenient way to modify the source, sometimes more convenient than a
+patch.
+@end table
+@end deftp
+
+@item @code{build-system}
+The build system that should be used to build the package, as a symbol.
+For example, @code{gnu}.  To list available build systems, use
+@code{guix potluck init --build-system=help} (@pxref{Invoking guix
+potluck}).
+
+@item @code{arguments} (default: @code{'()})
+The arguments that should be passed to the build system.  This is a
+list, typically containing sequential keyword-value pairs, and is the
+same as for the @code{arguments} argument of a normal @code{package}
+object.
+
+@item @code{inputs} (default: @code{'()})
+@itemx @code{native-inputs} (default: @code{'()})
+@itemx @code{propagated-inputs} (default: @code{'()})
+@cindex inputs, of packages
+These fields list dependencies of the package.  Each item of an input
+list is a package specification string, for example @code{guile} or
+@code{guile@@2.0} or, in the most specific form, @code{guile@@2.0:out}.
+@xref{Packages with Multiple Outputs}, for more on package outputs.  For
+example, the list below specifies three inputs:
+
+@example
+'("libffi" "libunistring" "glib:bin")
+@end example
+
+@cindex cross compilation, package dependencies
+The distinction between @code{native-inputs} and @code{inputs} is
+necessary when considering cross-compilation.
+
+@xref{package Reference}, for full details on the differences between
+these input types.
+
+@item @code{synopsis}
+A one-line description of the package.
+
+@item @code{description}
+A more elaborate description of the package.
+
+@item @code{license}
+The license of the package, as a symbol.  For example, @code{gpl3+}.  To
+list available build systems, use @code{guix potluck init
+--license=help} (@pxref{Invoking guix potluck}).
+
+@item @code{home-page}
+The URL to the home-page of the package, as a string.
+
+@item @code{location} (default: source location of the @code{package} form)
+The source location of the package.  It is useful to override this when
+inheriting from another package, in which case this field is not
+automatically corrected.
+@end table
+@end deftp
+
+As you can see, a potluck package is less elaborate than a normal Guix
+package.  If you find yourself needing more advanced features, probably
+your package should be a part of Guix proper.  But if not, a potluck
+package can often do the job.
+
 
 @node Build Systems
 @section Build Systems
@@ -4779,6 +4892,7 @@ the Scheme programming interface of Guix in a convenient way.
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Decoupled package definition.
 @end menu
 
 @node Invoking guix build
@@ -6997,6 +7111,123 @@ must be PID 1 of the container or one of its child processes.
 
 @end table
 
+@node Invoking guix potluck
+@section Invoking @command{guix potluck}
+@cindex potluck
+@cindex @command{guix potluck}
+@quotation Note
+As of version @value{VERSION}, this tool is experimental.  The interface
+is subject to radical change in the future.
+@end quotation
+
+Guix is developed as a unified project composed of both the package
+manager and the set of packages.  This allows Guix to evolve while
+remaining healthy and coherent.  If there is a change that needs to be
+done across Guix's entire tree, Guix developers can make it happen.  One
+way in which this principle manifests itself is in the @code{package}
+data type, where input packages are directly specified by value in the
+@code{inputs}, @code{native-inputs}, and @code{propagated-inputs}
+fields, instead of being specified as some abstract package name and
+version constraint that Guix would have to solve for.  @xref{package
+Reference}, for more on the @code{package} data type.
+
+However it is sometimes desirable to develop a package or set of
+packages in a more decoupled way, for example when a package set is
+still incubating or when a package is inappropriate for sending upstream
+for some reason.  Such packages use Guix and extend Guix but are not a
+part of the Guix project, properly speaking.  As such, they need to be
+resilient to changes in upstream Guix.  It would be brittle if such a
+package definition had to reference a Guix package by value; the Scheme
+variable denoting the upstream Guix package might move to a different
+module, or be renamed, or changed in some unexpected way.
+
+Guix's @dfn{potluck} facility fills this gap.  A @dfn{potluck package}
+is like a normal Guix package, except it expresses its inputs in the
+form of package specifications instead of direct references.
+@xref{potluck-package Reference}.  Potluck packages also have a simpler
+package structure with fewer fields; compared to normal Guix packages,
+they are less expressive but more isolated from details of upstream
+Guix.
+
+The user interface to potluck packages is concentrated in the
+@command{guix potluck} command.  To begin, let's say you are a developer
+of the @code{foo} project, and you'd like to package @code{foo} for use
+in your Guix system and maybe also that of a friend.  You're not sure if
+you want to support it yet so you don't want to make a proper release,
+but there should be something in the middle between that and not
+packaging it at all.  You decide to give @code{guix potluck} a go.
+
+So in that git checkout, you run @code{guix potluck init @var{url}},
+where @var{url} is a publicly accessible git URL at which @code{foo} is
+hosted.  @code{guix potluck init} takes the following options:
+
+@table @code
+@item --build-system=@var{sys}
+@itemx --build-system=help
+@itemx --autotools
+Indicate that the package uses the build system named @var{sys}.  Pass
+@code{help} as the build system to see available options.
+@code{--autotools} is like the common @code{--build-system=gnu}, but
+additionally indicating that an @code{autoreconf} step is needed before
+building.
+@item --license=@var{license}
+@itemx --license=help
+Specify the license of the project.
+@end table
+
+Calling @code{guix potluck init} will result in the creation of a
+@code{guix-potluck} directory in your git checkout, containing a brief
+overview @code{README.md} file as well as a @code{foo.scm} potluck
+package definition.  @xref{potluck-package Reference}.  Just fill in the
+synopsis and description and add the inputs and you have the beginnings
+of a potluck package.
+
+You can try building your new package by running @code{guix build -f
+guix-potluck/foo.scm}.  Once that works, you can share the file with
+your friends and they can build your package too.
+
+Of course, it would be nice if you could share that package with the
+world.  And it would be nice if your potluck package definitions could
+augment the set of available packages and versions.  And it would be
+nice if your potluck package could serve as a first draft of a proper
+Guix package definition.  We agree completely!
+
+Guix's potluck facility also implements a kind of registry of potluck
+recipes, as if it were hosting an actual potluck.  This
+@code{host-channel} facility takes requests to add potluck packages and
+translates that into a git repository of all potluck packages, as well
+as a git repository of Guix packages compiled from those potluck
+packages.
+
+To inform a channel host of the presence of fresh tasty potluck dishes,
+run @code{guix potluck update @var{url} @var{branch}}.  @var{url} should
+be the URL of a git repository containing a @code{guix-potluck}
+directory, and @var{branch} is a ref in that repository.  By default,
+the request is made to add the package to the default
+@code{guix-potluck.org} host; pass @code{--host=@var{host}} to specify
+an alternate registry.
+
+Running @code{guix potluck update} will simply enqueue an update request
+on the server.  Visit @code{https://@var{host}/} in your browser to see
+the state of the work queue, and to see whether your package update
+actually succeeded.  If it does succeed, you should be able to check out
+the git repository conventionally hosted at
+@indicateurl{https://@var{host}/git/main.git}, add that checkout to your
+@code{GUIX_PACKAGE_PATH}, and thereby have access to that package.  In
+the future this will be made easier with a @code{guix channel} facility,
+but for now you have to use @code{GUIX_PACKAGE_PATH} or similar.
+@xref{Defining Packages}, for more information.
+
+Finally, there is the code that actually runs the potluck service:
+@code{guix potluck host-channel}.  This tool will host a web server on
+localhost, listening on port 8080 by default.  It expects to be behind
+some kind of HTTPS terminator, like @code{nginx}.  It does the work of
+translating update requests to git repositories.  Guix includes an
+example operating system definition for a server combining HTTPS access
+to git repositories, an @code{nginx} web front-end, and a @code{guix
+potluck host-channel} instance.
+
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:52 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:52 2017
Received: from localhost ([127.0.0.1]:38449 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6K-0004Xp-6T
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:52 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:64165
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5H-0004Ow-Qs
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:53 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id A9A0174CF7
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:40 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=uY1rC0pj+vzX
 sMAC3yJaGZCOMP0=; b=ql0GkvknTUoCEf/TvRiL5YaqW/hlUTmQclV8t7Yd4E8K
 rRaI/Samo9Iacxk6wRrZxYbwhq5NzKcvPY8Pwhg8rMwPFZIBonUS8KL6K+aFD1Bx
 HsAEbRDSoDR3gjhiabGAP4pK04vlhLeLns/6XsD5fqltl4yjF95aZXPpfV0aQiE=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id A257374CF5
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:40 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id B5A3F74CEF
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 3/9] guix: Add git utility module.
Date: Mon, 24 Apr 2017 22:59:17 +0200
Message-Id: <20170424205923.27726-3-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: EEBE2BC6-2930-11E7-A808-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/git.scm: New file.
* Makefile.am (MODULES): Add new file.
---
 Makefile.am  |   1 +
 guix/git.scm | 164 +++++++++++++++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 165 insertions(+)
 create mode 100644 guix/git.scm

diff --git a/Makefile.am b/Makefile.am
index 22ba00e90..64a7a9265 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,7 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/git.scm					\
   guix/potluck/build-systems.scm		\
   guix/potluck/licenses.scm			\
   guix/potluck/packages.scm			\
diff --git a/guix/git.scm b/guix/git.scm
new file mode 100644
index 000000000..02f61edac
--- /dev/null
+++ b/guix/git.scm
@@ -0,0 +1,164 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 (guix utils)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:export (&git-condition
+            git-condition?
+            git-condition-argv
+            git-condition-output
+            git-condition-status
+
+            false-if-git-error
+
+            git-check-ref-format
+            git-rev-parse
+            git-config
+            git-describe
+            git-fetch
+            git-push
+            git-clone
+            git-reset
+            git-add
+            git-commit))
+
+;;; Commentary:
+;;;
+;;; A simple collection of Scheme wrappers for Git functionality.
+;;;
+;;; Code:
+
+(define-condition-type &git-condition &condition git-condition?
+  (argv git-condition-argv)
+  (output git-condition-output)
+  (status git-condition-status))
+
+(define-syntax-rule (false-if-git-error body0 body ...)
+  (guard (c ((git-condition? c) #f))
+    body0 body ...))
+
+(define (shell:quote str)
+  (with-output-to-string
+    (lambda ()
+      (display #\')
+      (string-for-each (lambda (ch)
+                         (if (eqv? ch #\')
+                             (begin (display #\\) (display #\'))
+                             (display ch)))
+                       str)
+      (display #\'))))
+
+(define (run env input-file args)
+  (define (prepend-env args)
+    (if (null? env)
+        args
+        (cons "env" (append env args))))
+  (define (redirect-input args)
+    (if input-file
+        (list "sh" "-c"
+              (string-append (string-join (map shell:quote args) " ")
+                             "<" input-file))
+        args))
+  (let* ((real-args (redirect-input (prepend-env args)))
+         (pipe (apply open-pipe* OPEN_READ real-args))
+         (output (read-string pipe))
+         (ret (close-pipe pipe)))
+    (case (status:exit-val ret)
+      ((0) output)
+      (else (raise (condition (&git-condition
+                               (argv real-args)
+                               (output output)
+                               (status ret))))))))
+
+(define* (git* args #:key (input #f) (env '()))
+  (if input
+      (call-with-temporary-output-file
+       (lambda (file-name file-port)
+         (display input file-port)
+         (close-port file-port)
+         (run env file-name (cons* "git" args))))
+      (run env #f (cons* "git" args))))
+
+(define (git . args)
+  (git* args))
+
+(define* (git-check-ref-format str #:key allow-onelevel?)
+  "Raise an exception if @var{str} is not a valid Git ref."
+  (when (string-prefix? "-" str)
+    (error "bad ref" str))
+  (git "check-ref-format"
+       (if allow-onelevel? "--allow-onelevel" "--no-allow-onelevel")
+       str))
+
+(define (git-rev-parse rev)
+  "Parse the string @var{rev} and return a Git commit hash, as a string.=
"
+  (string-trim-both (git "rev-parse" rev)))
+
+(define (git-config key)
+  "Return the configuration value for @var{key}, as a string."
+  (string-trim-both (git "config" key)))
+
+(define* (git-describe #:optional (ref "HEAD"))
+  "Run @command{git describe} on the given @var{ref}, defaulting to
+@code{HEAD}, and return the resulting string."
+  (string-trim-both (git "describe")))
+
+(define (git-fetch)
+  "Run @command{git fetch} in the current working directory."
+  (git "fetch"))
+
+(define (git-push)
+  "Run @command{git push} in the current working directory."
+  (git "push"))
+
+(define (git-clone repo dir)
+  "Check out @var{repo} into @var{dir}."
+  (git "clone" "--" repo dir))
+
+(define* (git-reset #:key (ref "HEAD") (mode 'hard))
+  ;; Can't let the ref be mistaken for a command-line argument.
+  "Reset the current working directory to @var{ref}.  Available values f=
or
+@var{mode} are the symbols @code{hard}, @code{soft}, and @code{mixed}."
+  (when (string-prefix? "-" ref)
+    (error "bad ref" ref))
+  (git "reset"
+       (case mode
+         ((hard) "--hard")
+         ((mixed) "--mixed")
+         ((soft) "--soft")
+         (else (error "unknown mode" mode)))
+       ref))
+
+(define (git-add file)
+  "Add @var{file} to the index in the current working directory."
+  (git "add" "--" file))
+
+(define* (git-commit #:key message author-name author-email)
+  "Commit the changes in the current working directory, with the message
+@var{message}.  The commit will be attributed to the author with the nam=
e and
+email address @var{author-name} and @var{author-email}, respectively."
+  (git* (list "commit" (string-append "--message=3D" message))
+        #:env (list (string-append "GIT_COMMITTER_NAME=3D" author-name)
+                    (string-append "GIT_COMMITTER_EMAIL=3D" author-email=
)
+                    (string-append "GIT_AUTHOR_NAME=3D" author-name)
+                    (string-append "GIT_AUTHOR_EMAIL=3D" author-email)))=
)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:52 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:52 2017
Received: from localhost ([127.0.0.1]:38447 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6J-0004Xi-P0
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:52 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:58648
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5H-0004Pd-Sl
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:53 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 0FC9F74D00
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=vuIy
 kyZV+GLSy3VaSk/3TUGbcyE=; b=umPGOfBqT0ef1fCihleola79tK2OaQUe14gC
 1CUdc/URQTkXDSzQxdrxWahRR6Sd5z5f0yxvPLBuvZBc8WhkEd1zSkc/2Q9tU//A
 e0Ak6uWIyvkbKfg4Osb6C3XS3k5FlRbxPPZKk/qnYSha8vnOEPJZYCuti0GPR3tp
 Lq+iOrY=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 086A574CFF
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:42 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id E855974CFA
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:40 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Date: Mon, 24 Apr 2017 22:59:16 +0200
Message-Id: <20170424205923.27726-2-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EF76D9F0-2930-11E7-956B-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/hash.scm (show-help, %options): Add -g option.
(vcs-file?): Pull out to top.
(guix-hash-git-checkout): New function.
(guix-hash): Support hashing of Git URLs.
* doc/guix.texi (Invoking guix hash): Document guix hash --git.
---
 doc/guix.texi         | 17 +++++++++++++
 guix/scripts/hash.scm | 67 ++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 65 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0d334e302..7f1074f9d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5384,6 +5384,23 @@ $ git clone http://example.org/foo.git
 $ cd foo
 $ guix hash -rx .
 @end example
+
+Hashing a git checkout is so common that it has its own alias:
+
+@item --git
+@itemx -g
+Clones the git repository at @var{file} into a temporary directory and
+recursively hashes it, excluding the @file{.git} subdirectory.  This is
+mainly useful if you want to get the Guix hash of the current Git
+checkout:
+
+@example
+$ git clone http://example.org/foo.git
+$ cd foo
+# Hack a bunch of things, make some commits
+$ guix hash -g .
+@end example
+
 @end table
 
 @node Invoking guix import
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index a048b5346..f1ac3c38a 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix base16)
+  #:use-module (guix utils)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs files)
   #:use-module (ice-9 match)
@@ -32,7 +33,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
-  #:export (guix-hash))
+  #:export (guix-hash-git-checkout
+            guix-hash))
 
 
 ;;;
@@ -52,6 +54,9 @@ and 'hexadecimal' can be used as well).\n"))
   (format #t (_ "
   -x, --exclude-vcs      exclude version control directories"))
   (format #t (_ "
+  -g, --git              clone the git repository at FILE and hash it
+                         (implies -r)"))
+  (format #t (_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (_ "
   -r, --recursive        compute the hash on FILE recursively"))
@@ -68,6 +73,10 @@ and 'hexadecimal' can be used as well).\n"))
   (list (option '(#\x "exclude-vcs") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'exclude-vcs? #t result)))
+        (option '(#\g "git") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git? #t
+                              (alist-cons 'exclude-vcs? #t result))))
         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (define fmt-proc
@@ -98,6 +107,35 @@ and 'hexadecimal' can be used as well).\n"))
 
 
 ;;;
+;;; Helpers.
+;;;
+
+(define (vcs-file? file stat)
+  (case (stat:type stat)
+    ((directory)
+     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+    ((regular)
+     ;; Git sub-modules have a '.git' file that is a regular text file.
+     (string=? (basename file) ".git"))
+    (else
+     #f)))
+
+(define* (recursive-hash file #:key (select? (const #t)))
+  (let-values (((port get-hash) (open-sha256-port)))
+    (write-file file port #:select? select?)
+    (force-output port)
+    (get-hash)))
+
+(define (guix-hash-git-checkout directory)
+  (call-with-temporary-directory
+   (lambda (dir)
+     (let ((checkout (in-vicinity dir "git-checkout")))
+       (unless (zero? (system* "git" "clone" "--" directory checkout))
+         (leave (_ "git clone failed~%")))
+       (recursive-hash checkout #:select? (negate vcs-file?))))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -112,16 +150,6 @@ and 'hexadecimal' can be used as well).\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
-  (define (vcs-file? file stat)
-    (case (stat:type stat)
-      ((directory)
-       (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-      ((regular)
-       ;; Git sub-modules have a '.git' file that is a regular text file.
-       (string=? (basename file) ".git"))
-      (else
-       #f)))
-
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
@@ -137,14 +165,15 @@ and 'hexadecimal' can be used as well).\n"))
       ;; Compute the hash of FILE.
       ;; Catch and gracefully report possible '&nar-error' conditions.
       (with-error-handling
-        (if (assoc-ref opts 'recursive?)
-            (let-values (((port get-hash) (open-sha256-port)))
-              (write-file file port #:select? select?)
-              (force-output port)
-              (get-hash))
-            (match file
-              ("-" (port-sha256 (current-input-port)))
-              (_   (call-with-input-file file port-sha256))))))
+        (cond
+         ((assoc-ref opts 'git?)
+          (guix-hash-git-checkout file))
+         ((assoc-ref opts 'recursive?)
+          (recursive-hash file #:select? select))
+         (else
+          (match file
+            ("-" (port-sha256 (current-input-port)))
+            (_   (call-with-input-file file port-sha256)))))))
 
     (match args
       ((file)
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:51 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:51 2017
Received: from localhost ([127.0.0.1]:38445 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6J-0004Xa-Cf
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:51 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:63999
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5H-0004PY-Gh
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:52 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id A3F9D74CF6
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:40 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=vuIy
 kyZV+GLSy3VaSk/3TUGbcyE=; b=umPGOfBqT0ef1fCihleola79tK2OaQUe14gC
 1CUdc/URQTkXDSzQxdrxWahRR6Sd5z5f0yxvPLBuvZBc8WhkEd1zSkc/2Q9tU//A
 e0Ak6uWIyvkbKfg4Osb6C3XS3k5FlRbxPPZKk/qnYSha8vnOEPJZYCuti0GPR3tp
 Lq+iOrY=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 9D00774CF4
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:40 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id B643574CF0
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Date: Mon, 24 Apr 2017 22:59:16 +0200
Message-Id: <20170424205923.27726-2-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EEBF3124-2930-11E7-BF54-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/hash.scm (show-help, %options): Add -g option.
(vcs-file?): Pull out to top.
(guix-hash-git-checkout): New function.
(guix-hash): Support hashing of Git URLs.
* doc/guix.texi (Invoking guix hash): Document guix hash --git.
---
 doc/guix.texi         | 17 +++++++++++++
 guix/scripts/hash.scm | 67 ++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 65 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0d334e302..7f1074f9d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5384,6 +5384,23 @@ $ git clone http://example.org/foo.git
 $ cd foo
 $ guix hash -rx .
 @end example
+
+Hashing a git checkout is so common that it has its own alias:
+
+@item --git
+@itemx -g
+Clones the git repository at @var{file} into a temporary directory and
+recursively hashes it, excluding the @file{.git} subdirectory.  This is
+mainly useful if you want to get the Guix hash of the current Git
+checkout:
+
+@example
+$ git clone http://example.org/foo.git
+$ cd foo
+# Hack a bunch of things, make some commits
+$ guix hash -g .
+@end example
+
 @end table
 
 @node Invoking guix import
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index a048b5346..f1ac3c38a 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix base16)
+  #:use-module (guix utils)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs files)
   #:use-module (ice-9 match)
@@ -32,7 +33,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
-  #:export (guix-hash))
+  #:export (guix-hash-git-checkout
+            guix-hash))
 
 
 ;;;
@@ -52,6 +54,9 @@ and 'hexadecimal' can be used as well).\n"))
   (format #t (_ "
   -x, --exclude-vcs      exclude version control directories"))
   (format #t (_ "
+  -g, --git              clone the git repository at FILE and hash it
+                         (implies -r)"))
+  (format #t (_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (_ "
   -r, --recursive        compute the hash on FILE recursively"))
@@ -68,6 +73,10 @@ and 'hexadecimal' can be used as well).\n"))
   (list (option '(#\x "exclude-vcs") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'exclude-vcs? #t result)))
+        (option '(#\g "git") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git? #t
+                              (alist-cons 'exclude-vcs? #t result))))
         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (define fmt-proc
@@ -98,6 +107,35 @@ and 'hexadecimal' can be used as well).\n"))
 
 
 ;;;
+;;; Helpers.
+;;;
+
+(define (vcs-file? file stat)
+  (case (stat:type stat)
+    ((directory)
+     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+    ((regular)
+     ;; Git sub-modules have a '.git' file that is a regular text file.
+     (string=? (basename file) ".git"))
+    (else
+     #f)))
+
+(define* (recursive-hash file #:key (select? (const #t)))
+  (let-values (((port get-hash) (open-sha256-port)))
+    (write-file file port #:select? select?)
+    (force-output port)
+    (get-hash)))
+
+(define (guix-hash-git-checkout directory)
+  (call-with-temporary-directory
+   (lambda (dir)
+     (let ((checkout (in-vicinity dir "git-checkout")))
+       (unless (zero? (system* "git" "clone" "--" directory checkout))
+         (leave (_ "git clone failed~%")))
+       (recursive-hash checkout #:select? (negate vcs-file?))))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -112,16 +150,6 @@ and 'hexadecimal' can be used as well).\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
-  (define (vcs-file? file stat)
-    (case (stat:type stat)
-      ((directory)
-       (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-      ((regular)
-       ;; Git sub-modules have a '.git' file that is a regular text file.
-       (string=? (basename file) ".git"))
-      (else
-       #f)))
-
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
@@ -137,14 +165,15 @@ and 'hexadecimal' can be used as well).\n"))
       ;; Compute the hash of FILE.
       ;; Catch and gracefully report possible '&nar-error' conditions.
       (with-error-handling
-        (if (assoc-ref opts 'recursive?)
-            (let-values (((port get-hash) (open-sha256-port)))
-              (write-file file port #:select? select?)
-              (force-output port)
-              (get-hash))
-            (match file
-              ("-" (port-sha256 (current-input-port)))
-              (_   (call-with-input-file file port-sha256))))))
+        (cond
+         ((assoc-ref opts 'git?)
+          (guix-hash-git-checkout file))
+         ((assoc-ref opts 'recursive?)
+          (recursive-hash file #:select? select))
+         (else
+          (match file
+            ("-" (port-sha256 (current-input-port)))
+            (_   (call-with-input-file file port-sha256)))))))
 
     (match args
       ((file)
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:51 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:51 2017
Received: from localhost ([127.0.0.1]:38443 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6I-0004XT-Lf
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:51 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:64288
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5H-0004PP-5j
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:52 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id B338574CEE
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=dap2
 9653BGrSWdSbYQB14G6nL+0=; b=URKj0KWlQU3fdrFA0qnacAdWkJeQvOd0Z2eV
 sQVca9WcWfznkFhxG/4nyfXrU7iXjemm1w08VBm83PpwyexxHBTJ9mHk1sbFLNF1
 kqIw2q0OWGLwICsL4mDnOgERVEjJi1vBg2m1hNiHnDoApqiZWXt0VJYCwAhzkzSN
 ETyEQrM=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id AC5D574CEC
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 27BD174CD4
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:36 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 9/9] doc: Document guix potluck.
Date: Mon, 24 Apr 2017 22:59:23 +0200
Message-Id: <20170424205923.27726-9-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EC9BED06-2930-11E7-9D2E-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* doc/guix.texi (potluck-package Reference):
(Invoking guix potluck): New sections.
---
 doc/guix.texi | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 231 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7f1074f9d..f2aa52653 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -58,6 +58,7 @@ Documentation License''.
 * guix environment: (guix)Invoking guix environment. Building development environments with Guix.
 * guix build: (guix)Invoking guix build.      Building packages.
 * guix pack: (guix)Invoking guix pack.        Creating binary bundles.
+* guix potluck: (guix)Invoking guix potluck.  Publishing package definitions.
 @end direntry
 
 @titlepage
@@ -137,6 +138,7 @@ Defining Packages
 
 * package Reference::           The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 
 Utilities
 
@@ -154,6 +156,7 @@ Utilities
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Simple, decoupled package development.
 
 Invoking @command{guix build}
 
@@ -2976,6 +2979,7 @@ when @var{cut?} returns true for a given package.
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 @end menu
 
 
@@ -3192,6 +3196,115 @@ this is @code{#f}, a sensible default is used.
 @end table
 @end deftp
 
+@node potluck-package Reference
+@subsection @code{potluck-package} Reference
+
+This section defines all the options available in @code{potluck-package}
+declarations.  @xref{Invoking guix potluck}, for more background and for
+information on how to work with potluck packages from the command-line
+interface.
+
+@deftp {Data Type} potluck-package
+This is the data type representing a potluck package recipe.
+
+@table @asis
+@item @code{name}
+The name of the package, as a string.
+
+@item @code{version}
+The version of the package, as a string.
+
+@item @code{source}
+An object telling how the source code for the package should be
+acquired.  This is a @code{potluck-source} object, which itself is its
+own data type:
+
+@deftp {Data Type} potluck-source
+This is the data type representing a potluck package's source code.
+
+@table @asis
+@item @code{git-uri}
+An object containing the URI of the source git repository.  Currently
+potluck packages all come from Git.  Use the ``normal'' Guix packages if
+you need to build from some other source.
+
+@item @code{git-commit}
+The given git commit for the source, for example as a sha1 string.
+
+@item @code{sha256}
+A bytevector containing the SHA-256 hash of the source, as a base32
+string.  Note that the explicit @code{base32} wrapper that is needed for
+normal Guix packages is not present in a potluck package source.
+
+You can obtain this information using @code{guix hash -g}
+(@pxref{Invoking guix hash}).
+
+@item @code{snippet} (default: @code{#f})
+An S-expression that will be run in the source directory.  This is a
+convenient way to modify the source, sometimes more convenient than a
+patch.
+@end table
+@end deftp
+
+@item @code{build-system}
+The build system that should be used to build the package, as a symbol.
+For example, @code{gnu}.  To list available build systems, use
+@code{guix potluck init --build-system=help} (@pxref{Invoking guix
+potluck}).
+
+@item @code{arguments} (default: @code{'()})
+The arguments that should be passed to the build system.  This is a
+list, typically containing sequential keyword-value pairs, and is the
+same as for the @code{arguments} argument of a normal @code{package}
+object.
+
+@item @code{inputs} (default: @code{'()})
+@itemx @code{native-inputs} (default: @code{'()})
+@itemx @code{propagated-inputs} (default: @code{'()})
+@cindex inputs, of packages
+These fields list dependencies of the package.  Each item of an input
+list is a package specification string, for example @code{guile} or
+@code{guile@@2.0} or, in the most specific form, @code{guile@@2.0:out}.
+@xref{Packages with Multiple Outputs}, for more on package outputs.  For
+example, the list below specifies three inputs:
+
+@example
+'("libffi" "libunistring" "glib:bin")
+@end example
+
+@cindex cross compilation, package dependencies
+The distinction between @code{native-inputs} and @code{inputs} is
+necessary when considering cross-compilation.
+
+@xref{package Reference}, for full details on the differences between
+these input types.
+
+@item @code{synopsis}
+A one-line description of the package.
+
+@item @code{description}
+A more elaborate description of the package.
+
+@item @code{license}
+The license of the package, as a symbol.  For example, @code{gpl3+}.  To
+list available build systems, use @code{guix potluck init
+--license=help} (@pxref{Invoking guix potluck}).
+
+@item @code{home-page}
+The URL to the home-page of the package, as a string.
+
+@item @code{location} (default: source location of the @code{package} form)
+The source location of the package.  It is useful to override this when
+inheriting from another package, in which case this field is not
+automatically corrected.
+@end table
+@end deftp
+
+As you can see, a potluck package is less elaborate than a normal Guix
+package.  If you find yourself needing more advanced features, probably
+your package should be a part of Guix proper.  But if not, a potluck
+package can often do the job.
+
 
 @node Build Systems
 @section Build Systems
@@ -4779,6 +4892,7 @@ the Scheme programming interface of Guix in a convenient way.
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Decoupled package definition.
 @end menu
 
 @node Invoking guix build
@@ -6997,6 +7111,123 @@ must be PID 1 of the container or one of its child processes.
 
 @end table
 
+@node Invoking guix potluck
+@section Invoking @command{guix potluck}
+@cindex potluck
+@cindex @command{guix potluck}
+@quotation Note
+As of version @value{VERSION}, this tool is experimental.  The interface
+is subject to radical change in the future.
+@end quotation
+
+Guix is developed as a unified project composed of both the package
+manager and the set of packages.  This allows Guix to evolve while
+remaining healthy and coherent.  If there is a change that needs to be
+done across Guix's entire tree, Guix developers can make it happen.  One
+way in which this principle manifests itself is in the @code{package}
+data type, where input packages are directly specified by value in the
+@code{inputs}, @code{native-inputs}, and @code{propagated-inputs}
+fields, instead of being specified as some abstract package name and
+version constraint that Guix would have to solve for.  @xref{package
+Reference}, for more on the @code{package} data type.
+
+However it is sometimes desirable to develop a package or set of
+packages in a more decoupled way, for example when a package set is
+still incubating or when a package is inappropriate for sending upstream
+for some reason.  Such packages use Guix and extend Guix but are not a
+part of the Guix project, properly speaking.  As such, they need to be
+resilient to changes in upstream Guix.  It would be brittle if such a
+package definition had to reference a Guix package by value; the Scheme
+variable denoting the upstream Guix package might move to a different
+module, or be renamed, or changed in some unexpected way.
+
+Guix's @dfn{potluck} facility fills this gap.  A @dfn{potluck package}
+is like a normal Guix package, except it expresses its inputs in the
+form of package specifications instead of direct references.
+@xref{potluck-package Reference}.  Potluck packages also have a simpler
+package structure with fewer fields; compared to normal Guix packages,
+they are less expressive but more isolated from details of upstream
+Guix.
+
+The user interface to potluck packages is concentrated in the
+@command{guix potluck} command.  To begin, let's say you are a developer
+of the @code{foo} project, and you'd like to package @code{foo} for use
+in your Guix system and maybe also that of a friend.  You're not sure if
+you want to support it yet so you don't want to make a proper release,
+but there should be something in the middle between that and not
+packaging it at all.  You decide to give @code{guix potluck} a go.
+
+So in that git checkout, you run @code{guix potluck init @var{url}},
+where @var{url} is a publicly accessible git URL at which @code{foo} is
+hosted.  @code{guix potluck init} takes the following options:
+
+@table @code
+@item --build-system=@var{sys}
+@itemx --build-system=help
+@itemx --autotools
+Indicate that the package uses the build system named @var{sys}.  Pass
+@code{help} as the build system to see available options.
+@code{--autotools} is like the common @code{--build-system=gnu}, but
+additionally indicating that an @code{autoreconf} step is needed before
+building.
+@item --license=@var{license}
+@itemx --license=help
+Specify the license of the project.
+@end table
+
+Calling @code{guix potluck init} will result in the creation of a
+@code{guix-potluck} directory in your git checkout, containing a brief
+overview @code{README.md} file as well as a @code{foo.scm} potluck
+package definition.  @xref{potluck-package Reference}.  Just fill in the
+synopsis and description and add the inputs and you have the beginnings
+of a potluck package.
+
+You can try building your new package by running @code{guix build -f
+guix-potluck/foo.scm}.  Once that works, you can share the file with
+your friends and they can build your package too.
+
+Of course, it would be nice if you could share that package with the
+world.  And it would be nice if your potluck package definitions could
+augment the set of available packages and versions.  And it would be
+nice if your potluck package could serve as a first draft of a proper
+Guix package definition.  We agree completely!
+
+Guix's potluck facility also implements a kind of registry of potluck
+recipes, as if it were hosting an actual potluck.  This
+@code{host-channel} facility takes requests to add potluck packages and
+translates that into a git repository of all potluck packages, as well
+as a git repository of Guix packages compiled from those potluck
+packages.
+
+To inform a channel host of the presence of fresh tasty potluck dishes,
+run @code{guix potluck update @var{url} @var{branch}}.  @var{url} should
+be the URL of a git repository containing a @code{guix-potluck}
+directory, and @var{branch} is a ref in that repository.  By default,
+the request is made to add the package to the default
+@code{guix-potluck.org} host; pass @code{--host=@var{host}} to specify
+an alternate registry.
+
+Running @code{guix potluck update} will simply enqueue an update request
+on the server.  Visit @code{https://@var{host}/} in your browser to see
+the state of the work queue, and to see whether your package update
+actually succeeded.  If it does succeed, you should be able to check out
+the git repository conventionally hosted at
+@indicateurl{https://@var{host}/git/main.git}, add that checkout to your
+@code{GUIX_PACKAGE_PATH}, and thereby have access to that package.  In
+the future this will be made easier with a @code{guix channel} facility,
+but for now you have to use @code{GUIX_PACKAGE_PATH} or similar.
+@xref{Defining Packages}, for more information.
+
+Finally, there is the code that actually runs the potluck service:
+@code{guix potluck host-channel}.  This tool will host a web server on
+localhost, listening on port 8080 by default.  It expects to be behind
+some kind of HTTPS terminator, like @code{nginx}.  It does the work of
+translating update requests to git repositories.  Guix includes an
+example operating system definition for a server combining HTTPS access
+to git repositories, an @code{nginx} web front-end, and a @code{guix
+potluck host-channel} instance.
+
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:50 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:50 2017
Received: from localhost ([127.0.0.1]:38441 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6H-0004XM-RC
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:50 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:53817
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5D-0004OX-Ju
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:52 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 84AF974CE6
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=dap2
 9653BGrSWdSbYQB14G6nL+0=; b=URKj0KWlQU3fdrFA0qnacAdWkJeQvOd0Z2eV
 sQVca9WcWfznkFhxG/4nyfXrU7iXjemm1w08VBm83PpwyexxHBTJ9mHk1sbFLNF1
 kqIw2q0OWGLwICsL4mDnOgERVEjJi1vBg2m1hNiHnDoApqiZWXt0VJYCwAhzkzSN
 ETyEQrM=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 7AE5A74CE3
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 14A9674CD1
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:35 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 9/9] doc: Document guix potluck.
Date: Mon, 24 Apr 2017 22:59:23 +0200
Message-Id: <20170424205923.27726-9-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EC8F66EE-2930-11E7-8869-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* doc/guix.texi (potluck-package Reference):
(Invoking guix potluck): New sections.
---
 doc/guix.texi | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 231 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7f1074f9d..f2aa52653 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -58,6 +58,7 @@ Documentation License''.
 * guix environment: (guix)Invoking guix environment. Building development environments with Guix.
 * guix build: (guix)Invoking guix build.      Building packages.
 * guix pack: (guix)Invoking guix pack.        Creating binary bundles.
+* guix potluck: (guix)Invoking guix potluck.  Publishing package definitions.
 @end direntry
 
 @titlepage
@@ -137,6 +138,7 @@ Defining Packages
 
 * package Reference::           The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 
 Utilities
 
@@ -154,6 +156,7 @@ Utilities
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Simple, decoupled package development.
 
 Invoking @command{guix build}
 
@@ -2976,6 +2979,7 @@ when @var{cut?} returns true for a given package.
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 @end menu
 
 
@@ -3192,6 +3196,115 @@ this is @code{#f}, a sensible default is used.
 @end table
 @end deftp
 
+@node potluck-package Reference
+@subsection @code{potluck-package} Reference
+
+This section defines all the options available in @code{potluck-package}
+declarations.  @xref{Invoking guix potluck}, for more background and for
+information on how to work with potluck packages from the command-line
+interface.
+
+@deftp {Data Type} potluck-package
+This is the data type representing a potluck package recipe.
+
+@table @asis
+@item @code{name}
+The name of the package, as a string.
+
+@item @code{version}
+The version of the package, as a string.
+
+@item @code{source}
+An object telling how the source code for the package should be
+acquired.  This is a @code{potluck-source} object, which itself is its
+own data type:
+
+@deftp {Data Type} potluck-source
+This is the data type representing a potluck package's source code.
+
+@table @asis
+@item @code{git-uri}
+An object containing the URI of the source git repository.  Currently
+potluck packages all come from Git.  Use the ``normal'' Guix packages if
+you need to build from some other source.
+
+@item @code{git-commit}
+The given git commit for the source, for example as a sha1 string.
+
+@item @code{sha256}
+A bytevector containing the SHA-256 hash of the source, as a base32
+string.  Note that the explicit @code{base32} wrapper that is needed for
+normal Guix packages is not present in a potluck package source.
+
+You can obtain this information using @code{guix hash -g}
+(@pxref{Invoking guix hash}).
+
+@item @code{snippet} (default: @code{#f})
+An S-expression that will be run in the source directory.  This is a
+convenient way to modify the source, sometimes more convenient than a
+patch.
+@end table
+@end deftp
+
+@item @code{build-system}
+The build system that should be used to build the package, as a symbol.
+For example, @code{gnu}.  To list available build systems, use
+@code{guix potluck init --build-system=help} (@pxref{Invoking guix
+potluck}).
+
+@item @code{arguments} (default: @code{'()})
+The arguments that should be passed to the build system.  This is a
+list, typically containing sequential keyword-value pairs, and is the
+same as for the @code{arguments} argument of a normal @code{package}
+object.
+
+@item @code{inputs} (default: @code{'()})
+@itemx @code{native-inputs} (default: @code{'()})
+@itemx @code{propagated-inputs} (default: @code{'()})
+@cindex inputs, of packages
+These fields list dependencies of the package.  Each item of an input
+list is a package specification string, for example @code{guile} or
+@code{guile@@2.0} or, in the most specific form, @code{guile@@2.0:out}.
+@xref{Packages with Multiple Outputs}, for more on package outputs.  For
+example, the list below specifies three inputs:
+
+@example
+'("libffi" "libunistring" "glib:bin")
+@end example
+
+@cindex cross compilation, package dependencies
+The distinction between @code{native-inputs} and @code{inputs} is
+necessary when considering cross-compilation.
+
+@xref{package Reference}, for full details on the differences between
+these input types.
+
+@item @code{synopsis}
+A one-line description of the package.
+
+@item @code{description}
+A more elaborate description of the package.
+
+@item @code{license}
+The license of the package, as a symbol.  For example, @code{gpl3+}.  To
+list available build systems, use @code{guix potluck init
+--license=help} (@pxref{Invoking guix potluck}).
+
+@item @code{home-page}
+The URL to the home-page of the package, as a string.
+
+@item @code{location} (default: source location of the @code{package} form)
+The source location of the package.  It is useful to override this when
+inheriting from another package, in which case this field is not
+automatically corrected.
+@end table
+@end deftp
+
+As you can see, a potluck package is less elaborate than a normal Guix
+package.  If you find yourself needing more advanced features, probably
+your package should be a part of Guix proper.  But if not, a potluck
+package can often do the job.
+
 
 @node Build Systems
 @section Build Systems
@@ -4779,6 +4892,7 @@ the Scheme programming interface of Guix in a convenient way.
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Decoupled package definition.
 @end menu
 
 @node Invoking guix build
@@ -6997,6 +7111,123 @@ must be PID 1 of the container or one of its child processes.
 
 @end table
 
+@node Invoking guix potluck
+@section Invoking @command{guix potluck}
+@cindex potluck
+@cindex @command{guix potluck}
+@quotation Note
+As of version @value{VERSION}, this tool is experimental.  The interface
+is subject to radical change in the future.
+@end quotation
+
+Guix is developed as a unified project composed of both the package
+manager and the set of packages.  This allows Guix to evolve while
+remaining healthy and coherent.  If there is a change that needs to be
+done across Guix's entire tree, Guix developers can make it happen.  One
+way in which this principle manifests itself is in the @code{package}
+data type, where input packages are directly specified by value in the
+@code{inputs}, @code{native-inputs}, and @code{propagated-inputs}
+fields, instead of being specified as some abstract package name and
+version constraint that Guix would have to solve for.  @xref{package
+Reference}, for more on the @code{package} data type.
+
+However it is sometimes desirable to develop a package or set of
+packages in a more decoupled way, for example when a package set is
+still incubating or when a package is inappropriate for sending upstream
+for some reason.  Such packages use Guix and extend Guix but are not a
+part of the Guix project, properly speaking.  As such, they need to be
+resilient to changes in upstream Guix.  It would be brittle if such a
+package definition had to reference a Guix package by value; the Scheme
+variable denoting the upstream Guix package might move to a different
+module, or be renamed, or changed in some unexpected way.
+
+Guix's @dfn{potluck} facility fills this gap.  A @dfn{potluck package}
+is like a normal Guix package, except it expresses its inputs in the
+form of package specifications instead of direct references.
+@xref{potluck-package Reference}.  Potluck packages also have a simpler
+package structure with fewer fields; compared to normal Guix packages,
+they are less expressive but more isolated from details of upstream
+Guix.
+
+The user interface to potluck packages is concentrated in the
+@command{guix potluck} command.  To begin, let's say you are a developer
+of the @code{foo} project, and you'd like to package @code{foo} for use
+in your Guix system and maybe also that of a friend.  You're not sure if
+you want to support it yet so you don't want to make a proper release,
+but there should be something in the middle between that and not
+packaging it at all.  You decide to give @code{guix potluck} a go.
+
+So in that git checkout, you run @code{guix potluck init @var{url}},
+where @var{url} is a publicly accessible git URL at which @code{foo} is
+hosted.  @code{guix potluck init} takes the following options:
+
+@table @code
+@item --build-system=@var{sys}
+@itemx --build-system=help
+@itemx --autotools
+Indicate that the package uses the build system named @var{sys}.  Pass
+@code{help} as the build system to see available options.
+@code{--autotools} is like the common @code{--build-system=gnu}, but
+additionally indicating that an @code{autoreconf} step is needed before
+building.
+@item --license=@var{license}
+@itemx --license=help
+Specify the license of the project.
+@end table
+
+Calling @code{guix potluck init} will result in the creation of a
+@code{guix-potluck} directory in your git checkout, containing a brief
+overview @code{README.md} file as well as a @code{foo.scm} potluck
+package definition.  @xref{potluck-package Reference}.  Just fill in the
+synopsis and description and add the inputs and you have the beginnings
+of a potluck package.
+
+You can try building your new package by running @code{guix build -f
+guix-potluck/foo.scm}.  Once that works, you can share the file with
+your friends and they can build your package too.
+
+Of course, it would be nice if you could share that package with the
+world.  And it would be nice if your potluck package definitions could
+augment the set of available packages and versions.  And it would be
+nice if your potluck package could serve as a first draft of a proper
+Guix package definition.  We agree completely!
+
+Guix's potluck facility also implements a kind of registry of potluck
+recipes, as if it were hosting an actual potluck.  This
+@code{host-channel} facility takes requests to add potluck packages and
+translates that into a git repository of all potluck packages, as well
+as a git repository of Guix packages compiled from those potluck
+packages.
+
+To inform a channel host of the presence of fresh tasty potluck dishes,
+run @code{guix potluck update @var{url} @var{branch}}.  @var{url} should
+be the URL of a git repository containing a @code{guix-potluck}
+directory, and @var{branch} is a ref in that repository.  By default,
+the request is made to add the package to the default
+@code{guix-potluck.org} host; pass @code{--host=@var{host}} to specify
+an alternate registry.
+
+Running @code{guix potluck update} will simply enqueue an update request
+on the server.  Visit @code{https://@var{host}/} in your browser to see
+the state of the work queue, and to see whether your package update
+actually succeeded.  If it does succeed, you should be able to check out
+the git repository conventionally hosted at
+@indicateurl{https://@var{host}/git/main.git}, add that checkout to your
+@code{GUIX_PACKAGE_PATH}, and thereby have access to that package.  In
+the future this will be made easier with a @code{guix channel} facility,
+but for now you have to use @code{GUIX_PACKAGE_PATH} or similar.
+@xref{Defining Packages}, for more information.
+
+Finally, there is the code that actually runs the potluck service:
+@code{guix potluck host-channel}.  This tool will host a web server on
+localhost, listening on port 8080 by default.  It expects to be behind
+some kind of HTTPS terminator, like @code{nginx}.  It does the work of
+translating update requests to git repositories.  Guix includes an
+example operating system definition for a server combining HTTPS access
+to git repositories, an @code{nginx} web front-end, and a @code{guix
+potluck host-channel} instance.
+
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:49 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:49 2017
Received: from localhost ([127.0.0.1]:38439 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6G-0004XD-Vr
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:49 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:58181
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5D-0004PJ-Ml
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:51 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 9F16674CE8
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=dap2
 9653BGrSWdSbYQB14G6nL+0=; b=URKj0KWlQU3fdrFA0qnacAdWkJeQvOd0Z2eV
 sQVca9WcWfznkFhxG/4nyfXrU7iXjemm1w08VBm83PpwyexxHBTJ9mHk1sbFLNF1
 kqIw2q0OWGLwICsL4mDnOgERVEjJi1vBg2m1hNiHnDoApqiZWXt0VJYCwAhzkzSN
 ETyEQrM=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 968BA74CE7
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 28E8A74CD5
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:36 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 9/9] doc: Document guix potluck.
Date: Mon, 24 Apr 2017 22:59:23 +0200
Message-Id: <20170424205923.27726-9-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EC9CB6AA-2930-11E7-99DB-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* doc/guix.texi (potluck-package Reference):
(Invoking guix potluck): New sections.
---
 doc/guix.texi | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 231 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7f1074f9d..f2aa52653 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -58,6 +58,7 @@ Documentation License''.
 * guix environment: (guix)Invoking guix environment. Building development environments with Guix.
 * guix build: (guix)Invoking guix build.      Building packages.
 * guix pack: (guix)Invoking guix pack.        Creating binary bundles.
+* guix potluck: (guix)Invoking guix potluck.  Publishing package definitions.
 @end direntry
 
 @titlepage
@@ -137,6 +138,7 @@ Defining Packages
 
 * package Reference::           The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 
 Utilities
 
@@ -154,6 +156,7 @@ Utilities
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Simple, decoupled package development.
 
 Invoking @command{guix build}
 
@@ -2976,6 +2979,7 @@ when @var{cut?} returns true for a given package.
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 @end menu
 
 
@@ -3192,6 +3196,115 @@ this is @code{#f}, a sensible default is used.
 @end table
 @end deftp
 
+@node potluck-package Reference
+@subsection @code{potluck-package} Reference
+
+This section defines all the options available in @code{potluck-package}
+declarations.  @xref{Invoking guix potluck}, for more background and for
+information on how to work with potluck packages from the command-line
+interface.
+
+@deftp {Data Type} potluck-package
+This is the data type representing a potluck package recipe.
+
+@table @asis
+@item @code{name}
+The name of the package, as a string.
+
+@item @code{version}
+The version of the package, as a string.
+
+@item @code{source}
+An object telling how the source code for the package should be
+acquired.  This is a @code{potluck-source} object, which itself is its
+own data type:
+
+@deftp {Data Type} potluck-source
+This is the data type representing a potluck package's source code.
+
+@table @asis
+@item @code{git-uri}
+An object containing the URI of the source git repository.  Currently
+potluck packages all come from Git.  Use the ``normal'' Guix packages if
+you need to build from some other source.
+
+@item @code{git-commit}
+The given git commit for the source, for example as a sha1 string.
+
+@item @code{sha256}
+A bytevector containing the SHA-256 hash of the source, as a base32
+string.  Note that the explicit @code{base32} wrapper that is needed for
+normal Guix packages is not present in a potluck package source.
+
+You can obtain this information using @code{guix hash -g}
+(@pxref{Invoking guix hash}).
+
+@item @code{snippet} (default: @code{#f})
+An S-expression that will be run in the source directory.  This is a
+convenient way to modify the source, sometimes more convenient than a
+patch.
+@end table
+@end deftp
+
+@item @code{build-system}
+The build system that should be used to build the package, as a symbol.
+For example, @code{gnu}.  To list available build systems, use
+@code{guix potluck init --build-system=help} (@pxref{Invoking guix
+potluck}).
+
+@item @code{arguments} (default: @code{'()})
+The arguments that should be passed to the build system.  This is a
+list, typically containing sequential keyword-value pairs, and is the
+same as for the @code{arguments} argument of a normal @code{package}
+object.
+
+@item @code{inputs} (default: @code{'()})
+@itemx @code{native-inputs} (default: @code{'()})
+@itemx @code{propagated-inputs} (default: @code{'()})
+@cindex inputs, of packages
+These fields list dependencies of the package.  Each item of an input
+list is a package specification string, for example @code{guile} or
+@code{guile@@2.0} or, in the most specific form, @code{guile@@2.0:out}.
+@xref{Packages with Multiple Outputs}, for more on package outputs.  For
+example, the list below specifies three inputs:
+
+@example
+'("libffi" "libunistring" "glib:bin")
+@end example
+
+@cindex cross compilation, package dependencies
+The distinction between @code{native-inputs} and @code{inputs} is
+necessary when considering cross-compilation.
+
+@xref{package Reference}, for full details on the differences between
+these input types.
+
+@item @code{synopsis}
+A one-line description of the package.
+
+@item @code{description}
+A more elaborate description of the package.
+
+@item @code{license}
+The license of the package, as a symbol.  For example, @code{gpl3+}.  To
+list available build systems, use @code{guix potluck init
+--license=help} (@pxref{Invoking guix potluck}).
+
+@item @code{home-page}
+The URL to the home-page of the package, as a string.
+
+@item @code{location} (default: source location of the @code{package} form)
+The source location of the package.  It is useful to override this when
+inheriting from another package, in which case this field is not
+automatically corrected.
+@end table
+@end deftp
+
+As you can see, a potluck package is less elaborate than a normal Guix
+package.  If you find yourself needing more advanced features, probably
+your package should be a part of Guix proper.  But if not, a potluck
+package can often do the job.
+
 
 @node Build Systems
 @section Build Systems
@@ -4779,6 +4892,7 @@ the Scheme programming interface of Guix in a convenient way.
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Decoupled package definition.
 @end menu
 
 @node Invoking guix build
@@ -6997,6 +7111,123 @@ must be PID 1 of the container or one of its child processes.
 
 @end table
 
+@node Invoking guix potluck
+@section Invoking @command{guix potluck}
+@cindex potluck
+@cindex @command{guix potluck}
+@quotation Note
+As of version @value{VERSION}, this tool is experimental.  The interface
+is subject to radical change in the future.
+@end quotation
+
+Guix is developed as a unified project composed of both the package
+manager and the set of packages.  This allows Guix to evolve while
+remaining healthy and coherent.  If there is a change that needs to be
+done across Guix's entire tree, Guix developers can make it happen.  One
+way in which this principle manifests itself is in the @code{package}
+data type, where input packages are directly specified by value in the
+@code{inputs}, @code{native-inputs}, and @code{propagated-inputs}
+fields, instead of being specified as some abstract package name and
+version constraint that Guix would have to solve for.  @xref{package
+Reference}, for more on the @code{package} data type.
+
+However it is sometimes desirable to develop a package or set of
+packages in a more decoupled way, for example when a package set is
+still incubating or when a package is inappropriate for sending upstream
+for some reason.  Such packages use Guix and extend Guix but are not a
+part of the Guix project, properly speaking.  As such, they need to be
+resilient to changes in upstream Guix.  It would be brittle if such a
+package definition had to reference a Guix package by value; the Scheme
+variable denoting the upstream Guix package might move to a different
+module, or be renamed, or changed in some unexpected way.
+
+Guix's @dfn{potluck} facility fills this gap.  A @dfn{potluck package}
+is like a normal Guix package, except it expresses its inputs in the
+form of package specifications instead of direct references.
+@xref{potluck-package Reference}.  Potluck packages also have a simpler
+package structure with fewer fields; compared to normal Guix packages,
+they are less expressive but more isolated from details of upstream
+Guix.
+
+The user interface to potluck packages is concentrated in the
+@command{guix potluck} command.  To begin, let's say you are a developer
+of the @code{foo} project, and you'd like to package @code{foo} for use
+in your Guix system and maybe also that of a friend.  You're not sure if
+you want to support it yet so you don't want to make a proper release,
+but there should be something in the middle between that and not
+packaging it at all.  You decide to give @code{guix potluck} a go.
+
+So in that git checkout, you run @code{guix potluck init @var{url}},
+where @var{url} is a publicly accessible git URL at which @code{foo} is
+hosted.  @code{guix potluck init} takes the following options:
+
+@table @code
+@item --build-system=@var{sys}
+@itemx --build-system=help
+@itemx --autotools
+Indicate that the package uses the build system named @var{sys}.  Pass
+@code{help} as the build system to see available options.
+@code{--autotools} is like the common @code{--build-system=gnu}, but
+additionally indicating that an @code{autoreconf} step is needed before
+building.
+@item --license=@var{license}
+@itemx --license=help
+Specify the license of the project.
+@end table
+
+Calling @code{guix potluck init} will result in the creation of a
+@code{guix-potluck} directory in your git checkout, containing a brief
+overview @code{README.md} file as well as a @code{foo.scm} potluck
+package definition.  @xref{potluck-package Reference}.  Just fill in the
+synopsis and description and add the inputs and you have the beginnings
+of a potluck package.
+
+You can try building your new package by running @code{guix build -f
+guix-potluck/foo.scm}.  Once that works, you can share the file with
+your friends and they can build your package too.
+
+Of course, it would be nice if you could share that package with the
+world.  And it would be nice if your potluck package definitions could
+augment the set of available packages and versions.  And it would be
+nice if your potluck package could serve as a first draft of a proper
+Guix package definition.  We agree completely!
+
+Guix's potluck facility also implements a kind of registry of potluck
+recipes, as if it were hosting an actual potluck.  This
+@code{host-channel} facility takes requests to add potluck packages and
+translates that into a git repository of all potluck packages, as well
+as a git repository of Guix packages compiled from those potluck
+packages.
+
+To inform a channel host of the presence of fresh tasty potluck dishes,
+run @code{guix potluck update @var{url} @var{branch}}.  @var{url} should
+be the URL of a git repository containing a @code{guix-potluck}
+directory, and @var{branch} is a ref in that repository.  By default,
+the request is made to add the package to the default
+@code{guix-potluck.org} host; pass @code{--host=@var{host}} to specify
+an alternate registry.
+
+Running @code{guix potluck update} will simply enqueue an update request
+on the server.  Visit @code{https://@var{host}/} in your browser to see
+the state of the work queue, and to see whether your package update
+actually succeeded.  If it does succeed, you should be able to check out
+the git repository conventionally hosted at
+@indicateurl{https://@var{host}/git/main.git}, add that checkout to your
+@code{GUIX_PACKAGE_PATH}, and thereby have access to that package.  In
+the future this will be made easier with a @code{guix channel} facility,
+but for now you have to use @code{GUIX_PACKAGE_PATH} or similar.
+@xref{Defining Packages}, for more information.
+
+Finally, there is the code that actually runs the potluck service:
+@code{guix potluck host-channel}.  This tool will host a web server on
+localhost, listening on port 8080 by default.  It expects to be behind
+some kind of HTTPS terminator, like @code{nginx}.  It does the work of
+translating update requests to git repositories.  Guix includes an
+example operating system definition for a server combining HTTPS access
+to git repositories, an @code{nginx} web front-end, and a @code{guix
+potluck host-channel} instance.
+
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:49 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:49 2017
Received: from localhost ([127.0.0.1]:38437 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6G-0004X6-Em
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:48 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:54696
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5H-0004OU-30
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:51 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id AD87C74CED
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=uY1rC0pj+vzX
 sMAC3yJaGZCOMP0=; b=ql0GkvknTUoCEf/TvRiL5YaqW/hlUTmQclV8t7Yd4E8K
 rRaI/Samo9Iacxk6wRrZxYbwhq5NzKcvPY8Pwhg8rMwPFZIBonUS8KL6K+aFD1Bx
 HsAEbRDSoDR3gjhiabGAP4pK04vlhLeLns/6XsD5fqltl4yjF95aZXPpfV0aQiE=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id A728B74CEA
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 97D7874CDE
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:38 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 3/9] guix: Add git utility module.
Date: Mon, 24 Apr 2017 22:59:17 +0200
Message-Id: <20170424205923.27726-3-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: EE13C6EA-2930-11E7-9354-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/git.scm: New file.
* Makefile.am (MODULES): Add new file.
---
 Makefile.am  |   1 +
 guix/git.scm | 164 +++++++++++++++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 165 insertions(+)
 create mode 100644 guix/git.scm

diff --git a/Makefile.am b/Makefile.am
index 22ba00e90..64a7a9265 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,7 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/git.scm					\
   guix/potluck/build-systems.scm		\
   guix/potluck/licenses.scm			\
   guix/potluck/packages.scm			\
diff --git a/guix/git.scm b/guix/git.scm
new file mode 100644
index 000000000..02f61edac
--- /dev/null
+++ b/guix/git.scm
@@ -0,0 +1,164 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 (guix utils)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:export (&git-condition
+            git-condition?
+            git-condition-argv
+            git-condition-output
+            git-condition-status
+
+            false-if-git-error
+
+            git-check-ref-format
+            git-rev-parse
+            git-config
+            git-describe
+            git-fetch
+            git-push
+            git-clone
+            git-reset
+            git-add
+            git-commit))
+
+;;; Commentary:
+;;;
+;;; A simple collection of Scheme wrappers for Git functionality.
+;;;
+;;; Code:
+
+(define-condition-type &git-condition &condition git-condition?
+  (argv git-condition-argv)
+  (output git-condition-output)
+  (status git-condition-status))
+
+(define-syntax-rule (false-if-git-error body0 body ...)
+  (guard (c ((git-condition? c) #f))
+    body0 body ...))
+
+(define (shell:quote str)
+  (with-output-to-string
+    (lambda ()
+      (display #\')
+      (string-for-each (lambda (ch)
+                         (if (eqv? ch #\')
+                             (begin (display #\\) (display #\'))
+                             (display ch)))
+                       str)
+      (display #\'))))
+
+(define (run env input-file args)
+  (define (prepend-env args)
+    (if (null? env)
+        args
+        (cons "env" (append env args))))
+  (define (redirect-input args)
+    (if input-file
+        (list "sh" "-c"
+              (string-append (string-join (map shell:quote args) " ")
+                             "<" input-file))
+        args))
+  (let* ((real-args (redirect-input (prepend-env args)))
+         (pipe (apply open-pipe* OPEN_READ real-args))
+         (output (read-string pipe))
+         (ret (close-pipe pipe)))
+    (case (status:exit-val ret)
+      ((0) output)
+      (else (raise (condition (&git-condition
+                               (argv real-args)
+                               (output output)
+                               (status ret))))))))
+
+(define* (git* args #:key (input #f) (env '()))
+  (if input
+      (call-with-temporary-output-file
+       (lambda (file-name file-port)
+         (display input file-port)
+         (close-port file-port)
+         (run env file-name (cons* "git" args))))
+      (run env #f (cons* "git" args))))
+
+(define (git . args)
+  (git* args))
+
+(define* (git-check-ref-format str #:key allow-onelevel?)
+  "Raise an exception if @var{str} is not a valid Git ref."
+  (when (string-prefix? "-" str)
+    (error "bad ref" str))
+  (git "check-ref-format"
+       (if allow-onelevel? "--allow-onelevel" "--no-allow-onelevel")
+       str))
+
+(define (git-rev-parse rev)
+  "Parse the string @var{rev} and return a Git commit hash, as a string.=
"
+  (string-trim-both (git "rev-parse" rev)))
+
+(define (git-config key)
+  "Return the configuration value for @var{key}, as a string."
+  (string-trim-both (git "config" key)))
+
+(define* (git-describe #:optional (ref "HEAD"))
+  "Run @command{git describe} on the given @var{ref}, defaulting to
+@code{HEAD}, and return the resulting string."
+  (string-trim-both (git "describe")))
+
+(define (git-fetch)
+  "Run @command{git fetch} in the current working directory."
+  (git "fetch"))
+
+(define (git-push)
+  "Run @command{git push} in the current working directory."
+  (git "push"))
+
+(define (git-clone repo dir)
+  "Check out @var{repo} into @var{dir}."
+  (git "clone" "--" repo dir))
+
+(define* (git-reset #:key (ref "HEAD") (mode 'hard))
+  ;; Can't let the ref be mistaken for a command-line argument.
+  "Reset the current working directory to @var{ref}.  Available values f=
or
+@var{mode} are the symbols @code{hard}, @code{soft}, and @code{mixed}."
+  (when (string-prefix? "-" ref)
+    (error "bad ref" ref))
+  (git "reset"
+       (case mode
+         ((hard) "--hard")
+         ((mixed) "--mixed")
+         ((soft) "--soft")
+         (else (error "unknown mode" mode)))
+       ref))
+
+(define (git-add file)
+  "Add @var{file} to the index in the current working directory."
+  (git "add" "--" file))
+
+(define* (git-commit #:key message author-name author-email)
+  "Commit the changes in the current working directory, with the message
+@var{message}.  The commit will be attributed to the author with the nam=
e and
+email address @var{author-name} and @var{author-email}, respectively."
+  (git* (list "commit" (string-append "--message=3D" message))
+        #:env (list (string-append "GIT_COMMITTER_NAME=3D" author-name)
+                    (string-append "GIT_COMMITTER_EMAIL=3D" author-email=
)
+                    (string-append "GIT_AUTHOR_NAME=3D" author-name)
+                    (string-append "GIT_AUTHOR_EMAIL=3D" author-email)))=
)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:48 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:48 2017
Received: from localhost ([127.0.0.1]:38435 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6E-0004Wx-UU
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:47 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:63334
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5C-0004P3-3R
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:50 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 729F574CE0
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=dap2
 9653BGrSWdSbYQB14G6nL+0=; b=URKj0KWlQU3fdrFA0qnacAdWkJeQvOd0Z2eV
 sQVca9WcWfznkFhxG/4nyfXrU7iXjemm1w08VBm83PpwyexxHBTJ9mHk1sbFLNF1
 kqIw2q0OWGLwICsL4mDnOgERVEjJi1vBg2m1hNiHnDoApqiZWXt0VJYCwAhzkzSN
 ETyEQrM=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 6ABC774CDF
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 390D674CD6
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:36 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 9/9] doc: Document guix potluck.
Date: Mon, 24 Apr 2017 22:59:23 +0200
Message-Id: <20170424205923.27726-9-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: ECA660A6-2930-11E7-B926-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* doc/guix.texi (potluck-package Reference):
(Invoking guix potluck): New sections.
---
 doc/guix.texi | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 231 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7f1074f9d..f2aa52653 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -58,6 +58,7 @@ Documentation License''.
 * guix environment: (guix)Invoking guix environment. Building development environments with Guix.
 * guix build: (guix)Invoking guix build.      Building packages.
 * guix pack: (guix)Invoking guix pack.        Creating binary bundles.
+* guix potluck: (guix)Invoking guix potluck.  Publishing package definitions.
 @end direntry
 
 @titlepage
@@ -137,6 +138,7 @@ Defining Packages
 
 * package Reference::           The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 
 Utilities
 
@@ -154,6 +156,7 @@ Utilities
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Simple, decoupled package development.
 
 Invoking @command{guix build}
 
@@ -2976,6 +2979,7 @@ when @var{cut?} returns true for a given package.
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 @end menu
 
 
@@ -3192,6 +3196,115 @@ this is @code{#f}, a sensible default is used.
 @end table
 @end deftp
 
+@node potluck-package Reference
+@subsection @code{potluck-package} Reference
+
+This section defines all the options available in @code{potluck-package}
+declarations.  @xref{Invoking guix potluck}, for more background and for
+information on how to work with potluck packages from the command-line
+interface.
+
+@deftp {Data Type} potluck-package
+This is the data type representing a potluck package recipe.
+
+@table @asis
+@item @code{name}
+The name of the package, as a string.
+
+@item @code{version}
+The version of the package, as a string.
+
+@item @code{source}
+An object telling how the source code for the package should be
+acquired.  This is a @code{potluck-source} object, which itself is its
+own data type:
+
+@deftp {Data Type} potluck-source
+This is the data type representing a potluck package's source code.
+
+@table @asis
+@item @code{git-uri}
+An object containing the URI of the source git repository.  Currently
+potluck packages all come from Git.  Use the ``normal'' Guix packages if
+you need to build from some other source.
+
+@item @code{git-commit}
+The given git commit for the source, for example as a sha1 string.
+
+@item @code{sha256}
+A bytevector containing the SHA-256 hash of the source, as a base32
+string.  Note that the explicit @code{base32} wrapper that is needed for
+normal Guix packages is not present in a potluck package source.
+
+You can obtain this information using @code{guix hash -g}
+(@pxref{Invoking guix hash}).
+
+@item @code{snippet} (default: @code{#f})
+An S-expression that will be run in the source directory.  This is a
+convenient way to modify the source, sometimes more convenient than a
+patch.
+@end table
+@end deftp
+
+@item @code{build-system}
+The build system that should be used to build the package, as a symbol.
+For example, @code{gnu}.  To list available build systems, use
+@code{guix potluck init --build-system=help} (@pxref{Invoking guix
+potluck}).
+
+@item @code{arguments} (default: @code{'()})
+The arguments that should be passed to the build system.  This is a
+list, typically containing sequential keyword-value pairs, and is the
+same as for the @code{arguments} argument of a normal @code{package}
+object.
+
+@item @code{inputs} (default: @code{'()})
+@itemx @code{native-inputs} (default: @code{'()})
+@itemx @code{propagated-inputs} (default: @code{'()})
+@cindex inputs, of packages
+These fields list dependencies of the package.  Each item of an input
+list is a package specification string, for example @code{guile} or
+@code{guile@@2.0} or, in the most specific form, @code{guile@@2.0:out}.
+@xref{Packages with Multiple Outputs}, for more on package outputs.  For
+example, the list below specifies three inputs:
+
+@example
+'("libffi" "libunistring" "glib:bin")
+@end example
+
+@cindex cross compilation, package dependencies
+The distinction between @code{native-inputs} and @code{inputs} is
+necessary when considering cross-compilation.
+
+@xref{package Reference}, for full details on the differences between
+these input types.
+
+@item @code{synopsis}
+A one-line description of the package.
+
+@item @code{description}
+A more elaborate description of the package.
+
+@item @code{license}
+The license of the package, as a symbol.  For example, @code{gpl3+}.  To
+list available build systems, use @code{guix potluck init
+--license=help} (@pxref{Invoking guix potluck}).
+
+@item @code{home-page}
+The URL to the home-page of the package, as a string.
+
+@item @code{location} (default: source location of the @code{package} form)
+The source location of the package.  It is useful to override this when
+inheriting from another package, in which case this field is not
+automatically corrected.
+@end table
+@end deftp
+
+As you can see, a potluck package is less elaborate than a normal Guix
+package.  If you find yourself needing more advanced features, probably
+your package should be a part of Guix proper.  But if not, a potluck
+package can often do the job.
+
 
 @node Build Systems
 @section Build Systems
@@ -4779,6 +4892,7 @@ the Scheme programming interface of Guix in a convenient way.
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Decoupled package definition.
 @end menu
 
 @node Invoking guix build
@@ -6997,6 +7111,123 @@ must be PID 1 of the container or one of its child processes.
 
 @end table
 
+@node Invoking guix potluck
+@section Invoking @command{guix potluck}
+@cindex potluck
+@cindex @command{guix potluck}
+@quotation Note
+As of version @value{VERSION}, this tool is experimental.  The interface
+is subject to radical change in the future.
+@end quotation
+
+Guix is developed as a unified project composed of both the package
+manager and the set of packages.  This allows Guix to evolve while
+remaining healthy and coherent.  If there is a change that needs to be
+done across Guix's entire tree, Guix developers can make it happen.  One
+way in which this principle manifests itself is in the @code{package}
+data type, where input packages are directly specified by value in the
+@code{inputs}, @code{native-inputs}, and @code{propagated-inputs}
+fields, instead of being specified as some abstract package name and
+version constraint that Guix would have to solve for.  @xref{package
+Reference}, for more on the @code{package} data type.
+
+However it is sometimes desirable to develop a package or set of
+packages in a more decoupled way, for example when a package set is
+still incubating or when a package is inappropriate for sending upstream
+for some reason.  Such packages use Guix and extend Guix but are not a
+part of the Guix project, properly speaking.  As such, they need to be
+resilient to changes in upstream Guix.  It would be brittle if such a
+package definition had to reference a Guix package by value; the Scheme
+variable denoting the upstream Guix package might move to a different
+module, or be renamed, or changed in some unexpected way.
+
+Guix's @dfn{potluck} facility fills this gap.  A @dfn{potluck package}
+is like a normal Guix package, except it expresses its inputs in the
+form of package specifications instead of direct references.
+@xref{potluck-package Reference}.  Potluck packages also have a simpler
+package structure with fewer fields; compared to normal Guix packages,
+they are less expressive but more isolated from details of upstream
+Guix.
+
+The user interface to potluck packages is concentrated in the
+@command{guix potluck} command.  To begin, let's say you are a developer
+of the @code{foo} project, and you'd like to package @code{foo} for use
+in your Guix system and maybe also that of a friend.  You're not sure if
+you want to support it yet so you don't want to make a proper release,
+but there should be something in the middle between that and not
+packaging it at all.  You decide to give @code{guix potluck} a go.
+
+So in that git checkout, you run @code{guix potluck init @var{url}},
+where @var{url} is a publicly accessible git URL at which @code{foo} is
+hosted.  @code{guix potluck init} takes the following options:
+
+@table @code
+@item --build-system=@var{sys}
+@itemx --build-system=help
+@itemx --autotools
+Indicate that the package uses the build system named @var{sys}.  Pass
+@code{help} as the build system to see available options.
+@code{--autotools} is like the common @code{--build-system=gnu}, but
+additionally indicating that an @code{autoreconf} step is needed before
+building.
+@item --license=@var{license}
+@itemx --license=help
+Specify the license of the project.
+@end table
+
+Calling @code{guix potluck init} will result in the creation of a
+@code{guix-potluck} directory in your git checkout, containing a brief
+overview @code{README.md} file as well as a @code{foo.scm} potluck
+package definition.  @xref{potluck-package Reference}.  Just fill in the
+synopsis and description and add the inputs and you have the beginnings
+of a potluck package.
+
+You can try building your new package by running @code{guix build -f
+guix-potluck/foo.scm}.  Once that works, you can share the file with
+your friends and they can build your package too.
+
+Of course, it would be nice if you could share that package with the
+world.  And it would be nice if your potluck package definitions could
+augment the set of available packages and versions.  And it would be
+nice if your potluck package could serve as a first draft of a proper
+Guix package definition.  We agree completely!
+
+Guix's potluck facility also implements a kind of registry of potluck
+recipes, as if it were hosting an actual potluck.  This
+@code{host-channel} facility takes requests to add potluck packages and
+translates that into a git repository of all potluck packages, as well
+as a git repository of Guix packages compiled from those potluck
+packages.
+
+To inform a channel host of the presence of fresh tasty potluck dishes,
+run @code{guix potluck update @var{url} @var{branch}}.  @var{url} should
+be the URL of a git repository containing a @code{guix-potluck}
+directory, and @var{branch} is a ref in that repository.  By default,
+the request is made to add the package to the default
+@code{guix-potluck.org} host; pass @code{--host=@var{host}} to specify
+an alternate registry.
+
+Running @code{guix potluck update} will simply enqueue an update request
+on the server.  Visit @code{https://@var{host}/} in your browser to see
+the state of the work queue, and to see whether your package update
+actually succeeded.  If it does succeed, you should be able to check out
+the git repository conventionally hosted at
+@indicateurl{https://@var{host}/git/main.git}, add that checkout to your
+@code{GUIX_PACKAGE_PATH}, and thereby have access to that package.  In
+the future this will be made easier with a @code{guix channel} facility,
+but for now you have to use @code{GUIX_PACKAGE_PATH} or similar.
+@xref{Defining Packages}, for more information.
+
+Finally, there is the code that actually runs the potluck service:
+@code{guix potluck host-channel}.  This tool will host a web server on
+localhost, listening on port 8080 by default.  It expects to be behind
+some kind of HTTPS terminator, like @code{nginx}.  It does the work of
+translating update requests to git repositories.  Guix includes an
+example operating system definition for a server combining HTTPS access
+to git repositories, an @code{nginx} web front-end, and a @code{guix
+potluck host-channel} instance.
+
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:47 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:46 2017
Received: from localhost ([127.0.0.1]:38433 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6E-0004Wq-53
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:46 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:61834
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5C-0004P7-4G
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:49 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 8223D74CE4
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=dap2
 9653BGrSWdSbYQB14G6nL+0=; b=URKj0KWlQU3fdrFA0qnacAdWkJeQvOd0Z2eV
 sQVca9WcWfznkFhxG/4nyfXrU7iXjemm1w08VBm83PpwyexxHBTJ9mHk1sbFLNF1
 kqIw2q0OWGLwICsL4mDnOgERVEjJi1vBg2m1hNiHnDoApqiZWXt0VJYCwAhzkzSN
 ETyEQrM=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 7A75B74CE1
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:39 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 3A39674CD7
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:36 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 9/9] doc: Document guix potluck.
Date: Mon, 24 Apr 2017 22:59:23 +0200
Message-Id: <20170424205923.27726-9-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: ECA7F3B2-2930-11E7-893C-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* doc/guix.texi (potluck-package Reference):
(Invoking guix potluck): New sections.
---
 doc/guix.texi | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 231 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7f1074f9d..f2aa52653 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -58,6 +58,7 @@ Documentation License''.
 * guix environment: (guix)Invoking guix environment. Building development environments with Guix.
 * guix build: (guix)Invoking guix build.      Building packages.
 * guix pack: (guix)Invoking guix pack.        Creating binary bundles.
+* guix potluck: (guix)Invoking guix potluck.  Publishing package definitions.
 @end direntry
 
 @titlepage
@@ -137,6 +138,7 @@ Defining Packages
 
 * package Reference::           The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 
 Utilities
 
@@ -154,6 +156,7 @@ Utilities
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Simple, decoupled package development.
 
 Invoking @command{guix build}
 
@@ -2976,6 +2979,7 @@ when @var{cut?} returns true for a given package.
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 @end menu
 
 
@@ -3192,6 +3196,115 @@ this is @code{#f}, a sensible default is used.
 @end table
 @end deftp
 
+@node potluck-package Reference
+@subsection @code{potluck-package} Reference
+
+This section defines all the options available in @code{potluck-package}
+declarations.  @xref{Invoking guix potluck}, for more background and for
+information on how to work with potluck packages from the command-line
+interface.
+
+@deftp {Data Type} potluck-package
+This is the data type representing a potluck package recipe.
+
+@table @asis
+@item @code{name}
+The name of the package, as a string.
+
+@item @code{version}
+The version of the package, as a string.
+
+@item @code{source}
+An object telling how the source code for the package should be
+acquired.  This is a @code{potluck-source} object, which itself is its
+own data type:
+
+@deftp {Data Type} potluck-source
+This is the data type representing a potluck package's source code.
+
+@table @asis
+@item @code{git-uri}
+An object containing the URI of the source git repository.  Currently
+potluck packages all come from Git.  Use the ``normal'' Guix packages if
+you need to build from some other source.
+
+@item @code{git-commit}
+The given git commit for the source, for example as a sha1 string.
+
+@item @code{sha256}
+A bytevector containing the SHA-256 hash of the source, as a base32
+string.  Note that the explicit @code{base32} wrapper that is needed for
+normal Guix packages is not present in a potluck package source.
+
+You can obtain this information using @code{guix hash -g}
+(@pxref{Invoking guix hash}).
+
+@item @code{snippet} (default: @code{#f})
+An S-expression that will be run in the source directory.  This is a
+convenient way to modify the source, sometimes more convenient than a
+patch.
+@end table
+@end deftp
+
+@item @code{build-system}
+The build system that should be used to build the package, as a symbol.
+For example, @code{gnu}.  To list available build systems, use
+@code{guix potluck init --build-system=help} (@pxref{Invoking guix
+potluck}).
+
+@item @code{arguments} (default: @code{'()})
+The arguments that should be passed to the build system.  This is a
+list, typically containing sequential keyword-value pairs, and is the
+same as for the @code{arguments} argument of a normal @code{package}
+object.
+
+@item @code{inputs} (default: @code{'()})
+@itemx @code{native-inputs} (default: @code{'()})
+@itemx @code{propagated-inputs} (default: @code{'()})
+@cindex inputs, of packages
+These fields list dependencies of the package.  Each item of an input
+list is a package specification string, for example @code{guile} or
+@code{guile@@2.0} or, in the most specific form, @code{guile@@2.0:out}.
+@xref{Packages with Multiple Outputs}, for more on package outputs.  For
+example, the list below specifies three inputs:
+
+@example
+'("libffi" "libunistring" "glib:bin")
+@end example
+
+@cindex cross compilation, package dependencies
+The distinction between @code{native-inputs} and @code{inputs} is
+necessary when considering cross-compilation.
+
+@xref{package Reference}, for full details on the differences between
+these input types.
+
+@item @code{synopsis}
+A one-line description of the package.
+
+@item @code{description}
+A more elaborate description of the package.
+
+@item @code{license}
+The license of the package, as a symbol.  For example, @code{gpl3+}.  To
+list available build systems, use @code{guix potluck init
+--license=help} (@pxref{Invoking guix potluck}).
+
+@item @code{home-page}
+The URL to the home-page of the package, as a string.
+
+@item @code{location} (default: source location of the @code{package} form)
+The source location of the package.  It is useful to override this when
+inheriting from another package, in which case this field is not
+automatically corrected.
+@end table
+@end deftp
+
+As you can see, a potluck package is less elaborate than a normal Guix
+package.  If you find yourself needing more advanced features, probably
+your package should be a part of Guix proper.  But if not, a potluck
+package can often do the job.
+
 
 @node Build Systems
 @section Build Systems
@@ -4779,6 +4892,7 @@ the Scheme programming interface of Guix in a convenient way.
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Decoupled package definition.
 @end menu
 
 @node Invoking guix build
@@ -6997,6 +7111,123 @@ must be PID 1 of the container or one of its child processes.
 
 @end table
 
+@node Invoking guix potluck
+@section Invoking @command{guix potluck}
+@cindex potluck
+@cindex @command{guix potluck}
+@quotation Note
+As of version @value{VERSION}, this tool is experimental.  The interface
+is subject to radical change in the future.
+@end quotation
+
+Guix is developed as a unified project composed of both the package
+manager and the set of packages.  This allows Guix to evolve while
+remaining healthy and coherent.  If there is a change that needs to be
+done across Guix's entire tree, Guix developers can make it happen.  One
+way in which this principle manifests itself is in the @code{package}
+data type, where input packages are directly specified by value in the
+@code{inputs}, @code{native-inputs}, and @code{propagated-inputs}
+fields, instead of being specified as some abstract package name and
+version constraint that Guix would have to solve for.  @xref{package
+Reference}, for more on the @code{package} data type.
+
+However it is sometimes desirable to develop a package or set of
+packages in a more decoupled way, for example when a package set is
+still incubating or when a package is inappropriate for sending upstream
+for some reason.  Such packages use Guix and extend Guix but are not a
+part of the Guix project, properly speaking.  As such, they need to be
+resilient to changes in upstream Guix.  It would be brittle if such a
+package definition had to reference a Guix package by value; the Scheme
+variable denoting the upstream Guix package might move to a different
+module, or be renamed, or changed in some unexpected way.
+
+Guix's @dfn{potluck} facility fills this gap.  A @dfn{potluck package}
+is like a normal Guix package, except it expresses its inputs in the
+form of package specifications instead of direct references.
+@xref{potluck-package Reference}.  Potluck packages also have a simpler
+package structure with fewer fields; compared to normal Guix packages,
+they are less expressive but more isolated from details of upstream
+Guix.
+
+The user interface to potluck packages is concentrated in the
+@command{guix potluck} command.  To begin, let's say you are a developer
+of the @code{foo} project, and you'd like to package @code{foo} for use
+in your Guix system and maybe also that of a friend.  You're not sure if
+you want to support it yet so you don't want to make a proper release,
+but there should be something in the middle between that and not
+packaging it at all.  You decide to give @code{guix potluck} a go.
+
+So in that git checkout, you run @code{guix potluck init @var{url}},
+where @var{url} is a publicly accessible git URL at which @code{foo} is
+hosted.  @code{guix potluck init} takes the following options:
+
+@table @code
+@item --build-system=@var{sys}
+@itemx --build-system=help
+@itemx --autotools
+Indicate that the package uses the build system named @var{sys}.  Pass
+@code{help} as the build system to see available options.
+@code{--autotools} is like the common @code{--build-system=gnu}, but
+additionally indicating that an @code{autoreconf} step is needed before
+building.
+@item --license=@var{license}
+@itemx --license=help
+Specify the license of the project.
+@end table
+
+Calling @code{guix potluck init} will result in the creation of a
+@code{guix-potluck} directory in your git checkout, containing a brief
+overview @code{README.md} file as well as a @code{foo.scm} potluck
+package definition.  @xref{potluck-package Reference}.  Just fill in the
+synopsis and description and add the inputs and you have the beginnings
+of a potluck package.
+
+You can try building your new package by running @code{guix build -f
+guix-potluck/foo.scm}.  Once that works, you can share the file with
+your friends and they can build your package too.
+
+Of course, it would be nice if you could share that package with the
+world.  And it would be nice if your potluck package definitions could
+augment the set of available packages and versions.  And it would be
+nice if your potluck package could serve as a first draft of a proper
+Guix package definition.  We agree completely!
+
+Guix's potluck facility also implements a kind of registry of potluck
+recipes, as if it were hosting an actual potluck.  This
+@code{host-channel} facility takes requests to add potluck packages and
+translates that into a git repository of all potluck packages, as well
+as a git repository of Guix packages compiled from those potluck
+packages.
+
+To inform a channel host of the presence of fresh tasty potluck dishes,
+run @code{guix potluck update @var{url} @var{branch}}.  @var{url} should
+be the URL of a git repository containing a @code{guix-potluck}
+directory, and @var{branch} is a ref in that repository.  By default,
+the request is made to add the package to the default
+@code{guix-potluck.org} host; pass @code{--host=@var{host}} to specify
+an alternate registry.
+
+Running @code{guix potluck update} will simply enqueue an update request
+on the server.  Visit @code{https://@var{host}/} in your browser to see
+the state of the work queue, and to see whether your package update
+actually succeeded.  If it does succeed, you should be able to check out
+the git repository conventionally hosted at
+@indicateurl{https://@var{host}/git/main.git}, add that checkout to your
+@code{GUIX_PACKAGE_PATH}, and thereby have access to that package.  In
+the future this will be made easier with a @code{guix channel} facility,
+but for now you have to use @code{GUIX_PACKAGE_PATH} or similar.
+@xref{Defining Packages}, for more information.
+
+Finally, there is the code that actually runs the potluck service:
+@code{guix potluck host-channel}.  This tool will host a web server on
+localhost, listening on port 8080 by default.  It expects to be behind
+some kind of HTTPS terminator, like @code{nginx}.  It does the work of
+translating update requests to git repositories.  Guix includes an
+example operating system definition for a server combining HTTPS access
+to git repositories, an @code{nginx} web front-end, and a @code{guix
+potluck host-channel} instance.
+
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:46 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:46 2017
Received: from localhost ([127.0.0.1]:38431 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6D-0004Wj-J3
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:46 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:54280
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5C-0004Oz-00
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:49 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 57F2A74CDD
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:38 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=uY1rC0pj+vzX
 sMAC3yJaGZCOMP0=; b=ql0GkvknTUoCEf/TvRiL5YaqW/hlUTmQclV8t7Yd4E8K
 rRaI/Samo9Iacxk6wRrZxYbwhq5NzKcvPY8Pwhg8rMwPFZIBonUS8KL6K+aFD1Bx
 HsAEbRDSoDR3gjhiabGAP4pK04vlhLeLns/6XsD5fqltl4yjF95aZXPpfV0aQiE=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 4A51B74CDB
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:38 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 65C6974CD9
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:37 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 3/9] guix: Add git utility module.
Date: Mon, 24 Apr 2017 22:59:17 +0200
Message-Id: <20170424205923.27726-3-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: ED5D50B8-2930-11E7-A99B-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/git.scm: New file.
* Makefile.am (MODULES): Add new file.
---
 Makefile.am  |   1 +
 guix/git.scm | 164 +++++++++++++++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 165 insertions(+)
 create mode 100644 guix/git.scm

diff --git a/Makefile.am b/Makefile.am
index 22ba00e90..64a7a9265 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,7 @@ MODULES =3D					\
   guix/build/make-bootstrap.scm			\
   guix/search-paths.scm				\
   guix/packages.scm				\
+  guix/git.scm					\
   guix/potluck/build-systems.scm		\
   guix/potluck/licenses.scm			\
   guix/potluck/packages.scm			\
diff --git a/guix/git.scm b/guix/git.scm
new file mode 100644
index 000000000..02f61edac
--- /dev/null
+++ b/guix/git.scm
@@ -0,0 +1,164 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 (guix utils)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:export (&git-condition
+            git-condition?
+            git-condition-argv
+            git-condition-output
+            git-condition-status
+
+            false-if-git-error
+
+            git-check-ref-format
+            git-rev-parse
+            git-config
+            git-describe
+            git-fetch
+            git-push
+            git-clone
+            git-reset
+            git-add
+            git-commit))
+
+;;; Commentary:
+;;;
+;;; A simple collection of Scheme wrappers for Git functionality.
+;;;
+;;; Code:
+
+(define-condition-type &git-condition &condition git-condition?
+  (argv git-condition-argv)
+  (output git-condition-output)
+  (status git-condition-status))
+
+(define-syntax-rule (false-if-git-error body0 body ...)
+  (guard (c ((git-condition? c) #f))
+    body0 body ...))
+
+(define (shell:quote str)
+  (with-output-to-string
+    (lambda ()
+      (display #\')
+      (string-for-each (lambda (ch)
+                         (if (eqv? ch #\')
+                             (begin (display #\\) (display #\'))
+                             (display ch)))
+                       str)
+      (display #\'))))
+
+(define (run env input-file args)
+  (define (prepend-env args)
+    (if (null? env)
+        args
+        (cons "env" (append env args))))
+  (define (redirect-input args)
+    (if input-file
+        (list "sh" "-c"
+              (string-append (string-join (map shell:quote args) " ")
+                             "<" input-file))
+        args))
+  (let* ((real-args (redirect-input (prepend-env args)))
+         (pipe (apply open-pipe* OPEN_READ real-args))
+         (output (read-string pipe))
+         (ret (close-pipe pipe)))
+    (case (status:exit-val ret)
+      ((0) output)
+      (else (raise (condition (&git-condition
+                               (argv real-args)
+                               (output output)
+                               (status ret))))))))
+
+(define* (git* args #:key (input #f) (env '()))
+  (if input
+      (call-with-temporary-output-file
+       (lambda (file-name file-port)
+         (display input file-port)
+         (close-port file-port)
+         (run env file-name (cons* "git" args))))
+      (run env #f (cons* "git" args))))
+
+(define (git . args)
+  (git* args))
+
+(define* (git-check-ref-format str #:key allow-onelevel?)
+  "Raise an exception if @var{str} is not a valid Git ref."
+  (when (string-prefix? "-" str)
+    (error "bad ref" str))
+  (git "check-ref-format"
+       (if allow-onelevel? "--allow-onelevel" "--no-allow-onelevel")
+       str))
+
+(define (git-rev-parse rev)
+  "Parse the string @var{rev} and return a Git commit hash, as a string.=
"
+  (string-trim-both (git "rev-parse" rev)))
+
+(define (git-config key)
+  "Return the configuration value for @var{key}, as a string."
+  (string-trim-both (git "config" key)))
+
+(define* (git-describe #:optional (ref "HEAD"))
+  "Run @command{git describe} on the given @var{ref}, defaulting to
+@code{HEAD}, and return the resulting string."
+  (string-trim-both (git "describe")))
+
+(define (git-fetch)
+  "Run @command{git fetch} in the current working directory."
+  (git "fetch"))
+
+(define (git-push)
+  "Run @command{git push} in the current working directory."
+  (git "push"))
+
+(define (git-clone repo dir)
+  "Check out @var{repo} into @var{dir}."
+  (git "clone" "--" repo dir))
+
+(define* (git-reset #:key (ref "HEAD") (mode 'hard))
+  ;; Can't let the ref be mistaken for a command-line argument.
+  "Reset the current working directory to @var{ref}.  Available values f=
or
+@var{mode} are the symbols @code{hard}, @code{soft}, and @code{mixed}."
+  (when (string-prefix? "-" ref)
+    (error "bad ref" ref))
+  (git "reset"
+       (case mode
+         ((hard) "--hard")
+         ((mixed) "--mixed")
+         ((soft) "--soft")
+         (else (error "unknown mode" mode)))
+       ref))
+
+(define (git-add file)
+  "Add @var{file} to the index in the current working directory."
+  (git "add" "--" file))
+
+(define* (git-commit #:key message author-name author-email)
+  "Commit the changes in the current working directory, with the message
+@var{message}.  The commit will be attributed to the author with the nam=
e and
+email address @var{author-name} and @var{author-email}, respectively."
+  (git* (list "commit" (string-append "--message=3D" message))
+        #:env (list (string-append "GIT_COMMITTER_NAME=3D" author-name)
+                    (string-append "GIT_COMMITTER_EMAIL=3D" author-email=
)
+                    (string-append "GIT_AUTHOR_NAME=3D" author-name)
+                    (string-append "GIT_AUTHOR_EMAIL=3D" author-email)))=
)
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:45 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:45 2017
Received: from localhost ([127.0.0.1]:38429 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l6A-0004WW-04
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:45 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:63878
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5B-0004Op-TS
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:49 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id CA59974CCD
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:35 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=wBkQ98h1JOq1
 zphzvxSgg9Ui7aw=; b=RpzteJEY1+mbNhsbXjXgP8votO9nogJke4q4GrpsewEo
 uwWO8lcW6RvmEHJj/IP60xKhEkpFtXOFLTcpmz+3gfp444FuM443qY+dJWYnNaRN
 3mejob7ZtG/d7Hcqt9v7U17aJ4J7HHzsokA0Soh/m+jcVTxh8hemsnQrQECpd4Q=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id C22DD74CC4
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:34 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id A8DD774CB6
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:30 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 4/9] guix: Add "potluck" command.
Date: Mon, 24 Apr 2017 22:59:18 +0200
Message-Id: <20170424205923.27726-4-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: E9595A52-2930-11E7-9DEF-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/potluck.scm: New file.
* Makefile.am: Add new file.
---
 Makefile.am              |   1 +
 guix/scripts/potluck.scm | 310 +++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 311 insertions(+)
 create mode 100644 guix/scripts/potluck.scm

diff --git a/Makefile.am b/Makefile.am
index 64a7a9265..295d7b3a6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -167,6 +167,7 @@ MODULES =3D					\
   guix/scripts/graph.scm			\
   guix/scripts/container.scm			\
   guix/scripts/container/exec.scm		\
+  guix/scripts/potluck.scm			\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
=20
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
new file mode 100644
index 000000000..f9cd40bd0
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 scripts potluck)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module ((guix build-system) #:select (build-system-description))
+  #:use-module ((guix licenses) #:select (license-uri))
+  #:use-module (guix git)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix potluck packages)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (json)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (guix-potluck))
+
+=0C
+;;;
+;;; guix potluck init
+;;;
+
+(define* (init-potluck remote-git-url #:key
+                       (build-system 'gnu) (autoreconf? #f)
+                       (license 'gplv3+))
+  (let* ((cwd (getcwd))
+         (dot-git (in-vicinity cwd ".git"))
+         (potluck-dir (in-vicinity cwd "potluck"))
+         (package-name (basename cwd)))
+    (unless (and (file-exists? dot-git)
+                 (file-is-directory? dot-git))
+      (leave (_ "init: must be run from the root of a git checkout~%")))
+    (when (file-exists? potluck-dir)
+      (leave (_ "init: ~a already exists~%") potluck-dir))
+    (let* ((user-name (git-config "user.name"))
+           (pkg-name (basename cwd))
+           (pkg-commit (git-rev-parse "HEAD"))
+           (pkg-version
+            (catch #t
+              (lambda () (git-describe pkg-commit))
+              (lambda _
+                (format (current-error-port)
+                        "guix potluck init: git describe failed\n")
+                (format (current-error-port)
+                        "Add a tag so that git can compute a version.\n"=
)
+                (exit 1))))
+           ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
+           ;; here.
+           (pkg-sha256 (guix-hash-git-checkout cwd)))
+      (format #t (_ "Creating potluck/~%"))
+      (mkdir potluck-dir)
+      (format #t (_ "Creating potluck/README.md~%"))
+      (call-with-output-file (in-vicinity potluck-dir "README.md")
+        (lambda (port)
+          (format port
+                  "\
+This directory defines potluck packages.  Each file in this directory sh=
ould
+define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+")))
+      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (call-with-output-file (in-vicinity potluck-dir
+                                          (string-append package-name ".=
scm"))
+        (lambda (port)
+         =20
+          (define-syntax-rule (dsp exp) (display exp port))
+          (dsp ";;; guix potluck package\n")
+          (dsp ";;; Copyright (C) 2017 ")
+          (dsp user-name)
+          (dsp "\n")
+          (dsp "
+;;; This file 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.  No warranty.  See
+;;; https://www.gnu.org/licenses/gpl.html for a copy of the GPLv3.
+
+")
+          (pretty-print-potluck-package
+           port
+           (potluck-package
+            (name pkg-name)
+            (version pkg-version)
+            (source
+             (potluck-source
+              (git-uri remote-git-url)
+              (git-commit pkg-commit)
+              (sha256 (bytevector->nix-base32-string pkg-sha256))))
+            (build-system build-system)
+            (inputs '())
+            (native-inputs
+             (if autoreconf?
+                 '("autoconf" "automake" "libtool" "pkg-config")
+                 '()))
+            (arguments
+             (if autoreconf?
+                 '(#:phases (modify-phases %standard-phases
+                              (add-before 'configure 'autoconf
+                                (lambda _
+                                  (zero?
+                                   (system* "autoreconf" "-vfi"))))))
+                 '()))
+            (home-page remote-git-url)
+            (synopsis "Declarative synopsis here")
+            (description
+             (string-append (string-titlecase pkg-name)
+                            " is a ..."))
+            (license license)))))
+      (format #t (_ "
+Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
+\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+build with
+
+  guix build --file=3Dpotluck/~a.scm
+
+When you get that working, commit your results to git via:
+
+  git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
+") pkg-name pkg-name))))
+
+=0C
+;;;
+;;; Options.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix potluck [OPTION ...] ACTION [ARG ...]
+Create \"potluck\" packages, register them with a central service, and a=
rrange
+to serve those packages as a Guix channel. Some ACTIONS require addition=
al
+ARGS.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (_ "\
+   init             create potluck recipe for current working directory\=
n"))
+
+  (newline)
+  (display (_ "The available OPTION flags are:\n"))
+  (display (_ "
+      --build-system=3DSYS for 'init', specify the build system.  Use
+                         --build-system=3Dhelp for all available options=
."))
+  (display (_ "
+      --autotools        for 'init', like --build-system=3Dgnu but addit=
ionally
+                         indicating that the package needs autoreconf be=
fore
+                         running ./configure"))
+  (display (_ "
+      --license=3DLICENSE  for 'init', specify the license of the packag=
e.  Use
+                         --license=3Dhelp for all available options."))
+  (display (_ "
+      --verbosity=3DLEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix potluck")))
+        (option '("build-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-system arg result)))
+        (option '("autotools") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'autoreconf? #t
+                              (alist-cons 'build-system "gnu" result))))
+        (option '("license") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'license arg result)))
+        (option '("verbosity") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'verbosity (string->number arg) result))))=
)
+
+(define %default-options
+  ;; Alist of default option values.
+  `((verbosity . 0)))
+
+(define (parse-url url-str)
+  (unless (string->uri url-str)
+    (leave (_ "invalid url: ~a~%") url-str))
+  url-str)
+
+(define (parse-build-system sys-str)
+  (unless sys-str
+    (leave (_ "\
+init: missing --build-system; try --build-system=3Dhelp for options~%"))=
)
+  (let ((sys (string->symbol (string-downcase sys-str))))
+    (when (eq? sys 'help)
+      (format #t "guix potluck: Available build systems:~%")
+      (for-each
+       (lambda (name)
+         (let ((sys (build-system-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (build-system-description sys=
))))
+       (all-potluck-build-system-names))
+      (format #t "
+Additionally, --autotools is like --build-system=3Dgnu, but also indicat=
ing
+that the package needs autoreconf before running ./configure.~%")
+      (exit 0))
+    (unless (build-system-by-name sys)
+      (leave (_ "invalid build system: ~a; try --build-system=3Dhelp~%")=
 sys))
+    sys))
+
+(define (parse-license license-str)
+  (unless license-str
+    (leave (_ "init: missing --license; try --license=3Dhelp for options=
~%")))
+  (let ((license (string->symbol (string-downcase license-str))))
+    (when (eq? license 'help)
+      (format #t "guix potluck: Available licenses:~%")
+      (for-each
+       (lambda (name)
+         (let ((license (license-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (license-uri license))))
+       (all-potluck-license-names))
+      (format #t "
+If your package's license is not in this list, add it to Guix first.~%")
+      (exit 0))
+    (unless (license-by-name license)
+      (leave (_ "invalid license: ~a; try --license=3Dhelp~%") license))
+    license))
+
+=0C
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-potluck . args)
+  (define (parse-sub-command arg result)
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (alist-cons 'action (string->symbol arg) result)))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:argument-handler
+                                         parse-sub-command))
+           (action   (assoc-ref opts 'action))
+           (args     (reverse (filter-map (match-pair 'argument) opts)))=
)
+      (define (see-help)
+        (format (current-error-port)
+                (_ "Try 'guix potluck --help' for more information.~%"))=
)
+      (define (wrong-number-of-args usage)
+        (format (current-error-port)
+                (_ "guix potluck ~a: wrong number of arguments~%")
+                action)
+        (display usage (current-error-port))
+        (newline (current-error-port))
+        (see-help)
+        (exit 1))
+      (match action
+        (#f
+         (format (current-error-port)
+                 (_ "guix potluck: missing command name~%"))
+         (see-help)
+         (exit 1))
+        ('init
+         (match args
+           ((remote-git-url)
+            (init-potluck (parse-url remote-git-url)
+                          #:build-system (parse-build-system
+                                          (assoc-ref opts 'build-system)=
)
+                          #:autoreconf? (assoc-ref opts 'autoreconf?)
+                          #:license (parse-license
+                                     (assoc-ref opts 'license))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        (action
+         (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:42 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:41 2017
Received: from localhost ([127.0.0.1]:38427 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l69-0004WN-79
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:41 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:56924
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5B-0004Ou-Vn
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:49 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 16D6474CD2
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:36 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=dap2
 9653BGrSWdSbYQB14G6nL+0=; b=URKj0KWlQU3fdrFA0qnacAdWkJeQvOd0Z2eV
 sQVca9WcWfznkFhxG/4nyfXrU7iXjemm1w08VBm83PpwyexxHBTJ9mHk1sbFLNF1
 kqIw2q0OWGLwICsL4mDnOgERVEjJi1vBg2m1hNiHnDoApqiZWXt0VJYCwAhzkzSN
 ETyEQrM=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 0C95E74CD0
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:36 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 92B1374CBE
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:34 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 9/9] doc: Document guix potluck.
Date: Mon, 24 Apr 2017 22:59:23 +0200
Message-Id: <20170424205923.27726-9-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EBAE84B2-2930-11E7-B74F-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* doc/guix.texi (potluck-package Reference):
(Invoking guix potluck): New sections.
---
 doc/guix.texi | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 231 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7f1074f9d..f2aa52653 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -58,6 +58,7 @@ Documentation License''.
 * guix environment: (guix)Invoking guix environment. Building development environments with Guix.
 * guix build: (guix)Invoking guix build.      Building packages.
 * guix pack: (guix)Invoking guix pack.        Creating binary bundles.
+* guix potluck: (guix)Invoking guix potluck.  Publishing package definitions.
 @end direntry
 
 @titlepage
@@ -137,6 +138,7 @@ Defining Packages
 
 * package Reference::           The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 
 Utilities
 
@@ -154,6 +156,7 @@ Utilities
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Simple, decoupled package development.
 
 Invoking @command{guix build}
 
@@ -2976,6 +2979,7 @@ when @var{cut?} returns true for a given package.
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 @end menu
 
 
@@ -3192,6 +3196,115 @@ this is @code{#f}, a sensible default is used.
 @end table
 @end deftp
 
+@node potluck-package Reference
+@subsection @code{potluck-package} Reference
+
+This section defines all the options available in @code{potluck-package}
+declarations.  @xref{Invoking guix potluck}, for more background and for
+information on how to work with potluck packages from the command-line
+interface.
+
+@deftp {Data Type} potluck-package
+This is the data type representing a potluck package recipe.
+
+@table @asis
+@item @code{name}
+The name of the package, as a string.
+
+@item @code{version}
+The version of the package, as a string.
+
+@item @code{source}
+An object telling how the source code for the package should be
+acquired.  This is a @code{potluck-source} object, which itself is its
+own data type:
+
+@deftp {Data Type} potluck-source
+This is the data type representing a potluck package's source code.
+
+@table @asis
+@item @code{git-uri}
+An object containing the URI of the source git repository.  Currently
+potluck packages all come from Git.  Use the ``normal'' Guix packages if
+you need to build from some other source.
+
+@item @code{git-commit}
+The given git commit for the source, for example as a sha1 string.
+
+@item @code{sha256}
+A bytevector containing the SHA-256 hash of the source, as a base32
+string.  Note that the explicit @code{base32} wrapper that is needed for
+normal Guix packages is not present in a potluck package source.
+
+You can obtain this information using @code{guix hash -g}
+(@pxref{Invoking guix hash}).
+
+@item @code{snippet} (default: @code{#f})
+An S-expression that will be run in the source directory.  This is a
+convenient way to modify the source, sometimes more convenient than a
+patch.
+@end table
+@end deftp
+
+@item @code{build-system}
+The build system that should be used to build the package, as a symbol.
+For example, @code{gnu}.  To list available build systems, use
+@code{guix potluck init --build-system=help} (@pxref{Invoking guix
+potluck}).
+
+@item @code{arguments} (default: @code{'()})
+The arguments that should be passed to the build system.  This is a
+list, typically containing sequential keyword-value pairs, and is the
+same as for the @code{arguments} argument of a normal @code{package}
+object.
+
+@item @code{inputs} (default: @code{'()})
+@itemx @code{native-inputs} (default: @code{'()})
+@itemx @code{propagated-inputs} (default: @code{'()})
+@cindex inputs, of packages
+These fields list dependencies of the package.  Each item of an input
+list is a package specification string, for example @code{guile} or
+@code{guile@@2.0} or, in the most specific form, @code{guile@@2.0:out}.
+@xref{Packages with Multiple Outputs}, for more on package outputs.  For
+example, the list below specifies three inputs:
+
+@example
+'("libffi" "libunistring" "glib:bin")
+@end example
+
+@cindex cross compilation, package dependencies
+The distinction between @code{native-inputs} and @code{inputs} is
+necessary when considering cross-compilation.
+
+@xref{package Reference}, for full details on the differences between
+these input types.
+
+@item @code{synopsis}
+A one-line description of the package.
+
+@item @code{description}
+A more elaborate description of the package.
+
+@item @code{license}
+The license of the package, as a symbol.  For example, @code{gpl3+}.  To
+list available build systems, use @code{guix potluck init
+--license=help} (@pxref{Invoking guix potluck}).
+
+@item @code{home-page}
+The URL to the home-page of the package, as a string.
+
+@item @code{location} (default: source location of the @code{package} form)
+The source location of the package.  It is useful to override this when
+inheriting from another package, in which case this field is not
+automatically corrected.
+@end table
+@end deftp
+
+As you can see, a potluck package is less elaborate than a normal Guix
+package.  If you find yourself needing more advanced features, probably
+your package should be a part of Guix proper.  But if not, a potluck
+package can often do the job.
+
 
 @node Build Systems
 @section Build Systems
@@ -4779,6 +4892,7 @@ the Scheme programming interface of Guix in a convenient way.
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Decoupled package definition.
 @end menu
 
 @node Invoking guix build
@@ -6997,6 +7111,123 @@ must be PID 1 of the container or one of its child processes.
 
 @end table
 
+@node Invoking guix potluck
+@section Invoking @command{guix potluck}
+@cindex potluck
+@cindex @command{guix potluck}
+@quotation Note
+As of version @value{VERSION}, this tool is experimental.  The interface
+is subject to radical change in the future.
+@end quotation
+
+Guix is developed as a unified project composed of both the package
+manager and the set of packages.  This allows Guix to evolve while
+remaining healthy and coherent.  If there is a change that needs to be
+done across Guix's entire tree, Guix developers can make it happen.  One
+way in which this principle manifests itself is in the @code{package}
+data type, where input packages are directly specified by value in the
+@code{inputs}, @code{native-inputs}, and @code{propagated-inputs}
+fields, instead of being specified as some abstract package name and
+version constraint that Guix would have to solve for.  @xref{package
+Reference}, for more on the @code{package} data type.
+
+However it is sometimes desirable to develop a package or set of
+packages in a more decoupled way, for example when a package set is
+still incubating or when a package is inappropriate for sending upstream
+for some reason.  Such packages use Guix and extend Guix but are not a
+part of the Guix project, properly speaking.  As such, they need to be
+resilient to changes in upstream Guix.  It would be brittle if such a
+package definition had to reference a Guix package by value; the Scheme
+variable denoting the upstream Guix package might move to a different
+module, or be renamed, or changed in some unexpected way.
+
+Guix's @dfn{potluck} facility fills this gap.  A @dfn{potluck package}
+is like a normal Guix package, except it expresses its inputs in the
+form of package specifications instead of direct references.
+@xref{potluck-package Reference}.  Potluck packages also have a simpler
+package structure with fewer fields; compared to normal Guix packages,
+they are less expressive but more isolated from details of upstream
+Guix.
+
+The user interface to potluck packages is concentrated in the
+@command{guix potluck} command.  To begin, let's say you are a developer
+of the @code{foo} project, and you'd like to package @code{foo} for use
+in your Guix system and maybe also that of a friend.  You're not sure if
+you want to support it yet so you don't want to make a proper release,
+but there should be something in the middle between that and not
+packaging it at all.  You decide to give @code{guix potluck} a go.
+
+So in that git checkout, you run @code{guix potluck init @var{url}},
+where @var{url} is a publicly accessible git URL at which @code{foo} is
+hosted.  @code{guix potluck init} takes the following options:
+
+@table @code
+@item --build-system=@var{sys}
+@itemx --build-system=help
+@itemx --autotools
+Indicate that the package uses the build system named @var{sys}.  Pass
+@code{help} as the build system to see available options.
+@code{--autotools} is like the common @code{--build-system=gnu}, but
+additionally indicating that an @code{autoreconf} step is needed before
+building.
+@item --license=@var{license}
+@itemx --license=help
+Specify the license of the project.
+@end table
+
+Calling @code{guix potluck init} will result in the creation of a
+@code{guix-potluck} directory in your git checkout, containing a brief
+overview @code{README.md} file as well as a @code{foo.scm} potluck
+package definition.  @xref{potluck-package Reference}.  Just fill in the
+synopsis and description and add the inputs and you have the beginnings
+of a potluck package.
+
+You can try building your new package by running @code{guix build -f
+guix-potluck/foo.scm}.  Once that works, you can share the file with
+your friends and they can build your package too.
+
+Of course, it would be nice if you could share that package with the
+world.  And it would be nice if your potluck package definitions could
+augment the set of available packages and versions.  And it would be
+nice if your potluck package could serve as a first draft of a proper
+Guix package definition.  We agree completely!
+
+Guix's potluck facility also implements a kind of registry of potluck
+recipes, as if it were hosting an actual potluck.  This
+@code{host-channel} facility takes requests to add potluck packages and
+translates that into a git repository of all potluck packages, as well
+as a git repository of Guix packages compiled from those potluck
+packages.
+
+To inform a channel host of the presence of fresh tasty potluck dishes,
+run @code{guix potluck update @var{url} @var{branch}}.  @var{url} should
+be the URL of a git repository containing a @code{guix-potluck}
+directory, and @var{branch} is a ref in that repository.  By default,
+the request is made to add the package to the default
+@code{guix-potluck.org} host; pass @code{--host=@var{host}} to specify
+an alternate registry.
+
+Running @code{guix potluck update} will simply enqueue an update request
+on the server.  Visit @code{https://@var{host}/} in your browser to see
+the state of the work queue, and to see whether your package update
+actually succeeded.  If it does succeed, you should be able to check out
+the git repository conventionally hosted at
+@indicateurl{https://@var{host}/git/main.git}, add that checkout to your
+@code{GUIX_PACKAGE_PATH}, and thereby have access to that package.  In
+the future this will be made easier with a @code{guix channel} facility,
+but for now you have to use @code{GUIX_PACKAGE_PATH} or similar.
+@xref{Defining Packages}, for more information.
+
+Finally, there is the code that actually runs the potluck service:
+@code{guix potluck host-channel}.  This tool will host a web server on
+localhost, listening on port 8080 by default.  It expects to be behind
+some kind of HTTPS terminator, like @code{nginx}.  It does the work of
+translating update requests to git repositories.  Guix includes an
+example operating system definition for a server combining HTTPS access
+to git repositories, an @code{nginx} web front-end, and a @code{guix
+potluck host-channel} instance.
+
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:41 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:41 2017
Received: from localhost ([127.0.0.1]:38425 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l64-0004WB-MA
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:41 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:50191
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l56-0004OW-Av
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:47 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id E1B3974CC7
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:34 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=wBkQ98h1JOq1
 zphzvxSgg9Ui7aw=; b=RpzteJEY1+mbNhsbXjXgP8votO9nogJke4q4GrpsewEo
 uwWO8lcW6RvmEHJj/IP60xKhEkpFtXOFLTcpmz+3gfp444FuM443qY+dJWYnNaRN
 3mejob7ZtG/d7Hcqt9v7U17aJ4J7HHzsokA0Soh/m+jcVTxh8hemsnQrQECpd4Q=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id DA39074CC6
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:34 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 85ED374CB1
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:30 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 4/9] guix: Add "potluck" command.
Date: Mon, 24 Apr 2017 22:59:18 +0200
Message-Id: <20170424205923.27726-4-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: E943BDB4-2930-11E7-A4EA-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/potluck.scm: New file.
* Makefile.am: Add new file.
---
 Makefile.am              |   1 +
 guix/scripts/potluck.scm | 310 +++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 311 insertions(+)
 create mode 100644 guix/scripts/potluck.scm

diff --git a/Makefile.am b/Makefile.am
index 64a7a9265..295d7b3a6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -167,6 +167,7 @@ MODULES =3D					\
   guix/scripts/graph.scm			\
   guix/scripts/container.scm			\
   guix/scripts/container/exec.scm		\
+  guix/scripts/potluck.scm			\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
=20
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
new file mode 100644
index 000000000..f9cd40bd0
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 scripts potluck)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module ((guix build-system) #:select (build-system-description))
+  #:use-module ((guix licenses) #:select (license-uri))
+  #:use-module (guix git)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix potluck packages)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (json)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (guix-potluck))
+
+=0C
+;;;
+;;; guix potluck init
+;;;
+
+(define* (init-potluck remote-git-url #:key
+                       (build-system 'gnu) (autoreconf? #f)
+                       (license 'gplv3+))
+  (let* ((cwd (getcwd))
+         (dot-git (in-vicinity cwd ".git"))
+         (potluck-dir (in-vicinity cwd "potluck"))
+         (package-name (basename cwd)))
+    (unless (and (file-exists? dot-git)
+                 (file-is-directory? dot-git))
+      (leave (_ "init: must be run from the root of a git checkout~%")))
+    (when (file-exists? potluck-dir)
+      (leave (_ "init: ~a already exists~%") potluck-dir))
+    (let* ((user-name (git-config "user.name"))
+           (pkg-name (basename cwd))
+           (pkg-commit (git-rev-parse "HEAD"))
+           (pkg-version
+            (catch #t
+              (lambda () (git-describe pkg-commit))
+              (lambda _
+                (format (current-error-port)
+                        "guix potluck init: git describe failed\n")
+                (format (current-error-port)
+                        "Add a tag so that git can compute a version.\n"=
)
+                (exit 1))))
+           ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
+           ;; here.
+           (pkg-sha256 (guix-hash-git-checkout cwd)))
+      (format #t (_ "Creating potluck/~%"))
+      (mkdir potluck-dir)
+      (format #t (_ "Creating potluck/README.md~%"))
+      (call-with-output-file (in-vicinity potluck-dir "README.md")
+        (lambda (port)
+          (format port
+                  "\
+This directory defines potluck packages.  Each file in this directory sh=
ould
+define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+")))
+      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (call-with-output-file (in-vicinity potluck-dir
+                                          (string-append package-name ".=
scm"))
+        (lambda (port)
+         =20
+          (define-syntax-rule (dsp exp) (display exp port))
+          (dsp ";;; guix potluck package\n")
+          (dsp ";;; Copyright (C) 2017 ")
+          (dsp user-name)
+          (dsp "\n")
+          (dsp "
+;;; This file 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.  No warranty.  See
+;;; https://www.gnu.org/licenses/gpl.html for a copy of the GPLv3.
+
+")
+          (pretty-print-potluck-package
+           port
+           (potluck-package
+            (name pkg-name)
+            (version pkg-version)
+            (source
+             (potluck-source
+              (git-uri remote-git-url)
+              (git-commit pkg-commit)
+              (sha256 (bytevector->nix-base32-string pkg-sha256))))
+            (build-system build-system)
+            (inputs '())
+            (native-inputs
+             (if autoreconf?
+                 '("autoconf" "automake" "libtool" "pkg-config")
+                 '()))
+            (arguments
+             (if autoreconf?
+                 '(#:phases (modify-phases %standard-phases
+                              (add-before 'configure 'autoconf
+                                (lambda _
+                                  (zero?
+                                   (system* "autoreconf" "-vfi"))))))
+                 '()))
+            (home-page remote-git-url)
+            (synopsis "Declarative synopsis here")
+            (description
+             (string-append (string-titlecase pkg-name)
+                            " is a ..."))
+            (license license)))))
+      (format #t (_ "
+Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
+\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+build with
+
+  guix build --file=3Dpotluck/~a.scm
+
+When you get that working, commit your results to git via:
+
+  git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
+") pkg-name pkg-name))))
+
+=0C
+;;;
+;;; Options.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix potluck [OPTION ...] ACTION [ARG ...]
+Create \"potluck\" packages, register them with a central service, and a=
rrange
+to serve those packages as a Guix channel. Some ACTIONS require addition=
al
+ARGS.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (_ "\
+   init             create potluck recipe for current working directory\=
n"))
+
+  (newline)
+  (display (_ "The available OPTION flags are:\n"))
+  (display (_ "
+      --build-system=3DSYS for 'init', specify the build system.  Use
+                         --build-system=3Dhelp for all available options=
."))
+  (display (_ "
+      --autotools        for 'init', like --build-system=3Dgnu but addit=
ionally
+                         indicating that the package needs autoreconf be=
fore
+                         running ./configure"))
+  (display (_ "
+      --license=3DLICENSE  for 'init', specify the license of the packag=
e.  Use
+                         --license=3Dhelp for all available options."))
+  (display (_ "
+      --verbosity=3DLEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix potluck")))
+        (option '("build-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-system arg result)))
+        (option '("autotools") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'autoreconf? #t
+                              (alist-cons 'build-system "gnu" result))))
+        (option '("license") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'license arg result)))
+        (option '("verbosity") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'verbosity (string->number arg) result))))=
)
+
+(define %default-options
+  ;; Alist of default option values.
+  `((verbosity . 0)))
+
+(define (parse-url url-str)
+  (unless (string->uri url-str)
+    (leave (_ "invalid url: ~a~%") url-str))
+  url-str)
+
+(define (parse-build-system sys-str)
+  (unless sys-str
+    (leave (_ "\
+init: missing --build-system; try --build-system=3Dhelp for options~%"))=
)
+  (let ((sys (string->symbol (string-downcase sys-str))))
+    (when (eq? sys 'help)
+      (format #t "guix potluck: Available build systems:~%")
+      (for-each
+       (lambda (name)
+         (let ((sys (build-system-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (build-system-description sys=
))))
+       (all-potluck-build-system-names))
+      (format #t "
+Additionally, --autotools is like --build-system=3Dgnu, but also indicat=
ing
+that the package needs autoreconf before running ./configure.~%")
+      (exit 0))
+    (unless (build-system-by-name sys)
+      (leave (_ "invalid build system: ~a; try --build-system=3Dhelp~%")=
 sys))
+    sys))
+
+(define (parse-license license-str)
+  (unless license-str
+    (leave (_ "init: missing --license; try --license=3Dhelp for options=
~%")))
+  (let ((license (string->symbol (string-downcase license-str))))
+    (when (eq? license 'help)
+      (format #t "guix potluck: Available licenses:~%")
+      (for-each
+       (lambda (name)
+         (let ((license (license-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (license-uri license))))
+       (all-potluck-license-names))
+      (format #t "
+If your package's license is not in this list, add it to Guix first.~%")
+      (exit 0))
+    (unless (license-by-name license)
+      (leave (_ "invalid license: ~a; try --license=3Dhelp~%") license))
+    license))
+
+=0C
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-potluck . args)
+  (define (parse-sub-command arg result)
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (alist-cons 'action (string->symbol arg) result)))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:argument-handler
+                                         parse-sub-command))
+           (action   (assoc-ref opts 'action))
+           (args     (reverse (filter-map (match-pair 'argument) opts)))=
)
+      (define (see-help)
+        (format (current-error-port)
+                (_ "Try 'guix potluck --help' for more information.~%"))=
)
+      (define (wrong-number-of-args usage)
+        (format (current-error-port)
+                (_ "guix potluck ~a: wrong number of arguments~%")
+                action)
+        (display usage (current-error-port))
+        (newline (current-error-port))
+        (see-help)
+        (exit 1))
+      (match action
+        (#f
+         (format (current-error-port)
+                 (_ "guix potluck: missing command name~%"))
+         (see-help)
+         (exit 1))
+        ('init
+         (match args
+           ((remote-git-url)
+            (init-potluck (parse-url remote-git-url)
+                          #:build-system (parse-build-system
+                                          (assoc-ref opts 'build-system)=
)
+                          #:autoreconf? (assoc-ref opts 'autoreconf?)
+                          #:license (parse-license
+                                     (assoc-ref opts 'license))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        (action
+         (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:36 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:36 2017
Received: from localhost ([127.0.0.1]:38423 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l63-0004W3-S8
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:36 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:64165
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l5B-0004Ow-Uu
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:47 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 4B09574CDC
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:38 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=dap2
 9653BGrSWdSbYQB14G6nL+0=; b=URKj0KWlQU3fdrFA0qnacAdWkJeQvOd0Z2eV
 sQVca9WcWfznkFhxG/4nyfXrU7iXjemm1w08VBm83PpwyexxHBTJ9mHk1sbFLNF1
 kqIw2q0OWGLwICsL4mDnOgERVEjJi1vBg2m1hNiHnDoApqiZWXt0VJYCwAhzkzSN
 ETyEQrM=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 3BC9774CDA
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:38 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 56F7474CD8
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:36 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 9/9] doc: Document guix potluck.
Date: Mon, 24 Apr 2017 22:59:23 +0200
Message-Id: <20170424205923.27726-9-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: ECB96A16-2930-11E7-9352-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* doc/guix.texi (potluck-package Reference):
(Invoking guix potluck): New sections.
---
 doc/guix.texi | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 231 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7f1074f9d..f2aa52653 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -58,6 +58,7 @@ Documentation License''.
 * guix environment: (guix)Invoking guix environment. Building development environments with Guix.
 * guix build: (guix)Invoking guix build.      Building packages.
 * guix pack: (guix)Invoking guix pack.        Creating binary bundles.
+* guix potluck: (guix)Invoking guix potluck.  Publishing package definitions.
 @end direntry
 
 @titlepage
@@ -137,6 +138,7 @@ Defining Packages
 
 * package Reference::           The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 
 Utilities
 
@@ -154,6 +156,7 @@ Utilities
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Simple, decoupled package development.
 
 Invoking @command{guix build}
 
@@ -2976,6 +2979,7 @@ when @var{cut?} returns true for a given package.
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 @end menu
 
 
@@ -3192,6 +3196,115 @@ this is @code{#f}, a sensible default is used.
 @end table
 @end deftp
 
+@node potluck-package Reference
+@subsection @code{potluck-package} Reference
+
+This section defines all the options available in @code{potluck-package}
+declarations.  @xref{Invoking guix potluck}, for more background and for
+information on how to work with potluck packages from the command-line
+interface.
+
+@deftp {Data Type} potluck-package
+This is the data type representing a potluck package recipe.
+
+@table @asis
+@item @code{name}
+The name of the package, as a string.
+
+@item @code{version}
+The version of the package, as a string.
+
+@item @code{source}
+An object telling how the source code for the package should be
+acquired.  This is a @code{potluck-source} object, which itself is its
+own data type:
+
+@deftp {Data Type} potluck-source
+This is the data type representing a potluck package's source code.
+
+@table @asis
+@item @code{git-uri}
+An object containing the URI of the source git repository.  Currently
+potluck packages all come from Git.  Use the ``normal'' Guix packages if
+you need to build from some other source.
+
+@item @code{git-commit}
+The given git commit for the source, for example as a sha1 string.
+
+@item @code{sha256}
+A bytevector containing the SHA-256 hash of the source, as a base32
+string.  Note that the explicit @code{base32} wrapper that is needed for
+normal Guix packages is not present in a potluck package source.
+
+You can obtain this information using @code{guix hash -g}
+(@pxref{Invoking guix hash}).
+
+@item @code{snippet} (default: @code{#f})
+An S-expression that will be run in the source directory.  This is a
+convenient way to modify the source, sometimes more convenient than a
+patch.
+@end table
+@end deftp
+
+@item @code{build-system}
+The build system that should be used to build the package, as a symbol.
+For example, @code{gnu}.  To list available build systems, use
+@code{guix potluck init --build-system=help} (@pxref{Invoking guix
+potluck}).
+
+@item @code{arguments} (default: @code{'()})
+The arguments that should be passed to the build system.  This is a
+list, typically containing sequential keyword-value pairs, and is the
+same as for the @code{arguments} argument of a normal @code{package}
+object.
+
+@item @code{inputs} (default: @code{'()})
+@itemx @code{native-inputs} (default: @code{'()})
+@itemx @code{propagated-inputs} (default: @code{'()})
+@cindex inputs, of packages
+These fields list dependencies of the package.  Each item of an input
+list is a package specification string, for example @code{guile} or
+@code{guile@@2.0} or, in the most specific form, @code{guile@@2.0:out}.
+@xref{Packages with Multiple Outputs}, for more on package outputs.  For
+example, the list below specifies three inputs:
+
+@example
+'("libffi" "libunistring" "glib:bin")
+@end example
+
+@cindex cross compilation, package dependencies
+The distinction between @code{native-inputs} and @code{inputs} is
+necessary when considering cross-compilation.
+
+@xref{package Reference}, for full details on the differences between
+these input types.
+
+@item @code{synopsis}
+A one-line description of the package.
+
+@item @code{description}
+A more elaborate description of the package.
+
+@item @code{license}
+The license of the package, as a symbol.  For example, @code{gpl3+}.  To
+list available build systems, use @code{guix potluck init
+--license=help} (@pxref{Invoking guix potluck}).
+
+@item @code{home-page}
+The URL to the home-page of the package, as a string.
+
+@item @code{location} (default: source location of the @code{package} form)
+The source location of the package.  It is useful to override this when
+inheriting from another package, in which case this field is not
+automatically corrected.
+@end table
+@end deftp
+
+As you can see, a potluck package is less elaborate than a normal Guix
+package.  If you find yourself needing more advanced features, probably
+your package should be a part of Guix proper.  But if not, a potluck
+package can often do the job.
+
 
 @node Build Systems
 @section Build Systems
@@ -4779,6 +4892,7 @@ the Scheme programming interface of Guix in a convenient way.
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Decoupled package definition.
 @end menu
 
 @node Invoking guix build
@@ -6997,6 +7111,123 @@ must be PID 1 of the container or one of its child processes.
 
 @end table
 
+@node Invoking guix potluck
+@section Invoking @command{guix potluck}
+@cindex potluck
+@cindex @command{guix potluck}
+@quotation Note
+As of version @value{VERSION}, this tool is experimental.  The interface
+is subject to radical change in the future.
+@end quotation
+
+Guix is developed as a unified project composed of both the package
+manager and the set of packages.  This allows Guix to evolve while
+remaining healthy and coherent.  If there is a change that needs to be
+done across Guix's entire tree, Guix developers can make it happen.  One
+way in which this principle manifests itself is in the @code{package}
+data type, where input packages are directly specified by value in the
+@code{inputs}, @code{native-inputs}, and @code{propagated-inputs}
+fields, instead of being specified as some abstract package name and
+version constraint that Guix would have to solve for.  @xref{package
+Reference}, for more on the @code{package} data type.
+
+However it is sometimes desirable to develop a package or set of
+packages in a more decoupled way, for example when a package set is
+still incubating or when a package is inappropriate for sending upstream
+for some reason.  Such packages use Guix and extend Guix but are not a
+part of the Guix project, properly speaking.  As such, they need to be
+resilient to changes in upstream Guix.  It would be brittle if such a
+package definition had to reference a Guix package by value; the Scheme
+variable denoting the upstream Guix package might move to a different
+module, or be renamed, or changed in some unexpected way.
+
+Guix's @dfn{potluck} facility fills this gap.  A @dfn{potluck package}
+is like a normal Guix package, except it expresses its inputs in the
+form of package specifications instead of direct references.
+@xref{potluck-package Reference}.  Potluck packages also have a simpler
+package structure with fewer fields; compared to normal Guix packages,
+they are less expressive but more isolated from details of upstream
+Guix.
+
+The user interface to potluck packages is concentrated in the
+@command{guix potluck} command.  To begin, let's say you are a developer
+of the @code{foo} project, and you'd like to package @code{foo} for use
+in your Guix system and maybe also that of a friend.  You're not sure if
+you want to support it yet so you don't want to make a proper release,
+but there should be something in the middle between that and not
+packaging it at all.  You decide to give @code{guix potluck} a go.
+
+So in that git checkout, you run @code{guix potluck init @var{url}},
+where @var{url} is a publicly accessible git URL at which @code{foo} is
+hosted.  @code{guix potluck init} takes the following options:
+
+@table @code
+@item --build-system=@var{sys}
+@itemx --build-system=help
+@itemx --autotools
+Indicate that the package uses the build system named @var{sys}.  Pass
+@code{help} as the build system to see available options.
+@code{--autotools} is like the common @code{--build-system=gnu}, but
+additionally indicating that an @code{autoreconf} step is needed before
+building.
+@item --license=@var{license}
+@itemx --license=help
+Specify the license of the project.
+@end table
+
+Calling @code{guix potluck init} will result in the creation of a
+@code{guix-potluck} directory in your git checkout, containing a brief
+overview @code{README.md} file as well as a @code{foo.scm} potluck
+package definition.  @xref{potluck-package Reference}.  Just fill in the
+synopsis and description and add the inputs and you have the beginnings
+of a potluck package.
+
+You can try building your new package by running @code{guix build -f
+guix-potluck/foo.scm}.  Once that works, you can share the file with
+your friends and they can build your package too.
+
+Of course, it would be nice if you could share that package with the
+world.  And it would be nice if your potluck package definitions could
+augment the set of available packages and versions.  And it would be
+nice if your potluck package could serve as a first draft of a proper
+Guix package definition.  We agree completely!
+
+Guix's potluck facility also implements a kind of registry of potluck
+recipes, as if it were hosting an actual potluck.  This
+@code{host-channel} facility takes requests to add potluck packages and
+translates that into a git repository of all potluck packages, as well
+as a git repository of Guix packages compiled from those potluck
+packages.
+
+To inform a channel host of the presence of fresh tasty potluck dishes,
+run @code{guix potluck update @var{url} @var{branch}}.  @var{url} should
+be the URL of a git repository containing a @code{guix-potluck}
+directory, and @var{branch} is a ref in that repository.  By default,
+the request is made to add the package to the default
+@code{guix-potluck.org} host; pass @code{--host=@var{host}} to specify
+an alternate registry.
+
+Running @code{guix potluck update} will simply enqueue an update request
+on the server.  Visit @code{https://@var{host}/} in your browser to see
+the state of the work queue, and to see whether your package update
+actually succeeded.  If it does succeed, you should be able to check out
+the git repository conventionally hosted at
+@indicateurl{https://@var{host}/git/main.git}, add that checkout to your
+@code{GUIX_PACKAGE_PATH}, and thereby have access to that package.  In
+the future this will be made easier with a @code{guix channel} facility,
+but for now you have to use @code{GUIX_PACKAGE_PATH} or similar.
+@xref{Defining Packages}, for more information.
+
+Finally, there is the code that actually runs the potluck service:
+@code{guix potluck host-channel}.  This tool will host a web server on
+localhost, listening on port 8080 by default.  It expects to be behind
+some kind of HTTPS terminator, like @code{nginx}.  It does the work of
+translating update requests to git repositories.  Guix includes an
+example operating system definition for a server combining HTTPS access
+to git repositories, an @code{nginx} web front-end, and a @code{guix
+potluck host-channel} instance.
+
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:36 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:35 2017
Received: from localhost ([127.0.0.1]:38421 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l5y-0004Vq-P7
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:35 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:57905
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l56-0004Oc-CD
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:47 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 0C30074CCA
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:35 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=wBkQ98h1JOq1
 zphzvxSgg9Ui7aw=; b=RpzteJEY1+mbNhsbXjXgP8votO9nogJke4q4GrpsewEo
 uwWO8lcW6RvmEHJj/IP60xKhEkpFtXOFLTcpmz+3gfp444FuM443qY+dJWYnNaRN
 3mejob7ZtG/d7Hcqt9v7U17aJ4J7HHzsokA0Soh/m+jcVTxh8hemsnQrQECpd4Q=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 03F5874CC9
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:35 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 8DD7B74CB2
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:30 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 4/9] guix: Add "potluck" command.
Date: Mon, 24 Apr 2017 22:59:18 +0200
Message-Id: <20170424205923.27726-4-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: E947DFD4-2930-11E7-B5AE-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/potluck.scm: New file.
* Makefile.am: Add new file.
---
 Makefile.am              |   1 +
 guix/scripts/potluck.scm | 310 +++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 311 insertions(+)
 create mode 100644 guix/scripts/potluck.scm

diff --git a/Makefile.am b/Makefile.am
index 64a7a9265..295d7b3a6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -167,6 +167,7 @@ MODULES =3D					\
   guix/scripts/graph.scm			\
   guix/scripts/container.scm			\
   guix/scripts/container/exec.scm		\
+  guix/scripts/potluck.scm			\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
=20
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
new file mode 100644
index 000000000..f9cd40bd0
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 scripts potluck)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module ((guix build-system) #:select (build-system-description))
+  #:use-module ((guix licenses) #:select (license-uri))
+  #:use-module (guix git)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix potluck packages)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (json)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (guix-potluck))
+
+=0C
+;;;
+;;; guix potluck init
+;;;
+
+(define* (init-potluck remote-git-url #:key
+                       (build-system 'gnu) (autoreconf? #f)
+                       (license 'gplv3+))
+  (let* ((cwd (getcwd))
+         (dot-git (in-vicinity cwd ".git"))
+         (potluck-dir (in-vicinity cwd "potluck"))
+         (package-name (basename cwd)))
+    (unless (and (file-exists? dot-git)
+                 (file-is-directory? dot-git))
+      (leave (_ "init: must be run from the root of a git checkout~%")))
+    (when (file-exists? potluck-dir)
+      (leave (_ "init: ~a already exists~%") potluck-dir))
+    (let* ((user-name (git-config "user.name"))
+           (pkg-name (basename cwd))
+           (pkg-commit (git-rev-parse "HEAD"))
+           (pkg-version
+            (catch #t
+              (lambda () (git-describe pkg-commit))
+              (lambda _
+                (format (current-error-port)
+                        "guix potluck init: git describe failed\n")
+                (format (current-error-port)
+                        "Add a tag so that git can compute a version.\n"=
)
+                (exit 1))))
+           ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
+           ;; here.
+           (pkg-sha256 (guix-hash-git-checkout cwd)))
+      (format #t (_ "Creating potluck/~%"))
+      (mkdir potluck-dir)
+      (format #t (_ "Creating potluck/README.md~%"))
+      (call-with-output-file (in-vicinity potluck-dir "README.md")
+        (lambda (port)
+          (format port
+                  "\
+This directory defines potluck packages.  Each file in this directory sh=
ould
+define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+")))
+      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (call-with-output-file (in-vicinity potluck-dir
+                                          (string-append package-name ".=
scm"))
+        (lambda (port)
+         =20
+          (define-syntax-rule (dsp exp) (display exp port))
+          (dsp ";;; guix potluck package\n")
+          (dsp ";;; Copyright (C) 2017 ")
+          (dsp user-name)
+          (dsp "\n")
+          (dsp "
+;;; This file 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.  No warranty.  See
+;;; https://www.gnu.org/licenses/gpl.html for a copy of the GPLv3.
+
+")
+          (pretty-print-potluck-package
+           port
+           (potluck-package
+            (name pkg-name)
+            (version pkg-version)
+            (source
+             (potluck-source
+              (git-uri remote-git-url)
+              (git-commit pkg-commit)
+              (sha256 (bytevector->nix-base32-string pkg-sha256))))
+            (build-system build-system)
+            (inputs '())
+            (native-inputs
+             (if autoreconf?
+                 '("autoconf" "automake" "libtool" "pkg-config")
+                 '()))
+            (arguments
+             (if autoreconf?
+                 '(#:phases (modify-phases %standard-phases
+                              (add-before 'configure 'autoconf
+                                (lambda _
+                                  (zero?
+                                   (system* "autoreconf" "-vfi"))))))
+                 '()))
+            (home-page remote-git-url)
+            (synopsis "Declarative synopsis here")
+            (description
+             (string-append (string-titlecase pkg-name)
+                            " is a ..."))
+            (license license)))))
+      (format #t (_ "
+Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
+\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+build with
+
+  guix build --file=3Dpotluck/~a.scm
+
+When you get that working, commit your results to git via:
+
+  git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
+") pkg-name pkg-name))))
+
+=0C
+;;;
+;;; Options.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix potluck [OPTION ...] ACTION [ARG ...]
+Create \"potluck\" packages, register them with a central service, and a=
rrange
+to serve those packages as a Guix channel. Some ACTIONS require addition=
al
+ARGS.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (_ "\
+   init             create potluck recipe for current working directory\=
n"))
+
+  (newline)
+  (display (_ "The available OPTION flags are:\n"))
+  (display (_ "
+      --build-system=3DSYS for 'init', specify the build system.  Use
+                         --build-system=3Dhelp for all available options=
."))
+  (display (_ "
+      --autotools        for 'init', like --build-system=3Dgnu but addit=
ionally
+                         indicating that the package needs autoreconf be=
fore
+                         running ./configure"))
+  (display (_ "
+      --license=3DLICENSE  for 'init', specify the license of the packag=
e.  Use
+                         --license=3Dhelp for all available options."))
+  (display (_ "
+      --verbosity=3DLEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix potluck")))
+        (option '("build-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-system arg result)))
+        (option '("autotools") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'autoreconf? #t
+                              (alist-cons 'build-system "gnu" result))))
+        (option '("license") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'license arg result)))
+        (option '("verbosity") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'verbosity (string->number arg) result))))=
)
+
+(define %default-options
+  ;; Alist of default option values.
+  `((verbosity . 0)))
+
+(define (parse-url url-str)
+  (unless (string->uri url-str)
+    (leave (_ "invalid url: ~a~%") url-str))
+  url-str)
+
+(define (parse-build-system sys-str)
+  (unless sys-str
+    (leave (_ "\
+init: missing --build-system; try --build-system=3Dhelp for options~%"))=
)
+  (let ((sys (string->symbol (string-downcase sys-str))))
+    (when (eq? sys 'help)
+      (format #t "guix potluck: Available build systems:~%")
+      (for-each
+       (lambda (name)
+         (let ((sys (build-system-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (build-system-description sys=
))))
+       (all-potluck-build-system-names))
+      (format #t "
+Additionally, --autotools is like --build-system=3Dgnu, but also indicat=
ing
+that the package needs autoreconf before running ./configure.~%")
+      (exit 0))
+    (unless (build-system-by-name sys)
+      (leave (_ "invalid build system: ~a; try --build-system=3Dhelp~%")=
 sys))
+    sys))
+
+(define (parse-license license-str)
+  (unless license-str
+    (leave (_ "init: missing --license; try --license=3Dhelp for options=
~%")))
+  (let ((license (string->symbol (string-downcase license-str))))
+    (when (eq? license 'help)
+      (format #t "guix potluck: Available licenses:~%")
+      (for-each
+       (lambda (name)
+         (let ((license (license-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (license-uri license))))
+       (all-potluck-license-names))
+      (format #t "
+If your package's license is not in this list, add it to Guix first.~%")
+      (exit 0))
+    (unless (license-by-name license)
+      (leave (_ "invalid license: ~a; try --license=3Dhelp~%") license))
+    license))
+
+=0C
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-potluck . args)
+  (define (parse-sub-command arg result)
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (alist-cons 'action (string->symbol arg) result)))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:argument-handler
+                                         parse-sub-command))
+           (action   (assoc-ref opts 'action))
+           (args     (reverse (filter-map (match-pair 'argument) opts)))=
)
+      (define (see-help)
+        (format (current-error-port)
+                (_ "Try 'guix potluck --help' for more information.~%"))=
)
+      (define (wrong-number-of-args usage)
+        (format (current-error-port)
+                (_ "guix potluck ~a: wrong number of arguments~%")
+                action)
+        (display usage (current-error-port))
+        (newline (current-error-port))
+        (see-help)
+        (exit 1))
+      (match action
+        (#f
+         (format (current-error-port)
+                 (_ "guix potluck: missing command name~%"))
+         (see-help)
+         (exit 1))
+        ('init
+         (match args
+           ((remote-git-url)
+            (init-potluck (parse-url remote-git-url)
+                          #:build-system (parse-build-system
+                                          (assoc-ref opts 'build-system)=
)
+                          #:autoreconf? (assoc-ref opts 'autoreconf?)
+                          #:license (parse-license
+                                     (assoc-ref opts 'license))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        (action
+         (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:30 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:30 2017
Received: from localhost ([127.0.0.1]:38419 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l5u-0004Ve-Nn
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:30 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:54696
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l56-0004OU-Ac
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:47 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 30C9F74CCC
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:35 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=wBkQ98h1JOq1
 zphzvxSgg9Ui7aw=; b=RpzteJEY1+mbNhsbXjXgP8votO9nogJke4q4GrpsewEo
 uwWO8lcW6RvmEHJj/IP60xKhEkpFtXOFLTcpmz+3gfp444FuM443qY+dJWYnNaRN
 3mejob7ZtG/d7Hcqt9v7U17aJ4J7HHzsokA0Soh/m+jcVTxh8hemsnQrQECpd4Q=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 138D974CCB
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:35 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 83F9A74CB0
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:30 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 4/9] guix: Add "potluck" command.
Date: Mon, 24 Apr 2017 22:59:18 +0200
Message-Id: <20170424205923.27726-4-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: E942A64A-2930-11E7-92F1-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/potluck.scm: New file.
* Makefile.am: Add new file.
---
 Makefile.am              |   1 +
 guix/scripts/potluck.scm | 310 +++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 311 insertions(+)
 create mode 100644 guix/scripts/potluck.scm

diff --git a/Makefile.am b/Makefile.am
index 64a7a9265..295d7b3a6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -167,6 +167,7 @@ MODULES =3D					\
   guix/scripts/graph.scm			\
   guix/scripts/container.scm			\
   guix/scripts/container/exec.scm		\
+  guix/scripts/potluck.scm			\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
=20
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
new file mode 100644
index 000000000..f9cd40bd0
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 scripts potluck)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module ((guix build-system) #:select (build-system-description))
+  #:use-module ((guix licenses) #:select (license-uri))
+  #:use-module (guix git)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix potluck packages)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (json)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (guix-potluck))
+
+=0C
+;;;
+;;; guix potluck init
+;;;
+
+(define* (init-potluck remote-git-url #:key
+                       (build-system 'gnu) (autoreconf? #f)
+                       (license 'gplv3+))
+  (let* ((cwd (getcwd))
+         (dot-git (in-vicinity cwd ".git"))
+         (potluck-dir (in-vicinity cwd "potluck"))
+         (package-name (basename cwd)))
+    (unless (and (file-exists? dot-git)
+                 (file-is-directory? dot-git))
+      (leave (_ "init: must be run from the root of a git checkout~%")))
+    (when (file-exists? potluck-dir)
+      (leave (_ "init: ~a already exists~%") potluck-dir))
+    (let* ((user-name (git-config "user.name"))
+           (pkg-name (basename cwd))
+           (pkg-commit (git-rev-parse "HEAD"))
+           (pkg-version
+            (catch #t
+              (lambda () (git-describe pkg-commit))
+              (lambda _
+                (format (current-error-port)
+                        "guix potluck init: git describe failed\n")
+                (format (current-error-port)
+                        "Add a tag so that git can compute a version.\n"=
)
+                (exit 1))))
+           ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
+           ;; here.
+           (pkg-sha256 (guix-hash-git-checkout cwd)))
+      (format #t (_ "Creating potluck/~%"))
+      (mkdir potluck-dir)
+      (format #t (_ "Creating potluck/README.md~%"))
+      (call-with-output-file (in-vicinity potluck-dir "README.md")
+        (lambda (port)
+          (format port
+                  "\
+This directory defines potluck packages.  Each file in this directory sh=
ould
+define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+")))
+      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (call-with-output-file (in-vicinity potluck-dir
+                                          (string-append package-name ".=
scm"))
+        (lambda (port)
+         =20
+          (define-syntax-rule (dsp exp) (display exp port))
+          (dsp ";;; guix potluck package\n")
+          (dsp ";;; Copyright (C) 2017 ")
+          (dsp user-name)
+          (dsp "\n")
+          (dsp "
+;;; This file 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.  No warranty.  See
+;;; https://www.gnu.org/licenses/gpl.html for a copy of the GPLv3.
+
+")
+          (pretty-print-potluck-package
+           port
+           (potluck-package
+            (name pkg-name)
+            (version pkg-version)
+            (source
+             (potluck-source
+              (git-uri remote-git-url)
+              (git-commit pkg-commit)
+              (sha256 (bytevector->nix-base32-string pkg-sha256))))
+            (build-system build-system)
+            (inputs '())
+            (native-inputs
+             (if autoreconf?
+                 '("autoconf" "automake" "libtool" "pkg-config")
+                 '()))
+            (arguments
+             (if autoreconf?
+                 '(#:phases (modify-phases %standard-phases
+                              (add-before 'configure 'autoconf
+                                (lambda _
+                                  (zero?
+                                   (system* "autoreconf" "-vfi"))))))
+                 '()))
+            (home-page remote-git-url)
+            (synopsis "Declarative synopsis here")
+            (description
+             (string-append (string-titlecase pkg-name)
+                            " is a ..."))
+            (license license)))))
+      (format #t (_ "
+Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
+\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+build with
+
+  guix build --file=3Dpotluck/~a.scm
+
+When you get that working, commit your results to git via:
+
+  git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
+") pkg-name pkg-name))))
+
+=0C
+;;;
+;;; Options.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix potluck [OPTION ...] ACTION [ARG ...]
+Create \"potluck\" packages, register them with a central service, and a=
rrange
+to serve those packages as a Guix channel. Some ACTIONS require addition=
al
+ARGS.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (_ "\
+   init             create potluck recipe for current working directory\=
n"))
+
+  (newline)
+  (display (_ "The available OPTION flags are:\n"))
+  (display (_ "
+      --build-system=3DSYS for 'init', specify the build system.  Use
+                         --build-system=3Dhelp for all available options=
."))
+  (display (_ "
+      --autotools        for 'init', like --build-system=3Dgnu but addit=
ionally
+                         indicating that the package needs autoreconf be=
fore
+                         running ./configure"))
+  (display (_ "
+      --license=3DLICENSE  for 'init', specify the license of the packag=
e.  Use
+                         --license=3Dhelp for all available options."))
+  (display (_ "
+      --verbosity=3DLEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix potluck")))
+        (option '("build-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-system arg result)))
+        (option '("autotools") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'autoreconf? #t
+                              (alist-cons 'build-system "gnu" result))))
+        (option '("license") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'license arg result)))
+        (option '("verbosity") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'verbosity (string->number arg) result))))=
)
+
+(define %default-options
+  ;; Alist of default option values.
+  `((verbosity . 0)))
+
+(define (parse-url url-str)
+  (unless (string->uri url-str)
+    (leave (_ "invalid url: ~a~%") url-str))
+  url-str)
+
+(define (parse-build-system sys-str)
+  (unless sys-str
+    (leave (_ "\
+init: missing --build-system; try --build-system=3Dhelp for options~%"))=
)
+  (let ((sys (string->symbol (string-downcase sys-str))))
+    (when (eq? sys 'help)
+      (format #t "guix potluck: Available build systems:~%")
+      (for-each
+       (lambda (name)
+         (let ((sys (build-system-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (build-system-description sys=
))))
+       (all-potluck-build-system-names))
+      (format #t "
+Additionally, --autotools is like --build-system=3Dgnu, but also indicat=
ing
+that the package needs autoreconf before running ./configure.~%")
+      (exit 0))
+    (unless (build-system-by-name sys)
+      (leave (_ "invalid build system: ~a; try --build-system=3Dhelp~%")=
 sys))
+    sys))
+
+(define (parse-license license-str)
+  (unless license-str
+    (leave (_ "init: missing --license; try --license=3Dhelp for options=
~%")))
+  (let ((license (string->symbol (string-downcase license-str))))
+    (when (eq? license 'help)
+      (format #t "guix potluck: Available licenses:~%")
+      (for-each
+       (lambda (name)
+         (let ((license (license-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (license-uri license))))
+       (all-potluck-license-names))
+      (format #t "
+If your package's license is not in this list, add it to Guix first.~%")
+      (exit 0))
+    (unless (license-by-name license)
+      (leave (_ "invalid license: ~a; try --license=3Dhelp~%") license))
+    license))
+
+=0C
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-potluck . args)
+  (define (parse-sub-command arg result)
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (alist-cons 'action (string->symbol arg) result)))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:argument-handler
+                                         parse-sub-command))
+           (action   (assoc-ref opts 'action))
+           (args     (reverse (filter-map (match-pair 'argument) opts)))=
)
+      (define (see-help)
+        (format (current-error-port)
+                (_ "Try 'guix potluck --help' for more information.~%"))=
)
+      (define (wrong-number-of-args usage)
+        (format (current-error-port)
+                (_ "guix potluck ~a: wrong number of arguments~%")
+                action)
+        (display usage (current-error-port))
+        (newline (current-error-port))
+        (see-help)
+        (exit 1))
+      (match action
+        (#f
+         (format (current-error-port)
+                 (_ "guix potluck: missing command name~%"))
+         (see-help)
+         (exit 1))
+        ('init
+         (match args
+           ((remote-git-url)
+            (init-potluck (parse-url remote-git-url)
+                          #:build-system (parse-build-system
+                                          (assoc-ref opts 'build-system)=
)
+                          #:autoreconf? (assoc-ref opts 'autoreconf?)
+                          #:license (parse-license
+                                     (assoc-ref opts 'license))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        (action
+         (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:26 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:26 2017
Received: from localhost ([127.0.0.1]:38417 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l5t-0004Va-BP
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:25 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:53817
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l56-0004OX-Bb
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:43 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 0806074CCF
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:36 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references; s=sasl; bh=dap2
 9653BGrSWdSbYQB14G6nL+0=; b=URKj0KWlQU3fdrFA0qnacAdWkJeQvOd0Z2eV
 sQVca9WcWfznkFhxG/4nyfXrU7iXjemm1w08VBm83PpwyexxHBTJ9mHk1sbFLNF1
 kqIw2q0OWGLwICsL4mDnOgERVEjJi1vBg2m1hNiHnDoApqiZWXt0VJYCwAhzkzSN
 ETyEQrM=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id DF56C74CCE
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:35 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 8FC3774CBD
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:34 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 9/9] doc: Document guix potluck.
Date: Mon, 24 Apr 2017 22:59:23 +0200
Message-Id: <20170424205923.27726-9-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
X-Pobox-Relay-ID: EBAC9CA6-2930-11E7-9E02-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* doc/guix.texi (potluck-package Reference):
(Invoking guix potluck): New sections.
---
 doc/guix.texi | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 231 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7f1074f9d..f2aa52653 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -58,6 +58,7 @@ Documentation License''.
 * guix environment: (guix)Invoking guix environment. Building development environments with Guix.
 * guix build: (guix)Invoking guix build.      Building packages.
 * guix pack: (guix)Invoking guix pack.        Creating binary bundles.
+* guix potluck: (guix)Invoking guix potluck.  Publishing package definitions.
 @end direntry
 
 @titlepage
@@ -137,6 +138,7 @@ Defining Packages
 
 * package Reference::           The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 
 Utilities
 
@@ -154,6 +156,7 @@ Utilities
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Simple, decoupled package development.
 
 Invoking @command{guix build}
 
@@ -2976,6 +2979,7 @@ when @var{cut?} returns true for a given package.
 @menu
 * package Reference ::          The package data type.
 * origin Reference::            The origin data type.
+* potluck-package Reference::   The potluck-package data type.
 @end menu
 
 
@@ -3192,6 +3196,115 @@ this is @code{#f}, a sensible default is used.
 @end table
 @end deftp
 
+@node potluck-package Reference
+@subsection @code{potluck-package} Reference
+
+This section defines all the options available in @code{potluck-package}
+declarations.  @xref{Invoking guix potluck}, for more background and for
+information on how to work with potluck packages from the command-line
+interface.
+
+@deftp {Data Type} potluck-package
+This is the data type representing a potluck package recipe.
+
+@table @asis
+@item @code{name}
+The name of the package, as a string.
+
+@item @code{version}
+The version of the package, as a string.
+
+@item @code{source}
+An object telling how the source code for the package should be
+acquired.  This is a @code{potluck-source} object, which itself is its
+own data type:
+
+@deftp {Data Type} potluck-source
+This is the data type representing a potluck package's source code.
+
+@table @asis
+@item @code{git-uri}
+An object containing the URI of the source git repository.  Currently
+potluck packages all come from Git.  Use the ``normal'' Guix packages if
+you need to build from some other source.
+
+@item @code{git-commit}
+The given git commit for the source, for example as a sha1 string.
+
+@item @code{sha256}
+A bytevector containing the SHA-256 hash of the source, as a base32
+string.  Note that the explicit @code{base32} wrapper that is needed for
+normal Guix packages is not present in a potluck package source.
+
+You can obtain this information using @code{guix hash -g}
+(@pxref{Invoking guix hash}).
+
+@item @code{snippet} (default: @code{#f})
+An S-expression that will be run in the source directory.  This is a
+convenient way to modify the source, sometimes more convenient than a
+patch.
+@end table
+@end deftp
+
+@item @code{build-system}
+The build system that should be used to build the package, as a symbol.
+For example, @code{gnu}.  To list available build systems, use
+@code{guix potluck init --build-system=help} (@pxref{Invoking guix
+potluck}).
+
+@item @code{arguments} (default: @code{'()})
+The arguments that should be passed to the build system.  This is a
+list, typically containing sequential keyword-value pairs, and is the
+same as for the @code{arguments} argument of a normal @code{package}
+object.
+
+@item @code{inputs} (default: @code{'()})
+@itemx @code{native-inputs} (default: @code{'()})
+@itemx @code{propagated-inputs} (default: @code{'()})
+@cindex inputs, of packages
+These fields list dependencies of the package.  Each item of an input
+list is a package specification string, for example @code{guile} or
+@code{guile@@2.0} or, in the most specific form, @code{guile@@2.0:out}.
+@xref{Packages with Multiple Outputs}, for more on package outputs.  For
+example, the list below specifies three inputs:
+
+@example
+'("libffi" "libunistring" "glib:bin")
+@end example
+
+@cindex cross compilation, package dependencies
+The distinction between @code{native-inputs} and @code{inputs} is
+necessary when considering cross-compilation.
+
+@xref{package Reference}, for full details on the differences between
+these input types.
+
+@item @code{synopsis}
+A one-line description of the package.
+
+@item @code{description}
+A more elaborate description of the package.
+
+@item @code{license}
+The license of the package, as a symbol.  For example, @code{gpl3+}.  To
+list available build systems, use @code{guix potluck init
+--license=help} (@pxref{Invoking guix potluck}).
+
+@item @code{home-page}
+The URL to the home-page of the package, as a string.
+
+@item @code{location} (default: source location of the @code{package} form)
+The source location of the package.  It is useful to override this when
+inheriting from another package, in which case this field is not
+automatically corrected.
+@end table
+@end deftp
+
+As you can see, a potluck package is less elaborate than a normal Guix
+package.  If you find yourself needing more advanced features, probably
+your package should be a part of Guix proper.  But if not, a potluck
+package can often do the job.
+
 
 @node Build Systems
 @section Build Systems
@@ -4779,6 +4892,7 @@ the Scheme programming interface of Guix in a convenient way.
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix potluck::       Decoupled package definition.
 @end menu
 
 @node Invoking guix build
@@ -6997,6 +7111,123 @@ must be PID 1 of the container or one of its child processes.
 
 @end table
 
+@node Invoking guix potluck
+@section Invoking @command{guix potluck}
+@cindex potluck
+@cindex @command{guix potluck}
+@quotation Note
+As of version @value{VERSION}, this tool is experimental.  The interface
+is subject to radical change in the future.
+@end quotation
+
+Guix is developed as a unified project composed of both the package
+manager and the set of packages.  This allows Guix to evolve while
+remaining healthy and coherent.  If there is a change that needs to be
+done across Guix's entire tree, Guix developers can make it happen.  One
+way in which this principle manifests itself is in the @code{package}
+data type, where input packages are directly specified by value in the
+@code{inputs}, @code{native-inputs}, and @code{propagated-inputs}
+fields, instead of being specified as some abstract package name and
+version constraint that Guix would have to solve for.  @xref{package
+Reference}, for more on the @code{package} data type.
+
+However it is sometimes desirable to develop a package or set of
+packages in a more decoupled way, for example when a package set is
+still incubating or when a package is inappropriate for sending upstream
+for some reason.  Such packages use Guix and extend Guix but are not a
+part of the Guix project, properly speaking.  As such, they need to be
+resilient to changes in upstream Guix.  It would be brittle if such a
+package definition had to reference a Guix package by value; the Scheme
+variable denoting the upstream Guix package might move to a different
+module, or be renamed, or changed in some unexpected way.
+
+Guix's @dfn{potluck} facility fills this gap.  A @dfn{potluck package}
+is like a normal Guix package, except it expresses its inputs in the
+form of package specifications instead of direct references.
+@xref{potluck-package Reference}.  Potluck packages also have a simpler
+package structure with fewer fields; compared to normal Guix packages,
+they are less expressive but more isolated from details of upstream
+Guix.
+
+The user interface to potluck packages is concentrated in the
+@command{guix potluck} command.  To begin, let's say you are a developer
+of the @code{foo} project, and you'd like to package @code{foo} for use
+in your Guix system and maybe also that of a friend.  You're not sure if
+you want to support it yet so you don't want to make a proper release,
+but there should be something in the middle between that and not
+packaging it at all.  You decide to give @code{guix potluck} a go.
+
+So in that git checkout, you run @code{guix potluck init @var{url}},
+where @var{url} is a publicly accessible git URL at which @code{foo} is
+hosted.  @code{guix potluck init} takes the following options:
+
+@table @code
+@item --build-system=@var{sys}
+@itemx --build-system=help
+@itemx --autotools
+Indicate that the package uses the build system named @var{sys}.  Pass
+@code{help} as the build system to see available options.
+@code{--autotools} is like the common @code{--build-system=gnu}, but
+additionally indicating that an @code{autoreconf} step is needed before
+building.
+@item --license=@var{license}
+@itemx --license=help
+Specify the license of the project.
+@end table
+
+Calling @code{guix potluck init} will result in the creation of a
+@code{guix-potluck} directory in your git checkout, containing a brief
+overview @code{README.md} file as well as a @code{foo.scm} potluck
+package definition.  @xref{potluck-package Reference}.  Just fill in the
+synopsis and description and add the inputs and you have the beginnings
+of a potluck package.
+
+You can try building your new package by running @code{guix build -f
+guix-potluck/foo.scm}.  Once that works, you can share the file with
+your friends and they can build your package too.
+
+Of course, it would be nice if you could share that package with the
+world.  And it would be nice if your potluck package definitions could
+augment the set of available packages and versions.  And it would be
+nice if your potluck package could serve as a first draft of a proper
+Guix package definition.  We agree completely!
+
+Guix's potluck facility also implements a kind of registry of potluck
+recipes, as if it were hosting an actual potluck.  This
+@code{host-channel} facility takes requests to add potluck packages and
+translates that into a git repository of all potluck packages, as well
+as a git repository of Guix packages compiled from those potluck
+packages.
+
+To inform a channel host of the presence of fresh tasty potluck dishes,
+run @code{guix potluck update @var{url} @var{branch}}.  @var{url} should
+be the URL of a git repository containing a @code{guix-potluck}
+directory, and @var{branch} is a ref in that repository.  By default,
+the request is made to add the package to the default
+@code{guix-potluck.org} host; pass @code{--host=@var{host}} to specify
+an alternate registry.
+
+Running @code{guix potluck update} will simply enqueue an update request
+on the server.  Visit @code{https://@var{host}/} in your browser to see
+the state of the work queue, and to see whether your package update
+actually succeeded.  If it does succeed, you should be able to check out
+the git repository conventionally hosted at
+@indicateurl{https://@var{host}/git/main.git}, add that checkout to your
+@code{GUIX_PACKAGE_PATH}, and thereby have access to that package.  In
+the future this will be made easier with a @code{guix channel} facility,
+but for now you have to use @code{GUIX_PACKAGE_PATH} or similar.
+@xref{Defining Packages}, for more information.
+
+Finally, there is the code that actually runs the potluck service:
+@code{guix potluck host-channel}.  This tool will host a web server on
+localhost, listening on port 8080 by default.  It expects to be behind
+some kind of HTTPS terminator, like @code{nginx}.  It does the work of
+translating update requests to git repositories.  Guix includes an
+example operating system definition for a server combining HTTPS access
+to git repositories, an @code{nginx} web front-end, and a @code{guix
+potluck host-channel} instance.
+
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
-- 
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:25 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:25 2017
Received: from localhost ([127.0.0.1]:38415 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l5o-0004VO-5f
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:25 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:50175
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l55-0004OQ-Nv
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:41 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 5115174CBC
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:33 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=wBkQ98h1JOq1
 zphzvxSgg9Ui7aw=; b=RpzteJEY1+mbNhsbXjXgP8votO9nogJke4q4GrpsewEo
 uwWO8lcW6RvmEHJj/IP60xKhEkpFtXOFLTcpmz+3gfp444FuM443qY+dJWYnNaRN
 3mejob7ZtG/d7Hcqt9v7U17aJ4J7HHzsokA0Soh/m+jcVTxh8hemsnQrQECpd4Q=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 4808E74CBB
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:33 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 9C0A674CB4
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:30 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 4/9] guix: Add "potluck" command.
Date: Mon, 24 Apr 2017 22:59:18 +0200
Message-Id: <20170424205923.27726-4-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: E9519C2C-2930-11E7-AF7E-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/potluck.scm: New file.
* Makefile.am: Add new file.
---
 Makefile.am              |   1 +
 guix/scripts/potluck.scm | 310 +++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 311 insertions(+)
 create mode 100644 guix/scripts/potluck.scm

diff --git a/Makefile.am b/Makefile.am
index 64a7a9265..295d7b3a6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -167,6 +167,7 @@ MODULES =3D					\
   guix/scripts/graph.scm			\
   guix/scripts/container.scm			\
   guix/scripts/container/exec.scm		\
+  guix/scripts/potluck.scm			\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
=20
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
new file mode 100644
index 000000000..f9cd40bd0
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 scripts potluck)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module ((guix build-system) #:select (build-system-description))
+  #:use-module ((guix licenses) #:select (license-uri))
+  #:use-module (guix git)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix potluck packages)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (json)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (guix-potluck))
+
+=0C
+;;;
+;;; guix potluck init
+;;;
+
+(define* (init-potluck remote-git-url #:key
+                       (build-system 'gnu) (autoreconf? #f)
+                       (license 'gplv3+))
+  (let* ((cwd (getcwd))
+         (dot-git (in-vicinity cwd ".git"))
+         (potluck-dir (in-vicinity cwd "potluck"))
+         (package-name (basename cwd)))
+    (unless (and (file-exists? dot-git)
+                 (file-is-directory? dot-git))
+      (leave (_ "init: must be run from the root of a git checkout~%")))
+    (when (file-exists? potluck-dir)
+      (leave (_ "init: ~a already exists~%") potluck-dir))
+    (let* ((user-name (git-config "user.name"))
+           (pkg-name (basename cwd))
+           (pkg-commit (git-rev-parse "HEAD"))
+           (pkg-version
+            (catch #t
+              (lambda () (git-describe pkg-commit))
+              (lambda _
+                (format (current-error-port)
+                        "guix potluck init: git describe failed\n")
+                (format (current-error-port)
+                        "Add a tag so that git can compute a version.\n"=
)
+                (exit 1))))
+           ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
+           ;; here.
+           (pkg-sha256 (guix-hash-git-checkout cwd)))
+      (format #t (_ "Creating potluck/~%"))
+      (mkdir potluck-dir)
+      (format #t (_ "Creating potluck/README.md~%"))
+      (call-with-output-file (in-vicinity potluck-dir "README.md")
+        (lambda (port)
+          (format port
+                  "\
+This directory defines potluck packages.  Each file in this directory sh=
ould
+define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+")))
+      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (call-with-output-file (in-vicinity potluck-dir
+                                          (string-append package-name ".=
scm"))
+        (lambda (port)
+         =20
+          (define-syntax-rule (dsp exp) (display exp port))
+          (dsp ";;; guix potluck package\n")
+          (dsp ";;; Copyright (C) 2017 ")
+          (dsp user-name)
+          (dsp "\n")
+          (dsp "
+;;; This file 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.  No warranty.  See
+;;; https://www.gnu.org/licenses/gpl.html for a copy of the GPLv3.
+
+")
+          (pretty-print-potluck-package
+           port
+           (potluck-package
+            (name pkg-name)
+            (version pkg-version)
+            (source
+             (potluck-source
+              (git-uri remote-git-url)
+              (git-commit pkg-commit)
+              (sha256 (bytevector->nix-base32-string pkg-sha256))))
+            (build-system build-system)
+            (inputs '())
+            (native-inputs
+             (if autoreconf?
+                 '("autoconf" "automake" "libtool" "pkg-config")
+                 '()))
+            (arguments
+             (if autoreconf?
+                 '(#:phases (modify-phases %standard-phases
+                              (add-before 'configure 'autoconf
+                                (lambda _
+                                  (zero?
+                                   (system* "autoreconf" "-vfi"))))))
+                 '()))
+            (home-page remote-git-url)
+            (synopsis "Declarative synopsis here")
+            (description
+             (string-append (string-titlecase pkg-name)
+                            " is a ..."))
+            (license license)))))
+      (format #t (_ "
+Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
+\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+build with
+
+  guix build --file=3Dpotluck/~a.scm
+
+When you get that working, commit your results to git via:
+
+  git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
+") pkg-name pkg-name))))
+
+=0C
+;;;
+;;; Options.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix potluck [OPTION ...] ACTION [ARG ...]
+Create \"potluck\" packages, register them with a central service, and a=
rrange
+to serve those packages as a Guix channel. Some ACTIONS require addition=
al
+ARGS.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (_ "\
+   init             create potluck recipe for current working directory\=
n"))
+
+  (newline)
+  (display (_ "The available OPTION flags are:\n"))
+  (display (_ "
+      --build-system=3DSYS for 'init', specify the build system.  Use
+                         --build-system=3Dhelp for all available options=
."))
+  (display (_ "
+      --autotools        for 'init', like --build-system=3Dgnu but addit=
ionally
+                         indicating that the package needs autoreconf be=
fore
+                         running ./configure"))
+  (display (_ "
+      --license=3DLICENSE  for 'init', specify the license of the packag=
e.  Use
+                         --license=3Dhelp for all available options."))
+  (display (_ "
+      --verbosity=3DLEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix potluck")))
+        (option '("build-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-system arg result)))
+        (option '("autotools") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'autoreconf? #t
+                              (alist-cons 'build-system "gnu" result))))
+        (option '("license") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'license arg result)))
+        (option '("verbosity") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'verbosity (string->number arg) result))))=
)
+
+(define %default-options
+  ;; Alist of default option values.
+  `((verbosity . 0)))
+
+(define (parse-url url-str)
+  (unless (string->uri url-str)
+    (leave (_ "invalid url: ~a~%") url-str))
+  url-str)
+
+(define (parse-build-system sys-str)
+  (unless sys-str
+    (leave (_ "\
+init: missing --build-system; try --build-system=3Dhelp for options~%"))=
)
+  (let ((sys (string->symbol (string-downcase sys-str))))
+    (when (eq? sys 'help)
+      (format #t "guix potluck: Available build systems:~%")
+      (for-each
+       (lambda (name)
+         (let ((sys (build-system-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (build-system-description sys=
))))
+       (all-potluck-build-system-names))
+      (format #t "
+Additionally, --autotools is like --build-system=3Dgnu, but also indicat=
ing
+that the package needs autoreconf before running ./configure.~%")
+      (exit 0))
+    (unless (build-system-by-name sys)
+      (leave (_ "invalid build system: ~a; try --build-system=3Dhelp~%")=
 sys))
+    sys))
+
+(define (parse-license license-str)
+  (unless license-str
+    (leave (_ "init: missing --license; try --license=3Dhelp for options=
~%")))
+  (let ((license (string->symbol (string-downcase license-str))))
+    (when (eq? license 'help)
+      (format #t "guix potluck: Available licenses:~%")
+      (for-each
+       (lambda (name)
+         (let ((license (license-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (license-uri license))))
+       (all-potluck-license-names))
+      (format #t "
+If your package's license is not in this list, add it to Guix first.~%")
+      (exit 0))
+    (unless (license-by-name license)
+      (leave (_ "invalid license: ~a; try --license=3Dhelp~%") license))
+    license))
+
+=0C
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-potluck . args)
+  (define (parse-sub-command arg result)
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (alist-cons 'action (string->symbol arg) result)))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:argument-handler
+                                         parse-sub-command))
+           (action   (assoc-ref opts 'action))
+           (args     (reverse (filter-map (match-pair 'argument) opts)))=
)
+      (define (see-help)
+        (format (current-error-port)
+                (_ "Try 'guix potluck --help' for more information.~%"))=
)
+      (define (wrong-number-of-args usage)
+        (format (current-error-port)
+                (_ "guix potluck ~a: wrong number of arguments~%")
+                action)
+        (display usage (current-error-port))
+        (newline (current-error-port))
+        (see-help)
+        (exit 1))
+      (match action
+        (#f
+         (format (current-error-port)
+                 (_ "guix potluck: missing command name~%"))
+         (see-help)
+         (exit 1))
+        ('init
+         (match args
+           ((remote-git-url)
+            (init-potluck (parse-url remote-git-url)
+                          #:build-system (parse-build-system
+                                          (assoc-ref opts 'build-system)=
)
+                          #:autoreconf? (assoc-ref opts 'autoreconf?)
+                          #:license (parse-license
+                                     (assoc-ref opts 'license))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        (action
+         (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:20 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:20 2017
Received: from localhost ([127.0.0.1]:38413 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l5k-0004V9-4J
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:20 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:55077
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l55-0004OP-EN
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:41 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 337FA74CBA
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:33 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=wBkQ98h1JOq1
 zphzvxSgg9Ui7aw=; b=RpzteJEY1+mbNhsbXjXgP8votO9nogJke4q4GrpsewEo
 uwWO8lcW6RvmEHJj/IP60xKhEkpFtXOFLTcpmz+3gfp444FuM443qY+dJWYnNaRN
 3mejob7ZtG/d7Hcqt9v7U17aJ4J7HHzsokA0Soh/m+jcVTxh8hemsnQrQECpd4Q=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 2AAEE74CB9
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:33 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id AF06274CB7
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:30 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 4/9] guix: Add "potluck" command.
Date: Mon, 24 Apr 2017 22:59:18 +0200
Message-Id: <20170424205923.27726-4-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: E95D72A4-2930-11E7-8CFB-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/potluck.scm: New file.
* Makefile.am: Add new file.
---
 Makefile.am              |   1 +
 guix/scripts/potluck.scm | 310 +++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 311 insertions(+)
 create mode 100644 guix/scripts/potluck.scm

diff --git a/Makefile.am b/Makefile.am
index 64a7a9265..295d7b3a6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -167,6 +167,7 @@ MODULES =3D					\
   guix/scripts/graph.scm			\
   guix/scripts/container.scm			\
   guix/scripts/container/exec.scm		\
+  guix/scripts/potluck.scm			\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
=20
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
new file mode 100644
index 000000000..f9cd40bd0
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 scripts potluck)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module ((guix build-system) #:select (build-system-description))
+  #:use-module ((guix licenses) #:select (license-uri))
+  #:use-module (guix git)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix potluck packages)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (json)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (guix-potluck))
+
+=0C
+;;;
+;;; guix potluck init
+;;;
+
+(define* (init-potluck remote-git-url #:key
+                       (build-system 'gnu) (autoreconf? #f)
+                       (license 'gplv3+))
+  (let* ((cwd (getcwd))
+         (dot-git (in-vicinity cwd ".git"))
+         (potluck-dir (in-vicinity cwd "potluck"))
+         (package-name (basename cwd)))
+    (unless (and (file-exists? dot-git)
+                 (file-is-directory? dot-git))
+      (leave (_ "init: must be run from the root of a git checkout~%")))
+    (when (file-exists? potluck-dir)
+      (leave (_ "init: ~a already exists~%") potluck-dir))
+    (let* ((user-name (git-config "user.name"))
+           (pkg-name (basename cwd))
+           (pkg-commit (git-rev-parse "HEAD"))
+           (pkg-version
+            (catch #t
+              (lambda () (git-describe pkg-commit))
+              (lambda _
+                (format (current-error-port)
+                        "guix potluck init: git describe failed\n")
+                (format (current-error-port)
+                        "Add a tag so that git can compute a version.\n"=
)
+                (exit 1))))
+           ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
+           ;; here.
+           (pkg-sha256 (guix-hash-git-checkout cwd)))
+      (format #t (_ "Creating potluck/~%"))
+      (mkdir potluck-dir)
+      (format #t (_ "Creating potluck/README.md~%"))
+      (call-with-output-file (in-vicinity potluck-dir "README.md")
+        (lambda (port)
+          (format port
+                  "\
+This directory defines potluck packages.  Each file in this directory sh=
ould
+define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+")))
+      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (call-with-output-file (in-vicinity potluck-dir
+                                          (string-append package-name ".=
scm"))
+        (lambda (port)
+         =20
+          (define-syntax-rule (dsp exp) (display exp port))
+          (dsp ";;; guix potluck package\n")
+          (dsp ";;; Copyright (C) 2017 ")
+          (dsp user-name)
+          (dsp "\n")
+          (dsp "
+;;; This file 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.  No warranty.  See
+;;; https://www.gnu.org/licenses/gpl.html for a copy of the GPLv3.
+
+")
+          (pretty-print-potluck-package
+           port
+           (potluck-package
+            (name pkg-name)
+            (version pkg-version)
+            (source
+             (potluck-source
+              (git-uri remote-git-url)
+              (git-commit pkg-commit)
+              (sha256 (bytevector->nix-base32-string pkg-sha256))))
+            (build-system build-system)
+            (inputs '())
+            (native-inputs
+             (if autoreconf?
+                 '("autoconf" "automake" "libtool" "pkg-config")
+                 '()))
+            (arguments
+             (if autoreconf?
+                 '(#:phases (modify-phases %standard-phases
+                              (add-before 'configure 'autoconf
+                                (lambda _
+                                  (zero?
+                                   (system* "autoreconf" "-vfi"))))))
+                 '()))
+            (home-page remote-git-url)
+            (synopsis "Declarative synopsis here")
+            (description
+             (string-append (string-titlecase pkg-name)
+                            " is a ..."))
+            (license license)))))
+      (format #t (_ "
+Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
+\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+build with
+
+  guix build --file=3Dpotluck/~a.scm
+
+When you get that working, commit your results to git via:
+
+  git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
+") pkg-name pkg-name))))
+
+=0C
+;;;
+;;; Options.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix potluck [OPTION ...] ACTION [ARG ...]
+Create \"potluck\" packages, register them with a central service, and a=
rrange
+to serve those packages as a Guix channel. Some ACTIONS require addition=
al
+ARGS.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (_ "\
+   init             create potluck recipe for current working directory\=
n"))
+
+  (newline)
+  (display (_ "The available OPTION flags are:\n"))
+  (display (_ "
+      --build-system=3DSYS for 'init', specify the build system.  Use
+                         --build-system=3Dhelp for all available options=
."))
+  (display (_ "
+      --autotools        for 'init', like --build-system=3Dgnu but addit=
ionally
+                         indicating that the package needs autoreconf be=
fore
+                         running ./configure"))
+  (display (_ "
+      --license=3DLICENSE  for 'init', specify the license of the packag=
e.  Use
+                         --license=3Dhelp for all available options."))
+  (display (_ "
+      --verbosity=3DLEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix potluck")))
+        (option '("build-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-system arg result)))
+        (option '("autotools") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'autoreconf? #t
+                              (alist-cons 'build-system "gnu" result))))
+        (option '("license") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'license arg result)))
+        (option '("verbosity") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'verbosity (string->number arg) result))))=
)
+
+(define %default-options
+  ;; Alist of default option values.
+  `((verbosity . 0)))
+
+(define (parse-url url-str)
+  (unless (string->uri url-str)
+    (leave (_ "invalid url: ~a~%") url-str))
+  url-str)
+
+(define (parse-build-system sys-str)
+  (unless sys-str
+    (leave (_ "\
+init: missing --build-system; try --build-system=3Dhelp for options~%"))=
)
+  (let ((sys (string->symbol (string-downcase sys-str))))
+    (when (eq? sys 'help)
+      (format #t "guix potluck: Available build systems:~%")
+      (for-each
+       (lambda (name)
+         (let ((sys (build-system-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (build-system-description sys=
))))
+       (all-potluck-build-system-names))
+      (format #t "
+Additionally, --autotools is like --build-system=3Dgnu, but also indicat=
ing
+that the package needs autoreconf before running ./configure.~%")
+      (exit 0))
+    (unless (build-system-by-name sys)
+      (leave (_ "invalid build system: ~a; try --build-system=3Dhelp~%")=
 sys))
+    sys))
+
+(define (parse-license license-str)
+  (unless license-str
+    (leave (_ "init: missing --license; try --license=3Dhelp for options=
~%")))
+  (let ((license (string->symbol (string-downcase license-str))))
+    (when (eq? license 'help)
+      (format #t "guix potluck: Available licenses:~%")
+      (for-each
+       (lambda (name)
+         (let ((license (license-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (license-uri license))))
+       (all-potluck-license-names))
+      (format #t "
+If your package's license is not in this list, add it to Guix first.~%")
+      (exit 0))
+    (unless (license-by-name license)
+      (leave (_ "invalid license: ~a; try --license=3Dhelp~%") license))
+    license))
+
+=0C
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-potluck . args)
+  (define (parse-sub-command arg result)
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (alist-cons 'action (string->symbol arg) result)))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:argument-handler
+                                         parse-sub-command))
+           (action   (assoc-ref opts 'action))
+           (args     (reverse (filter-map (match-pair 'argument) opts)))=
)
+      (define (see-help)
+        (format (current-error-port)
+                (_ "Try 'guix potluck --help' for more information.~%"))=
)
+      (define (wrong-number-of-args usage)
+        (format (current-error-port)
+                (_ "guix potluck ~a: wrong number of arguments~%")
+                action)
+        (display usage (current-error-port))
+        (newline (current-error-port))
+        (see-help)
+        (exit 1))
+      (match action
+        (#f
+         (format (current-error-port)
+                 (_ "guix potluck: missing command name~%"))
+         (see-help)
+         (exit 1))
+        ('init
+         (match args
+           ((remote-git-url)
+            (init-potluck (parse-url remote-git-url)
+                          #:build-system (parse-build-system
+                                          (assoc-ref opts 'build-system)=
)
+                          #:autoreconf? (assoc-ref opts 'autoreconf?)
+                          #:license (parse-license
+                                     (assoc-ref opts 'license))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        (action
+         (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:16 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 17:00:16 2017
Received: from localhost ([127.0.0.1]:38409 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l5S-0004Rg-Si
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 17:00:16 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:59579
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l55-0004OO-As
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:41 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id D031E74CC5
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:34 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=wBkQ98h1JOq1
 zphzvxSgg9Ui7aw=; b=RpzteJEY1+mbNhsbXjXgP8votO9nogJke4q4GrpsewEo
 uwWO8lcW6RvmEHJj/IP60xKhEkpFtXOFLTcpmz+3gfp444FuM443qY+dJWYnNaRN
 3mejob7ZtG/d7Hcqt9v7U17aJ4J7HHzsokA0Soh/m+jcVTxh8hemsnQrQECpd4Q=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id B5D8674CC3
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:34 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 941AE74CB3
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:30 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 4/9] guix: Add "potluck" command.
Date: Mon, 24 Apr 2017 22:59:18 +0200
Message-Id: <20170424205923.27726-4-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: E94BAF74-2930-11E7-AA6E-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/potluck.scm: New file.
* Makefile.am: Add new file.
---
 Makefile.am              |   1 +
 guix/scripts/potluck.scm | 310 +++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 311 insertions(+)
 create mode 100644 guix/scripts/potluck.scm

diff --git a/Makefile.am b/Makefile.am
index 64a7a9265..295d7b3a6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -167,6 +167,7 @@ MODULES =3D					\
   guix/scripts/graph.scm			\
   guix/scripts/container.scm			\
   guix/scripts/container/exec.scm		\
+  guix/scripts/potluck.scm			\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
=20
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
new file mode 100644
index 000000000..f9cd40bd0
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 scripts potluck)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module ((guix build-system) #:select (build-system-description))
+  #:use-module ((guix licenses) #:select (license-uri))
+  #:use-module (guix git)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix potluck packages)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (json)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (guix-potluck))
+
+=0C
+;;;
+;;; guix potluck init
+;;;
+
+(define* (init-potluck remote-git-url #:key
+                       (build-system 'gnu) (autoreconf? #f)
+                       (license 'gplv3+))
+  (let* ((cwd (getcwd))
+         (dot-git (in-vicinity cwd ".git"))
+         (potluck-dir (in-vicinity cwd "potluck"))
+         (package-name (basename cwd)))
+    (unless (and (file-exists? dot-git)
+                 (file-is-directory? dot-git))
+      (leave (_ "init: must be run from the root of a git checkout~%")))
+    (when (file-exists? potluck-dir)
+      (leave (_ "init: ~a already exists~%") potluck-dir))
+    (let* ((user-name (git-config "user.name"))
+           (pkg-name (basename cwd))
+           (pkg-commit (git-rev-parse "HEAD"))
+           (pkg-version
+            (catch #t
+              (lambda () (git-describe pkg-commit))
+              (lambda _
+                (format (current-error-port)
+                        "guix potluck init: git describe failed\n")
+                (format (current-error-port)
+                        "Add a tag so that git can compute a version.\n"=
)
+                (exit 1))))
+           ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
+           ;; here.
+           (pkg-sha256 (guix-hash-git-checkout cwd)))
+      (format #t (_ "Creating potluck/~%"))
+      (mkdir potluck-dir)
+      (format #t (_ "Creating potluck/README.md~%"))
+      (call-with-output-file (in-vicinity potluck-dir "README.md")
+        (lambda (port)
+          (format port
+                  "\
+This directory defines potluck packages.  Each file in this directory sh=
ould
+define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+")))
+      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (call-with-output-file (in-vicinity potluck-dir
+                                          (string-append package-name ".=
scm"))
+        (lambda (port)
+         =20
+          (define-syntax-rule (dsp exp) (display exp port))
+          (dsp ";;; guix potluck package\n")
+          (dsp ";;; Copyright (C) 2017 ")
+          (dsp user-name)
+          (dsp "\n")
+          (dsp "
+;;; This file 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.  No warranty.  See
+;;; https://www.gnu.org/licenses/gpl.html for a copy of the GPLv3.
+
+")
+          (pretty-print-potluck-package
+           port
+           (potluck-package
+            (name pkg-name)
+            (version pkg-version)
+            (source
+             (potluck-source
+              (git-uri remote-git-url)
+              (git-commit pkg-commit)
+              (sha256 (bytevector->nix-base32-string pkg-sha256))))
+            (build-system build-system)
+            (inputs '())
+            (native-inputs
+             (if autoreconf?
+                 '("autoconf" "automake" "libtool" "pkg-config")
+                 '()))
+            (arguments
+             (if autoreconf?
+                 '(#:phases (modify-phases %standard-phases
+                              (add-before 'configure 'autoconf
+                                (lambda _
+                                  (zero?
+                                   (system* "autoreconf" "-vfi"))))))
+                 '()))
+            (home-page remote-git-url)
+            (synopsis "Declarative synopsis here")
+            (description
+             (string-append (string-titlecase pkg-name)
+                            " is a ..."))
+            (license license)))))
+      (format #t (_ "
+Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
+\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+build with
+
+  guix build --file=3Dpotluck/~a.scm
+
+When you get that working, commit your results to git via:
+
+  git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
+") pkg-name pkg-name))))
+
+=0C
+;;;
+;;; Options.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix potluck [OPTION ...] ACTION [ARG ...]
+Create \"potluck\" packages, register them with a central service, and a=
rrange
+to serve those packages as a Guix channel. Some ACTIONS require addition=
al
+ARGS.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (_ "\
+   init             create potluck recipe for current working directory\=
n"))
+
+  (newline)
+  (display (_ "The available OPTION flags are:\n"))
+  (display (_ "
+      --build-system=3DSYS for 'init', specify the build system.  Use
+                         --build-system=3Dhelp for all available options=
."))
+  (display (_ "
+      --autotools        for 'init', like --build-system=3Dgnu but addit=
ionally
+                         indicating that the package needs autoreconf be=
fore
+                         running ./configure"))
+  (display (_ "
+      --license=3DLICENSE  for 'init', specify the license of the packag=
e.  Use
+                         --license=3Dhelp for all available options."))
+  (display (_ "
+      --verbosity=3DLEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix potluck")))
+        (option '("build-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-system arg result)))
+        (option '("autotools") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'autoreconf? #t
+                              (alist-cons 'build-system "gnu" result))))
+        (option '("license") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'license arg result)))
+        (option '("verbosity") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'verbosity (string->number arg) result))))=
)
+
+(define %default-options
+  ;; Alist of default option values.
+  `((verbosity . 0)))
+
+(define (parse-url url-str)
+  (unless (string->uri url-str)
+    (leave (_ "invalid url: ~a~%") url-str))
+  url-str)
+
+(define (parse-build-system sys-str)
+  (unless sys-str
+    (leave (_ "\
+init: missing --build-system; try --build-system=3Dhelp for options~%"))=
)
+  (let ((sys (string->symbol (string-downcase sys-str))))
+    (when (eq? sys 'help)
+      (format #t "guix potluck: Available build systems:~%")
+      (for-each
+       (lambda (name)
+         (let ((sys (build-system-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (build-system-description sys=
))))
+       (all-potluck-build-system-names))
+      (format #t "
+Additionally, --autotools is like --build-system=3Dgnu, but also indicat=
ing
+that the package needs autoreconf before running ./configure.~%")
+      (exit 0))
+    (unless (build-system-by-name sys)
+      (leave (_ "invalid build system: ~a; try --build-system=3Dhelp~%")=
 sys))
+    sys))
+
+(define (parse-license license-str)
+  (unless license-str
+    (leave (_ "init: missing --license; try --license=3Dhelp for options=
~%")))
+  (let ((license (string->symbol (string-downcase license-str))))
+    (when (eq? license 'help)
+      (format #t "guix potluck: Available licenses:~%")
+      (for-each
+       (lambda (name)
+         (let ((license (license-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (license-uri license))))
+       (all-potluck-license-names))
+      (format #t "
+If your package's license is not in this list, add it to Guix first.~%")
+      (exit 0))
+    (unless (license-by-name license)
+      (leave (_ "invalid license: ~a; try --license=3Dhelp~%") license))
+    license))
+
+=0C
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-potluck . args)
+  (define (parse-sub-command arg result)
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (alist-cons 'action (string->symbol arg) result)))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:argument-handler
+                                         parse-sub-command))
+           (action   (assoc-ref opts 'action))
+           (args     (reverse (filter-map (match-pair 'argument) opts)))=
)
+      (define (see-help)
+        (format (current-error-port)
+                (_ "Try 'guix potluck --help' for more information.~%"))=
)
+      (define (wrong-number-of-args usage)
+        (format (current-error-port)
+                (_ "guix potluck ~a: wrong number of arguments~%")
+                action)
+        (display usage (current-error-port))
+        (newline (current-error-port))
+        (see-help)
+        (exit 1))
+      (match action
+        (#f
+         (format (current-error-port)
+                 (_ "guix potluck: missing command name~%"))
+         (see-help)
+         (exit 1))
+        ('init
+         (match args
+           ((remote-git-url)
+            (init-potluck (parse-url remote-git-url)
+                          #:build-system (parse-build-system
+                                          (assoc-ref opts 'build-system)=
)
+                          #:autoreconf? (assoc-ref opts 'autoreconf?)
+                          #:license (parse-license
+                                     (assoc-ref opts 'license))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        (action
+         (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 20:59:59 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 16:59:58 2017
Received: from localhost ([127.0.0.1]:38388 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l5I-0004Pn-7v
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:58 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:62399
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l55-0004OM-Ap
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:36 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 9B75A74CC0
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:34 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=wBkQ98h1JOq1
 zphzvxSgg9Ui7aw=; b=RpzteJEY1+mbNhsbXjXgP8votO9nogJke4q4GrpsewEo
 uwWO8lcW6RvmEHJj/IP60xKhEkpFtXOFLTcpmz+3gfp444FuM443qY+dJWYnNaRN
 3mejob7ZtG/d7Hcqt9v7U17aJ4J7HHzsokA0Soh/m+jcVTxh8hemsnQrQECpd4Q=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 9362374CBF
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:34 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id A24B074CB5
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:30 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 4/9] guix: Add "potluck" command.
Date: Mon, 24 Apr 2017 22:59:18 +0200
Message-Id: <20170424205923.27726-4-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: E9541574-2930-11E7-A586-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/potluck.scm: New file.
* Makefile.am: Add new file.
---
 Makefile.am              |   1 +
 guix/scripts/potluck.scm | 310 +++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 311 insertions(+)
 create mode 100644 guix/scripts/potluck.scm

diff --git a/Makefile.am b/Makefile.am
index 64a7a9265..295d7b3a6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -167,6 +167,7 @@ MODULES =3D					\
   guix/scripts/graph.scm			\
   guix/scripts/container.scm			\
   guix/scripts/container/exec.scm		\
+  guix/scripts/potluck.scm			\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
=20
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
new file mode 100644
index 000000000..f9cd40bd0
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 scripts potluck)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module ((guix build-system) #:select (build-system-description))
+  #:use-module ((guix licenses) #:select (license-uri))
+  #:use-module (guix git)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix potluck packages)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (json)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (guix-potluck))
+
+=0C
+;;;
+;;; guix potluck init
+;;;
+
+(define* (init-potluck remote-git-url #:key
+                       (build-system 'gnu) (autoreconf? #f)
+                       (license 'gplv3+))
+  (let* ((cwd (getcwd))
+         (dot-git (in-vicinity cwd ".git"))
+         (potluck-dir (in-vicinity cwd "potluck"))
+         (package-name (basename cwd)))
+    (unless (and (file-exists? dot-git)
+                 (file-is-directory? dot-git))
+      (leave (_ "init: must be run from the root of a git checkout~%")))
+    (when (file-exists? potluck-dir)
+      (leave (_ "init: ~a already exists~%") potluck-dir))
+    (let* ((user-name (git-config "user.name"))
+           (pkg-name (basename cwd))
+           (pkg-commit (git-rev-parse "HEAD"))
+           (pkg-version
+            (catch #t
+              (lambda () (git-describe pkg-commit))
+              (lambda _
+                (format (current-error-port)
+                        "guix potluck init: git describe failed\n")
+                (format (current-error-port)
+                        "Add a tag so that git can compute a version.\n"=
)
+                (exit 1))))
+           ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
+           ;; here.
+           (pkg-sha256 (guix-hash-git-checkout cwd)))
+      (format #t (_ "Creating potluck/~%"))
+      (mkdir potluck-dir)
+      (format #t (_ "Creating potluck/README.md~%"))
+      (call-with-output-file (in-vicinity potluck-dir "README.md")
+        (lambda (port)
+          (format port
+                  "\
+This directory defines potluck packages.  Each file in this directory sh=
ould
+define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+")))
+      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (call-with-output-file (in-vicinity potluck-dir
+                                          (string-append package-name ".=
scm"))
+        (lambda (port)
+         =20
+          (define-syntax-rule (dsp exp) (display exp port))
+          (dsp ";;; guix potluck package\n")
+          (dsp ";;; Copyright (C) 2017 ")
+          (dsp user-name)
+          (dsp "\n")
+          (dsp "
+;;; This file 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.  No warranty.  See
+;;; https://www.gnu.org/licenses/gpl.html for a copy of the GPLv3.
+
+")
+          (pretty-print-potluck-package
+           port
+           (potluck-package
+            (name pkg-name)
+            (version pkg-version)
+            (source
+             (potluck-source
+              (git-uri remote-git-url)
+              (git-commit pkg-commit)
+              (sha256 (bytevector->nix-base32-string pkg-sha256))))
+            (build-system build-system)
+            (inputs '())
+            (native-inputs
+             (if autoreconf?
+                 '("autoconf" "automake" "libtool" "pkg-config")
+                 '()))
+            (arguments
+             (if autoreconf?
+                 '(#:phases (modify-phases %standard-phases
+                              (add-before 'configure 'autoconf
+                                (lambda _
+                                  (zero?
+                                   (system* "autoreconf" "-vfi"))))))
+                 '()))
+            (home-page remote-git-url)
+            (synopsis "Declarative synopsis here")
+            (description
+             (string-append (string-titlecase pkg-name)
+                            " is a ..."))
+            (license license)))))
+      (format #t (_ "
+Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
+\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+build with
+
+  guix build --file=3Dpotluck/~a.scm
+
+When you get that working, commit your results to git via:
+
+  git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
+") pkg-name pkg-name))))
+
+=0C
+;;;
+;;; Options.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix potluck [OPTION ...] ACTION [ARG ...]
+Create \"potluck\" packages, register them with a central service, and a=
rrange
+to serve those packages as a Guix channel. Some ACTIONS require addition=
al
+ARGS.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (_ "\
+   init             create potluck recipe for current working directory\=
n"))
+
+  (newline)
+  (display (_ "The available OPTION flags are:\n"))
+  (display (_ "
+      --build-system=3DSYS for 'init', specify the build system.  Use
+                         --build-system=3Dhelp for all available options=
."))
+  (display (_ "
+      --autotools        for 'init', like --build-system=3Dgnu but addit=
ionally
+                         indicating that the package needs autoreconf be=
fore
+                         running ./configure"))
+  (display (_ "
+      --license=3DLICENSE  for 'init', specify the license of the packag=
e.  Use
+                         --license=3Dhelp for all available options."))
+  (display (_ "
+      --verbosity=3DLEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix potluck")))
+        (option '("build-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-system arg result)))
+        (option '("autotools") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'autoreconf? #t
+                              (alist-cons 'build-system "gnu" result))))
+        (option '("license") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'license arg result)))
+        (option '("verbosity") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'verbosity (string->number arg) result))))=
)
+
+(define %default-options
+  ;; Alist of default option values.
+  `((verbosity . 0)))
+
+(define (parse-url url-str)
+  (unless (string->uri url-str)
+    (leave (_ "invalid url: ~a~%") url-str))
+  url-str)
+
+(define (parse-build-system sys-str)
+  (unless sys-str
+    (leave (_ "\
+init: missing --build-system; try --build-system=3Dhelp for options~%"))=
)
+  (let ((sys (string->symbol (string-downcase sys-str))))
+    (when (eq? sys 'help)
+      (format #t "guix potluck: Available build systems:~%")
+      (for-each
+       (lambda (name)
+         (let ((sys (build-system-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (build-system-description sys=
))))
+       (all-potluck-build-system-names))
+      (format #t "
+Additionally, --autotools is like --build-system=3Dgnu, but also indicat=
ing
+that the package needs autoreconf before running ./configure.~%")
+      (exit 0))
+    (unless (build-system-by-name sys)
+      (leave (_ "invalid build system: ~a; try --build-system=3Dhelp~%")=
 sys))
+    sys))
+
+(define (parse-license license-str)
+  (unless license-str
+    (leave (_ "init: missing --license; try --license=3Dhelp for options=
~%")))
+  (let ((license (string->symbol (string-downcase license-str))))
+    (when (eq? license 'help)
+      (format #t "guix potluck: Available licenses:~%")
+      (for-each
+       (lambda (name)
+         (let ((license (license-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (license-uri license))))
+       (all-potluck-license-names))
+      (format #t "
+If your package's license is not in this list, add it to Guix first.~%")
+      (exit 0))
+    (unless (license-by-name license)
+      (leave (_ "invalid license: ~a; try --license=3Dhelp~%") license))
+    license))
+
+=0C
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-potluck . args)
+  (define (parse-sub-command arg result)
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (alist-cons 'action (string->symbol arg) result)))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:argument-handler
+                                         parse-sub-command))
+           (action   (assoc-ref opts 'action))
+           (args     (reverse (filter-map (match-pair 'argument) opts)))=
)
+      (define (see-help)
+        (format (current-error-port)
+                (_ "Try 'guix potluck --help' for more information.~%"))=
)
+      (define (wrong-number-of-args usage)
+        (format (current-error-port)
+                (_ "guix potluck ~a: wrong number of arguments~%")
+                action)
+        (display usage (current-error-port))
+        (newline (current-error-port))
+        (see-help)
+        (exit 1))
+      (match action
+        (#f
+         (format (current-error-port)
+                 (_ "guix potluck: missing command name~%"))
+         (see-help)
+         (exit 1))
+        ('init
+         (match args
+           ((remote-git-url)
+            (init-potluck (parse-url remote-git-url)
+                          #:build-system (parse-build-system
+                                          (assoc-ref opts 'build-system)=
)
+                          #:autoreconf? (assoc-ref opts 'autoreconf?)
+                          #:license (parse-license
+                                     (assoc-ref opts 'license))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        (action
+         (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at 26645 <at> debbugs.gnu.org:


Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 20:59:48 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 16:59:48 2017
Received: from localhost ([127.0.0.1]:38370 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2l58-0004Oj-Em
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:48 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:56426
 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2l55-0004ON-Ar
 for 26645 <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:59:36 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id B4C6C74CC2
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:34 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:in-reply-to:references:mime-version
 :content-type:content-transfer-encoding; s=sasl; bh=wBkQ98h1JOq1
 zphzvxSgg9Ui7aw=; b=RpzteJEY1+mbNhsbXjXgP8votO9nogJke4q4GrpsewEo
 uwWO8lcW6RvmEHJj/IP60xKhEkpFtXOFLTcpmz+3gfp444FuM443qY+dJWYnNaRN
 3mejob7ZtG/d7Hcqt9v7U17aJ4J7HHzsokA0Soh/m+jcVTxh8hemsnQrQECpd4Q=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id 9EC9874CC1
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:34 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id B5AAE74CB8
 for <26645 <at> debbugs.gnu.org>; Mon, 24 Apr 2017 16:59:30 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: 26645 <at> debbugs.gnu.org
Subject: [PATCH 4/9] guix: Add "potluck" command.
Date: Mon, 24 Apr 2017 22:59:18 +0200
Message-Id: <20170424205923.27726-4-wingo@HIDDEN>
X-Mailer: git-send-email 2.12.2
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN>
References: <20170424205923.27726-1-wingo@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Pobox-Relay-ID: E961294E-2930-11E7-93F5-571C92A0D1B0-02397024!pb-sasl2.pobox.com
Content-Transfer-Encoding: quoted-printable
X-Spam-Score: 0.7 (/)
X-Debbugs-Envelope-To: 26645
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: 0.7 (/)

* guix/scripts/potluck.scm: New file.
* Makefile.am: Add new file.
---
 Makefile.am              |   1 +
 guix/scripts/potluck.scm | 310 +++++++++++++++++++++++++++++++++++++++++=
++++++
 2 files changed, 311 insertions(+)
 create mode 100644 guix/scripts/potluck.scm

diff --git a/Makefile.am b/Makefile.am
index 64a7a9265..295d7b3a6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -167,6 +167,7 @@ MODULES =3D					\
   guix/scripts/graph.scm			\
   guix/scripts/container.scm			\
   guix/scripts/container/exec.scm		\
+  guix/scripts/potluck.scm			\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
=20
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
new file mode 100644
index 000000000..f9cd40bd0
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright =C2=A9 2017 Andy Wingo <wingo@HIDDEN>
+;;;
+;;; 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 (a=
t
+;;; 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 scripts potluck)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module ((guix build-system) #:select (build-system-description))
+  #:use-module ((guix licenses) #:select (license-uri))
+  #:use-module (guix git)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix potluck packages)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (json)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (guix-potluck))
+
+=0C
+;;;
+;;; guix potluck init
+;;;
+
+(define* (init-potluck remote-git-url #:key
+                       (build-system 'gnu) (autoreconf? #f)
+                       (license 'gplv3+))
+  (let* ((cwd (getcwd))
+         (dot-git (in-vicinity cwd ".git"))
+         (potluck-dir (in-vicinity cwd "potluck"))
+         (package-name (basename cwd)))
+    (unless (and (file-exists? dot-git)
+                 (file-is-directory? dot-git))
+      (leave (_ "init: must be run from the root of a git checkout~%")))
+    (when (file-exists? potluck-dir)
+      (leave (_ "init: ~a already exists~%") potluck-dir))
+    (let* ((user-name (git-config "user.name"))
+           (pkg-name (basename cwd))
+           (pkg-commit (git-rev-parse "HEAD"))
+           (pkg-version
+            (catch #t
+              (lambda () (git-describe pkg-commit))
+              (lambda _
+                (format (current-error-port)
+                        "guix potluck init: git describe failed\n")
+                (format (current-error-port)
+                        "Add a tag so that git can compute a version.\n"=
)
+                (exit 1))))
+           ;; FIXME: Race condition if HEAD changes between git-rev-pars=
e and
+           ;; here.
+           (pkg-sha256 (guix-hash-git-checkout cwd)))
+      (format #t (_ "Creating potluck/~%"))
+      (mkdir potluck-dir)
+      (format #t (_ "Creating potluck/README.md~%"))
+      (call-with-output-file (in-vicinity potluck-dir "README.md")
+        (lambda (port)
+          (format port
+                  "\
+This directory defines potluck packages.  Each file in this directory sh=
ould
+define one package.  See https://potluck.guixsd.org/ for more informatio=
n.
+")))
+      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (call-with-output-file (in-vicinity potluck-dir
+                                          (string-append package-name ".=
scm"))
+        (lambda (port)
+         =20
+          (define-syntax-rule (dsp exp) (display exp port))
+          (dsp ";;; guix potluck package\n")
+          (dsp ";;; Copyright (C) 2017 ")
+          (dsp user-name)
+          (dsp "\n")
+          (dsp "
+;;; This file 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.  No warranty.  See
+;;; https://www.gnu.org/licenses/gpl.html for a copy of the GPLv3.
+
+")
+          (pretty-print-potluck-package
+           port
+           (potluck-package
+            (name pkg-name)
+            (version pkg-version)
+            (source
+             (potluck-source
+              (git-uri remote-git-url)
+              (git-commit pkg-commit)
+              (sha256 (bytevector->nix-base32-string pkg-sha256))))
+            (build-system build-system)
+            (inputs '())
+            (native-inputs
+             (if autoreconf?
+                 '("autoconf" "automake" "libtool" "pkg-config")
+                 '()))
+            (arguments
+             (if autoreconf?
+                 '(#:phases (modify-phases %standard-phases
+                              (add-before 'configure 'autoconf
+                                (lambda _
+                                  (zero?
+                                   (system* "autoreconf" "-vfi"))))))
+                 '()))
+            (home-page remote-git-url)
+            (synopsis "Declarative synopsis here")
+            (description
+             (string-append (string-titlecase pkg-name)
+                            " is a ..."))
+            (license license)))))
+      (format #t (_ "
+Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\"=
 and
+\"description\" fields, add dependencies to the 'inputs' field, and try =
to
+build with
+
+  guix build --file=3Dpotluck/~a.scm
+
+When you get that working, commit your results to git via:
+
+  git add guix-potluck && git commit -m 'Add initial Guix potluck files.=
'
+") pkg-name pkg-name))))
+
+=0C
+;;;
+;;; Options.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix potluck [OPTION ...] ACTION [ARG ...]
+Create \"potluck\" packages, register them with a central service, and a=
rrange
+to serve those packages as a Guix channel. Some ACTIONS require addition=
al
+ARGS.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (_ "\
+   init             create potluck recipe for current working directory\=
n"))
+
+  (newline)
+  (display (_ "The available OPTION flags are:\n"))
+  (display (_ "
+      --build-system=3DSYS for 'init', specify the build system.  Use
+                         --build-system=3Dhelp for all available options=
."))
+  (display (_ "
+      --autotools        for 'init', like --build-system=3Dgnu but addit=
ionally
+                         indicating that the package needs autoreconf be=
fore
+                         running ./configure"))
+  (display (_ "
+      --license=3DLICENSE  for 'init', specify the license of the packag=
e.  Use
+                         --license=3Dhelp for all available options."))
+  (display (_ "
+      --verbosity=3DLEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix potluck")))
+        (option '("build-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-system arg result)))
+        (option '("autotools") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'autoreconf? #t
+                              (alist-cons 'build-system "gnu" result))))
+        (option '("license") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'license arg result)))
+        (option '("verbosity") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'verbosity (string->number arg) result))))=
)
+
+(define %default-options
+  ;; Alist of default option values.
+  `((verbosity . 0)))
+
+(define (parse-url url-str)
+  (unless (string->uri url-str)
+    (leave (_ "invalid url: ~a~%") url-str))
+  url-str)
+
+(define (parse-build-system sys-str)
+  (unless sys-str
+    (leave (_ "\
+init: missing --build-system; try --build-system=3Dhelp for options~%"))=
)
+  (let ((sys (string->symbol (string-downcase sys-str))))
+    (when (eq? sys 'help)
+      (format #t "guix potluck: Available build systems:~%")
+      (for-each
+       (lambda (name)
+         (let ((sys (build-system-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (build-system-description sys=
))))
+       (all-potluck-build-system-names))
+      (format #t "
+Additionally, --autotools is like --build-system=3Dgnu, but also indicat=
ing
+that the package needs autoreconf before running ./configure.~%")
+      (exit 0))
+    (unless (build-system-by-name sys)
+      (leave (_ "invalid build system: ~a; try --build-system=3Dhelp~%")=
 sys))
+    sys))
+
+(define (parse-license license-str)
+  (unless license-str
+    (leave (_ "init: missing --license; try --license=3Dhelp for options=
~%")))
+  (let ((license (string->symbol (string-downcase license-str))))
+    (when (eq? license 'help)
+      (format #t "guix potluck: Available licenses:~%")
+      (for-each
+       (lambda (name)
+         (let ((license (license-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (license-uri license))))
+       (all-potluck-license-names))
+      (format #t "
+If your package's license is not in this list, add it to Guix first.~%")
+      (exit 0))
+    (unless (license-by-name license)
+      (leave (_ "invalid license: ~a; try --license=3Dhelp~%") license))
+    license))
+
+=0C
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-potluck . args)
+  (define (parse-sub-command arg result)
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (alist-cons 'action (string->symbol arg) result)))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:argument-handler
+                                         parse-sub-command))
+           (action   (assoc-ref opts 'action))
+           (args     (reverse (filter-map (match-pair 'argument) opts)))=
)
+      (define (see-help)
+        (format (current-error-port)
+                (_ "Try 'guix potluck --help' for more information.~%"))=
)
+      (define (wrong-number-of-args usage)
+        (format (current-error-port)
+                (_ "guix potluck ~a: wrong number of arguments~%")
+                action)
+        (display usage (current-error-port))
+        (newline (current-error-port))
+        (see-help)
+        (exit 1))
+      (match action
+        (#f
+         (format (current-error-port)
+                 (_ "guix potluck: missing command name~%"))
+         (see-help)
+         (exit 1))
+        ('init
+         (match args
+           ((remote-git-url)
+            (init-potluck (parse-url remote-git-url)
+                          #:build-system (parse-build-system
+                                          (assoc-ref opts 'build-system)=
)
+                          #:autoreconf? (assoc-ref opts 'autoreconf?)
+                          #:license (parse-license
+                                     (assoc-ref opts 'license))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        (action
+         (leave (_ "~a: unknown action~%") action))))))
--=20
2.12.2





Information forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.

Message received at submit <at> debbugs.gnu.org:


Received: (at submit) by debbugs.gnu.org; 24 Apr 2017 20:54:00 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Apr 24 16:54:00 2017
Received: from localhost ([127.0.0.1]:38357 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d2kzf-0004GK-QI
	for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:53:59 -0400
Received: from eggs.gnu.org ([208.118.235.92]:44348)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <wingo@HIDDEN>) id 1d2kzc-0004G5-E7
 for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:53:58 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <wingo@HIDDEN>) id 1d2kzW-00082m-90
 for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:53:51 -0400
X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org
X-Spam-Level: 
X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,T_DKIM_INVALID
 autolearn=disabled version=3.3.2
Received: from lists.gnu.org ([2001:4830:134:3::11]:41724)
 by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_256_CBC_SHA1:32)
 (Exim 4.71) (envelope-from <wingo@HIDDEN>) id 1d2kzW-00082f-5F
 for submit <at> debbugs.gnu.org; Mon, 24 Apr 2017 16:53:50 -0400
Received: from eggs.gnu.org ([2001:4830:134:3::10]:35305)
 by lists.gnu.org with esmtp (Exim 4.71)
 (envelope-from <wingo@HIDDEN>) id 1d2kzU-0001v2-W9
 for guix-patches@HIDDEN; Mon, 24 Apr 2017 16:53:49 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <wingo@HIDDEN>) id 1d2kzS-00080E-GE
 for guix-patches@HIDDEN; Mon, 24 Apr 2017 16:53:49 -0400
Received: from pb-sasl2.pobox.com ([64.147.108.67]:53989
 helo=sasl.smtp.pobox.com)
 by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32)
 (Exim 4.71) (envelope-from <wingo@HIDDEN>) id 1d2kzS-0007zz-C4
 for guix-patches@HIDDEN; Mon, 24 Apr 2017 16:53:46 -0400
Received: from sasl.smtp.pobox.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id DA20574C72
 for <guix-patches@HIDDEN>; Mon, 24 Apr 2017 16:53:44 -0400 (EDT)
DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to
 :subject:date:message-id:mime-version:content-type; s=sasl; bh=p
 VPaFSlopW6sVbIADOtnFv/AKn8=; b=DQlnvB4OASNpYrYJulizZ+qJz5YrIBd1I
 3qJPjznymrIvAE47+7VI9p2cix+r5VQ+ycS5yrUYJlWBON89On9R3QBhs3PjzQeB
 UCfMtIUJtPwRA3XbW7dPsJ7r/hDVMZFrlLB0Ul3Z41cKRkEQ96BChmlqkNc1jCrZ
 k4kCHK6XUI=
DomainKey-Signature: a=rsa-sha1; c=nofws; d=pobox.com; h=from:to:subject
 :date:message-id:mime-version:content-type; q=dns; s=sasl; b=vcS
 TYVQxDoMv/UqJoMyW2n+TvOYKhkf2Jh4x9o0K2+1y7Wq7hxuvc9t2W9brFPXv+GK
 cF58HwnQxaou4mQ5hTcFM5+LZ0WlQeY3hEDCt7oG7gjFcXTfxadW/l7RrZIsjD/z
 pIFzx8yHlnvc2fjzg8IA2LR9vR4Ukx6pf6hcstLw=
Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1])
 by pb-sasl2.pobox.com (Postfix) with ESMTP id D2D6D74C71
 for <guix-patches@HIDDEN>; Mon, 24 Apr 2017 16:53:44 -0400 (EDT)
Received: from clucks (unknown [88.160.190.192])
 (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits))
 (No client certificate requested)
 by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 03D9174C70
 for <guix-patches@HIDDEN>; Mon, 24 Apr 2017 16:53:43 -0400 (EDT)
From: Andy Wingo <wingo@HIDDEN>
To: guix-patches@HIDDEN
Subject: guix potluck
Date: Mon, 24 Apr 2017 22:53:36 +0200
Message-ID: <87y3upttm7.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.1 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain
X-Pobox-Relay-ID: 1ACA2A68-2930-11E7-A452-571C92A0D1B0-02397024!pb-sasl2.pobox.com
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
 [fuzzy]
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x
X-Received-From: 2001:4830:134:3::11
X-Spam-Score: -4.3 (----)
X-Debbugs-Envelope-To: submit
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -4.3 (----)

Hi,

The attached patches add a "guix potluck" facility, as described on
guix-devel:

  https://lists.gnu.org/archive/html/guix-devel/2017-04/msg00250.html

Cheers,

Andy




Acknowledgement sent to Andy Wingo <wingo@HIDDEN>:
New bug report received and forwarded. Copy sent to guix-patches@HIDDEN. Full text available.
Report forwarded to guix-patches@HIDDEN:
bug#26645; Package guix-patches. Full text available.
Please note: This is a static page, with minimal formatting, updated once a day.
Click here to see this page with the latest information and nicer formatting.
Last modified: Tue, 2 May 2017 21:45:01 UTC

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997 nCipher Corporation Ltd, 1994-97 Ian Jackson.