GNU logs - #26645, boring messages


Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: guix potluck
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 20:54:02 +0000
Resent-Message-ID: <handler.26645.B.149306724016392 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: report 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
X-Debbugs-Original-To: guix-patches@HIDDEN
Received: via spool by submit <at> debbugs.gnu.org id=B.149306724016392
          (code B ref -1); Mon, 24 Apr 2017 20:54:02 +0000
Received: (at submit) by debbugs.gnu.org; 24 Apr 2017 20:54:00 +0000
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>
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-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




Message sent:


Content-Disposition: inline
Content-Transfer-Encoding: quoted-printable
MIME-Version: 1.0
X-Mailer: MIME-tools 5.505 (Entity 5.505)
Content-Type: text/plain; charset=utf-8
X-Loop: help-debbugs@HIDDEN
From: help-debbugs@HIDDEN (GNU bug Tracking System)
To: Andy Wingo <wingo@HIDDEN>
Subject: bug#26645: Acknowledgement (guix potluck)
Message-ID: <handler.26645.B.149306724016392.ack <at> debbugs.gnu.org>
References: <87y3upttm7.fsf@HIDDEN>
X-Gnu-PR-Message: ack 26645
X-Gnu-PR-Package: guix-patches
Reply-To: 26645 <at> debbugs.gnu.org
Date: Mon, 24 Apr 2017 20:54:02 +0000

Thank you for filing a new bug report with debbugs.gnu.org.

This is an automatically generated reply to let you know your message
has been received.

Your message is being forwarded to the package maintainers and other
interested parties for their attention; they will reply in due course.

Your message has been sent to the package maintainer(s):
 guix-patches@HIDDEN

If you wish to submit further information on this problem, please
send it to 26645 <at> debbugs.gnu.org.

Please do not send mail to help-debbugs@HIDDEN unless you wish
to report a problem with the Bug-tracking system.

--=20
26645: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=3D26645
GNU Bug Tracking System
Contact help-debbugs@HIDDEN with problems


Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 4/9] guix: Add "potluck" command.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:00:03 +0000
Resent-Message-ID: <handler.26645.B26645.149306758816978 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306758816978
          (code B ref 26645); Mon, 24 Apr 2017 21:00:03 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 20:59:48 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 4/9] guix: Add "potluck" command.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:00:04 +0000
Resent-Message-ID: <handler.26645.B26645.149306759917094 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306759917094
          (code B ref 26645); Mon, 24 Apr 2017 21:00:04 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 20:59:59 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 4/9] guix: Add "potluck" command.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:01 +0000
Resent-Message-ID: <handler.26645.B26645.149306761617310 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306761617310
          (code B ref 26645); Mon, 24 Apr 2017 21:01:01 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:16 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 4/9] guix: Add "potluck" command.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:02 +0000
Resent-Message-ID: <handler.26645.B26645.149306762017320 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306762017320
          (code B ref 26645); Mon, 24 Apr 2017 21:01:02 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:20 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 4/9] guix: Add "potluck" command.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:03 +0000
Resent-Message-ID: <handler.26645.B26645.149306762517332 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306762517332
          (code B ref 26645); Mon, 24 Apr 2017 21:01:03 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:25 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 9/9] doc: Document guix potluck.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:03 +0000
Resent-Message-ID: <handler.26645.B26645.149306762617341 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306762617341
          (code B ref 26645); Mon, 24 Apr 2017 21:01:03 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:26 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 4/9] guix: Add "potluck" command.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:04 +0000
Resent-Message-ID: <handler.26645.B26645.149306763017353 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306763017353
          (code B ref 26645); Mon, 24 Apr 2017 21:01:04 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:30 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 4/9] guix: Add "potluck" command.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:04 +0000
Resent-Message-ID: <handler.26645.B26645.149306763617367 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306763617367
          (code B ref 26645); Mon, 24 Apr 2017 21:01:04 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:36 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 9/9] doc: Document guix potluck.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:05 +0000
Resent-Message-ID: <handler.26645.B26645.149306763617374 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306763617374
          (code B ref 26645); Mon, 24 Apr 2017 21:01:05 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:36 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 4/9] guix: Add "potluck" command.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:05 +0000
Resent-Message-ID: <handler.26645.B26645.149306764117385 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306764117385
          (code B ref 26645); Mon, 24 Apr 2017 21:01:05 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:41 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 9/9] doc: Document guix potluck.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:06 +0000
Resent-Message-ID: <handler.26645.B26645.149306764217393 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306764217393
          (code B ref 26645); Mon, 24 Apr 2017 21:01:06 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:42 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 4/9] guix: Add "potluck" command.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:06 +0000
Resent-Message-ID: <handler.26645.B26645.149306764517407 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306764517407
          (code B ref 26645); Mon, 24 Apr 2017 21:01:06 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:45 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 3/9] guix: Add git utility module.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:07 +0000
Resent-Message-ID: <handler.26645.B26645.149306764617415 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306764617415
          (code B ref 26645); Mon, 24 Apr 2017 21:01:07 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:46 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 9/9] doc: Document guix potluck.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:07 +0000
