diff options
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/asdf.scm | 360 | ||||
-rw-r--r-- | guix/build/asdf-build-system.scm | 282 | ||||
-rw-r--r-- | guix/build/bournish.scm | 14 | ||||
-rw-r--r-- | guix/build/graft.scm | 30 | ||||
-rw-r--r-- | guix/build/lisp-utils.scm | 327 | ||||
-rw-r--r-- | guix/import/github.scm | 2 | ||||
-rw-r--r-- | guix/licenses.scm | 7 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 12 | ||||
-rw-r--r-- | guix/scripts/system.scm | 25 | ||||
-rw-r--r-- | guix/utils.scm | 21 |
10 files changed, 1050 insertions, 30 deletions
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm new file mode 100644 index 0000000000..f28c098ea2 --- /dev/null +++ b/guix/build-system/asdf.scm @@ -0,0 +1,360 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca> +;;; +;;; 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 build-system asdf) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%asdf-build-system-modules + %asdf-build-modules + asdf-build + asdf-build-system/sbcl + asdf-build-system/ecl + asdf-build-system/source + sbcl-package->cl-source-package + sbcl-package->ecl-package)) + +;; Commentary: +;; +;; Standard build procedure for asdf packages. This is implemented as an +;; extension of 'gnu-build-system'. +;; +;; Code: + +(define %asdf-build-system-modules + ;; Imported build-side modules + `((guix build asdf-build-system) + (guix build lisp-utils) + ,@%gnu-build-system-modules)) + +(define %asdf-build-modules + ;; Used (visible) build-side modules + '((guix build asdf-build-system) + (guix build utils) + (guix build lisp-utils))) + +(define (default-lisp implementation) + "Return the default package for the lisp IMPLEMENTATION." + ;; Lazily resolve the binding to avoid a circular dependancy. + (let ((lisp-module (resolve-interface '(gnu packages lisp)))) + (module-ref lisp-module implementation))) + +(define* (lower/source name + #:key source inputs outputs native-inputs system target + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME" + (define private-keywords + '(#:target #:inputs #:native-inputs)) + + (and (not target) + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ,@(standard-packages))) + (build-inputs native-inputs) + (outputs outputs) + (build asdf-build/source) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (asdf-build/source store name inputs + #:key source outputs + (phases '(@ (guix build asdf-build-system) + %standard-phases/source)) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %asdf-build-system-modules) + (modules %asdf-build-modules)) + (define builder + `(begin + (use-modules ,@modules) + (asdf-build/source #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) source) + (source source)) + #:system ,system + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define* (package-with-build-system from-build-system to-build-system + from-prefix to-prefix + #:key variant-property + phases-transformer) + "Return a precedure which takes a package PKG which uses FROM-BUILD-SYSTEM, +and returns one using TO-BUILD-SYSTEM. If PKG was prefixed by FROM-PREFIX, +the resulting package will be prefixed by TO-PREFIX. Inputs of PKG are +recursively transformed using the same rule. The result's #:phases argument +will be modified by PHASES-TRANSFORMER, an S-expression which evaluates on the +build side to a procedure of one argument. + +VARIANT-PROPERTY can be added to a package's properties to indicate that the +corresponding package promise should be used as the result of this +transformation. This allows the result to differ from what the transformation +would otherwise produce. + +If TO-BUILD-SYSTEM is asdf-build-system/source, the resulting package will be +set up using CL source package conventions." + (define target-is-source? (eq? asdf-build-system/source to-build-system)) + + (define (transform-package-name name) + (if (string-prefix? from-prefix name) + (let ((new-name (string-drop name (string-length from-prefix)))) + (if (string-prefix? to-prefix new-name) + new-name + (string-append to-prefix new-name))) + name)) + + (define (has-from-build-system? pkg) + (eq? from-build-system (package-build-system pkg))) + + (define transform + (memoize + (lambda (pkg) + (define rewrite + (match-lambda + ((name content . rest) + (let* ((is-package? (package? content)) + (new-content (if is-package? (transform content) content)) + (new-name (if (and is-package? + (string-prefix? from-prefix name)) + (package-name new-content) + name))) + `(,new-name ,new-content ,@rest))))) + + ;; Special considerations for source packages: CL inputs become + ;; propagated, and un-handled arguments are removed. Native inputs are + ;; removed as are extraneous outputs. + (define new-propagated-inputs + (if target-is-source? + (map rewrite + (filter (match-lambda + ((_ input . _) + (has-from-build-system? input))) + (package-inputs pkg))) + '())) + + (define new-inputs + (if target-is-source? + (map rewrite + (filter (match-lambda + ((_ input . _) + (not (has-from-build-system? input)))) + (package-inputs pkg))) + (map rewrite (package-inputs pkg)))) + + (define base-arguments + (if target-is-source? + (strip-keyword-arguments + '(#:tests? #:special-dependencies #:asd-file + #:test-only-systems #:lisp) + (package-arguments pkg)) + (package-arguments pkg))) + + (cond + ((and variant-property + (assoc-ref (package-properties pkg) variant-property)) + => force) + + ((has-from-build-system? pkg) + (package + (inherit pkg) + (location (package-location pkg)) + (name (transform-package-name (package-name pkg))) + (build-system to-build-system) + (arguments + (substitute-keyword-arguments base-arguments + ((#:phases phases) (list phases-transformer phases)))) + (inputs new-inputs) + (propagated-inputs new-propagated-inputs) + (native-inputs (if target-is-source? + '() + (map rewrite (package-native-inputs pkg)))) + (outputs (if target-is-source? + '("out") + (package-outputs pkg))))) + (else pkg))))) + + transform) + +(define (strip-variant-as-necessary variant pkg) + (define properties (package-properties pkg)) + (if (assoc variant properties) + (package + (inherit pkg) + (properties (alist-delete variant properties))) + pkg)) + +(define (lower lisp-implementation) + (lambda* (name + #:key source inputs outputs native-inputs system target + (lisp (default-lisp (string->symbol lisp-implementation))) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME" + (define private-keywords + '(#:target #:inputs #:native-inputs #:lisp)) + + (and (not target) + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ,@(standard-packages))) + (build-inputs `((,lisp-implementation ,lisp) + ,@native-inputs)) + (outputs outputs) + (build (asdf-build lisp-implementation)) + (arguments (strip-keyword-arguments private-keywords arguments)))))) + +(define (asdf-build lisp-implementation) + (lambda* (store name inputs + #:key source outputs + (tests? #t) + (special-dependencies ''()) + (asd-file #f) + (test-only-systems ''()) + (lisp lisp-implementation) + (phases '(@ (guix build asdf-build-system) + %standard-phases)) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %asdf-build-system-modules) + (modules %asdf-build-modules)) + + (define builder + `(begin + (use-modules ,@modules) + (asdf-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) source) + (source source)) + #:lisp ,lisp + #:special-dependencies ,special-dependencies + #:asd-file ,asd-file + #:test-only-systems ,test-only-systems + #:system ,system + #:tests? ,tests? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build))) + +(define asdf-build-system/sbcl + (build-system + (name 'asdf/sbcl) + (description "The build system for ASDF binary packages using SBCL") + (lower (lower "sbcl")))) + +(define asdf-build-system/ecl + (build-system + (name 'asdf/ecl) + (description "The build system for ASDF binary packages using ECL") + (lower (lower "ecl")))) + +(define asdf-build-system/source + (build-system + (name 'asdf/source) + (description "The build system for ASDF source packages") + (lower lower/source))) + +(define sbcl-package->cl-source-package + (let* ((property 'cl-source-variant) + (transformer + (package-with-build-system asdf-build-system/sbcl + asdf-build-system/source + "sbcl-" + "cl-" + #:variant-property property + #:phases-transformer + '(const %standard-phases/source)))) + (lambda (pkg) + (transformer + (strip-variant-as-necessary property pkg))))) + +(define sbcl-package->ecl-package + (let* ((property 'ecl-variant) + (transformer + (package-with-build-system asdf-build-system/sbcl + asdf-build-system/ecl + "sbcl-" + "ecl-" + #:variant-property property + #:phases-transformer + 'identity))) + (lambda (pkg) + (transformer + (strip-variant-as-necessary property pkg))))) + +;;; asdf.scm ends here diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm new file mode 100644 index 0000000000..085d073dea --- /dev/null +++ b/guix/build/asdf-build-system.scm @@ -0,0 +1,282 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca> +;;; +;;; 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 build asdf-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (guix build lisp-utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 ftw) + #:export (%standard-phases + %standard-phases/source + asdf-build + asdf-build/source)) + +;; Commentary: +;; +;; System for building ASDF packages; creating executable programs and images +;; from them. +;; +;; Code: + +(define %object-prefix "/lib") + +(define (source-install-prefix lisp) + (string-append %install-prefix "/" lisp "-source")) + +(define %system-install-prefix + (string-append %install-prefix "/systems")) + +(define (output-path->package-name path) + (package-name->name+version (strip-store-file-name path))) + +(define (outputs->name outputs) + (output-path->package-name + (assoc-ref outputs "out"))) + +(define (lisp-source-directory output lisp name) + (string-append output (source-install-prefix lisp) "/" name)) + +(define (source-directory output name) + (string-append output %install-prefix "/source/" name)) + +(define (library-directory output lisp) + (string-append output %object-prefix + "/" lisp)) + +(define (output-translation source-path + object-output + lisp) + "Return a translation for the system's source path +to it's binary output." + `((,source-path + :**/ :*.*.*) + (,(library-directory object-output lisp) + :**/ :*.*.*))) + +(define (source-asd-file output lisp name asd-file) + (string-append (lisp-source-directory output lisp name) "/" asd-file)) + +(define (copy-files-to-output outputs output name) + "Copy all files from OUTPUT to \"out\". Create an extra link to any +system-defining files in the source to a convenient location. This is done +before any compiling so that the compiled source locations will be valid." + (let* ((out (assoc-ref outputs output)) + (source (getcwd)) + (target (source-directory out name)) + (system-path (string-append out %system-install-prefix))) + (copy-recursively source target) + (mkdir-p system-path) + (for-each + (lambda (file) + (symlink file + (string-append system-path "/" (basename file)))) + (find-files target "\\.asd$")) + #t)) + +(define* (install #:key outputs #:allow-other-keys) + "Copy and symlink all the source files." + (copy-files-to-output outputs "out" (outputs->name outputs))) + +(define* (copy-source #:key outputs lisp #:allow-other-keys) + "Copy the source to \"out\"." + (let* ((out (assoc-ref outputs "out")) + (name (remove-lisp-from-name (output-path->package-name out) lisp)) + (install-path (string-append out %install-prefix))) + (copy-files-to-output outputs "out" name) + ;; Hide the files from asdf + (with-directory-excursion install-path + (rename-file "source" (string-append lisp "-source")) + (delete-file-recursively "systems"))) + #t) + +(define* (build #:key outputs inputs lisp asd-file + #:allow-other-keys) + "Compile the system." + (let* ((out (assoc-ref outputs "out")) + (name (remove-lisp-from-name (output-path->package-name out) lisp)) + (source-path (lisp-source-directory out lisp name)) + (translations (wrap-output-translations + `(,(output-translation source-path + out + lisp)))) + (asd-file (and=> asd-file (cut source-asd-file out lisp name <>)))) + + (setenv "ASDF_OUTPUT_TRANSLATIONS" + (replace-escaped-macros (format #f "~S" translations))) + + ;; We don't need this if we have the asd file, and it can mess with the + ;; load ordering we're trying to enforce + (unless asd-file + (prepend-to-source-registry (string-append source-path "//"))) + + (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache + + (parameterize ((%lisp (string-append + (assoc-ref inputs lisp) "/bin/" lisp))) + (compile-system name lisp asd-file)) + + ;; As above, ecl will sometimes create this even though it doesn't use it + + (let ((cache-directory (string-append out "/.cache"))) + (when (directory-exists? cache-directory) + (delete-file-recursively cache-directory)))) + #t) + +(define* (check #:key lisp tests? outputs inputs asd-file + #:allow-other-keys) + "Test the system." + (let* ((name (remove-lisp-from-name (outputs->name outputs) lisp)) + (out (assoc-ref outputs "out")) + (asd-file (and=> asd-file (cut source-asd-file out lisp name <>)))) + (if tests? + (parameterize ((%lisp (string-append + (assoc-ref inputs lisp) "/bin/" lisp))) + (test-system name lisp asd-file)) + (format #t "test suite not run~%"))) + #t) + +(define* (patch-asd-files #:key outputs + inputs + lisp + special-dependencies + test-only-systems + #:allow-other-keys) + "Patch any asd files created by the compilation process so that they can +find their dependencies. Exclude any TEST-ONLY-SYSTEMS which were only +included to run tests. Add any SPECIAL-DEPENDENCIES which the LISP +implementation itself provides." + (let* ((out (assoc-ref outputs "out")) + (name (remove-lisp-from-name (output-path->package-name out) lisp)) + (registry (lset-difference + (lambda (input system) + (match input + ((name . path) (string=? name system)))) + (lisp-dependencies lisp inputs) + test-only-systems)) + (lisp-systems (map first registry))) + + (for-each + (lambda (asd-file) + (patch-asd-file asd-file registry lisp + (append lisp-systems special-dependencies))) + (find-files out "\\.asd$"))) + #t) + +(define* (symlink-asd-files #:key outputs lisp #:allow-other-keys) + "Create an extra reference to the system in a convenient location." + (let* ((out (assoc-ref outputs "out"))) + (for-each + (lambda (asd-file) + (substitute* asd-file + ((";;; Built for.*") "") ; remove potential non-determinism + (("^\\(DEFSYSTEM(.*)$" all end) (string-append "(asdf:defsystem" end))) + (receive (new-asd-file asd-file-directory) + (bundle-asd-file out asd-file lisp) + (mkdir-p asd-file-directory) + (symlink asd-file new-asd-file) + ;; Update the source registry for future phases which might want to + ;; use the newly compiled system. + (prepend-to-source-registry + (string-append asd-file-directory "/")))) + + (find-files (string-append out %object-prefix) "\\.asd$")) +) + #t) + +(define* (cleanup-files #:key outputs lisp + #:allow-other-keys) + "Remove any compiled files which are not a part of the final bundle." + (let ((out (assoc-ref outputs "out"))) + (match lisp + ("sbcl" + (for-each + (lambda (file) + (unless (string-suffix? "--system.fasl" file) + (delete-file file))) + (find-files out "\\.fasl$"))) + ("ecl" + (for-each delete-file + (append (find-files out "\\.fas$") + (find-files out "\\.o$") + (find-files out "\\.a$"))))) + + (with-directory-excursion (library-directory out lisp) + (for-each + (lambda (file) + (rename-file file + (string-append "./" (basename file)))) + (find-files ".")) + (for-each delete-file-recursively + (scandir "." + (lambda (file) + (and + (directory-exists? file) + (string<> "." file) + (string<> ".." file))))))) + #t) + +(define* (strip #:key lisp #:allow-other-keys #:rest args) + ;; stripping sbcl binaries removes their entry program and extra systems + (or (string=? lisp "sbcl") + (apply (assoc-ref gnu:%standard-phases 'strip) args))) + +(define %standard-phases/source + (modify-phases gnu:%standard-phases + (delete 'configure) + (delete 'check) + (delete 'build) + (replace 'install install))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'configure) + (delete 'install) + (replace 'build build) + (add-before 'build 'copy-source copy-source) + (replace 'check check) + (replace 'strip strip) + (add-after 'check 'link-dependencies patch-asd-files) + (add-after 'link-dependencies 'cleanup cleanup-files) + (add-after 'cleanup 'create-symlinks symlink-asd-files))) + +(define* (asdf-build #:key inputs + (phases %standard-phases) + #:allow-other-keys + #:rest args) + (apply gnu:gnu-build + #:inputs inputs + #:phases phases + args)) + +(define* (asdf-build/source #:key inputs + (phases %standard-phases/source) + #:allow-other-keys + #:rest args) + (apply gnu:gnu-build + #:inputs inputs + #:phases phases + args)) + +;;; asdf-build-system.scm ends here diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm index 928bef5b9e..51dad17ba7 100644 --- a/guix/build/bournish.scm +++ b/guix/build/bournish.scm @@ -162,6 +162,17 @@ characters." (else `((@@ (guix build bournish) wc-command-implementation) ,@args)))) +(define (reboot-command . args) + "Emit code for 'reboot'." + ;; Normally Bournish is used in the initrd, where 'reboot' is provided + ;; directly by (guile-user). In other cases, just bail out. + `(if (defined? 'reboot) + (reboot) + (begin + (format (current-error-port) + "I don't know how to reboot, sorry about that!~%") + #f))) + (define (help-command . _) (display "\ Hello, this is Bournish, a minimal Bourne-like shell in Guile! @@ -189,7 +200,8 @@ commands such as 'ls' and 'cd'; it lacks globbing, pipes---everything.\n")) ("ls" ,ls-command) ("which" ,which-command) ("cat" ,cat-command) - ("wc" ,wc-command))) + ("wc" ,wc-command) + ("reboot" ,reboot-command))) (define (read-bournish port env) "Read a Bournish expression from PORT, and return the corresponding Scheme diff --git a/guix/build/graft.scm b/guix/build/graft.scm index b08b65b7cf..7025b72fea 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -210,6 +210,32 @@ an exception is caught." (print-exception port #f key args) (primitive-exit 1)))))) +(define* (mkdir-p* dir #:optional (mode #o755)) + "This is a variant of 'mkdir-p' that works around +<http://bugs.gnu.org/24659> by passing MODE explicitly in each 'mkdir' call." + (define absolute? + (string-prefix? "/" dir)) + + (define not-slash + (char-set-complement (char-set #\/))) + + (let loop ((components (string-tokenize dir not-slash)) + (root (if absolute? + "" + "."))) + (match components + ((head tail ...) + (let ((path (string-append root "/" head))) + (catch 'system-error + (lambda () + (mkdir path mode) + (loop tail path)) + (lambda args + (if (= EEXIST (system-error-errno args)) + (loop tail path) + (apply throw args)))))) + (() #t)))) + (define* (rewrite-directory directory output mapping #:optional (store (%store-directory))) "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of @@ -258,7 +284,7 @@ file name pairs." (define (rewrite-leaf file) (let ((stat (lstat file)) (dest (destination file))) - (mkdir-p (dirname dest)) + (mkdir-p* (dirname dest)) (case (stat:type stat) ((symlink) (let ((target (readlink file))) @@ -277,7 +303,7 @@ file name pairs." store) (chmod output (stat:perms stat))))))) ((directory) - (mkdir-p dest)) + (mkdir-p* dest)) (else (error "unsupported file type" stat))))) diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm new file mode 100644 index 0000000000..55a07c7207 --- /dev/null +++ b/guix/build/lisp-utils.scm @@ -0,0 +1,327 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca> +;;; +;;; 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 build lisp-utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (guix build utils) + #:export (%lisp + %install-prefix + lisp-eval-program + compile-system + test-system + replace-escaped-macros + generate-executable-wrapper-system + generate-executable-entry-point + generate-executable-for-system + patch-asd-file + bundle-install-prefix + lisp-dependencies + bundle-asd-file + remove-lisp-from-name + wrap-output-translations + prepend-to-source-registry + build-program + build-image)) + +;;; Commentary: +;;; +;;; Tools to evaluate lisp programs within a lisp session, generate wrapper +;;; systems for executables. Compile, test, and produce images for systems and +;;; programs, and link them with their dependencies. +;;; +;;; Code: + +(define %lisp + ;; File name of the Lisp compiler. + (make-parameter "lisp")) + +(define %install-prefix "/share/common-lisp") + +(define (bundle-install-prefix lisp) + (string-append %install-prefix "/" lisp "-bundle-systems")) + +(define (remove-lisp-from-name name lisp) + (string-drop name (1+ (string-length lisp)))) + +(define (wrap-output-translations translations) + `(:output-translations + ,@translations + :inherit-configuration)) + +(define (lisp-eval-program lisp program) + "Evaluate PROGRAM with a given LISP implementation." + (unless (zero? (apply system* + (lisp-invoke lisp (format #f "~S" program)))) + (error "lisp-eval-program failed!" lisp program))) + +(define (lisp-invoke lisp program) + "Return a list of arguments for system* determining how to invoke LISP +with PROGRAM." + (match lisp + ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program)) + ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)")))) + +(define (asdf-load-all systems) + (map (lambda (system) + `(funcall + (find-symbol + (symbol-name :load-system) + (symbol-name :asdf)) + ,system)) + systems)) + +(define (compile-system system lisp asd-file) + "Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE +first if SYSTEM is defined there." + (lisp-eval-program lisp + `(progn + (require :asdf) + (in-package :asdf) + ,@(if asd-file + `((load ,asd-file)) + '()) + (in-package :cl-user) + (funcall (find-symbol + (symbol-name :operate) + (symbol-name :asdf)) + (find-symbol + (symbol-name :compile-bundle-op) + (symbol-name :asdf)) + ,system) + (funcall (find-symbol + (symbol-name :operate) + (symbol-name :asdf)) + (find-symbol + (symbol-name :deliver-asd-op) + (symbol-name :asdf)) + ,system)))) + +(define (test-system system lisp asd-file) + "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first +if SYSTEM is defined there." + (lisp-eval-program lisp + `(progn + (require :asdf) + (in-package :asdf) + ,@(if asd-file + `((load ,asd-file)) + '()) + (in-package :cl-user) + (funcall (find-symbol + (symbol-name :test-system) + (symbol-name :asdf)) + ,system)))) + +(define (string->lisp-keyword . strings) + "Return a lisp keyword for the concatenation of STRINGS." + (string->symbol (apply string-append ":" strings))) + +(define (generate-executable-for-system type system lisp) + "Use LISP to generate an executable, whose TYPE can be \"image\" or +\"program\". The latter will always be standalone. Depends on having created +a \"SYSTEM-exec\" system which contains the entry program." + (lisp-eval-program + lisp + `(progn + (require :asdf) + (funcall (find-symbol + (symbol-name :operate) + (symbol-name :asdf)) + (find-symbol + (symbol-name ,(string->lisp-keyword type "-op")) + (symbol-name :asdf)) + ,(string-append system "-exec"))))) + +(define (generate-executable-wrapper-system system dependencies) + "Generates a system which can be used by asdf to produce an image or program +inside the current directory. The image or program will contain +DEPENDENCIES." + (with-output-to-file (string-append system "-exec.asd") + (lambda _ + (format #t "~y~%" + `(defsystem ,(string->lisp-keyword system "-exec") + :entry-point ,(string-append system "-exec:main") + :depends-on (:uiop + ,@(map string->lisp-keyword + dependencies)) + :components ((:file ,(string-append system "-exec")))))))) + +(define (generate-executable-entry-point system entry-program) + "Generates an entry point program from the list of lisp statements +ENTRY-PROGRAM for SYSTEM within the current directory." + (with-output-to-file (string-append system "-exec.lisp") + (lambda _ + (let ((system (string->lisp-keyword system "-exec"))) + (format #t "~{~y~%~%~}" + `((defpackage ,system + (:use :cl) + (:export :main)) + + (in-package ,system) + + (defun main () + (let ((arguments uiop:*command-line-arguments*)) + (declare (ignorable arguments)) + ,@entry-program)))))))) + +(define (wrap-perform-method lisp registry dependencies file-name) + "Creates a wrapper method which allows the system to locate its dependent +systems from REGISTRY, an alist of the same form as %outputs, which contains +lisp systems which the systems is dependent on. All DEPENDENCIES which the +system depends on will the be loaded before this system." + (let* ((system (string-drop-right (basename file-name) 4)) + (system-symbol (string->lisp-keyword system))) + + `(defmethod asdf:perform :before + (op (c (eql (asdf:find-system ,system-symbol)))) + (asdf/source-registry:ensure-source-registry) + ,@(map (match-lambda + ((name . path) + (let ((asd-file (string-append path + (bundle-install-prefix lisp) + "/" name ".asd"))) + `(setf + (gethash ,name + asdf/source-registry:*source-registry*) + ,(string->symbol "#p") + ,(bundle-asd-file path asd-file lisp))))) + registry) + ,@(map (lambda (system) + `(asdf:load-system ,(string->lisp-keyword system))) + dependencies)))) + +(define (patch-asd-file asd-file registry lisp dependencies) + "Patches ASD-FILE with a perform method as described in WRAP-PERFORM-METHOD." + (chmod asd-file #o644) + (let ((port (open-file asd-file "a"))) + (dynamic-wind + (lambda _ #t) + (lambda _ + (display + (replace-escaped-macros + (format #f "~%~y~%" + (wrap-perform-method lisp registry + dependencies asd-file))) + port)) + (lambda _ (close-port port)))) + (chmod asd-file #o444)) + +(define (lisp-dependencies lisp inputs) + "Determine which inputs are lisp system dependencies, by using the convention +that a lisp system dependency will resemble \"system-LISP\"." + (filter-map (match-lambda + ((name . value) + (and (string-prefix? lisp name) + (string<> lisp name) + `(,(remove-lisp-from-name name lisp) + . ,value)))) + inputs)) + +(define (bundle-asd-file output-path original-asd-file lisp) + "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in +OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd. Returns two +values: the asd file itself and the directory in which it resides." + (let ((bundle-asd-path (string-append output-path + (bundle-install-prefix lisp)))) + (values (string-append bundle-asd-path "/" (basename original-asd-file)) + bundle-asd-path))) + +(define (replace-escaped-macros string) + "Replace simple lisp forms that the guile writer escapes, for example by +replacing #{#p}# with #p. Should only be used to replace truly simple forms +which are not nested." + (regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string + 'pre 2 'post)) + +(define (prepend-to-source-registry path) + (setenv "CL_SOURCE_REGISTRY" + (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") "")))) + +(define* (build-program lisp program #:key inputs + (dependencies (list (basename program))) + entry-program + #:allow-other-keys) + "Generate an executable program containing all DEPENDENCIES, and which will +execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it +will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments' +has been bound to the command-line arguments which were passed." + (generate-executable lisp program + #:inputs inputs + #:dependencies dependencies + #:entry-program entry-program + #:type "program") + (let* ((name (basename program)) + (bin-directory (dirname program))) + (with-directory-excursion bin-directory + (rename-file (string-append name "-exec") + name))) + #t) + +(define* (build-image lisp image #:key inputs + (dependencies (list (basename image))) + #:allow-other-keys) + "Generate an image, possibly standalone, which contains all DEPENDENCIES, +placing the result in IMAGE.image." + (generate-executable lisp image + #:inputs inputs + #:dependencies dependencies + #:entry-program '(nil) + #:type "image") + (let* ((name (basename image)) + (bin-directory (dirname image))) + (with-directory-excursion bin-directory + (rename-file (string-append name "-exec--all-systems.image") + (string-append name ".image")))) + #t) + +(define* (generate-executable lisp out-file #:key inputs + dependencies + entry-program + type + #:allow-other-keys) + "Generate an executable by using asdf's TYPE-op, containing whithin the +image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an +executable." + (let* ((bin-directory (dirname out-file)) + (name (basename out-file))) + (mkdir-p bin-directory) + (with-directory-excursion bin-directory + (generate-executable-wrapper-system name dependencies) + (generate-executable-entry-point name entry-program)) + + (prepend-to-source-registry + (string-append bin-directory "/")) + + (setenv "ASDF_OUTPUT_TRANSLATIONS" + (replace-escaped-macros + (format + #f "~S" + (wrap-output-translations + `(((,bin-directory :**/ :*.*.*) + (,bin-directory :**/ :*.*.*))))))) + + (parameterize ((%lisp (string-append + (assoc-ref inputs lisp) "/bin/" lisp))) + (generate-executable-for-system type name lisp)) + + (delete-file (string-append bin-directory "/" name "-exec.asd")) + (delete-file (string-append bin-directory "/" name "-exec.lisp")))) diff --git a/guix/import/github.scm b/guix/import/github.scm index 9ba9a10ba0..0843ddeefd 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -44,7 +44,7 @@ failure." "Return the extension of the archive e.g. '.tar.gz' given a URL, or false if none is recognized" (find (lambda (x) (string-suffix? x url)) - (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar" ".tgz"))) + (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar" ".tgz" ".love"))) (define (updated-github-url old-package new-version) ;; Return a url for the OLD-PACKAGE with NEW-VERSION. If no source url in diff --git a/guix/licenses.scm b/guix/licenses.scm index 8a98b0960a..ff214cf957 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2016 Leo Famulari <leo@famulari.name> ;;; Copyright © 2016 Fabian Harfert <fhmgufs@web.de> ;;; Copyright © 2016 Rene Saavedra <rennes@openmailbox.org> +;;; Copyright © 2016 ng0 <ngillmann@runbox.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,6 +44,7 @@ epl1.0 expat freetype + freebsd-doc giftware gpl1 gpl1+ gpl2 gpl2+ gpl3 gpl3+ gfl1.0 @@ -286,6 +288,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.gnu.org/licenses/fdl.html" "https://www.gnu.org/licenses/license-list#FDL")) +(define freebsd-doc + (license "FreeBSD Documentation License" + "https://www.freebsd.org/copyright/freebsd-doc-license.html" + "https://www.gnu.org/licenses/license-list.html#FreeBSDDL")) + (define opl1.0+ (license "Open Publication License 1.0 or later" "http://opencontent.org/openpub/" diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 21e0613a8a..8f50477801 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -391,7 +391,7 @@ No authentication and authorization checks are performed here!" (define* (assert-valid-narinfo narinfo #:optional (acl (current-acl)) - #:key (verbose? #t)) + #:key verbose?) "Raise an exception if NARINFO lacks a signature, has an invalid signature, or is signed by an unauthorized key." (let ((hash (narinfo-sha256 narinfo))) @@ -404,9 +404,8 @@ or is signed by an unauthorized key." (unless %allow-unauthenticated-substitutes? (assert-valid-signature narinfo signature hash acl) (when verbose? - ;; Visually separate substitutions with a newline. (format (current-error-port) - (_ "~%Found valid signature for ~a~%") + (_ "Found valid signature for ~a~%") (narinfo-path narinfo)) (format (current-error-port) (_ "From ~a~%") @@ -893,7 +892,7 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; "(4.1MiB installed)"; it shows the size of the package once ;; installed. (_ "Downloading ~a~:[~*~; (~a installed)~]...~%") - (store-path-abbreviation store-item) + (uri->string uri) ;; Use the Nar size as an estimate of the installed size. (narinfo-size narinfo) (and=> (narinfo-size narinfo) @@ -921,8 +920,9 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) - ;; Skip a line after what 'progress-proc' printed. - (newline (current-error-port)) + ;; Skip a line after what 'progress-proc' printed, and another one to + ;; visually separate substitutions. + (display "\n\n" (current-error-port)) (every (compose zero? cdr waitpid) pids)))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index a2cd97ac1f..0519ab8c0b 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -227,25 +227,20 @@ BODY..., and restore them." (set! %load-path path) (set! %load-compiled-path cpath))))) -(define-syntax-rule (warn-on-system-error body ...) - (catch 'system-error - (lambda () - body ...) - (lambda (key proc format-string format-args errno . rest) - (warning (_ "while talking to shepherd: ~a~%") - (apply format #f format-string format-args)) - (with-monad %store-monad - (return #f))))) - (define-syntax-rule (with-shepherd-error-handling mbody ...) "Catch and report Shepherd errors that arise when binding MBODY, a monadic expression in %STORE-MONAD." (lambda (store) - (warn-on-system-error - (guard (c ((shepherd-error? c) - (values (report-shepherd-error c) store))) - (values (run-with-store store (begin mbody ...)) - store))))) + (catch 'system-error + (lambda () + (guard (c ((shepherd-error? c) + (values (report-shepherd-error c) store))) + (values (run-with-store store (begin mbody ...)) + store))) + (lambda (key proc format-string format-args errno . rest) + (warning (_ "while talking to shepherd: ~a~%") + (apply format #f format-string format-args)) + (values #f store))))) (define (report-shepherd-error error) "Report ERROR, a '&shepherd-error' error condition object." diff --git a/guix/utils.scm b/guix/utils.scm index c68094cf49..decadf64a6 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -369,19 +369,30 @@ keywords not already present in ARGS." (match defaults ((kw value rest ...) (loop rest - (if (assoc-ref kw args) + (if (memq kw args) args (cons* kw value args)))) (() args)))) +(define-syntax collect-default-args + (syntax-rules () + ((_) + '()) + ((_ (_ _) rest ...) + (collect-default-args rest ...)) + ((_ (kw _ dflt) rest ...) + (cons* kw dflt (collect-default-args rest ...))))) + (define-syntax substitute-keyword-arguments (syntax-rules () "Return a new list of arguments where the value for keyword arg KW is -replaced by EXP. EXP is evaluated in a context where VAR is boud to the -previous value of the keyword argument." - ((_ original-args ((kw var) exp) ...) - (let loop ((args original-args) +replaced by EXP. EXP is evaluated in a context where VAR is bound to the +previous value of the keyword argument, or DFLT if given." + ((_ original-args ((kw var dflt ...) exp) ...) + (let loop ((args (default-keyword-arguments + original-args + (collect-default-args (kw var dflt ...) ...))) (before '())) (match args ((kw var rest (... ...)) |