[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/02: guix: Add beginnings of "guix potluck"
|
From: |
Andy Wingo |
|
Subject: |
02/02: guix: Add beginnings of "guix potluck" |
|
Date: |
Wed, 5 Apr 2017 11:20:23 -0400 (EDT) |
wingo pushed a commit to branch wip-potluck
in repository guix.
commit 09cf44da1e1dd3b46a14e19faf940602f252e1ee
Author: Andy Wingo <address@hidden>
Date: Wed Apr 5 17:12:31 2017 +0200
guix: Add beginnings of "guix potluck"
* guix/potluck/build-systems.scm:
* guix/potluck/licenses.scm:
* guix/potluck/packages.scm:
* guix/scripts/potluck.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 | 4 +
guix/potluck/build-systems.scm | 54 +++++
guix/potluck/licenses.scm | 41 ++++
guix/potluck/packages.scm | 399 +++++++++++++++++++++++++++++++++++
guix/scripts/build.scm | 54 +++--
guix/scripts/potluck.scm | 458 +++++++++++++++++++++++++++++++++++++++++
6 files changed, 990 insertions(+), 20 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 06c85e9..33b23de 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -123,6 +123,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 \
@@ -160,6 +163,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/potluck/build-systems.scm b/guix/potluck/build-systems.scm
new file mode 100644
index 0000000..45bd402
--- /dev/null
+++ b/guix/potluck/build-systems.scm
@@ -0,0 +1,54 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Andy Wingo <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (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 (resolve-module '(guix build-system)))
+ (root (dirname (dirname (module-filename 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 0000000..6efeee2
--- /dev/null
+++ b/guix/potluck/licenses.scm
@@ -0,0 +1,41 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Andy Wingo <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (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 0000000..0f26553
--- /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
<address@hidden>
+;;; Copyright © 2014, 2015 Mark H Weaver <address@hidden>
+;;; Copyright © 2015 Eric Bavier <address@hidden>
+;;; Copyright © 2016 Alex Kost <address@hidden>
+;;; Copyright © 2017 Andy Wingo <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (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 '()) (thunked))
+ (inputs potluck-package-inputs ; input packages or
+ ; derivations
+ (default '()) (thunked))
+ (propagated-inputs potluck-package-propagated-inputs ; same, but propagated
+ (default '()) (thunked))
+ (native-inputs potluck-package-native-inputs ; native input packages or
+ ; derivations
+ (default '()) (thunked))
+ (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 address@hidden ~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 address@hidden ~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 address@hidden 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 68402fd..3915476 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.
@@ -577,11 +578,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)
@@ -601,7 +611,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))
@@ -625,27 +635,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)
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
new file mode 100644
index 0000000..8836798
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,458 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Andy Wingo <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (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 ui)
+ #: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 (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 popen)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (web uri)
+ #:export (guix-potluck))
+
+
+;;;
+;;; git utilities
+;;;
+
+(define-condition-type &git-condition &condition git-condition?
+ (argv git-condition-argv)
+ (output git-condition-output)
+ (status git-condition-status))
+
+(define-syntax false-if-git-error
+ (syntax-rules ()
+ ((_ 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 (get-string-all 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-rev-parse rev)
+ (string-trim-both (git "rev-parse" rev)))
+
+(define (git-config key)
+ (string-trim-both (git "config" key)))
+
+(define* (git-describe #:optional (ref "HEAD"))
+ (string-trim-both (git "describe")))
+
+
+;;;
+;;; guix potluck init
+;;;
+
+(define* (init-potluck host-url 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 potluck && git commit -m 'Add initial Guix potluck files.'
+") pkg-name pkg-name))))
+
+
+;;;
+;;; guix potluck register
+;;;
+
+(define (register-potluck host-url git-url branch)
+ #t)
+
+
+;;;
+;;; guix potluck host-channel
+;;;
+
+(define (host-potluck host-url local-port local-git-checkout-dir)
+ #t)
+
+
+;;;
+;;; guix potluck request-update
+;;;
+
+(define (request-potluck-update host-url git-url branch)
+ #t)
+
+
+;;;
+;;; 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"))
+ (display (_ "\
+ register register remote git branch with potluck host\n"))
+ (display (_ "\
+ host-channel run web service providing potluck packages as Guix
channel\n"))
+ (display (_ "\
+ request-update ask potluck host to update a potluck package\n"))
+
+ (newline)
+ (display (_ "The available OPTION flags are:\n"))
+ (display (_ "
+ --host-url=URL for 'register', 'host-channel', and 'request-update',
+ the URL of the channel host
+ (default: https://potluck.guixsd.org/)"))
+ (display (_ "
+ --port=PORT for 'host-channel', the local TCP port on which to
+ listen for HTTP connections
+ (default: 8080)"))
+ (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 '("host-url") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'host-url arg result)))
+ (option '("port") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'port 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.
+ `((host-url . "https://potluck.guixsd.org/";)
+ (port . "8080")
+ (verbosity . 0)))
+
+(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-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))
+ (exit 0))
+ (unless (build-system-by-name sys)
+ (leave (_ "invalid build system: ~a; try --build-system=help~%") sys))
+ sys))
+
+(define (parse-license license-str)
+ (unless license-str
+ (leave (_ "init: missing --license; try --license=help for options~%")))
+ (let ((license (string->symbol (string-downcase license-str))))
+ (when (eq? license 'help)
+ (format #t "guix potluck: Available licenses:~%")
+ (for-each
+ (lambda (name)
+ (let ((license (license-by-name name)))
+ (format #t " ~a ~25t~a~%" name (license-uri license))))
+ (all-potluck-license-names))
+ (format #t "
+If your package's license is not in this list, add it to Guix first.~%")
+ (exit 0))
+ (unless (license-by-name license)
+ (leave (_ "invalid license: ~a; try --license=help~%") license))
+ license))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-potluck . args)
+ (define (parse-sub-command arg result)
+ (if (assoc-ref result 'action)
+ (alist-cons 'argument arg result)
+ (alist-cons 'action (string->symbol arg) result)))
+
+ (define (match-pair car)
+ ;; Return a procedure that matches a pair with CAR.
+ (match-lambda
+ ((head . tail)
+ (and (eq? car head) tail))
+ (_ #f)))
+
+ (with-error-handling
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)
+ #:argument-handler
+ parse-sub-command))
+ (action (assoc-ref opts 'action))
+ (args (reverse (filter-map (match-pair 'argument) opts))))
+ (define (see-help)
+ (format (current-error-port)
+ (_ "Try 'guix potluck --help' for more information.~%")))
+ (define (wrong-number-of-args usage)
+ (format (current-error-port)
+ (_ "guix potluck ~a: wrong number of arguments~%")
+ action)
+ (display usage (current-error-port))
+ (newline (current-error-port))
+ (see-help)
+ (exit 1))
+ (match action
+ (#f
+ (format (current-error-port)
+ (_ "guix potluck: missing command name~%"))
+ (see-help)
+ (exit 1))
+ ('init
+ (match args
+ ((remote-git-url)
+ (init-potluck (parse-url (assoc-ref opts 'host-url))
+ (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")))))
+ ('register
+ (match args
+ ((remote-git-url branch)
+ (register-potluck (parse-url (assoc-ref opts 'host-url))
+ (parse-url remote-git-url)
+ branch))
+ (args
+ (wrong-number-of-args
+ (_ "usage: guix potluck register REMOTE-GIT-URL BRANCH-NAME")))))
+ ('host-channel
+ (match args
+ ((local-git-checkout)
+ (host-potluck (parse-url (assoc-ref opts 'host-url))
+ (parse-port (assoc-ref opts 'port))
+ local-git-checkout))
+ (args
+ (wrong-number-of-args
+ (_ "usage: guix potluck host-channel CHANNEL-DIRECTORY"))
+ (exit 1))))
+ ('request-update
+ (match args
+ ((remote-git-url branch)
+ (request-potluck-update (parse-url (assoc-ref opts 'host-url))
+ (parse-url remote-git-url)
+ branch))
+ (args
+ (wrong-number-of-args
+ (_ "usage: guix potluck request-update REMOTE-GIT-URL
BRANCH-NAME")))))
+ (action
+ (leave (_ "~a: unknown action~%") action))))))