guix potluck

+++ b/Makefile.am

+  guix/scripts/potluck.scm			\

+++ b/guix/scripts/potluck.scm

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

+++ b/doc/guix.texi

+* guix potluck: (guix)Invoking guix potluck.  Publishing package definitions.

+* potluck-package Reference::   The potluck-package data type.

+* Invoking guix potluck::       Simple, decoupled package development.

+* potluck-package Reference::   The potluck-package data type.

+@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.

+

+* Invoking guix potluck::       Decoupled package definition.

+@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.

+

+

+++ b/Makefile.am

+  guix/git.scm					\

+++ b/guix/git.scm

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

+++ b/doc/guix.texi

+

+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

+

+++ b/guix/scripts/hash.scm

+  #:use-module (guix utils)

+  #:export (guix-hash-git-checkout

+            guix-hash))

+  -g, --git              clone the git repository at FILE and hash it

+                         (implies -r)"))

+  (format #t (_ "

+        (option '(#\g "git") #f #f

+                (lambda (opt name arg result)

+                  (alist-cons 'git? #t

+                              (alist-cons 'exclude-vcs? #t result))))

+;;; 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?))))))

+

+

+;;;

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

+++ b/Makefile.am

+  guix/potluck/build-systems.scm		\

+  guix/potluck/licenses.scm			\

+  guix/potluck/packages.scm			\

+++ b/guix/potluck/build-systems.scm

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

+++ b/guix/potluck/licenses.scm

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

+++ b/guix/potluck/packages.scm

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

+++ b/guix/scripts/build.scm

+  #:use-module (guix potluck packages)

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

+

+    (unless (or (package? x) (potluck-package? x)

+                (derivation? x) (gexp? x) (procedure? x))

+                 (ensure-list (load-package-or-derivation-from-file file)))

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

+

+                   (package->derivation-list p))

+                  ((? potluck-package? p)

+                   (package->derivation-list (lower-potluck-package p)))

+++ b/guix/potluck/packages.scm

+  #:use-module ((guix ui) #:select (package-specification->name+version+output))

+  #:use-module ((srfi srfi-1) #:select (concatenate delete-duplicates))

+            lower-potluck-package

+

+            lower-potluck-package-to-module))

+

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

+++ b/Makefile.am

+  guix/potluck/host.scm				\

+++ b/guix/potluck/host.scm

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

+++ b/guix/scripts/potluck.scm

+  #:use-module (guix potluck host)

+(define* (init-potluck host remote-git-url #:key

+         (potluck-dir (in-vicinity cwd "guix-potluck"))

+      (format #t (_ "Creating guix-potluck/~%"))

+      (format #t (_ "Creating guix-potluck/README.md~%"))

+define one package.  See https://guix-potluck.org/ for more information.

+      (format #t (_ "Creating guix-potluck/~a.scm~%") package-name)

+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

+  guix build --file=guix-potluck/~a.scm

+

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

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

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

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

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

+

+            (init-potluck (parse-host (assoc-ref opts 'host))

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

+++ b/Makefile.am

+  guix/potluck/environment.scm			\

+++ b/guix/potluck/environment.scm

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