guix potluck

OpenSubmitted by Andy Wingo.
Details
7 participants
  • Brice Waegeneire
  • ng0
  • Jack Hill
  • Ludovic Courtès
  • Ricardo Wurmus
  • Andy Wingo
  • Andy Wingo
Owner
unassigned
Severity
important
A
A
Andy Wingo wrote on 24 Apr 2017 22:53
(address . guix-patches@gnu.org)
87y3upttm7.fsf@pobox.com
Hi,
The attached patches add a "guix potluck" facility, as described onguix-devel:
https://lists.gnu.org/archive/html/guix-devel/2017-04/msg00250.html
Cheers,
Andy
A
A
Andy Wingo wrote on 24 Apr 2017 22:59
[PATCH 4/9] guix: Add "potluck" command.
(address . 26645@debbugs.gnu.org)
20170424205923.27726-4-wingo@igalia.com
* 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
Toggle diff (330 lines)diff --git a/Makefile.am b/Makefile.amindex 64a7a9265..295d7b3a6 100644--- a/Makefile.am+++ b/Makefile.am@@ -167,6 +167,7 @@ MODULES = \ guix/scripts/graph.scm \ guix/scripts/container.scm \ guix/scripts/container/exec.scm \+ guix/scripts/potluck.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scmnew file mode 100644index 000000000..f9cd40bd0--- /dev/null+++ b/guix/scripts/potluck.scm@@ -0,0 +1,310 @@+;;; GNU Guix --- Functional package management for GNU+;;; Copyright © 2017 Andy Wingo <wingo@pobox.com>+;;;+;;; This file is part of GNU Guix.+;;;+;;; GNU Guix is free software; you can redistribute it and/or modify it+;;; under the terms of the GNU General Public License as published by+;;; the Free Software Foundation; either version 3 of the License, or (at+;;; your option) any later version.+;;;+;;; GNU Guix is distributed in the hope that it will be useful, but+;;; WITHOUT ANY WARRANTY; without even the implied warranty of+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+;;; GNU General Public License for more details.+;;;+;;; You should have received a copy of the GNU General Public License+;;; along with GNU Guix. If not, see <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))++ +;;;+;;; 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-parse 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 should+define one package. See https://potluck.guixsd.org/ for more information.+")))+ (format #t (_ "Creating potluck/~a.scm~%") package-name)+ (call-with-output-file (in-vicinity potluck-dir+ (string-append package-name ".scm"))+ (lambda (port)+ + (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=potluck/~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))))++ +;;;+;;; Options.+;;;++(define (show-help)+ (display (_ "Usage: guix potluck [OPTION ...] ACTION [ARG ...]+Create \"potluck\" packages, register them with a central service, and arrange+to serve those packages as a Guix channel. Some ACTIONS require additional+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=SYS for 'init', specify the build system. Use+ --build-system=help for all available options."))+ (display (_ "+ --autotools for 'init', like --build-system=gnu but additionally+ indicating that the package needs autoreconf before+ running ./configure"))+ (display (_ "+ --license=LICENSE for 'init', specify the license of the package. Use+ --license=help for all available options."))+ (display (_ "+ --verbosity=LEVEL 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=help 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=gnu, but also indicating+that the package needs autoreconf before running ./configure.~%")+ (exit 0))+ (unless (build-system-by-name sys)+ (leave (_ "invalid build system: ~a; try --build-system=help~%") sys))+ sys))++(define (parse-license license-str)+ (unless license-str+ (leave (_ "init: missing --license; try --license=help 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=help~%") license))+ license))++ +;;;+;;; 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))))))-- 2.12.2
A
A
Andy Wingo wrote on 24 Apr 2017 22:59
[PATCH 9/9] doc: Document guix potluck.
(address . 26645@debbugs.gnu.org)
20170424205923.27726-9-wingo@igalia.com
* doc/guix.texi (potluck-package Reference):(Invoking guix potluck): New sections.--- doc/guix.texi | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 231 insertions(+)
Toggle diff (286 lines)diff --git a/doc/guix.texi b/doc/guix.texiindex 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
A
A
Andy Wingo wrote on 24 Apr 2017 22:59
[PATCH 3/9] guix: Add git utility module.
(address . 26645@debbugs.gnu.org)
20170424205923.27726-3-wingo@igalia.com
* 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
Toggle diff (184 lines)diff --git a/Makefile.am b/Makefile.amindex 22ba00e90..64a7a9265 100644--- a/Makefile.am+++ b/Makefile.am@@ -126,6 +126,7 @@ MODULES = \ 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.scmnew file mode 100644index 000000000..02f61edac--- /dev/null+++ b/guix/git.scm@@ -0,0 +1,164 @@+;;; GNU Guix --- Functional package management for GNU+;;; Copyright © 2017 Andy Wingo <wingo@pobox.com>+;;;+;;; This file is part of GNU Guix.+;;;+;;; GNU Guix is free software; you can redistribute it and/or modify it+;;; under the terms of the GNU General Public License as published by+;;; the Free Software Foundation; either version 3 of the License, or (at+;;; your option) any later version.+;;;+;;; GNU Guix is distributed in the hope that it will be useful, but+;;; WITHOUT ANY WARRANTY; without even the implied warranty of+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+;;; GNU General Public License for more details.+;;;+;;; You should have received a copy of the GNU General Public License+;;; along with GNU Guix. If not, see <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 for+@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 name and+email address @var{author-name} and @var{author-email}, respectively."+ (git* (list "commit" (string-append "--message=" message))+ #:env (list (string-append "GIT_COMMITTER_NAME=" author-name)+ (string-append "GIT_COMMITTER_EMAIL=" author-email)+ (string-append "GIT_AUTHOR_NAME=" author-name)+ (string-append "GIT_AUTHOR_EMAIL=" author-email))))-- 2.12.2
A
A
Andy Wingo wrote on 24 Apr 2017 22:59
[PATCH 2/9] guix hash: Add --git option to hash a git checkout.
(address . 26645@debbugs.gnu.org)
20170424205923.27726-2-wingo@igalia.com
* 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(-)
Toggle diff (150 lines)diff --git a/doc/guix.texi b/doc/guix.texiindex 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 importdiff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scmindex 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
A
A
Andy Wingo wrote on 24 Apr 2017 22:59
[PATCH 1/9] guix: Add "potluck" packages.
(address . 26645@debbugs.gnu.org)
20170424205923.27726-1-wingo@igalia.com
* 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" and"potluck-source" to environment of file. Lower potluck packages to Guixpackages.--- 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
Toggle diff (622 lines)diff --git a/Makefile.am b/Makefile.amindex db4ebe04d..22ba00e90 100644--- a/Makefile.am+++ b/Makefile.am@@ -126,6 +126,9 @@ MODULES = \ 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.scmnew file mode 100644index 000000000..1f6aa1fe3--- /dev/null+++ b/guix/potluck/build-systems.scm@@ -0,0 +1,55 @@+;;; GNU Guix --- Functional package management for GNU+;;; Copyright © 2017 Andy Wingo <wingo@pobox.com>+;;;+;;; This file is part of GNU Guix.+;;;+;;; GNU Guix is free software; you can redistribute it and/or modify it+;;; under the terms of the GNU General Public License as published by+;;; the Free Software Foundation; either version 3 of the License, or (at+;;; your option) any later version.+;;;+;;; GNU Guix is distributed in the hope that it will be useful, but+;;; WITHOUT ANY WARRANTY; without even the implied warranty of+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+;;; GNU General Public License for more details.+;;;+;;; You should have received a copy of the GNU General Public License+;;; along with GNU Guix. If not, see <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.scmnew file mode 100644index 000000000..6efeee21a--- /dev/null+++ b/guix/potluck/licenses.scm@@ -0,0 +1,41 @@+;;; GNU Guix --- Functional package management for GNU+;;; Copyright © 2017 Andy Wingo <wingo@pobox.com>+;;;+;;; This file is part of GNU Guix.+;;;+;;; GNU Guix is free software; you can redistribute it and/or modify it+;;; under the terms of the GNU General Public License as published by+;;; the Free Software Foundation; either version 3 of the License, or (at+;;; your option) any later version.+;;;+;;; GNU Guix is distributed in the hope that it will be useful, but+;;; WITHOUT ANY WARRANTY; without even the implied warranty of+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+;;; GNU General Public License for more details.+;;;+;;; You should have received a copy of the GNU General Public License+;;; along with GNU Guix. If not, see <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.scmnew file mode 100644index 000000000..c7dae3791--- /dev/null+++ b/guix/potluck/packages.scm@@ -0,0 +1,399 @@+;;; GNU Guix --- Functional package management for GNU+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>+;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>+;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>+;;; Copyright © 2017 Andy Wingo <wingo@pobox.com>+;;;+;;; This file is part of GNU Guix.+;;;+;;; GNU Guix is free software; you can redistribute it and/or modify it+;;; under the terms of the GNU General Public License as published by+;;; the Free Software Foundation; either version 3 of the License, or (at+;;; your option) any later version.+;;;+;;; GNU Guix is distributed in the hope that it will be useful, but+;;; WITHOUT ANY WARRANTY; without even the implied warranty of+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+;;; GNU General Public License for more details.+;;;+;;; You should have received a copy of the GNU General Public License+;;; along with GNU Guix. If not, see <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 propagated+ (default '()))+ (native-inputs potluck-package-native-inputs ; native input packages or+ ; derivations+ (default '()))+ (synopsis potluck-package-synopsis) ; one-line description+ (description potluck-package-description) ; one or two paragraphs+ (license potluck-package-license)+ (home-page potluck-package-home-page)+ (location potluck-package-location+ (default (and=> (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-inputs)+ (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 PACKAGE, or+#f if it could not be determined."+ (define (goto port line column)+ (unless (and (= (port-column port) (- column 1))+ (= (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 argument of+ ;; `and=>', to work around a compiler bug in 2.0.5.+ (or (and=> (source-properties value)+ source-properties->location)+ (and=> (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-package-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 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)))+ (assertion-failed pkg field-name "public URI" str))))++(define (validate-git-commit pkg field-name commit)+ (unless (and (string? commit)+ (= (string-length commit) 40)+ (string-every (string->char-set "abcdef0123456789") commit))+ (assertion-failed pkg field-name "full git commit SHA1 hash" commit)))++(define (validate-base32-sha256 pkg field-name str)+ (unless (and (string? str)+ (= (string-length str) 52)+ (false-if-exception (nix-base32-string->bytevector str)))+ (assertion-failed pkg field-name "sha256 hash as a base32 string" str)))++(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 pkg))+ (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.scmindex 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) ;; 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))) +(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))) (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?)) + (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)-- 2.12.2
A
A
Andy Wingo wrote on 24 Apr 2017 22:59
[PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
(address . 26645@debbugs.gnu.org)
20170424205923.27726-7-wingo@igalia.com
* guix/potluck/packages.scm (lower-potluck-package-to-module): New publicfunction.--- guix/potluck/packages.scm | 118 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 117 insertions(+), 1 deletion(-)
Toggle diff (144 lines)diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scmindex 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
A
A
Andy Wingo wrote on 24 Apr 2017 22:59
[PATCH 8/9] potluck: Add host-channel subcommand.
(address . 26645@debbugs.gnu.org)
20170424205923.27726-8-wingo@igalia.com
* 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
Toggle diff (553 lines)diff --git a/Makefile.am b/Makefile.amindex 628283b57..94fa05d5b 100644--- a/Makefile.am+++ b/Makefile.am@@ -129,6 +129,7 @@ MODULES = \ 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.scmnew file mode 100644index 000000000..5ac8e0f5f--- /dev/null+++ b/guix/potluck/host.scm@@ -0,0 +1,304 @@+;;; GNU Guix --- Functional package management for GNU+;;; Copyright © 2017 Andy Wingo <wingo@pobox.com>+;;;+;;; This file is part of GNU Guix.+;;;+;;; GNU Guix is free software; you can redistribute it and/or modify it+;;; under the terms of the GNU General Public License as published by+;;; the Free Software Foundation; either version 3 of the License, or (at+;;; your option) any later version.+;;;+;;; GNU Guix is distributed in the hope that it will be useful, but+;;; WITHOUT ANY WARRANTY; without even the implied warranty of+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+;;; GNU General Public License for more details.+;;;+;;; You should have received a copy of the GNU General Public License+;;; along with GNU Guix. If not, see <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))++ +;;;+;;; 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)))))))++ +;;;+;;; backend+;;;++(define (bytes-free-on-fs filename)+ (let* ((p (open-pipe* "r" "df" "-B1" "--output=avail" 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" filename)))))++(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? ";" trimmed))+ (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 file))+ (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)))))++ +;;;+;;; 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.scmindex 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 ;;; -(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-parse 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 should-define one package. See https://potluck.guixsd.org/ for more information.+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 \"synopsis\"+and \"description\" fields, add dependencies to the 'inputs' field, and try to build with - guix build --file=potluck/~a.scm+ guix build --file=guix-potluck/~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))))++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))))) ;;;@@ -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 channel\n")) (newline) (display (_ "The available OPTION flags are:\n")) (display (_ "+ --host=HOST for 'update' and 'host-channel', the name of the+ channel host+ (default: guix-potluck.org)"))+ (display (_ "+ --port=PORT for 'host-channel', the local TCP port on which to+ listen for HTTP connections+ (default: 8080)"))+ (display (_ "+ --scratch=DIR for 'host-channel', the path to a local directory+ that will be used as a scratch space to check out+ remote git repositories"))+ (display (_ "+ --source=DIR for 'host-channel', the path to a local checkout+ of guix potluck source packages to be managed by+ host-channel"))+ (display (_ "+ --target=DIR for 'host-channel', the path to a local checkout+ of a guix channel to be managed by host-channel"))+ (display (_ " --build-system=SYS for 'init', specify the build system. Use --build-system=help 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))))) (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) (define (parse-url url-str) (unless (string->uri url-str) (leave (_ "invalid url: ~a~%") url-str)) url-str) +(define (parse-port port-str)+ (let ((port (string->number port-str)))+ (cond+ ((and port (exact-integer? port) (<= 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 it 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=DIR \+--source=DIR --target=DIR"))+ (exit 1)))) (action (leave (_ "~a: unknown action~%") action))))))-- 2.12.2
A
A
Andy Wingo wrote on 24 Apr 2017 22:59
[PATCH 5/9] potluck: Add ability to load potluck package in sandbox.
(address . 26645@debbugs.gnu.org)
20170424205923.27726-5-wingo@igalia.com
* 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
Toggle diff (635 lines)diff --git a/Makefile.am b/Makefile.amindex 295d7b3a6..628283b57 100644--- a/Makefile.am+++ b/Makefile.am@@ -128,6 +128,7 @@ MODULES = \ 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.scmnew file mode 100644index 000000000..f28ca11d5--- /dev/null+++ b/guix/potluck/environment.scm@@ -0,0 +1,538 @@+;;; GNU Guix --- Functional package management for GNU+;;; Copyright © 2017 Andy Wingo <wingo@pobox.com>+;;;+;;; This file is part of GNU Guix.+;;;+;;; GNU Guix is free software; you can redistribute it and/or modify it+;;; under the terms of the GNU General Public License as published by+;;; the Free Software Foundation; either version 3 of the License, or (at+;;; your option) any later version.+;;;+;;; GNU Guix is distributed in the hope that it will be useful, but+;;; WITHOUT ANY WARRANTY; without even the implied warranty of+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+;;; GNU General Public License for more details.+;;;+;;; You should have received a copy of the GNU General Public License+;;; along with GNU Guix. If not, see <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+ λ)++;; 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=>+ 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-+ <+ <=+ =+ >+ >=+ 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<=+ char-set=+ 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<=+ string-ci<=?+ string-ci<>+ string-ci<?+ string-ci=+ string-ci=?+ string-ci>+ string-ci>=+ string-ci>=?+ 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<=+ string<=?+ string<>+ string<?+ string=+ string=?+ string>+ string>=+ string>=?+ 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<=?+ char-ci<?+ char-ci=?+ char-ci>=?+ 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<=?+ char<?+ char=?+ char>=?+ 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.scmindex 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 + load-potluck-package+ validate-potluck-package lower-potluck-source@@ -191,6 +193,63 @@ (format port "~a (description ~s)\n" prefix description) (format port "~a (license '~s))\n" prefix license))) +;; 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)))+ => (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 them in+a potluck sandbox. The result of evaluating that expression sequence should+be a potluck package. Any syntax error reading the expressions or run-time+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. (define (potluck-package-field-location package field)-- 2.12.2
N
Re: bug#26645: guix potluck
(name . Andy Wingo)(address . wingo@pobox.com)(address . 26645@debbugs.gnu.org)
20170424210918.pwipe4a26ivaexvc@abyayala
Andy Wingo transcribed 0.2K bytes:
Toggle quote (14 lines)> 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/
A
A
Andy Wingo wrote on 24 Apr 2017 22:59
[PATCH 6/9] gnu: Add find-package-binding.
(address . 26645@debbugs.gnu.org)
20170424205923.27726-6-wingo@igalia.com
* gnu/packages.scm (find-package-binding): New export.--- gnu/packages.scm | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 61 insertions(+), 1 deletion(-)
Toggle diff (79 lines)diff --git a/gnu/packages.scm b/gnu/packages.scmindex 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
L
L
Ludovic Courtès wrote on 2 May 2017 23:39
control message for bug #26645
(address . control@debbugs.gnu.org)
87inljym3m.fsf@gnu.org
severity 26645 important
L
L
Ludovic Courtès wrote on 3 May 2017 22:19
Re: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
(name . Andy Wingo)(address . wingo@igalia.com)(address . 26645@debbugs.gnu.org)
87efw5r8vd.fsf@gnu.org
Hi!
Finally some review for all these exciting bits! :-)
Andy Wingo <wingo@igalia.com> skribis:
Toggle quote (8 lines)> * 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" and> "potluck-source" to environment of file. Lower potluck packages to Guix> packages.
[...]
Toggle quote (30 lines)> +(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 ‘lookup-build-system’ procedure in (guixbuild-systems) directly that would reuse the logic from ‘fold-packages’and co.? That would avoid repetition.
I can move the relevant bits to (guix plugins) or (guix discovery),which should help, WDYT?
Toggle quote (16 lines)> +(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.
Toggle quote (2 lines)> +(define-module (guix potluck packages)
Nice!
Toggle quote (21 lines)> +(define (potluck-package-field-location package field)> + "Return the source code location of the definition of FIELD for PACKAGE, or> +#f if it could not be determined."> + (define (goto port line column)> + (unless (and (= (port-column port) (- column 1))> + (= (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 ‘package-field-location’? In fact, it lookslike we could extract:
(define (sexp-location start-location car) "Return the location of the sexp with the given CAR, starting from START-LOCATION." …)
and define both ‘package-field-location’ and‘potluck-package-field-location’ in terms of it. Thoughts?
Toggle quote (28 lines)> +(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?
Toggle quote (5 lines)> 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’d move this part to a separate patch.
As discussed on IRC I think, I was wondering whether it would make senseto have a ‘guix potluck build’ command instead. Normally, use‘%standard-build-options’ and ‘set-build-options-from-command-line’ from(guix scripts build), there should be little duplication, I think. Thatwould avoid entangling potluck and ‘guix build’ too much.
Could you check if that’s doable? If it turns out it’s tooinconvenient, then we can take the approach here.
Thank you!
Ludo’.
L
L
Ludovic Courtès wrote on 3 May 2017 22:23
Re: bug#26645: [PATCH 3/9] guix: Add git utility module.
(name . Andy Wingo)(address . wingo@igalia.com)(address . 26645@debbugs.gnu.org)
87a86tr8ov.fsf@gnu.org
Andy Wingo <wingo@igalia.com> skribis:
Toggle quote (3 lines)> * guix/git.scm: New file.> * Makefile.am (MODULES): Add new file.
Looking forward, what about calling it (guix git-program) or (guixpotluck git) instead? :-)
The reason is that (1) after the release we’ll start using Guile-Gitdirectly, and (2) Mathieu O. is working on a (guix git) module that doeshigher-level Git repo management using Guile-Git.
Otherwise LGTM!
Ludo’.
L
L
Ludovic Courtès wrote on 3 May 2017 23:55
Re: bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
(name . Andy Wingo)(address . wingo@igalia.com)(address . 26645@debbugs.gnu.org)
87zietppvc.fsf@gnu.org
ludo@gnu.org (Ludovic Courtès) skribis:
Toggle quote (7 lines)> What about adding a ‘lookup-build-system’ procedure in (guix> build-systems) directly that would reuse the logic from ‘fold-packages’> 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 itturns out to be useful in another situation already.
HTH!
Ludo’.
L
L
Ludovic Courtès wrote on 4 May 2017 22:23
Re: bug#26645: [PATCH 4/9] guix: Add "potluck" command.
(name . Andy Wingo)(address . wingo@igalia.com)(address . 26645@debbugs.gnu.org)
87tw509xrt.fsf@gnu.org
Hello!
Andy Wingo <wingo@igalia.com> skribis:
Toggle quote (3 lines)> * guix/scripts/potluck.scm: New file.> * Makefile.am: Add new file.
[...]
Toggle quote (5 lines)> + (call-with-output-file (in-vicinity potluck-dir "README.md")> + (lambda (port)> + (format port> + "\
Please add (G_ …) for i18n, and also add the file to po/guix/POTFILES.in.
Toggle quote (3 lines)> +This directory defines potluck packages. Each file in this directory should> +define one package. See https://potluck.guixsd.org/ for more information.
I’ll email guix-sysadmin so potluck.guixsd.org points to the same IP asguix-potluck.org. :-)
Toggle quote (5 lines)> + (let* ((opts (parse-command-line args %options> + (list %default-options)> + #:argument-handler> + parse-sub-command))
‘parse-command-line’ honors $GUIX_BUILD_OPTIONS, which is unnecessaryhere. Instead, we should use ‘args-fold*’ like in (guix scripts hash),for instance.
Otherwise LGTM, thanks!
Ludo’.
L
L
Ludovic Courtès wrote on 4 May 2017 22:27
Re: bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox.
(name . Andy Wingo)(address . wingo@igalia.com)(address . 26645@debbugs.gnu.org)
87pofo9xlu.fsf@gnu.org
Andy Wingo <wingo@igalia.com> skribis:
Toggle quote (6 lines)> * 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.
[...]
Toggle quote (3 lines)> + ((getenv "GUIX_POTLUCK_NO_SANDBOX")> + (warn "No sandbox available; be warned!!!")
Perhaps this should use ‘warning’ from (guix ui).
Toggle quote (11 lines)> +;; 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 them in> +a potluck sandbox. The result of evaluating that expression sequence should> +be a potluck package. Any syntax error reading the expressions or run-time> +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 thispart, or maybe for ‘eval-in-sandbox’?
Otherwise LGTM, thank you!
Ludo’.
L
L
Ludovic Courtès wrote on 4 May 2017 22:29
Re: bug#26645: [PATCH 6/9] gnu: Add find-package-binding.
(name . Andy Wingo)(address . wingo@igalia.com)(address . 26645@debbugs.gnu.org)
87lgqc9xh5.fsf@gnu.org
Andy Wingo <wingo@igalia.com> skribis:
Toggle quote (2 lines)> * gnu/packages.scm (find-package-binding): New export.
[...]
Toggle quote (58 lines)> +(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))))
I think it would be enough to assume that (package-location package) isalways valid (which is the case by default), and bail out if it’s not.
WDYT?
Otherwise LGTM, thanks!
Ludo’.
L
L
Ludovic Courtès wrote on 4 May 2017 22:31
Re: bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
(name . Andy Wingo)(address . wingo@igalia.com)(address . 26645@debbugs.gnu.org)
87h9109xf2.fsf@gnu.org
Andy Wingo <wingo@igalia.com> skribis:
Toggle quote (3 lines)> * guix/potluck/packages.scm (lower-potluck-package-to-module): New public> function.
Could you add a quick test for this? :-)
Otherwise LGTM!
Ludo’.
L
L
Ludovic Courtès wrote on 4 May 2017 22:55
Re: bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand.
(name . Andy Wingo)(address . wingo@igalia.com)(address . 26645@debbugs.gnu.org)
87y3uc8hpz.fsf@gnu.org
Andy Wingo <wingo@igalia.com> skribis:
Toggle quote (4 lines)> * guix/potluck/host.scm: New file.> * Makefile.am (MODULES): Add new file.> * guix/scripts/potluck.scm: Add host-channel command.
[...]
Toggle quote (2 lines)> +(define-module (guix potluck host)
Could you add a commentary explaining what it does?
Toggle quote (4 lines)> +;;;> +;;; async queues> +;;;
Nice; perhaps in the future (guix workers) should use these instead ofrolling & entangling its own.
Toggle quote (3 lines)> +(define (bytes-free-on-fs filename)> + (let* ((p (open-pipe* "r" "df" "-B1" "--output=avail" filename))
Please use ‘statfs’ from (guix build syscalls) instead, it should benicer. ;-)
Toggle quote (3 lines)> +(define (process-update host working-dir source-checkout target-checkout> + remote-git-url branch)
Please add a docstring to guide the reader.
Toggle quote (33 lines)> + (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’t there be multiple threads running this code in parallel? I’mwary of changing the cwd in general, especially in multi-threadedprograms. How hard would it be to aviod the ‘chdir’ and‘with-directory-excursion’ uses?
Toggle quote (3 lines)> +(define (host-potluck host local-port working-dir source-checkout> + target-checkout)
Please add a docstring.
Toggle quote (17 lines)> + (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. :-) Perhapswe could spawn a service thread as in tests/publish.scm, and mock theGit procedures?
Thank you!
Ludo’.
L
L
Ludovic Courtès wrote on 4 May 2017 22:56
Re: bug#26645: [PATCH 9/9] doc: Document guix potluck.
(name . Andy Wingo)(address . wingo@igalia.com)(address . 26645@debbugs.gnu.org)
87tw508hno.fsf@gnu.org
Andy Wingo <wingo@igalia.com> skribis:
Toggle quote (3 lines)> * doc/guix.texi (potluck-package Reference):> (Invoking guix potluck): New sections.
Perfect, awesome!!
Thank you,Ludo’.
J
J
Jack Hill wrote on 18 Mar 21:03 +0100
Potluck still relivant
(address . 26645@debbugs.gnu.org)
alpine.DEB.2.20.2003181602190.19733@marsh.hcoop.net
Hi Guix,
I was looking through some old issue, and wondering if potluck is still relevant now that we have channels.
Shall we close this issue?
Best,Jack
B
B
Brice Waegeneire wrote on 1 Apr 18:11 +0200
(name . Jack Hill)(address . jackhill@jackhill.us)
361978f8437c699e48688757a246c64a@waegenei.re
Hello Jack,
On 2020-03-18 20:03, Jack Hill wrote:
Toggle quote (5 lines)> Hi Guix,> > I was looking through some old issue, and wondering if potluck is> still relevant now that we have channels.
Reading through the initial email[0] by Andy the potlock feature seemsto be way more extensive than channels: it allows one to create simplepackages in an interactive manner and centralize the discoverability ofsuch packages. Channels provide us a way to create package outise ofGuix proper but finding channels containing the package you are lookingfor is still an unsolved problem.
He even write the following:
Toggle quote (8 lines)> So, remaining tasks to do:> [...]> (3) Someone needs to design and implement a "guix channel" facility to> take advantage of this branch :) Until then, GUIX_PACKAGE_PATH> and the -L argument are the things to use.
> Shall we close this issue?
Having an answer form Andy or Ludovic on this front you be great.
[0]: https://lists.gnu.org/archive/html/guix-devel/2017-04/msg00250.html
- Brice
R
R
Ricardo Wurmus wrote on 29 Apr 08:02 +0200
(address . 26645@debbugs.gnu.org)
87k11ykewf.fsf@elephly.net
Hi Brice,
Toggle quote (7 lines)> Reading through the initial email[0] by Andy the potlock feature seems> to be way more extensive than channels: it allows one to create simple> packages in an interactive manner and centralize the discoverability of> such packages. Channels provide us a way to create package outise of> Guix proper but finding channels containing the package you are looking> for is still an unsolved problem.
One of the objectives was to provide a simpler and more robust way todefine packages that would not break when package variables in Guixproper are moved around:
Toggle quote (8 lines)> +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.
We have the same facilities in JSON package definitions such as this one:
Toggle snippet (33 lines)[ { "name": "myhello", "version": "2.10", "source": "mirror://gnu/hello/hello-2.10.tar.gz", "build-system": "gnu", "arguments": { "tests?": false } "home-page": "https://www.gnu.org/software/hello/", "synopsis": "Hello, GNU world: An example GNU package", "description": "GNU Hello prints a greeting.", "license": "GPL-3.0+", "native-inputs": ["gettext"] }, { "name": "greeter", "version": "1.0", "source": "https://example.com/greeter-1.0.tar.gz", "build-system": "gnu", "arguments": { "test-target": "foo", "parallel-build?": false, }, "home-page": "https://example.com/", "synopsis": "Greeter using GNU Hello", "description": "This is a wrapper around GNU Hello.", "license": "GPL-3.0+", "inputs": ["myhello", "hello"] }]
Since this can be fed to “guix build -f” directly, there doesn’t seem tobe a need for “guix potluck init” any more.
While I think it would be very convenient to be able to publish packagedefinitions with “guix potluck update <url> <branch>”, it would requiremaintenance of the host-channel service that accepts possibly hostileuser input. To prevent denial of service it should probably requireauthentication and enforce quotas.
Since users can also push packages for non-free software we cannot hostthis on Guix project infrastructure. (I guess this was why the proposeddomain was guix-potluck.org.)
--Ricardo
?