* bug#26645: guix potluck
@ 2017-04-24 20:53 Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
` (2 more replies)
0 siblings, 3 replies; 24+ messages in thread
From: Andy Wingo @ 2017-04-24 20:53 UTC (permalink / raw)
To: 26645
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
^ permalink raw reply [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
2017-04-24 20:53 bug#26645: guix potluck Andy Wingo
@ 2017-04-24 20:59 ` Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout Andy Wingo
` (8 more replies)
2017-04-24 21:09 ` bug#26645: guix potluck ng0
2020-03-18 20:03 ` [bug#26645] Potluck still relivant Jack Hill
2 siblings, 9 replies; 24+ messages in thread
From: Andy Wingo @ 2017-04-24 20:59 UTC (permalink / raw)
To: 26645
* 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.
---
Makefile.am | 3 +
guix/potluck/build-systems.scm | 55 ++++++
guix/potluck/licenses.scm | 41 +++++
guix/potluck/packages.scm | 399 +++++++++++++++++++++++++++++++++++++++++
guix/scripts/build.scm | 54 +++---
5 files changed, 532 insertions(+), 20 deletions(-)
create mode 100644 guix/potluck/build-systems.scm
create mode 100644 guix/potluck/licenses.scm
create mode 100644 guix/potluck/packages.scm
diff --git a/Makefile.am b/Makefile.am
index db4ebe04d..22ba00e90 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,9 @@ MODULES = \
guix/build/make-bootstrap.scm \
guix/search-paths.scm \
guix/packages.scm \
+ guix/potluck/build-systems.scm \
+ guix/potluck/licenses.scm \
+ guix/potluck/packages.scm \
guix/import/utils.scm \
guix/import/gnu.scm \
guix/import/snix.scm \
diff --git a/guix/potluck/build-systems.scm b/guix/potluck/build-systems.scm
new file mode 100644
index 000000000..1f6aa1fe3
--- /dev/null
+++ b/guix/potluck/build-systems.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 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.scm
new file mode 100644
index 000000000..6efeee21a
--- /dev/null
+++ b/guix/potluck/licenses.scm
@@ -0,0 +1,41 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 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.scm
new file mode 100644
index 000000000..c7dae3791
--- /dev/null
+++ b/guix/potluck/packages.scm
@@ -0,0 +1,399 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 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.scm
index 6bb1f72eb..be26f63c9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix packages)
+ #:use-module (guix potluck packages)
#:use-module (guix grafts)
;; 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
^ permalink raw reply related [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout.
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
@ 2017-04-24 20:59 ` Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 3/9] guix: Add git utility module Andy Wingo
` (7 subsequent siblings)
8 siblings, 0 replies; 24+ messages in thread
From: Andy Wingo @ 2017-04-24 20:59 UTC (permalink / raw)
To: 26645
* guix/scripts/hash.scm (show-help, %options): Add -g option.
(vcs-file?): Pull out to top.
(guix-hash-git-checkout): New function.
(guix-hash): Support hashing of Git URLs.
* doc/guix.texi (Invoking guix hash): Document guix hash --git.
---
doc/guix.texi | 17 +++++++++++++
guix/scripts/hash.scm | 67 ++++++++++++++++++++++++++++++++++++---------------
2 files changed, 65 insertions(+), 19 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 0d334e302..7f1074f9d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5384,6 +5384,23 @@ $ git clone http://example.org/foo.git
$ cd foo
$ guix hash -rx .
@end example
+
+Hashing a git checkout is so common that it has its own alias:
+
+@item --git
+@itemx -g
+Clones the git repository at @var{file} into a temporary directory and
+recursively hashes it, excluding the @file{.git} subdirectory. This is
+mainly useful if you want to get the Guix hash of the current Git
+checkout:
+
+@example
+$ git clone http://example.org/foo.git
+$ cd foo
+# Hack a bunch of things, make some commits
+$ guix hash -g .
+@end example
+
@end table
@node Invoking guix import
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index a048b5346..f1ac3c38a 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -25,6 +25,7 @@
#:use-module (guix ui)
#:use-module (guix scripts)
#:use-module (guix base16)
+ #:use-module (guix utils)
#:use-module (ice-9 binary-ports)
#:use-module (rnrs files)
#:use-module (ice-9 match)
@@ -32,7 +33,8 @@
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
- #:export (guix-hash))
+ #:export (guix-hash-git-checkout
+ guix-hash))
\f
;;;
@@ -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"))
\f
;;;
+;;; 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?))))))
+
+\f
+;;;
;;; 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
^ permalink raw reply related [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 3/9] guix: Add git utility module.
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout Andy Wingo
@ 2017-04-24 20:59 ` Andy Wingo
2017-05-03 20:23 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 4/9] guix: Add "potluck" command Andy Wingo
` (6 subsequent siblings)
8 siblings, 1 reply; 24+ messages in thread
From: Andy Wingo @ 2017-04-24 20:59 UTC (permalink / raw)
To: 26645
* guix/git.scm: New file.
* Makefile.am (MODULES): Add new file.
---
Makefile.am | 1 +
guix/git.scm | 164 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 165 insertions(+)
create mode 100644 guix/git.scm
diff --git a/Makefile.am b/Makefile.am
index 22ba00e90..64a7a9265 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -126,6 +126,7 @@ MODULES = \
guix/build/make-bootstrap.scm \
guix/search-paths.scm \
guix/packages.scm \
+ guix/git.scm \
guix/potluck/build-systems.scm \
guix/potluck/licenses.scm \
guix/potluck/packages.scm \
diff --git a/guix/git.scm b/guix/git.scm
new file mode 100644
index 000000000..02f61edac
--- /dev/null
+++ b/guix/git.scm
@@ -0,0 +1,164 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 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
^ permalink raw reply related [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 4/9] guix: Add "potluck" command.
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 3/9] guix: Add git utility module Andy Wingo
@ 2017-04-24 20:59 ` Andy Wingo
2017-05-04 20:23 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox Andy Wingo
` (5 subsequent siblings)
8 siblings, 1 reply; 24+ messages in thread
From: Andy Wingo @ 2017-04-24 20:59 UTC (permalink / raw)
To: 26645
* guix/scripts/potluck.scm: New file.
* Makefile.am: Add new file.
---
Makefile.am | 1 +
guix/scripts/potluck.scm | 310 +++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 311 insertions(+)
create mode 100644 guix/scripts/potluck.scm
diff --git a/Makefile.am b/Makefile.am
index 64a7a9265..295d7b3a6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -167,6 +167,7 @@ MODULES = \
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.scm
new file mode 100644
index 000000000..f9cd40bd0
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 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))
+
+\f
+;;;
+;;; 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))))
+
+\f
+;;;
+;;; 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))
+
+\f
+;;;
+;;; 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
^ permalink raw reply related [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox.
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
` (2 preceding siblings ...)
2017-04-24 20:59 ` bug#26645: [PATCH 4/9] guix: Add "potluck" command Andy Wingo
@ 2017-04-24 20:59 ` Andy Wingo
2017-05-04 20:27 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 6/9] gnu: Add find-package-binding Andy Wingo
` (4 subsequent siblings)
8 siblings, 1 reply; 24+ messages in thread
From: Andy Wingo @ 2017-04-24 20:59 UTC (permalink / raw)
To: 26645
* guix/potluck/environment.scm: New file.
* Makefile.am (MODULES): Add new files.
* guix/potluck/packages.scm (make-potluck-sandbox-module)
(eval-in-sandbox): New helpers.
(load-potluck-package): New public function.
---
Makefile.am | 1 +
guix/potluck/environment.scm | 538 +++++++++++++++++++++++++++++++++++++++++++
guix/potluck/packages.scm | 59 +++++
3 files changed, 598 insertions(+)
create mode 100644 guix/potluck/environment.scm
diff --git a/Makefile.am b/Makefile.am
index 295d7b3a6..628283b57 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -128,6 +128,7 @@ MODULES = \
guix/packages.scm \
guix/git.scm \
guix/potluck/build-systems.scm \
+ guix/potluck/environment.scm \
guix/potluck/licenses.scm \
guix/potluck/packages.scm \
guix/import/utils.scm \
diff --git a/guix/potluck/environment.scm b/guix/potluck/environment.scm
new file mode 100644
index 000000000..f28ca11d5
--- /dev/null
+++ b/guix/potluck/environment.scm
@@ -0,0 +1,538 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 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.scm
index c7dae3791..3bf2d67c1 100644
--- a/guix/potluck/packages.scm
+++ b/guix/potluck/packages.scm
@@ -62,6 +62,8 @@
pretty-print-potluck-source
pretty-print-potluck-package
+ 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
^ permalink raw reply related [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 6/9] gnu: Add find-package-binding.
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
` (3 preceding siblings ...)
2017-04-24 20:59 ` bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox Andy Wingo
@ 2017-04-24 20:59 ` Andy Wingo
2017-05-04 20:29 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package Andy Wingo
` (3 subsequent siblings)
8 siblings, 1 reply; 24+ messages in thread
From: Andy Wingo @ 2017-04-24 20:59 UTC (permalink / raw)
To: 26645
* gnu/packages.scm (find-package-binding): New export.
---
gnu/packages.scm | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 61 insertions(+), 1 deletion(-)
diff --git a/gnu/packages.scm b/gnu/packages.scm
index 92bab7228..5e85d3dd6 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -55,7 +55,9 @@
find-newest-available-packages
specification->package
- specification->package+output))
+ specification->package+output
+
+ find-package-binding))
;;; Commentary:
;;;
@@ -368,3 +370,61 @@ version; if SPEC does not specify an output, return OUTPUT."
(leave (_ "package `~a' lacks output `~a'~%")
(package-full-name package)
sub-drv))))))
+
+(define (find-package-binding package)
+ "Find the module that exports PACKAGE. Return two values, an interface name
+and a symbol that can be used to import PACKAGE. Signal an error if no public variable binds PACKAGE."
+ (define (strip-extension file exts)
+ (or (or-map (lambda (ext)
+ (and (string-suffix? ext file)
+ (substring file 0 (- (string-length file)
+ (string-length ext)))))
+ exts)
+ file))
+ (define (file-name->module-name file)
+ (and (not (absolute-file-name? file))
+ (map string->symbol
+ (string-split (strip-extension file %load-extensions)
+ #\/))))
+ ;; Instead of building a table and always doing a search, first just see if
+ ;; we can use the package's location to find its module and look in that
+ ;; module.
+ (define (global-search)
+ (let search ((modules (all-package-modules)))
+ (match modules
+ (()
+ (raise (condition
+ (&message (message
+ (format #f (_ "~a@~a: binding not found")
+ (package-name package)
+ (package-version package)))))))
+ ((mod . modules)
+ (let ((next (lambda () (search modules))))
+ (local-search (module-name mod) mod next))))))
+ (define (local-search module-name iface k)
+ (let lp ((bindings (module-map cons iface)))
+ (match bindings
+ (() (k))
+ (((sym . var) . bindings)
+ (if (eq? (variable-ref var) package)
+ (values module-name sym)
+ (lp bindings))))))
+ (cond
+ ((package-location package)
+ => (lambda (loc)
+ (cond
+ ((file-name->module-name (location-file loc))
+ => (lambda (module-name)
+ (cond
+ ((false-if-exception (resolve-interface module-name))
+ => (lambda (iface)
+ (let ((def (string->symbol (package-name package))))
+ (cond
+ ((and (module-variable iface def)
+ (eq? (module-ref iface def) package))
+ (values module-name def))
+ (else
+ (local-search module-name iface global-search))))))
+ (else (global-search)))))
+ (else (global-search)))))
+ (else (global-search))))
--
2.12.2
^ permalink raw reply related [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
` (4 preceding siblings ...)
2017-04-24 20:59 ` bug#26645: [PATCH 6/9] gnu: Add find-package-binding Andy Wingo
@ 2017-04-24 20:59 ` Andy Wingo
2017-05-04 20:31 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand Andy Wingo
` (2 subsequent siblings)
8 siblings, 1 reply; 24+ messages in thread
From: Andy Wingo @ 2017-04-24 20:59 UTC (permalink / raw)
To: 26645
* guix/potluck/packages.scm (lower-potluck-package-to-module): New public
function.
---
guix/potluck/packages.scm | 118 +++++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 117 insertions(+), 1 deletion(-)
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
index 3bf2d67c1..3c7a1ca49 100644
--- a/guix/potluck/packages.scm
+++ b/guix/potluck/packages.scm
@@ -29,8 +29,10 @@
#:use-module (guix potluck licenses)
#:use-module (guix records)
#:use-module (guix utils)
+ #:use-module ((guix ui) #:select (package-specification->name+version+output))
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
+ #:use-module ((srfi srfi-1) #:select (concatenate delete-duplicates))
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
@@ -67,7 +69,9 @@
validate-potluck-package
lower-potluck-source
- lower-potluck-package))
+ lower-potluck-package
+
+ lower-potluck-package-to-module))
;;; Commentary:
;;;
@@ -456,3 +460,115 @@ potluck package will be validated with @code{validate-potluck-package}."
(synopsis synopsis)
(description description)
(license (license-by-name license)))))
+
+(define (lower-potluck-package-to-module port lowered-module-name pkg)
+ (let ((lowered (lower-potluck-package pkg))
+ ;; specification -> exp
+ (spec->binding (make-hash-table))
+ ;; mod-name -> (sym ...)
+ (imports (make-hash-table))
+ ;; sym -> specification
+ (imported-syms (make-hash-table))
+ (needs-runtime-lookup? #f))
+ (define (add-bindings spec)
+ (unless (hash-ref spec->binding spec)
+ (match (false-if-exception (lower-input spec))
+ ((name pkg . outputs)
+ ;; Given that we found the pkg, surely we should find its binding
+ ;; also.
+ (call-with-values (lambda () (find-package-binding pkg))
+ (lambda (module-name sym)
+ ;; Currently we import these bindings using their original
+ ;; names. We need to make sure that names don't collide.
+ ;; Ideally we should also ensure that they don't collide with
+ ;; other bindings that we import.
+ (when (hashq-ref imported-syms sym)
+ (error "duplicate import name" sym))
+ (hashq-set! imported-syms sym spec)
+ (hash-set! spec->binding spec
+ `(list ,name ,sym . ,outputs))
+ (hash-set! imports module-name
+ (cons sym (hash-ref imports module-name '()))))))
+ (#f
+ (warn "could not resolve package specification" spec)
+ (call-with-values
+ (lambda ()
+ (package-specification->name+version+output spec))
+ (lambda (name version . outputs)
+ (hash-set! spec->binding spec
+ `(list ,name (specification->package ,spec) .
+ ,(if (equal? outputs '("out")) '() outputs)))
+ (set! needs-runtime-lookup? #t)))))))
+
+ (for-each add-bindings (potluck-package-inputs pkg))
+ (for-each add-bindings (potluck-package-native-inputs pkg))
+ (for-each add-bindings (potluck-package-propagated-inputs pkg))
+
+ (format port "(define-module ~a" lowered-module-name)
+ (format port "~% #:pure")
+ ;; Because we're pure, we have to import these.
+ (format port "~% #:use-module ((guile) #:select (list quote define-public))")
+ (when needs-runtime-lookup?
+ (format port "~% #:use-module ((gnu packages) #:select (specification->package))"))
+ (format port "~% #:use-module ((guix packages) #:select (package origin base32))")
+ (format port "~% #:use-module ((guix git-download) #:select (git-fetch git-reference))")
+ (format port "~% #:use-module ((guix licenses) #:select ((~a . license:~a)))"
+ (potluck-package-license pkg) (potluck-package-license pkg))
+ (format port "~% #:use-module ((guix build-system ~a) #:select (~a-build-system))"
+ (potluck-package-build-system pkg) (potluck-package-build-system pkg))
+ (for-each (match-lambda
+ ((module-name . syms)
+ (format port "~% #:use-module (~a #:select ~a)"
+ module-name syms)))
+ (hash-map->list cons imports))
+ (format port ")~%~%")
+
+ (format port "(define-public ~s\n" (string->symbol
+ (potluck-package-name pkg)))
+ (format port " (package\n")
+ (format port " (name ~s)\n" (potluck-package-name pkg))
+ (format port " (version ~s)\n" (potluck-package-version pkg))
+ (format port " (source\n")
+
+ (let ((source (potluck-package-source pkg)))
+ (format port " (origin\n")
+ (format port " (method git-fetch)\n")
+ (format port " (uri (git-reference\n")
+ (format port " (url ~s)\n" (potluck-source-git-uri source))
+ (format port " (commit ~s)))\n"
+ (potluck-source-git-commit source))
+ (when (potluck-source-snippet source)
+ (pretty-print `(snippet ',(potluck-source-snippet source)) port
+ #:per-line-prefix " "))
+ (format port " (sha256 (base32 ~s))))\n"
+ (potluck-source-sha256 source)))
+
+ (format port " (build-system ~s-build-system)\n"
+ (potluck-package-build-system pkg))
+
+ (for-each
+ (match-lambda
+ ((name)
+ ;; No inputs; do nothing.
+ #t)
+ ((name . specs)
+ (pretty-print
+ `(,name (list ,@(map (lambda (spec)
+ (or (hash-ref spec->binding spec)
+ (error "internal error" spec)))
+ specs)))
+ port #:per-line-prefix " ")))
+ `((inputs . ,(potluck-package-inputs pkg))
+ (native-inputs . ,(potluck-package-native-inputs pkg))
+ (propagated-inputs . ,(potluck-package-propagated-inputs pkg))))
+
+ (match (potluck-package-arguments pkg)
+ (() #t)
+ (arguments
+ (pretty-print `(arguments ',arguments) port #:per-line-prefix " ")))
+
+ (format port " (home-page ~s)\n" (potluck-package-home-page pkg))
+ (format port " (synopsis ~s)\n" (potluck-package-synopsis pkg))
+ (format port " (description ~s)\n" (potluck-package-description pkg))
+ (format port " (license license:~s)))\n" (potluck-package-license pkg))
+ (force-output port)))
--
2.12.2
^ permalink raw reply related [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand.
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
` (5 preceding siblings ...)
2017-04-24 20:59 ` bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package Andy Wingo
@ 2017-04-24 20:59 ` Andy Wingo
2017-05-04 20:55 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 9/9] doc: Document guix potluck Andy Wingo
2017-05-03 20:19 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Ludovic Courtès
8 siblings, 1 reply; 24+ messages in thread
From: Andy Wingo @ 2017-04-24 20:59 UTC (permalink / raw)
To: 26645
* guix/potluck/host.scm: New file.
* Makefile.am (MODULES): Add new file.
* guix/scripts/potluck.scm: Add host-channel command.
---
Makefile.am | 1 +
guix/potluck/host.scm | 304 +++++++++++++++++++++++++++++++++++++++++++++++
guix/scripts/potluck.scm | 137 +++++++++++++++++++--
3 files changed, 430 insertions(+), 12 deletions(-)
create mode 100644 guix/potluck/host.scm
diff --git a/Makefile.am b/Makefile.am
index 628283b57..94fa05d5b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -129,6 +129,7 @@ MODULES = \
guix/git.scm \
guix/potluck/build-systems.scm \
guix/potluck/environment.scm \
+ guix/potluck/host.scm \
guix/potluck/licenses.scm \
guix/potluck/packages.scm \
guix/import/utils.scm \
diff --git a/guix/potluck/host.scm b/guix/potluck/host.scm
new file mode 100644
index 000000000..5ac8e0f5f
--- /dev/null
+++ b/guix/potluck/host.scm
@@ -0,0 +1,304 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 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))
+
+\f
+;;;
+;;; 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)))))))
+
+\f
+;;;
+;;; 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)))))
+
+\f
+;;;
+;;; frontend
+;;;
+
+(define* (validate-public-uri str #:key (schemes '(http https)))
+ (define (public-host? host)
+ ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+ ;; addresses; this is just a sanity check.
+ (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+ (let ((uri (and (string? str) (string->uri str))))
+ (unless (and uri
+ (memq (uri-scheme uri) schemes)
+ (not (uri-fragment uri))
+ (public-host? (uri-host uri)))
+ (error "expected a public URI" str))))
+
+(define (validate-branch-name str)
+ (unless (git-check-ref-format str #:allow-onelevel? #t)
+ (error "expected a valid git branch name" str)))
+
+(define (enqueue-update params queue)
+ (let ((remote-git-url (hash-ref params "git-url"))
+ (branch-name (hash-ref params "branch")))
+ (validate-public-uri remote-git-url)
+ (validate-branch-name branch-name)
+ (async-queue-push! queue (cons remote-git-url branch-name))))
+
+(define (request-body-json request body)
+ (cond
+ ((string? body) (json-string->scm body))
+ ((bytevector? body)
+ (let* ((content-type (request-content-type request))
+ (charset (or (assoc-ref (cdr content-type) "charset")
+ "utf-8")))
+ (json-string->scm (bytevector->string body charset))))
+ ((port? body) (json->scm body))
+ (else (error "unexpected body" body))))
+
+(define (handler request body queue)
+ (match (cons (request-method request)
+ (split-and-decode-uri-path (uri-path (request-uri request))))
+ (('GET)
+ (values (build-response #:code 200)
+ "todo: show work queue"))
+ (('POST "api" "enqueue-update")
+ ;; An exception will cause error 500.
+ (enqueue-update (request-body-json request body) queue)
+ (values (build-response #:code 200)
+ ""))
+ (_
+ (values (build-response #:code 404)
+ ""))))
+
+(define (host-potluck host local-port working-dir source-checkout
+ target-checkout)
+ (let ((worker-thread #f)
+ (queue (make-async-queue)))
+ (dynamic-wind (lambda ()
+ (set! worker-thread
+ (make-thread
+ (service-queue host working-dir
+ source-checkout target-checkout
+ queue))))
+ (lambda ()
+ (run-server
+ (lambda (request body)
+ (handler request body queue))
+ ;; Always listen on localhost.
+ 'http `(#:port ,local-port)))
+ (lambda ()
+ (cancel-thread worker-thread)))))
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
index f9cd40bd0..ec306cae6 100644
--- a/guix/scripts/potluck.scm
+++ b/guix/scripts/potluck.scm
@@ -25,6 +25,7 @@
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix potluck build-systems)
+ #:use-module (guix potluck host)
#:use-module (guix potluck licenses)
#:use-module (guix potluck packages)
#:use-module (guix scripts)
@@ -47,12 +48,12 @@
;;; guix potluck init
;;;
-(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)))))
\f
;;;
@@ -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
^ permalink raw reply related [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 9/9] doc: Document guix potluck.
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
` (6 preceding siblings ...)
2017-04-24 20:59 ` bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand Andy Wingo
@ 2017-04-24 20:59 ` Andy Wingo
2017-05-04 20:56 ` Ludovic Courtès
2017-05-03 20:19 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Ludovic Courtès
8 siblings, 1 reply; 24+ messages in thread
From: Andy Wingo @ 2017-04-24 20:59 UTC (permalink / raw)
To: 26645
* doc/guix.texi (potluck-package Reference):
(Invoking guix potluck): New sections.
---
doc/guix.texi | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 231 insertions(+)
diff --git a/doc/guix.texi b/doc/guix.texi
index 7f1074f9d..f2aa52653 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -58,6 +58,7 @@ Documentation License''.
* guix environment: (guix)Invoking guix environment. Building development environments with Guix.
* guix build: (guix)Invoking guix build. Building packages.
* guix pack: (guix)Invoking guix pack. Creating binary bundles.
+* guix potluck: (guix)Invoking guix potluck. Publishing package definitions.
@end direntry
@titlepage
@@ -137,6 +138,7 @@ Defining Packages
* package Reference:: The package data type.
* origin Reference:: The origin data type.
+* potluck-package Reference:: The potluck-package data type.
Utilities
@@ -154,6 +156,7 @@ Utilities
* Invoking guix challenge:: Challenging substitute servers.
* Invoking guix copy:: Copying to and from a remote store.
* Invoking guix container:: Process isolation.
+* Invoking guix potluck:: Simple, decoupled package development.
Invoking @command{guix build}
@@ -2976,6 +2979,7 @@ when @var{cut?} returns true for a given package.
@menu
* package Reference :: The package data type.
* origin Reference:: The origin data type.
+* potluck-package Reference:: The potluck-package data type.
@end menu
@@ -3192,6 +3196,115 @@ this is @code{#f}, a sensible default is used.
@end table
@end deftp
+@node potluck-package Reference
+@subsection @code{potluck-package} Reference
+
+This section defines all the options available in @code{potluck-package}
+declarations. @xref{Invoking guix potluck}, for more background and for
+information on how to work with potluck packages from the command-line
+interface.
+
+@deftp {Data Type} potluck-package
+This is the data type representing a potluck package recipe.
+
+@table @asis
+@item @code{name}
+The name of the package, as a string.
+
+@item @code{version}
+The version of the package, as a string.
+
+@item @code{source}
+An object telling how the source code for the package should be
+acquired. This is a @code{potluck-source} object, which itself is its
+own data type:
+
+@deftp {Data Type} potluck-source
+This is the data type representing a potluck package's source code.
+
+@table @asis
+@item @code{git-uri}
+An object containing the URI of the source git repository. Currently
+potluck packages all come from Git. Use the ``normal'' Guix packages if
+you need to build from some other source.
+
+@item @code{git-commit}
+The given git commit for the source, for example as a sha1 string.
+
+@item @code{sha256}
+A bytevector containing the SHA-256 hash of the source, as a base32
+string. Note that the explicit @code{base32} wrapper that is needed for
+normal Guix packages is not present in a potluck package source.
+
+You can obtain this information using @code{guix hash -g}
+(@pxref{Invoking guix hash}).
+
+@item @code{snippet} (default: @code{#f})
+An S-expression that will be run in the source directory. This is a
+convenient way to modify the source, sometimes more convenient than a
+patch.
+@end table
+@end deftp
+
+@item @code{build-system}
+The build system that should be used to build the package, as a symbol.
+For example, @code{gnu}. To list available build systems, use
+@code{guix potluck init --build-system=help} (@pxref{Invoking guix
+potluck}).
+
+@item @code{arguments} (default: @code{'()})
+The arguments that should be passed to the build system. This is a
+list, typically containing sequential keyword-value pairs, and is the
+same as for the @code{arguments} argument of a normal @code{package}
+object.
+
+@item @code{inputs} (default: @code{'()})
+@itemx @code{native-inputs} (default: @code{'()})
+@itemx @code{propagated-inputs} (default: @code{'()})
+@cindex inputs, of packages
+These fields list dependencies of the package. Each item of an input
+list is a package specification string, for example @code{guile} or
+@code{guile@@2.0} or, in the most specific form, @code{guile@@2.0:out}.
+@xref{Packages with Multiple Outputs}, for more on package outputs. For
+example, the list below specifies three inputs:
+
+@example
+'("libffi" "libunistring" "glib:bin")
+@end example
+
+@cindex cross compilation, package dependencies
+The distinction between @code{native-inputs} and @code{inputs} is
+necessary when considering cross-compilation.
+
+@xref{package Reference}, for full details on the differences between
+these input types.
+
+@item @code{synopsis}
+A one-line description of the package.
+
+@item @code{description}
+A more elaborate description of the package.
+
+@item @code{license}
+The license of the package, as a symbol. For example, @code{gpl3+}. To
+list available build systems, use @code{guix potluck init
+--license=help} (@pxref{Invoking guix potluck}).
+
+@item @code{home-page}
+The URL to the home-page of the package, as a string.
+
+@item @code{location} (default: source location of the @code{package} form)
+The source location of the package. It is useful to override this when
+inheriting from another package, in which case this field is not
+automatically corrected.
+@end table
+@end deftp
+
+As you can see, a potluck package is less elaborate than a normal Guix
+package. If you find yourself needing more advanced features, probably
+your package should be a part of Guix proper. But if not, a potluck
+package can often do the job.
+
@node Build Systems
@section Build Systems
@@ -4779,6 +4892,7 @@ the Scheme programming interface of Guix in a convenient way.
* Invoking guix challenge:: Challenging substitute servers.
* Invoking guix copy:: Copying to and from a remote store.
* Invoking guix container:: Process isolation.
+* Invoking guix potluck:: Decoupled package definition.
@end menu
@node Invoking guix build
@@ -6997,6 +7111,123 @@ must be PID 1 of the container or one of its child processes.
@end table
+@node Invoking guix potluck
+@section Invoking @command{guix potluck}
+@cindex potluck
+@cindex @command{guix potluck}
+@quotation Note
+As of version @value{VERSION}, this tool is experimental. The interface
+is subject to radical change in the future.
+@end quotation
+
+Guix is developed as a unified project composed of both the package
+manager and the set of packages. This allows Guix to evolve while
+remaining healthy and coherent. If there is a change that needs to be
+done across Guix's entire tree, Guix developers can make it happen. One
+way in which this principle manifests itself is in the @code{package}
+data type, where input packages are directly specified by value in the
+@code{inputs}, @code{native-inputs}, and @code{propagated-inputs}
+fields, instead of being specified as some abstract package name and
+version constraint that Guix would have to solve for. @xref{package
+Reference}, for more on the @code{package} data type.
+
+However it is sometimes desirable to develop a package or set of
+packages in a more decoupled way, for example when a package set is
+still incubating or when a package is inappropriate for sending upstream
+for some reason. Such packages use Guix and extend Guix but are not a
+part of the Guix project, properly speaking. As such, they need to be
+resilient to changes in upstream Guix. It would be brittle if such a
+package definition had to reference a Guix package by value; the Scheme
+variable denoting the upstream Guix package might move to a different
+module, or be renamed, or changed in some unexpected way.
+
+Guix's @dfn{potluck} facility fills this gap. A @dfn{potluck package}
+is like a normal Guix package, except it expresses its inputs in the
+form of package specifications instead of direct references.
+@xref{potluck-package Reference}. Potluck packages also have a simpler
+package structure with fewer fields; compared to normal Guix packages,
+they are less expressive but more isolated from details of upstream
+Guix.
+
+The user interface to potluck packages is concentrated in the
+@command{guix potluck} command. To begin, let's say you are a developer
+of the @code{foo} project, and you'd like to package @code{foo} for use
+in your Guix system and maybe also that of a friend. You're not sure if
+you want to support it yet so you don't want to make a proper release,
+but there should be something in the middle between that and not
+packaging it at all. You decide to give @code{guix potluck} a go.
+
+So in that git checkout, you run @code{guix potluck init @var{url}},
+where @var{url} is a publicly accessible git URL at which @code{foo} is
+hosted. @code{guix potluck init} takes the following options:
+
+@table @code
+@item --build-system=@var{sys}
+@itemx --build-system=help
+@itemx --autotools
+Indicate that the package uses the build system named @var{sys}. Pass
+@code{help} as the build system to see available options.
+@code{--autotools} is like the common @code{--build-system=gnu}, but
+additionally indicating that an @code{autoreconf} step is needed before
+building.
+@item --license=@var{license}
+@itemx --license=help
+Specify the license of the project.
+@end table
+
+Calling @code{guix potluck init} will result in the creation of a
+@code{guix-potluck} directory in your git checkout, containing a brief
+overview @code{README.md} file as well as a @code{foo.scm} potluck
+package definition. @xref{potluck-package Reference}. Just fill in the
+synopsis and description and add the inputs and you have the beginnings
+of a potluck package.
+
+You can try building your new package by running @code{guix build -f
+guix-potluck/foo.scm}. Once that works, you can share the file with
+your friends and they can build your package too.
+
+Of course, it would be nice if you could share that package with the
+world. And it would be nice if your potluck package definitions could
+augment the set of available packages and versions. And it would be
+nice if your potluck package could serve as a first draft of a proper
+Guix package definition. We agree completely!
+
+Guix's potluck facility also implements a kind of registry of potluck
+recipes, as if it were hosting an actual potluck. This
+@code{host-channel} facility takes requests to add potluck packages and
+translates that into a git repository of all potluck packages, as well
+as a git repository of Guix packages compiled from those potluck
+packages.
+
+To inform a channel host of the presence of fresh tasty potluck dishes,
+run @code{guix potluck update @var{url} @var{branch}}. @var{url} should
+be the URL of a git repository containing a @code{guix-potluck}
+directory, and @var{branch} is a ref in that repository. By default,
+the request is made to add the package to the default
+@code{guix-potluck.org} host; pass @code{--host=@var{host}} to specify
+an alternate registry.
+
+Running @code{guix potluck update} will simply enqueue an update request
+on the server. Visit @code{https://@var{host}/} in your browser to see
+the state of the work queue, and to see whether your package update
+actually succeeded. If it does succeed, you should be able to check out
+the git repository conventionally hosted at
+@indicateurl{https://@var{host}/git/main.git}, add that checkout to your
+@code{GUIX_PACKAGE_PATH}, and thereby have access to that package. In
+the future this will be made easier with a @code{guix channel} facility,
+but for now you have to use @code{GUIX_PACKAGE_PATH} or similar.
+@xref{Defining Packages}, for more information.
+
+Finally, there is the code that actually runs the potluck service:
+@code{guix potluck host-channel}. This tool will host a web server on
+localhost, listening on port 8080 by default. It expects to be behind
+some kind of HTTPS terminator, like @code{nginx}. It does the work of
+translating update requests to git repositories. Guix includes an
+example operating system definition for a server combining HTTPS access
+to git repositories, an @code{nginx} web front-end, and a @code{guix
+potluck host-channel} instance.
+
+
@c *********************************************************************
@node GNU Distribution
@chapter GNU Distribution
--
2.12.2
^ permalink raw reply related [flat|nested] 24+ messages in thread
* bug#26645: guix potluck
2017-04-24 20:53 bug#26645: guix potluck Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
@ 2017-04-24 21:09 ` ng0
2020-03-18 20:03 ` [bug#26645] Potluck still relivant Jack Hill
2 siblings, 0 replies; 24+ messages in thread
From: ng0 @ 2017-04-24 21:09 UTC (permalink / raw)
To: Andy Wingo; +Cc: 26645
Andy Wingo transcribed 0.2K bytes:
> Hi,
>
> The attached patches add a "guix potluck" facility, as described on
> guix-devel:
>
> https://lists.gnu.org/archive/html/guix-devel/2017-04/msg00250.html
>
> Cheers,
>
> Andy
>
>
>
Cool :)
(but as you might've realized, this broke guix-patches in the way that you've just sent 57 new messages, hopefully all in one bug)
--
PGP and more: https://people.pragmatique.xyz/ng0/
^ permalink raw reply [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
` (7 preceding siblings ...)
2017-04-24 20:59 ` bug#26645: [PATCH 9/9] doc: Document guix potluck Andy Wingo
@ 2017-05-03 20:19 ` Ludovic Courtès
2017-05-03 21:55 ` Ludovic Courtès
8 siblings, 1 reply; 24+ messages in thread
From: Ludovic Courtès @ 2017-05-03 20:19 UTC (permalink / raw)
To: Andy Wingo; +Cc: 26645
Hi!
Finally some review for all these exciting bits! :-)
Andy Wingo <wingo@igalia.com> skribis:
> * guix/potluck/build-systems.scm:
> * guix/potluck/licenses.scm:
> * guix/potluck/packages.scm: New files.
> * guix/scripts/build.scm (load-package-or-derivation-from-file):
> (options->things-to-build, options->derivations): Add "potluck-package" and
> "potluck-source" to environment of file. Lower potluck packages to Guix
> packages.
[...]
> +(define-module (guix potluck build-systems)
> + #:use-module ((guix build-system) #:select (build-system?))
> + #:use-module ((gnu packages) #:select (scheme-modules))
> + #:use-module (ice-9 match)
> + #:export (build-system-by-name all-potluck-build-system-names))
> +
> +(define all-build-systems
> + (delay
> + (let* ((gbs (or (search-path %load-path "guix/build-system.scm")
> + (error "can't find (guix build-system)")))
> + (root (dirname (dirname gbs)))
> + (by-name (make-hash-table)))
> + (for-each (lambda (iface)
> + (module-for-each
> + (lambda (k var)
> + (let* ((str (symbol->string k))
> + (pos (string-contains str "-build-system"))
> + (val (variable-ref var)))
> + (when (and pos (build-system? val))
> + (let* ((head (substring str 0 pos))
> + (tail (substring str
> + (+ pos (string-length
> + "-build-system"))))
> + (name (string->symbol
> + (string-append head tail))))
> + (hashq-set! by-name name val)))))
> + iface))
> + (scheme-modules root "guix/build-system"))
> + by-name)))
What about adding a ‘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?
> +(define-module (guix potluck licenses)
> + #:use-module ((guix licenses) #:select (license?))
> + #:use-module (ice-9 match)
> + #:export (license-by-name all-potluck-license-names))
> +
> +(define all-licenses
> + (delay
> + (let ((iface (resolve-interface '(guix licenses)))
> + (by-name (make-hash-table)))
> + (module-for-each (lambda (k var)
> + (let ((val (variable-ref var)))
> + (when (license? val)
> + (hashq-set! by-name k val))))
> + (resolve-interface '(guix licenses)))
> + by-name)))
Likewise here.
> +(define-module (guix potluck packages)
Nice!
> +(define (potluck-package-field-location package field)
> + "Return the source code location of the definition of FIELD for 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 looks
like we could extract:
(define (sexp-location start-location car)
"Return the location of the sexp with the given CAR, starting from
START-LOCATION."
…)
and define both ‘package-field-location’ and
‘potluck-package-field-location’ in terms of it. Thoughts?
> +(define (lower-potluck-package pkg)
> + (validate-potluck-package pkg)
> + (let ((name (potluck-package-name pkg))
> + (version (potluck-package-version pkg))
> + (source (potluck-package-source pkg))
> + (build-system (potluck-package-build-system pkg))
> + (inputs (potluck-package-inputs pkg))
> + (native-inputs (potluck-package-native-inputs pkg))
> + (propagated-inputs (potluck-package-propagated-inputs pkg))
> + (arguments (potluck-package-arguments pkg))
> + (home-page (potluck-package-home-page pkg))
> + (synopsis (potluck-package-synopsis pkg))
> + (description (potluck-package-description pkg))
> + (license (potluck-package-license pkg)))
> + (package
> + (name name)
> + (version version)
> + (source (lower-potluck-source source))
> + (build-system (build-system-by-name build-system))
> + (inputs (lower-inputs inputs))
> + (native-inputs (lower-inputs native-inputs))
> + (propagated-inputs (lower-inputs propagated-inputs))
> + (arguments arguments)
> + (home-page home-page)
> + (synopsis synopsis)
> + (description description)
> + (license (license-by-name license)))))
Could you add a couple of tests for this?
> diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
> index 6bb1f72eb..be26f63c9 100644
> --- a/guix/scripts/build.scm
> +++ b/guix/scripts/build.scm
I’d move this part to a separate patch.
As discussed on IRC I think, I was wondering whether it would make sense
to 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. That
would avoid entangling potluck and ‘guix build’ too much.
Could you check if that’s doable? If it turns out it’s too
inconvenient, then we can take the approach here.
Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 3/9] guix: Add git utility module.
2017-04-24 20:59 ` bug#26645: [PATCH 3/9] guix: Add git utility module Andy Wingo
@ 2017-05-03 20:23 ` Ludovic Courtès
0 siblings, 0 replies; 24+ messages in thread
From: Ludovic Courtès @ 2017-05-03 20:23 UTC (permalink / raw)
To: Andy Wingo; +Cc: 26645
Andy Wingo <wingo@igalia.com> skribis:
> * guix/git.scm: New file.
> * Makefile.am (MODULES): Add new file.
Looking forward, what about calling it (guix git-program) or (guix
potluck git) instead? :-)
The reason is that (1) after the release we’ll start using Guile-Git
directly, and (2) Mathieu O. is working on a (guix git) module that does
higher-level Git repo management using Guile-Git.
Otherwise LGTM!
Ludo’.
^ permalink raw reply [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 1/9] guix: Add "potluck" packages.
2017-05-03 20:19 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Ludovic Courtès
@ 2017-05-03 21:55 ` Ludovic Courtès
0 siblings, 0 replies; 24+ messages in thread
From: Ludovic Courtès @ 2017-05-03 21:55 UTC (permalink / raw)
To: Andy Wingo; +Cc: 26645
ludo@gnu.org (Ludovic Courtès) skribis:
> 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 it
turns out to be useful in another situation already.
HTH!
Ludo’.
^ permalink raw reply [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 4/9] guix: Add "potluck" command.
2017-04-24 20:59 ` bug#26645: [PATCH 4/9] guix: Add "potluck" command Andy Wingo
@ 2017-05-04 20:23 ` Ludovic Courtès
0 siblings, 0 replies; 24+ messages in thread
From: Ludovic Courtès @ 2017-05-04 20:23 UTC (permalink / raw)
To: Andy Wingo; +Cc: 26645
Hello!
Andy Wingo <wingo@igalia.com> skribis:
> * guix/scripts/potluck.scm: New file.
> * Makefile.am: Add new file.
[...]
> + (call-with-output-file (in-vicinity potluck-dir "README.md")
> + (lambda (port)
> + (format port
> + "\
Please add (G_ …) for i18n, and also add the file to po/guix/POTFILES.in.
> +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 as
guix-potluck.org. :-)
> + (let* ((opts (parse-command-line args %options
> + (list %default-options)
> + #:argument-handler
> + parse-sub-command))
‘parse-command-line’ honors $GUIX_BUILD_OPTIONS, which is unnecessary
here. Instead, we should use ‘args-fold*’ like in (guix scripts hash),
for instance.
Otherwise LGTM, thanks!
Ludo’.
^ permalink raw reply [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox.
2017-04-24 20:59 ` bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox Andy Wingo
@ 2017-05-04 20:27 ` Ludovic Courtès
0 siblings, 0 replies; 24+ messages in thread
From: Ludovic Courtès @ 2017-05-04 20:27 UTC (permalink / raw)
To: Andy Wingo; +Cc: 26645
Andy Wingo <wingo@igalia.com> skribis:
> * guix/potluck/environment.scm: New file.
> * Makefile.am (MODULES): Add new files.
> * guix/potluck/packages.scm (make-potluck-sandbox-module)
> (eval-in-sandbox): New helpers.
> (load-potluck-package): New public function.
[...]
> + ((getenv "GUIX_POTLUCK_NO_SANDBOX")
> + (warn "No sandbox available; be warned!!!")
Perhaps this should use ‘warning’ from (guix ui).
> +;; Because potluck package definitions come from untrusted parties, they need
> +;; to be sandboxed to prevent them from harming the host system.
> +(define* (load-potluck-package file #:key
> + (time-limit 1)
> + (allocation-limit 50e6))
> + "Read a sequence of Scheme expressions from @var{file} and evaluate 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 this
part, or maybe for ‘eval-in-sandbox’?
Otherwise LGTM, thank you!
Ludo’.
^ permalink raw reply [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 6/9] gnu: Add find-package-binding.
2017-04-24 20:59 ` bug#26645: [PATCH 6/9] gnu: Add find-package-binding Andy Wingo
@ 2017-05-04 20:29 ` Ludovic Courtès
0 siblings, 0 replies; 24+ messages in thread
From: Ludovic Courtès @ 2017-05-04 20:29 UTC (permalink / raw)
To: Andy Wingo; +Cc: 26645
Andy Wingo <wingo@igalia.com> skribis:
> * gnu/packages.scm (find-package-binding): New export.
[...]
> +(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) is
always valid (which is the case by default), and bail out if it’s not.
WDYT?
Otherwise LGTM, thanks!
Ludo’.
^ permalink raw reply [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
2017-04-24 20:59 ` bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package Andy Wingo
@ 2017-05-04 20:31 ` Ludovic Courtès
0 siblings, 0 replies; 24+ messages in thread
From: Ludovic Courtès @ 2017-05-04 20:31 UTC (permalink / raw)
To: Andy Wingo; +Cc: 26645
Andy Wingo <wingo@igalia.com> skribis:
> * guix/potluck/packages.scm (lower-potluck-package-to-module): New public
> function.
Could you add a quick test for this? :-)
Otherwise LGTM!
Ludo’.
^ permalink raw reply [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand.
2017-04-24 20:59 ` bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand Andy Wingo
@ 2017-05-04 20:55 ` Ludovic Courtès
0 siblings, 0 replies; 24+ messages in thread
From: Ludovic Courtès @ 2017-05-04 20:55 UTC (permalink / raw)
To: Andy Wingo; +Cc: 26645
Andy Wingo <wingo@igalia.com> skribis:
> * guix/potluck/host.scm: New file.
> * Makefile.am (MODULES): Add new file.
> * guix/scripts/potluck.scm: Add host-channel command.
[...]
> +(define-module (guix potluck host)
Could you add a commentary explaining what it does?
> +;;;
> +;;; async queues
> +;;;
Nice; perhaps in the future (guix workers) should use these instead of
rolling & entangling its own.
> +(define (bytes-free-on-fs filename)
> + (let* ((p (open-pipe* "r" "df" "-B1" "--output=avail" filename))
Please use ‘statfs’ from (guix build syscalls) instead, it should be
nicer. ;-)
> +(define (process-update host working-dir source-checkout target-checkout
> + remote-git-url branch)
Please add a docstring to guide the reader.
> + (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
> + (delete-directory-contents-recursively working-dir)
> + (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
> + (error "not enough free space")))
> + (chdir working-dir)
> + (let* ((repo-dir (uri-encode remote-git-url))
> + (repo+branch-dir (in-vicinity repo-dir (uri-encode branch))))
> + (cond
> + ((file-exists? repo-dir)
> + (chdir repo-dir)
> + (git-fetch))
> + (else
> + (git-clone remote-git-url repo-dir)
> + (chdir repo-dir)))
> + (git-reset #:ref (string-append "origin/" branch) #:mode 'hard)
> + (unless (file-is-directory? "guix-potluck")
> + (error "repo+branch has no guix-potluck dir" remote-git-url branch))
> + (let* ((files (scm-files-in-dir "guix-potluck"))
> + ;; This step safely loads and validates the potluck package
> + ;; definitions.
> + (packages (map load-potluck-package files))
> + (source-dir (in-vicinity source-checkout repo+branch-dir))
> + (target-dir (in-vicinity target-checkout
> + (in-vicinity "gnu/packages/potluck"
> + repo+branch-dir))))
> + ;; Clear source and target repo entries.
> + (define (ensure-empty-dir filename)
> + (when (file-exists? filename)
> + (delete-file-recursively filename))
> + (mkdir-p filename))
> + (define (commit-dir dir)
> + (with-directory-excursion dir
Can’t there be multiple threads running this code in parallel? I’m
wary of changing the cwd in general, especially in multi-threaded
programs. How hard would it be to aviod the ‘chdir’ and
‘with-directory-excursion’ uses?
> +(define (host-potluck host local-port working-dir source-checkout
> + target-checkout)
Please add a docstring.
> + (let ((worker-thread #f)
> + (queue (make-async-queue)))
> + (dynamic-wind (lambda ()
> + (set! worker-thread
> + (make-thread
> + (service-queue host working-dir
> + source-checkout target-checkout
> + queue))))
> + (lambda ()
> + (run-server
> + (lambda (request body)
> + (handler request body queue))
> + ;; Always listen on localhost.
> + 'http `(#:port ,local-port)))
> + (lambda ()
> + (cancel-thread worker-thread)))))
In fact perhaps (guix workers) would work here?
As always I would feel reassured with a couple of tests. :-) Perhaps
we could spawn a service thread as in tests/publish.scm, and mock the
Git procedures?
Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 24+ messages in thread
* bug#26645: [PATCH 9/9] doc: Document guix potluck.
2017-04-24 20:59 ` bug#26645: [PATCH 9/9] doc: Document guix potluck Andy Wingo
@ 2017-05-04 20:56 ` Ludovic Courtès
0 siblings, 0 replies; 24+ messages in thread
From: Ludovic Courtès @ 2017-05-04 20:56 UTC (permalink / raw)
To: Andy Wingo; +Cc: 26645
Andy Wingo <wingo@igalia.com> skribis:
> * doc/guix.texi (potluck-package Reference):
> (Invoking guix potluck): New sections.
Perfect, awesome!!
Thank you,
Ludo’.
^ permalink raw reply [flat|nested] 24+ messages in thread
* [bug#26645] Potluck still relivant
2017-04-24 20:53 bug#26645: guix potluck Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
2017-04-24 21:09 ` bug#26645: guix potluck ng0
@ 2020-03-18 20:03 ` Jack Hill
2020-04-01 16:11 ` Brice Waegeneire
2 siblings, 1 reply; 24+ messages in thread
From: Jack Hill @ 2020-03-18 20:03 UTC (permalink / raw)
To: 26645
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
^ permalink raw reply [flat|nested] 24+ messages in thread
* [bug#26645] Potluck still relivant
2020-03-18 20:03 ` [bug#26645] Potluck still relivant Jack Hill
@ 2020-04-01 16:11 ` Brice Waegeneire
2020-04-29 6:02 ` Ricardo Wurmus
0 siblings, 1 reply; 24+ messages in thread
From: Brice Waegeneire @ 2020-04-01 16:11 UTC (permalink / raw)
To: Jack Hill; +Cc: 26645, wingo, ludo, Guix-patches
Hello Jack,
On 2020-03-18 20:03, Jack Hill wrote:
> 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 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.
He even write the following:
> 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
^ permalink raw reply [flat|nested] 24+ messages in thread
* [bug#26645] Potluck still relivant
2020-04-01 16:11 ` Brice Waegeneire
@ 2020-04-29 6:02 ` Ricardo Wurmus
2023-07-21 16:57 ` bug#26645: guix potluck Maxim Cournoyer
0 siblings, 1 reply; 24+ messages in thread
From: Ricardo Wurmus @ 2020-04-29 6:02 UTC (permalink / raw)
To: 26645; +Cc: wingo, Jack Hill, Brice Waegeneire, ludo
Hi Brice,
> 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 to
define packages that would not break when package variables in Guix
proper are moved around:
> +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:
--8<---------------cut here---------------start------------->8---
[
{
"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"]
}
]
--8<---------------cut here---------------end--------------->8---
Since this can be fed to “guix build -f” directly, there doesn’t seem to
be a need for “guix potluck init” any more.
While I think it would be very convenient to be able to publish package
definitions with “guix potluck update <url> <branch>”, it would require
maintenance of the host-channel service that accepts possibly hostile
user input. To prevent denial of service it should probably require
authentication and enforce quotas.
Since users can also push packages for non-free software we cannot host
this on Guix project infrastructure. (I guess this was why the proposed
domain was guix-potluck.org.)
--
Ricardo
^ permalink raw reply [flat|nested] 24+ messages in thread
* bug#26645: guix potluck
2020-04-29 6:02 ` Ricardo Wurmus
@ 2023-07-21 16:57 ` Maxim Cournoyer
0 siblings, 0 replies; 24+ messages in thread
From: Maxim Cournoyer @ 2023-07-21 16:57 UTC (permalink / raw)
To: Ricardo Wurmus; +Cc: 26645-done, wingo, Jack Hill, Brice Waegeneire, ludo
Hi,
Ricardo Wurmus <rekado@elephly.net> writes:
> Hi Brice,
>
>> 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 to
> define packages that would not break when package variables in Guix
> proper are moved around:
>
>> +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:
>
> [
> {
> "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 to
> be a need for “guix potluck init” any more.
>
> While I think it would be very convenient to be able to publish package
> definitions with “guix potluck update <url> <branch>”, it would require
> maintenance of the host-channel service that accepts possibly hostile
> user input. To prevent denial of service it should probably require
> authentication and enforce quotas.
>
> Since users can also push packages for non-free software we cannot host
> this on Guix project infrastructure. (I guess this was why the proposed
> domain was guix-potluck.org.)
OK. I'm closing the issue since it's been opened for 6 years with no
sign of it being driven home. Do send a refreshed version again if it's
still relevant/desired.
--
Thanks,
Maxim
^ permalink raw reply [flat|nested] 24+ messages in thread
end of thread, other threads:[~2023-07-21 16:59 UTC | newest]
Thread overview: 24+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2017-04-24 20:53 bug#26645: guix potluck Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 3/9] guix: Add git utility module Andy Wingo
2017-05-03 20:23 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 4/9] guix: Add "potluck" command Andy Wingo
2017-05-04 20:23 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox Andy Wingo
2017-05-04 20:27 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 6/9] gnu: Add find-package-binding Andy Wingo
2017-05-04 20:29 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package Andy Wingo
2017-05-04 20:31 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand Andy Wingo
2017-05-04 20:55 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 9/9] doc: Document guix potluck Andy Wingo
2017-05-04 20:56 ` Ludovic Courtès
2017-05-03 20:19 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Ludovic Courtès
2017-05-03 21:55 ` Ludovic Courtès
2017-04-24 21:09 ` bug#26645: guix potluck ng0
2020-03-18 20:03 ` [bug#26645] Potluck still relivant Jack Hill
2020-04-01 16:11 ` Brice Waegeneire
2020-04-29 6:02 ` Ricardo Wurmus
2023-07-21 16:57 ` bug#26645: guix potluck Maxim Cournoyer
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).