Resent-Message-ID: <handler.26645.B26645.149306764717422 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306764717422
          (code B ref 26645); Mon, 24 Apr 2017 21:01:07 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:47 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 9/9] doc: Document guix potluck.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:08 +0000
Resent-Message-ID: <handler.26645.B26645.149306764817431 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306764817431
          (code B ref 26645); Mon, 24 Apr 2017 21:01:08 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:48 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 3/9] guix: Add git utility module.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:08 +0000
Resent-Message-ID: <handler.26645.B26645.149306764917438 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306764917438
          (code B ref 26645); Mon, 24 Apr 2017 21:01:08 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:49 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 9/9] doc: Document guix potluck.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:10 +0000
Resent-Message-ID: <handler.26645.B26645.149306764917446 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306764917446
          (code B ref 26645); Mon, 24 Apr 2017 21:01:10 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:49 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 9/9] doc: Document guix potluck.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:10 +0000
Resent-Message-ID: <handler.26645.B26645.149306765017454 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765017454
          (code B ref 26645); Mon, 24 Apr 2017 21:01:10 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:50 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 9/9] doc: Document guix potluck.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:11 +0000
Resent-Message-ID: <handler.26645.B26645.149306765117461 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765117461
          (code B ref 26645); Mon, 24 Apr 2017 21:01:11 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:51 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:11 +0000
Resent-Message-ID: <handler.26645.B26645.149306765117469 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765117469
          (code B ref 26645); Mon, 24 Apr 2017 21:01:11 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:51 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:12 +0000
Resent-Message-ID: <handler.26645.B26645.149306765217476 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765217476
          (code B ref 26645); Mon, 24 Apr 2017 21:01:12 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:52 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 3/9] guix: Add git utility module.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:12 +0000
Resent-Message-ID: <handler.26645.B26645.149306765217484 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765217484
          (code B ref 26645); Mon, 24 Apr 2017 21:01:12 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:52 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 9/9] doc: Document guix potluck.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:13 +0000
Resent-Message-ID: <handler.26645.B26645.149306765317491 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765317491
          (code B ref 26645); Mon, 24 Apr 2017 21:01:13 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:53 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:13 +0000
Resent-Message-ID: <handler.26645.B26645.149306765417499 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765417499
          (code B ref 26645); Mon, 24 Apr 2017 21:01:13 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:54 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:14 +0000
Resent-Message-ID: <handler.26645.B26645.149306765417506 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765417506
          (code B ref 26645); Mon, 24 Apr 2017 21:01:14 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:54 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:14 +0000
Resent-Message-ID: <handler.26645.B26645.149306765417514 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765417514
          (code B ref 26645); Mon, 24 Apr 2017 21:01:14 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:54 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:15 +0000
Resent-Message-ID: <handler.26645.B26645.149306765517522 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765517522
          (code B ref 26645); Mon, 24 Apr 2017 21:01:15 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:55 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:15 +0000
Resent-Message-ID: <handler.26645.B26645.149306765517529 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765517529
          (code B ref 26645); Mon, 24 Apr 2017 21:01:15 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:55 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:16 +0000
Resent-Message-ID: <handler.26645.B26645.149306765617537 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765617537
          (code B ref 26645); Mon, 24 Apr 2017 21:01:16 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:56 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
References: <87y3upttm7.fsf@HIDDEN>
In-Reply-To: <87y3upttm7.fsf@HIDDEN>
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:16 +0000
Resent-Message-ID: <handler.26645.B26645.149306765717545 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306765717545
          (code B ref 26645); Mon, 24 Apr 2017 21:01:16 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:00:57 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
References: <87y3upttm7.fsf@HIDDEN>
In-Reply-To: <87y3upttm7.fsf@HIDDEN>
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:17 +0000
Resent-Message-ID: <handler.26645.B26645.149306766117555 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306766117555
          (code B ref 26645); Mon, 24 Apr 2017 21:01:17 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:01 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
References: <87y3upttm7.fsf@HIDDEN>
In-Reply-To: <87y3upttm7.fsf@HIDDEN>
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:17 +0000
Resent-Message-ID: <handler.26645.B26645.149306766217583 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306766217583
          (code B ref 26645); Mon, 24 Apr 2017 21:01:17 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:02 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
References: <87y3upttm7.fsf@HIDDEN>
In-Reply-To: <87y3upttm7.fsf@HIDDEN>
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:18 +0000
Resent-Message-ID: <handler.26645.B26645.149306766617639 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306766617639
          (code B ref 26645); Mon, 24 Apr 2017 21:01:18 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:06 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
References: <87y3upttm7.fsf@HIDDEN>
In-Reply-To: <87y3upttm7.fsf@HIDDEN>
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:18 +0000
Resent-Message-ID: <handler.26645.B26645.149306767017704 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306767017704
          (code B ref 26645); Mon, 24 Apr 2017 21:01:18 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:10 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:19 +0000
Resent-Message-ID: <handler.26645.B26645.149306767117715 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306767117715
          (code B ref 26645); Mon, 24 Apr 2017 21:01:19 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:11 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:19 +0000
