From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:39990) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d2l6s-0003Tt-Ah for guix-patches@gnu.org; Mon, 24 Apr 2017 17:01:37 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d2l6j-0003xc-Sk for guix-patches@gnu.org; Mon, 24 Apr 2017 17:01:26 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:40311) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d2l6j-0003x0-K9 for guix-patches@gnu.org; Mon, 24 Apr 2017 17:01:17 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1d2l6j-0004dZ-Bo for guix-patches@gnu.org; Mon, 24 Apr 2017 17:01:17 -0400 Subject: bug#26645: [PATCH 1/9] guix: Add "potluck" packages. References: <87y3upttm7.fsf@pobox.com> In-Reply-To: <87y3upttm7.fsf@pobox.com> Resent-Message-ID: From: Andy Wingo Date: Mon, 24 Apr 2017 22:59:15 +0200 Message-Id: <20170424205923.27726-1-wingo@igalia.com> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 26645@debbugs.gnu.org * guix/potluck/build-systems.scm: * guix/potluck/licenses.scm: * guix/potluck/packages.scm: New files. * guix/scripts/build.scm (load-package-or-derivation-from-file): (options->things-to-build, options->derivations): Add "potluck-package" a= nd "potluck-source" to environment of file. Lower potluck packages to Guix packages. --- Makefile.am | 3 + guix/potluck/build-systems.scm | 55 ++++++ guix/potluck/licenses.scm | 41 +++++ guix/potluck/packages.scm | 399 +++++++++++++++++++++++++++++++++++= ++++++ guix/scripts/build.scm | 54 +++--- 5 files changed, 532 insertions(+), 20 deletions(-) create mode 100644 guix/potluck/build-systems.scm create mode 100644 guix/potluck/licenses.scm create mode 100644 guix/potluck/packages.scm diff --git a/Makefile.am b/Makefile.am index db4ebe04d..22ba00e90 100644 --- a/Makefile.am +++ b/Makefile.am @@ -126,6 +126,9 @@ MODULES =3D \ guix/build/make-bootstrap.scm \ guix/search-paths.scm \ guix/packages.scm \ + guix/potluck/build-systems.scm \ + guix/potluck/licenses.scm \ + guix/potluck/packages.scm \ guix/import/utils.scm \ guix/import/gnu.scm \ guix/import/snix.scm \ diff --git a/guix/potluck/build-systems.scm b/guix/potluck/build-systems.= scm new file mode 100644 index 000000000..1f6aa1fe3 --- /dev/null +++ b/guix/potluck/build-systems.scm @@ -0,0 +1,55 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2017 Andy Wingo +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (a= t +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(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) (stringstring a) (symbol->string b))))) + +(define (build-system-by-name name) + (hashq-ref (force all-build-systems) name)) diff --git a/guix/potluck/licenses.scm b/guix/potluck/licenses.scm new file mode 100644 index 000000000..6efeee21a --- /dev/null +++ b/guix/potluck/licenses.scm @@ -0,0 +1,41 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2017 Andy Wingo +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (a= t +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(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) (stringstring a) (symbol->string b))))) + +(define (license-by-name name) + (hashq-ref (force all-licenses) name)) diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm new file mode 100644 index 000000000..c7dae3791 --- /dev/null +++ b/guix/potluck/packages.scm @@ -0,0 +1,399 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Court=C3= =A8s +;;; Copyright =C2=A9 2014, 2015 Mark H Weaver +;;; Copyright =C2=A9 2015 Eric Bavier +;;; Copyright =C2=A9 2016 Alex Kost +;;; Copyright =C2=A9 2017 Andy Wingo +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (a= t +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(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 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 make-potluck-package + potluck-package? + (name potluck-package-name) ; string + (version potluck-package-version) ; string + (source potluck-package-source) ; + ; instance + (build-system potluck-package-build-system) ; build system name = as + ; symbol + (arguments potluck-package-arguments ; arguments for the = build + ; method + (default '())) + (inputs potluck-package-inputs ; input packages or + ; derivations + (default '())) + (propagated-inputs potluck-package-propagated-inputs ; same, but prop= agated + (default '())) + (native-inputs potluck-package-native-inputs ; native input packa= ges or + ; derivations + (default '())) + (synopsis potluck-package-synopsis) ; one-line descripti= on + (description potluck-package-description) ; one or two paragra= phs + (license potluck-package-license) + (home-page potluck-package-home-page) + (location potluck-package-location + (default (and=3D> (current-source-location) + source-properties->location)) + (innate))) + +;; Printers. + +(define (print-potluck-source potluck-source port) + "Write a concise representation of POTLUCK-SOURCE to PORT." + (match potluck-source + (($ git-uri git-commit sha256 snippet) + (simple-format port "#" + 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-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! print-potluck-source) +(set-record-type-printer! print-potluck-package) + +;; Pretty-printers. + +(define* (pretty-print-potluck-source port source #:key (prefix "") + (suffix "\n")) + (let ((uri (potluck-source-git-uri source)) + (commit (potluck-source-git-commit source)) + (sha256 (potluck-source-sha256 source)) + (snippet (potluck-source-snippet source))) + (format port "~a(potluck-source" prefix) + (format port "\n~a (git-uri ~s)" prefix uri) + (format port "\n~a (git-commit ~s)" prefix commit) + (format port "\n~a (sha256 ~s)" prefix sha256) + (when snippet + (format port "\n~a (snippet '~s)" prefix snippet)) + (format port ")~a" suffix))) + +(define* (pretty-print-potluck-package port pkg #:key (prefix "")) + (let ((name (potluck-package-name pkg)) + (version (potluck-package-version pkg)) + (source (potluck-package-source pkg)) + (build-system (potluck-package-build-system pkg)) + (inputs (potluck-package-inputs pkg)) + (native-inputs (potluck-package-native-inputs pkg)) + (propagated-inputs (potluck-package-propagated-inputs pkg)) + (arguments (potluck-package-arguments pkg)) + (home-page (potluck-package-home-page pkg)) + (synopsis (potluck-package-synopsis pkg)) + (description (potluck-package-description pkg)) + (license (potluck-package-license pkg))) + (format port "~a(potluck-package\n" prefix) + (format port "~a (name ~s)\n" prefix name) + (format port "~a (version ~s)\n" prefix version) + (format port "~a (source\n" prefix) + (pretty-print-potluck-source port source #:prefix + (string-append prefix " ") + #:suffix ")\n") + (format port "~a (build-system '~s)\n" prefix build-system) + (format port "~a (inputs '~s)\n" prefix inputs) + (format port "~a (native-inputs '~s)\n" prefix native-inputs) + (format port "~a (propagated-inputs '~s)\n" prefix propagated-input= s) + (match arguments + (() + (format port "~a (arguments '())\n" prefix)) + (arguments + (pretty-print `(arguments ',arguments) port + #:per-line-prefix (format #f "~a " prefix)))) + (format port "~a (home-page ~s)\n" prefix home-page) + (format port "~a (synopsis ~s)\n" prefix synopsis) + (format port "~a (description ~s)\n" prefix description) + (format port "~a (license '~s))\n" prefix license))) + +;; Editing. + +(define (potluck-package-field-location package field) + "Return the source code location of the definition of FIELD for PACKAG= E, or +#f if it could not be determined." + (define (goto port line column) + (unless (and (=3D (port-column port) (- column 1)) + (=3D (port-line port) (- line 1))) + (unless (eof-object? (read-char port)) + (goto port line column)))) + + (match (potluck-package-location package) + (($ file line column) + (catch 'system + (lambda () + ;; In general we want to keep relative file names for modules. + (with-fluids ((%file-port-name-canonicalization 'relative)) + (call-with-input-file (search-path %load-path file) + (lambda (port) + (goto port line column) + (match (read port) + (('potluck-package inits ...) + (let ((field (assoc field inits))) + (match field + ((_ value) + ;; Put the `or' here, and not in the first argume= nt of + ;; `and=3D>', to work around a compiler bug in 2.= 0.5. + (or (and=3D> (source-properties value) + source-properties->location) + (and=3D> (source-properties field) + source-properties->location))) + (_ + #f)))) + (_ + #f)))))) + (lambda _ + #f))) + (_ #f))) + +;; Lower potluck packages to Guix packages. + +(define-condition-type &potluck-package-error &error + potluck-package-error? + (potluck-package potluck-package-error-potluck-package)) + +(define-condition-type &potluck-package-validation-error &potluck-packag= e-error + potluck-package-validation-error? + (field-name potluck-package-validation-error-field-name) + (assertion potluck-package-validation-error-assertion) + (value potluck-package-validation-error-value)) + +(define (assertion-failed pkg field-name assertion value) + (raise (condition (&potluck-package-validation-error + (potluck-package pkg) + (field-name field-name) + (assertion assertion) + (value value))))) + +(define* (validate-public-uri pkg field-name str #:key (schemes '(http h= ttps))) + (define (public-host? host) + ;; There are other ways to spell "localhost" using raw IPv4 or IPv6 + ;; addresses; this is just a sanity check. + (not (member host '("localhost" "127.0.0.1" "[::1]")))) + (let ((uri (and (string? str) (string->uri str)))) + (unless (and uri + (memq (uri-scheme uri) schemes) + (not (uri-fragment uri)) + (public-host? (uri-host uri))) + (assertion-failed pkg field-name "public URI" str)))) + +(define (validate-git-commit pkg field-name commit) + (unless (and (string? commit) + (=3D (string-length commit) 40) + (string-every (string->char-set "abcdef0123456789") commi= t)) + (assertion-failed pkg field-name "full git commit SHA1 hash" commit)= )) + +(define (validate-base32-sha256 pkg field-name str) + (unless (and (string? str) + (=3D (string-length str) 52) + (false-if-exception (nix-base32-string->bytevector str))) + (assertion-failed pkg field-name "sha256 hash as a base32 string" st= r))) + +(define (validate-potluck-source pkg field-name source) + (validate-public-uri pkg field-name (potluck-source-git-uri source) + #:schemes '(git http https)) + (validate-git-commit pkg field-name (potluck-source-git-commit source)= ) + (validate-base32-sha256 pkg field-name (potluck-source-sha256 source)) + (validate-snippet pkg field-name (potluck-source-snippet source))) + +(define (validate-snippet pkg field-name snippet) + (match snippet + (#f #t) + ((_ ...) #t) + (_ (assertion-failed pkg field-name "valid snippet" snippet)))) + +(define (validate-non-empty-string pkg field-name str) + (unless (and (string? str) + (not (string-null? str))) + (assertion-failed pkg field-name "non-empty string" str))) + +(define (validate-build-system pkg field-name sym) + (unless (build-system-by-name sym) + (assertion-failed pkg field-name "build system name as symbol" sym))= ) + +(define (validate-package-list pkg field-name l) + (unless (and (list? l) (and-map string? l)) + (assertion-failed pkg field-name + "list of package or package@version strings" l))) + +(define* (validate-keyword-arguments pkg field-name l #:optional (valid-= kw? (const #t))) + (define validate-1 + (case-lambda + (() #t) + ((k v . rest) + (unless (and (keyword? k) (valid-kw? k)) + (assertion-failed pkg field-name "keyword" k)) + (apply validate-1 rest)) + (_ (assertion-failed pkg field-name "keyword argument list" l)))) + (apply validate-1 l)) + +(define (validate-arguments pkg field-name arguments) + (validate-keyword-arguments pkg field-name arguments)) + +(define (validate-synopsis pkg field-name str) + (validate-non-empty-string pkg field-name str) + ;; The synopsis set by "guix potluck init". + (when (equal? str "Declarative synopsis here") + (assertion-failed pkg field-name "updated synopsis" str))) + +(define (validate-description pkg field-name str) + (validate-non-empty-string pkg field-name str) + ;; The description set by "guix potluck init". + (when (string-suffix? "..." str) + (assertion-failed pkg field-name "updated description" str))) + +(define (validate-license pkg field-name sym) + (unless (license-by-name sym) + (assertion-failed pkg field-name "license name as symbol" sym))) + +(define (validate-potluck-package pkg) + (validate-non-empty-string pkg 'name (potluck-package-name pkg)) + (validate-non-empty-string pkg 'version (potluck-package-version pkg)) + (validate-potluck-source pkg 'source (potluck-package-source pkg)) + (validate-build-system pkg 'build-system (potluck-package-build-system= pkg)) + (validate-package-list pkg 'inputs (potluck-package-inputs pkg)) + (validate-package-list pkg 'native-inputs + (potluck-package-native-inputs pkg)) + (validate-package-list pkg 'propagated-inputs + (potluck-package-propagated-inputs pkg)) + (validate-arguments pkg 'arguments (potluck-package-arguments pkg)) + (validate-public-uri pkg 'home-page (potluck-package-home-page pkg)) + (validate-synopsis pkg 'synopsis (potluck-package-synopsis pkg)) + (validate-description pkg 'description (potluck-package-description pk= g)) + (validate-license pkg 'license (potluck-package-license pkg))) + +(define (lower-potluck-source o) + (let ((uri (potluck-source-git-uri o)) + (commit (potluck-source-git-commit o)) + (sha256 (potluck-source-sha256 o)) + (snippet (potluck-source-snippet o))) + (origin + (method git-fetch) + (uri (git-reference + (url uri) + (commit commit))) + (snippet snippet) + (sha256 (base32 sha256))))) + +(define (lower-input input) + (call-with-values (lambda () (specification->package+output input)) + (lambda (pkg output) + (cons* (package-name pkg) pkg + (if (equal? output "out") + '() + (list output)))))) + +(define (lower-inputs inputs) + (map lower-input inputs)) + +(define (lower-potluck-package pkg) + (validate-potluck-package pkg) + (let ((name (potluck-package-name pkg)) + (version (potluck-package-version pkg)) + (source (potluck-package-source pkg)) + (build-system (potluck-package-build-system pkg)) + (inputs (potluck-package-inputs pkg)) + (native-inputs (potluck-package-native-inputs pkg)) + (propagated-inputs (potluck-package-propagated-inputs pkg)) + (arguments (potluck-package-arguments pkg)) + (home-page (potluck-package-home-page pkg)) + (synopsis (potluck-package-synopsis pkg)) + (description (potluck-package-description pkg)) + (license (potluck-package-license pkg))) + (package + (name name) + (version version) + (source (lower-potluck-source source)) + (build-system (build-system-by-name build-system)) + (inputs (lower-inputs inputs)) + (native-inputs (lower-inputs native-inputs)) + (propagated-inputs (lower-inputs propagated-inputs)) + (arguments arguments) + (home-page home-page) + (synopsis synopsis) + (description description) + (license (license-by-name license))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 6bb1f72eb..be26f63c9 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -23,6 +23,7 @@ #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix potluck packages) #:use-module (guix grafts) =20 ;; Use the procedure that destructures "NAME-VERSION" forms. @@ -582,11 +583,20 @@ must be one of 'package', 'all', or 'transitive'~%"= ) (append %transformation-options %standard-build-options))) =20 +(define (load-package-or-derivation-from-file file) + (let ((mod (make-user-module '()))) + ;; Expose potluck-package and potluck-source to the file. + (module-use! mod (resolve-interface + '(guix potluck packages) + #:select '(potluck-package potluck-source))) + (load* file mod))) + (define (options->things-to-build opts) "Read the arguments from OPTS and return a list of high-level objects = to build---packages, gexps, derivations, and so on." (define (validate-type x) - (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x)) + (unless (or (package? x) (potluck-package? x) + (derivation? x) (gexp? x) (procedure? x)) (leave (_ "~s: not something we can build~%") x))) =20 (define (ensure-list x) @@ -606,7 +616,7 @@ build---packages, gexps, derivations, and so on." (else (list (specification->package spec))))) (('file . file) - (ensure-list (load* file (make-user-module '())))) + (ensure-list (load-package-or-derivation-from-file file= ))) (('expression . str) (ensure-list (read/eval str))) (('argument . (? derivation? drv)) @@ -630,27 +640,31 @@ build." (define system (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) =20 + (define (package->derivation-list p) + (let ((p (or (and graft? (package-replacement p)) p))) + (match src + (#f + (list (package->derivation store p system))) + (#t + (match (package-source p) + (#f + (format (current-error-port) + (_ "~a: warning: package '~a' has no source~%") + (location->string (package-location p)) + (package-name p)) + '()) + (s + (list (package-source-derivation store s))))) + (proc + (map (cut package-source-derivation store <>) + (proc p)))))) + (parameterize ((%graft? graft?)) (append-map (match-lambda ((? package? p) - (let ((p (or (and graft? (package-replacement p)) p))= ) - (match src - (#f - (list (package->derivation store p system))) - (#t - (match (package-source p) - (#f - (format (current-error-port) - (_ "~a: warning: \ -package '~a' has no source~%") - (location->string (package-location p= )) - (package-name p)) - '()) - (s - (list (package-source-derivation store s))))) - (proc - (map (cut package-source-derivation store <>) - (proc p)))))) + (package->derivation-list p)) + ((? potluck-package? p) + (package->derivation-list (lower-potluck-package p))) ((? derivation? drv) (list drv)) ((? procedure? proc) --=20 2.12.2