Resent-Message-ID: <handler.26645.B26645.149306767117727 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306767117727
          (code B ref 26645); Mon, 24 Apr 2017 21:01:19 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:11 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
References: <87y3upttm7.fsf@HIDDEN>
In-Reply-To: <87y3upttm7.fsf@HIDDEN>
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:20 +0000
Resent-Message-ID: <handler.26645.B26645.149306767517787 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306767517787
          (code B ref 26645); Mon, 24 Apr 2017 21:01:20 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:15 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
References: <87y3upttm7.fsf@HIDDEN>
In-Reply-To: <87y3upttm7.fsf@HIDDEN>
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:01:20 +0000
Resent-Message-ID: <handler.26645.B26645.149306767917870 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306767917870
          (code B ref 26645); Mon, 24 Apr 2017 21:01:20 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:19 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:02:02 +0000
Resent-Message-ID: <handler.26645.B26645.149306768417913 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306768417913
          (code B ref 26645); Mon, 24 Apr 2017 21:02:02 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:24 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:02:02 +0000
Resent-Message-ID: <handler.26645.B26645.149306768917923 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306768917923
          (code B ref 26645); Mon, 24 Apr 2017 21:02:02 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:29 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:02:03 +0000
Resent-Message-ID: <handler.26645.B26645.149306768917932 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306768917932
          (code B ref 26645); Mon, 24 Apr 2017 21:02:03 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:29 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:02:04 +0000
Resent-Message-ID: <handler.26645.B26645.149306768917938 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306768917938
          (code B ref 26645); Mon, 24 Apr 2017 21:02:04 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:29 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:02:05 +0000
Resent-Message-ID: <handler.26645.B26645.149306769417953 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306769417953
          (code B ref 26645); Mon, 24 Apr 2017 21:02:05 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:34 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:02:05 +0000
Resent-Message-ID: <handler.26645.B26645.149306770017965 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306770017965
          (code B ref 26645); Mon, 24 Apr 2017 21:02:05 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:01:40 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
References: <87y3upttm7.fsf@HIDDEN>
In-Reply-To: <87y3upttm7.fsf@HIDDEN>
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:04:02 +0000
Resent-Message-ID: <handler.26645.B26645.149306784118232 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306784118232
          (code B ref 26645); Mon, 24 Apr 2017 21:04:02 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:01 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:04:03 +0000
Resent-Message-ID: <handler.26645.B26645.149306784118239 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306784118239
          (code B ref 26645); Mon, 24 Apr 2017 21:04:03 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:01 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:04:04 +0000
Resent-Message-ID: <handler.26645.B26645.149306784218252 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306784218252
          (code B ref 26645); Mon, 24 Apr 2017 21:04:04 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:02 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:04:04 +0000
Resent-Message-ID: <handler.26645.B26645.149306784218268 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306784218268
          (code B ref 26645); Mon, 24 Apr 2017 21:04:04 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:02 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:05:02 +0000
Resent-Message-ID: <handler.26645.B26645.149306784818326 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306784818326
          (code B ref 26645); Mon, 24 Apr 2017 21:05:02 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:08 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
References: <87y3upttm7.fsf@HIDDEN>
In-Reply-To: <87y3upttm7.fsf@HIDDEN>
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:05:02 +0000
Resent-Message-ID: <handler.26645.B26645.149306785218336 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306785218336
          (code B ref 26645); Mon, 24 Apr 2017 21:05:02 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:04:12 +0000
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>
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-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





Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: guix potluck
Resent-From: ng0 <contact.ng0@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:11:03 +0000
Resent-Message-ID: <handler.26645.B26645.149306820518894 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: Andy Wingo <wingo@HIDDEN>
Cc: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306820518894
          (code B ref 26645); Mon, 24 Apr 2017 21:11:03 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:10:05 +0000
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>
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-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/




Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 6/9] gnu: Add find-package-binding.
Resent-From: Andy Wingo <wingo@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Mon, 24 Apr 2017 21:22:02 +0000
Resent-Message-ID: <handler.26645.B26645.149306891119931 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149306891119931
          (code B ref 26645); Mon, 24 Apr 2017 21:22:02 +0000
Received: (at 26645) by debbugs.gnu.org; 24 Apr 2017 21:21:51 +0000
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>
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-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





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


Received: (at control) by debbugs.gnu.org; 2 May 2017 21:39:51 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Tue May 02 17:39:51 2017
Received: from localhost ([127.0.0.1]:51644 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d5fWR-0005Lh-2g
	for submit <at> debbugs.gnu.org; Tue, 02 May 2017 17:39:51 -0400
Received: from eggs.gnu.org ([208.118.235.92]:50098)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1d5fWP-0005LS-5q
 for control <at> debbugs.gnu.org; Tue, 02 May 2017 17:39:49 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@HIDDEN>) id 1d5fWJ-00062j-F0
 for control <at> debbugs.gnu.org; Tue, 02 May 2017 17:39:44 -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,RP_MATCHES_RCVD
 autolearn=disabled version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:37294)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@HIDDEN>)
 id 1d5fWJ-00062f-CN
 for control <at> debbugs.gnu.org; Tue, 02 May 2017 17:39:43 -0400
Received: from reverse-83.fdn.fr ([80.67.176.83]:53898 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>) id 1d5fWI-0007pw-OG
 for control <at> debbugs.gnu.org; Tue, 02 May 2017 17:39:43 -0400
Date: Tue, 02 May 2017 23:39:41 +0200
Message-Id: <87inljym3m.fsf@HIDDEN>
To: control <at> debbugs.gnu.org
From: ludo@HIDDEN (Ludovic =?utf-8?Q?Court=C3=A8s?=)
Subject: control message for bug #26645
MIME-version: 1.0
Content-type: text/plain; charset=utf-8
Content-Transfer-Encoding: 8bit
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
X-Debbugs-Envelope-To: control
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: -5.0 (-----)

severity 26645 important




Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
Resent-From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Wed, 03 May 2017 20:20:02 +0000
Resent-Message-ID: <handler.26645.B26645.149384279016350 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: Andy Wingo <wingo@HIDDEN>
Cc: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149384279016350
          (code B ref 26645); Wed, 03 May 2017 20:20:02 +0000
Received: (at 26645) by debbugs.gnu.org; 3 May 2017 20:19:50 +0000
Received: from localhost ([127.0.0.1]:53229 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d60kX-0004Fe-Ms
	for submit <at> debbugs.gnu.org; Wed, 03 May 2017 16:19:49 -0400
Received: from eggs.gnu.org ([208.118.235.92]:59323)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1d60kV-0004FS-UT
 for 26645 <at> debbugs.gnu.org; Wed, 03 May 2017 16:19:48 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@HIDDEN>) id 1d60kL-0002Jk-L1
 for 26645 <at> debbugs.gnu.org; Wed, 03 May 2017 16:19:42 -0400
X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org
X-Spam-Level: 
X-Spam-Status: No, score=0.8 required=5.0 tests=BAYES_50,RP_MATCHES_RCVD
 autolearn=disabled version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:50801)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@HIDDEN>)
 id 1d60kL-0002Jf-Ga; Wed, 03 May 2017 16:19:37 -0400
Received: from reverse-83.fdn.fr ([80.67.176.83]:35584 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1d60kK-0000cY-Nw; Wed, 03 May 2017 16:19:37 -0400
From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
References: <87y3upttm7.fsf@HIDDEN>
 <20170424205923.27726-1-wingo@HIDDEN>
Date: Wed, 03 May 2017 22:19:34 +0200
In-Reply-To: <20170424205923.27726-1-wingo@HIDDEN> (Andy Wingo's message
 of "Mon, 24 Apr 2017 22:59:15 +0200")
Message-ID: <87efw5r8vd.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.2 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
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: -5.0 (-----)

Hi!

Finally some review for all these exciting bits!  :-)

Andy Wingo <wingo@HIDDEN> skribis:

> * 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.

[...]

> +(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)))

What about adding a =E2=80=98lookup-build-system=E2=80=99 procedure in (guix
build-systems) directly that would reuse the logic from =E2=80=98fold-packa=
ges=E2=80=99
and co.?  That would avoid repetition.

I can move the relevant bits to (guix plugins) or (guix discovery),
which should help, WDYT?

> +(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)))

Likewise here.

> +(define-module (guix potluck packages)

Nice!

> +(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 ...)

Can we factorize it with =E2=80=98package-field-location=E2=80=99?  In fact=
, it looks
like we could extract:

  (define (sexp-location start-location car)
    "Return the location of the sexp with the given CAR, starting from
  START-LOCATION."
    =E2=80=A6)

and define both =E2=80=98package-field-location=E2=80=99 and
=E2=80=98potluck-package-field-location=E2=80=99 in terms of it.  Thoughts?

> +(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)))))

Could you add a couple of tests for this?

> 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

I=E2=80=99d move this part to a separate patch.

As discussed on IRC I think, I was wondering whether it would make sense
to have a =E2=80=98guix potluck build=E2=80=99 command instead.  Normally, =
use
=E2=80=98%standard-build-options=E2=80=99 and =E2=80=98set-build-options-fr=
om-command-line=E2=80=99 from
(guix scripts build), there should be little duplication, I think.  That
would avoid entangling potluck and =E2=80=98guix build=E2=80=99 too much.

Could you check if that=E2=80=99s doable?  If it turns out it=E2=80=99s too
inconvenient, then we can take the approach here.

Thank you!

Ludo=E2=80=99.




Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 3/9] guix: Add git utility module.
Resent-From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Wed, 03 May 2017 20:24:02 +0000
Resent-Message-ID: <handler.26645.B26645.149384302216715 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: Andy Wingo <wingo@HIDDEN>
Cc: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149384302216715
          (code B ref 26645); Wed, 03 May 2017 20:24:02 +0000
Received: (at 26645) by debbugs.gnu.org; 3 May 2017 20:23:42 +0000
Received: from localhost ([127.0.0.1]:53233 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d60oI-0004LX-AR
	for submit <at> debbugs.gnu.org; Wed, 03 May 2017 16:23:42 -0400
Received: from eggs.gnu.org ([208.118.235.92]:60126)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1d60oG-0004LL-Ug
 for 26645 <at> debbugs.gnu.org; Wed, 03 May 2017 16:23:41 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@HIDDEN>) id 1d60o7-0006Nb-2w
 for 26645 <at> debbugs.gnu.org; Wed, 03 May 2017 16:23:35 -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,RP_MATCHES_RCVD
 autolearn=disabled version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:50839)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@HIDDEN>)
 id 1d60o6-0006NR-Vp; Wed, 03 May 2017 16:23:31 -0400
Received: from reverse-83.fdn.fr ([80.67.176.83]:35594 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1d60o6-0000q2-BK; Wed, 03 May 2017 16:23:30 -0400
From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
References: <20170424205923.27726-1-wingo@HIDDEN>
 <20170424205923.27726-3-wingo@HIDDEN>
Date: Wed, 03 May 2017 22:23:28 +0200
In-Reply-To: <20170424205923.27726-3-wingo@HIDDEN> (Andy Wingo's message
 of "Mon, 24 Apr 2017 22:59:17 +0200")
Message-ID: <87a86tr8ov.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.2 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
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: -5.0 (-----)

Andy Wingo <wingo@HIDDEN> skribis:

> * guix/git.scm: New file.
> * Makefile.am (MODULES): Add new file.

Looking forward, what about calling it (guix git-program) or (guix
potluck git) instead?  :-)

The reason is that (1) after the release we=E2=80=99ll start using Guile-Git
directly, and (2) Mathieu O. is working on a (guix git) module that does
higher-level Git repo management using Guile-Git.

Otherwise LGTM!

Ludo=E2=80=99.




Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
Resent-From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Wed, 03 May 2017 21:56:02 +0000
Resent-Message-ID: <handler.26645.B26645.149384853224582 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: Andy Wingo <wingo@HIDDEN>
Cc: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149384853224582
          (code B ref 26645); Wed, 03 May 2017 21:56:02 +0000
Received: (at 26645) by debbugs.gnu.org; 3 May 2017 21:55:32 +0000
Received: from localhost ([127.0.0.1]:53292 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d62F9-0006OP-Tn
	for submit <at> debbugs.gnu.org; Wed, 03 May 2017 17:55:32 -0400
Received: from eggs.gnu.org ([208.118.235.92]:53412)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1d62F9-0006O7-0g
 for 26645 <at> debbugs.gnu.org; Wed, 03 May 2017 17:55:31 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@HIDDEN>) id 1d62F0-00022H-TG
 for 26645 <at> debbugs.gnu.org; Wed, 03 May 2017 17:55:26 -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,RP_MATCHES_RCVD
 autolearn=disabled version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:52104)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@HIDDEN>)
 id 1d62F0-00022C-Px; Wed, 03 May 2017 17:55:22 -0400
Received: from reverse-83.fdn.fr ([80.67.176.83]:40362 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1d62F0-00089B-3Z; Wed, 03 May 2017 17:55:22 -0400
From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
References: <87y3upttm7.fsf@HIDDEN>
 <20170424205923.27726-1-wingo@HIDDEN> <87efw5r8vd.fsf@HIDDEN>
Date: Wed, 03 May 2017 23:55:19 +0200
In-Reply-To: <87efw5r8vd.fsf@HIDDEN> ("Ludovic
 \=\?utf-8\?Q\?Court\=C3\=A8s\=22'\?\=
 \=\?utf-8\?Q\?s\?\= message of "Wed, 03 May 2017 22:19:34 +0200")
Message-ID: <87zietppvc.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.2 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
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: -5.0 (-----)

ludo@HIDDEN (Ludovic Court=C3=A8s) skribis:

> What about adding a =E2=80=98lookup-build-system=E2=80=99 procedure in (g=
uix
> build-systems) directly that would reuse the logic from =E2=80=98fold-pac=
kages=E2=80=99
> and co.?  That would avoid repetition.
>
> I can move the relevant bits to (guix plugins) or (guix discovery),
> which should help, WDYT?

I did that in commit cd903ef7871170d3c4eced45418459d293ef48a7, and it
turns out to be useful in another situation already.

HTH!

Ludo=E2=80=99.




Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 4/9] guix: Add "potluck" command.
Resent-From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Thu, 04 May 2017 20:24:02 +0000
Resent-Message-ID: <handler.26645.B26645.149392943217233 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: Andy Wingo <wingo@HIDDEN>
Cc: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149392943217233
          (code B ref 26645); Thu, 04 May 2017 20:24:02 +0000
Received: (at 26645) by debbugs.gnu.org; 4 May 2017 20:23:52 +0000
Received: from localhost ([127.0.0.1]:54901 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d6NHw-0004Te-IH
	for submit <at> debbugs.gnu.org; Thu, 04 May 2017 16:23:52 -0400
Received: from eggs.gnu.org ([208.118.235.92]:54775)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1d6NHu-0004TT-Uv
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:23:47 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@HIDDEN>) id 1d6NHl-0001kq-V7
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:23:41 -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,RP_MATCHES_RCVD
 autolearn=disabled version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:40809)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@HIDDEN>)
 id 1d6NHl-0001kk-R7; Thu, 04 May 2017 16:23:37 -0400
Received: from reverse-83.fdn.fr ([80.67.176.83]:39636 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1d6NHl-0006gS-82; Thu, 04 May 2017 16:23:37 -0400
From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
References: <20170424205923.27726-1-wingo@HIDDEN>
 <20170424205923.27726-4-wingo@HIDDEN>
Date: Thu, 04 May 2017 22:23:34 +0200
In-Reply-To: <20170424205923.27726-4-wingo@HIDDEN> (Andy Wingo's message
 of "Mon, 24 Apr 2017 22:59:18 +0200")
Message-ID: <87tw509xrt.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.2 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
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: -5.0 (-----)

Hello!

Andy Wingo <wingo@HIDDEN> skribis:

> * guix/scripts/potluck.scm: New file.
> * Makefile.am: Add new file.

[...]

> +      (call-with-output-file (in-vicinity potluck-dir "README.md")
> +        (lambda (port)
> +          (format port
> +                  "\

Please add (G_ =E2=80=A6) for i18n, and also add the file to po/guix/POTFIL=
ES.in.

> +This directory defines potluck packages.  Each file in this directory sh=
ould
> +define one package.  See https://potluck.guixsd.org/ for more informatio=
n.

I=E2=80=99ll email guix-sysadmin so potluck.guixsd.org points to the same I=
P as
guix-potluck.org.  :-)

> +    (let* ((opts     (parse-command-line args %options
> +                                         (list %default-options)
> +                                         #:argument-handler
> +                                         parse-sub-command))

=E2=80=98parse-command-line=E2=80=99 honors $GUIX_BUILD_OPTIONS, which is u=
nnecessary
here.  Instead, we should use =E2=80=98args-fold*=E2=80=99 like in (guix sc=
ripts hash),
for instance.

Otherwise LGTM, thanks!

Ludo=E2=80=99.




Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox.
Resent-From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Thu, 04 May 2017 20:28:01 +0000
Resent-Message-ID: <handler.26645.B26645.149392964417583 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: Andy Wingo <wingo@HIDDEN>
Cc: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149392964417583
          (code B ref 26645); Thu, 04 May 2017 20:28:01 +0000
Received: (at 26645) by debbugs.gnu.org; 4 May 2017 20:27:24 +0000
Received: from localhost ([127.0.0.1]:54905 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d6NLQ-0004ZX-1N
	for submit <at> debbugs.gnu.org; Thu, 04 May 2017 16:27:24 -0400
Received: from eggs.gnu.org ([208.118.235.92]:55342)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1d6NLO-0004ZI-Ht
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:27:22 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@HIDDEN>) id 1d6NLE-0002xn-K1
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:27:17 -0400
X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org
X-Spam-Level: 
X-Spam-Status: No, score=-0.5 required=5.0 tests=BAYES_05,RP_MATCHES_RCVD
 autolearn=disabled version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:40843)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@HIDDEN>)
 id 1d6NLE-0002xb-Gp; Thu, 04 May 2017 16:27:12 -0400
Received: from reverse-83.fdn.fr ([80.67.176.83]:39650 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1d6NLD-00078n-Rd; Thu, 04 May 2017 16:27:12 -0400
From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
References: <20170424205923.27726-1-wingo@HIDDEN>
 <20170424205923.27726-5-wingo@HIDDEN>
Date: Thu, 04 May 2017 22:27:09 +0200
In-Reply-To: <20170424205923.27726-5-wingo@HIDDEN> (Andy Wingo's message
 of "Mon, 24 Apr 2017 22:59:19 +0200")
Message-ID: <87pofo9xlu.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.2 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
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: -5.0 (-----)

Andy Wingo <wingo@HIDDEN> skribis:

> * 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.

[...]

> +     ((getenv "GUIX_POTLUCK_NO_SANDBOX")
> +      (warn "No sandbox available; be warned!!!")

Perhaps this should use =E2=80=98warning=E2=80=99 from (guix ui).

> +;; 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}."

Could you add a couple of tests in tests/potluck-package.scm for this
part, or maybe for =E2=80=98eval-in-sandbox=E2=80=99?

Otherwise LGTM, thank you!

Ludo=E2=80=99.




Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 6/9] gnu: Add find-package-binding.
Resent-From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Thu, 04 May 2017 20:31:02 +0000
Resent-Message-ID: <handler.26645.B26645.149392981217933 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: Andy Wingo <wingo@HIDDEN>
Cc: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149392981217933
          (code B ref 26645); Thu, 04 May 2017 20:31:02 +0000
Received: (at 26645) by debbugs.gnu.org; 4 May 2017 20:30:12 +0000
Received: from localhost ([127.0.0.1]:54909 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d6NO8-0004fB-G1
	for submit <at> debbugs.gnu.org; Thu, 04 May 2017 16:30:12 -0400
Received: from eggs.gnu.org ([208.118.235.92]:55858)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1d6NO7-0004eT-5f
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:30:11 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@HIDDEN>) id 1d6NNx-0004Kl-1L
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:30:06 -0400
X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org
X-Spam-Level: 
X-Spam-Status: No, score=0.8 required=5.0 tests=BAYES_50,RP_MATCHES_RCVD
 autolearn=disabled version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:40871)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@HIDDEN>)
 id 1d6NNw-0004Kb-V2; Thu, 04 May 2017 16:30:00 -0400
Received: from reverse-83.fdn.fr ([80.67.176.83]:39660 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1d6NNw-0003Vx-Ev; Thu, 04 May 2017 16:30:00 -0400
From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
References: <20170424205923.27726-1-wingo@HIDDEN>
 <20170424205923.27726-6-wingo@HIDDEN>
Date: Thu, 04 May 2017 22:29:58 +0200
In-Reply-To: <20170424205923.27726-6-wingo@HIDDEN> (Andy Wingo's message
 of "Mon, 24 Apr 2017 22:59:20 +0200")
Message-ID: <87lgqc9xh5.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.2 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
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: -5.0 (-----)

Andy Wingo <wingo@HIDDEN> skribis:

> * gnu/packages.scm (find-package-binding): New export.

[...]

> +(define (find-package-binding package)
> +  "Find the module that exports PACKAGE.  Return two values, an interfac=
e 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 s=
ee if
> +  ;; we can use the package's location to find its module and look in th=
at
> +  ;; 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)
> +    =3D> (lambda (loc)
> +         (cond
> +          ((file-name->module-name (location-file loc))
> +           =3D> (lambda (module-name)
> +                (cond
> +                 ((false-if-exception (resolve-interface module-name))
> +                  =3D> (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))))

I think it would be enough to assume that (package-location package) is
always valid (which is the case by default), and bail out if it=E2=80=99s n=
ot.

WDYT?

Otherwise LGTM, thanks!

Ludo=E2=80=99.




Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
Resent-From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Thu, 04 May 2017 20:32:01 +0000
Resent-Message-ID: <handler.26645.B26645.149392988718064 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: Andy Wingo <wingo@HIDDEN>
Cc: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149392988718064
          (code B ref 26645); Thu, 04 May 2017 20:32:01 +0000
Received: (at 26645) by debbugs.gnu.org; 4 May 2017 20:31:27 +0000
Received: from localhost ([127.0.0.1]:54914 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d6NPK-0004hI-RE
	for submit <at> debbugs.gnu.org; Thu, 04 May 2017 16:31:27 -0400
Received: from eggs.gnu.org ([208.118.235.92]:56134)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1d6NPJ-0004h3-K4
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:31:25 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@HIDDEN>) id 1d6NP9-0005Ex-PY
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:31:20 -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,RP_MATCHES_RCVD
 autolearn=disabled version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:40903)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@HIDDEN>)
 id 1d6NP9-0005Es-Mm; Thu, 04 May 2017 16:31:15 -0400
Received: from reverse-83.fdn.fr ([80.67.176.83]:39666 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1d6NP9-0005L0-3X; Thu, 04 May 2017 16:31:15 -0400
From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
References: <20170424205923.27726-1-wingo@HIDDEN>
 <20170424205923.27726-7-wingo@HIDDEN>
Date: Thu, 04 May 2017 22:31:13 +0200
In-Reply-To: <20170424205923.27726-7-wingo@HIDDEN> (Andy Wingo's message
 of "Mon, 24 Apr 2017 22:59:21 +0200")
Message-ID: <87h9109xf2.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.2 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
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: -5.0 (-----)

Andy Wingo <wingo@HIDDEN> skribis:

> * guix/potluck/packages.scm (lower-potluck-package-to-module): New public
> function.

Could you add a quick test for this?  :-)

Otherwise LGTM!

Ludo=E2=80=99.




Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand.
Resent-From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Thu, 04 May 2017 20:56:01 +0000
Resent-Message-ID: <handler.26645.B26645.149393135020295 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: Andy Wingo <wingo@HIDDEN>
Cc: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149393135020295
          (code B ref 26645); Thu, 04 May 2017 20:56:01 +0000
Received: (at 26645) by debbugs.gnu.org; 4 May 2017 20:55:50 +0000
Received: from localhost ([127.0.0.1]:54921 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d6Nmv-0005HH-Uo
	for submit <at> debbugs.gnu.org; Thu, 04 May 2017 16:55:50 -0400
Received: from eggs.gnu.org ([208.118.235.92]:60740)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1d6Nmt-0005H4-SL
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:55:48 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@HIDDEN>) id 1d6Nml-0007mo-A3
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:55:42 -0400
X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org
X-Spam-Level: 
X-Spam-Status: No, score=0.8 required=5.0 tests=BAYES_50,RP_MATCHES_RCVD
 autolearn=disabled version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:41149)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@HIDDEN>)
 id 1d6Nml-0007mk-6L; Thu, 04 May 2017 16:55:39 -0400
Received: from reverse-83.fdn.fr ([80.67.176.83]:39738 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1d6Nmk-0005xS-FZ; Thu, 04 May 2017 16:55:38 -0400
From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
References: <20170424205923.27726-1-wingo@HIDDEN>
 <20170424205923.27726-8-wingo@HIDDEN>
Date: Thu, 04 May 2017 22:55:36 +0200
In-Reply-To: <20170424205923.27726-8-wingo@HIDDEN> (Andy Wingo's message
 of "Mon, 24 Apr 2017 22:59:22 +0200")
Message-ID: <87y3uc8hpz.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.2 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
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: -5.0 (-----)

Andy Wingo <wingo@HIDDEN> skribis:

> * guix/potluck/host.scm: New file.
> * Makefile.am (MODULES): Add new file.
> * guix/scripts/potluck.scm: Add host-channel command.

[...]

> +(define-module (guix potluck host)

Could you add a commentary explaining what it does?

> +;;;
> +;;; async queues
> +;;;

Nice; perhaps in the future (guix workers) should use these instead of
rolling & entangling its own.

> +(define (bytes-free-on-fs filename)
> +  (let* ((p (open-pipe* "r" "df" "-B1" "--output=3Davail" filename))

Please use =E2=80=98statfs=E2=80=99 from (guix build syscalls) instead, it =
should be
nicer.  ;-)

> +(define (process-update host working-dir source-checkout target-checkout
> +                        remote-git-url branch)

Please add a docstring to guide the reader.

> +  (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

Can=E2=80=99t there be multiple threads running this code in parallel?  I=
=E2=80=99m
wary of changing the cwd in general, especially in multi-threaded
programs.  How hard would it be to aviod the =E2=80=98chdir=E2=80=99 and
=E2=80=98with-directory-excursion=E2=80=99 uses?

> +(define (host-potluck host local-port working-dir source-checkout
> +                      target-checkout)

Please add a docstring.

> +  (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)))))

In fact perhaps (guix workers) would work here?

As always I would feel reassured with a couple of tests.  :-)  Perhaps
we could spawn a service thread as in tests/publish.scm, and mock the
Git procedures?

Thank you!

Ludo=E2=80=99.




Message sent to guix-patches@HIDDEN:


X-Loop: help-debbugs@HIDDEN
Subject: bug#26645: [PATCH 9/9] doc: Document guix potluck.
Resent-From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: guix-patches@HIDDEN
Resent-Date: Thu, 04 May 2017 20:58:02 +0000
Resent-Message-ID: <handler.26645.B26645.149393143220437 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: followup 26645
X-GNU-PR-Package: guix-patches
X-GNU-PR-Keywords: 
To: Andy Wingo <wingo@HIDDEN>
Cc: 26645 <at> debbugs.gnu.org
Received: via spool by 26645-submit <at> debbugs.gnu.org id=B26645.149393143220437
          (code B ref 26645); Thu, 04 May 2017 20:58:02 +0000
Received: (at 26645) by debbugs.gnu.org; 4 May 2017 20:57:12 +0000
Received: from localhost ([127.0.0.1]:54925 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1d6NoG-0005JZ-B2
	for submit <at> debbugs.gnu.org; Thu, 04 May 2017 16:57:12 -0400
Received: from eggs.gnu.org ([208.118.235.92]:32840)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@HIDDEN>) id 1d6NoE-0005JN-D3
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:57:10 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@HIDDEN>) id 1d6No6-0008Eo-7l
 for 26645 <at> debbugs.gnu.org; Thu, 04 May 2017 16:57:05 -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,RP_MATCHES_RCVD
 autolearn=disabled version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:41170)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@HIDDEN>)
 id 1d6No6-0008Eh-4n; Thu, 04 May 2017 16:57:02 -0400
Received: from reverse-83.fdn.fr ([80.67.176.83]:39740 helo=ribbon)
 by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@HIDDEN>)
 id 1d6No5-0006Dn-Ih; Thu, 04 May 2017 16:57:01 -0400
From: ludo@HIDDEN (Ludovic =?UTF-8?Q?Court=C3=A8s?=)
References: <20170424205923.27726-1-wingo@HIDDEN>
 <20170424205923.27726-9-wingo@HIDDEN>
Date: Thu, 04 May 2017 22:56:59 +0200
In-Reply-To: <20170424205923.27726-9-wingo@HIDDEN> (Andy Wingo's message
 of "Mon, 24 Apr 2017 22:59:23 +0200")
Message-ID: <87tw508hno.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.2 (gnu/linux)
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
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: -5.0 (-----)

Andy Wingo <wingo@HIDDEN> skribis:

> * doc/guix.texi (potluck-package Reference):
> (Invoking guix potluck): New sections.

Perfect, awesome!!

Thank you,
Ludo=E2=80=99.





Last modified: Mon, 25 Nov 2019 12:00:02 UTC

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