From 4b41febf9c73d9d933b4873edadf9693ae4d5bb3 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 11 Dec 2016 21:17:40 +0000 Subject: services: mysql: Add port to configuration MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/databases.scm (): Add port field. (mysql-configuration-file): Use the port field when creating the configuration file. * doc/guix.texi (Database Services): Document it. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 3 +++ 1 file changed, 3 insertions(+) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 0cb1bc7665..f1c5963f76 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10177,6 +10177,9 @@ or @var{mysql}. For MySQL, a temporary root password will be displayed at activation time. For MariaDB, the root password is empty. + +@item @code{port} (default: @code{3306}) +TCP port on which the database server listens for incoming connections. @end table @end deftp -- cgit 1.4.1 From 3e0c036584b41bcc08a8c8e040295716108bb0b2 Mon Sep 17 00:00:00 2001 From: David Craven Date: Thu, 22 Sep 2016 11:40:58 +0200 Subject: import: Add importer for rust crates. * guix/import/crate.scm: New file. * guix/scripts/import/crate.scm: New file. * guix/scripts/import.scm (importers): Add crate importer. * tests/crate.scm: New file. * doc/guix.texi: Add crate importer to table. * Makefile.am (MODULES, SCM_TESTS): Add files. --- Makefile.am | 5 +- doc/guix.texi | 5 ++ guix/import/crate.scm | 125 ++++++++++++++++++++++++++++++++++++++++++ guix/scripts/import.scm | 2 +- guix/scripts/import/crate.scm | 94 +++++++++++++++++++++++++++++++ guix/scripts/refresh.scm | 1 + tests/crate.scm | 102 ++++++++++++++++++++++++++++++++++ 7 files changed, 332 insertions(+), 2 deletions(-) create mode 100644 guix/import/crate.scm create mode 100644 guix/scripts/import/crate.scm create mode 100644 tests/crate.scm (limited to 'doc/guix.texi') diff --git a/Makefile.am b/Makefile.am index 5cb4261f4b..84ff6642a2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -122,6 +122,7 @@ MODULES = \ guix/import/snix.scm \ guix/import/cabal.scm \ guix/import/cran.scm \ + guix/import/crate.scm \ guix/import/hackage.scm \ guix/import/elpa.scm \ guix/scripts.scm \ @@ -141,6 +142,7 @@ MODULES = \ guix/scripts/lint.scm \ guix/scripts/challenge.scm \ guix/scripts/import/cran.scm \ + guix/scripts/import/crate.scm \ guix/scripts/import/gnu.scm \ guix/scripts/import/nix.scm \ guix/scripts/import/hackage.scm \ @@ -282,7 +284,8 @@ if HAVE_GUILE_JSON SCM_TESTS += \ tests/pypi.scm \ tests/cpan.scm \ - tests/gem.scm + tests/gem.scm \ + tests/crate.scm endif diff --git a/doc/guix.texi b/doc/guix.texi index f1c5963f76..5db20ecdfa 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5267,6 +5267,11 @@ signatures,, emacs, The GNU Emacs Manual}). identifier. @end itemize @end table + +@item crate +@cindex crate +Import metadata from the crates.io Rust package repository +@uref{https://crates.io, crates.io}. @end table The structure of the @command{guix import} code is modular. It would be diff --git a/guix/import/crate.scm b/guix/import/crate.scm new file mode 100644 index 0000000000..e78e3ad9ca --- /dev/null +++ b/guix/import/crate.scm @@ -0,0 +1,125 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 David Craven +;;; +;;; 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 . + +(define-module (guix import crate) + #:use-module (guix base32) + #:use-module (guix build-system cargo) + #:use-module ((guix download) #:prefix download:) + #:use-module (guix hash) + #:use-module (guix http-client) + #:use-module (guix import json) + #:use-module (guix import utils) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) ; recursive + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-26) + #:export (crate->guix-package + guix-package->crate-name)) + +(define (crate-fetch crate-name callback) + "Fetch the metadata for CRATE-NAME from crates.io and call the callback." + + (define (crates->inputs crates) + (sort (map (cut assoc-ref <> "crate_id") crates) string-cilicense string) + (map spdx-string->license (string-split string #\/))) + + (define (crate-kind-predicate kind) + (lambda (dep) (string=? (assoc-ref dep "kind") kind))) + + (and-let* ((crate-json (json-fetch (string-append crate-url crate-name))) + (crate (assoc-ref crate-json "crate")) + (name (assoc-ref crate "name")) + (version (assoc-ref crate "max_version")) + (home-page (assoc-ref crate "homepage")) + (synopsis (assoc-ref crate "description")) + (description (assoc-ref crate "description")) + (license (string->license (assoc-ref crate "license"))) + (path (string-append "/" version "/dependencies")) + (deps-json (json-fetch (string-append crate-url name path))) + (deps (assoc-ref deps-json "dependencies")) + (input-crates (filter (crate-kind-predicate "normal") deps)) + (native-input-crates + (filter (lambda (dep) + (not ((crate-kind-predicate "normal") dep))) deps)) + (inputs (crates->inputs input-crates)) + (native-inputs (crates->inputs native-input-crates))) + (callback #:name name #:version version + #:inputs inputs #:native-inputs native-inputs + #:home-page home-page #:synopsis synopsis + #:description description #:license license))) + +(define* (make-crate-sexp #:key name version inputs native-inputs + home-page synopsis description license + #:allow-other-keys) + "Return the `package' s-expression for a rust package with the given NAME, +VERSION, INPUTS, NATIVE-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." + (let* ((port (http-fetch (crate-uri name version))) + (guix-name (crate-name->package-name name)) + (inputs (map crate-name->package-name inputs)) + (native-inputs (map crate-name->package-name native-inputs)) + (pkg `(package + (name ,guix-name) + (version ,version) + (source (origin + (method url-fetch) + (uri (crate-uri ,name version)) + (file-name (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + ,(bytevector->nix-base32-string (port-sha256 port)))))) + (build-system cargo-build-system) + ,@(maybe-native-inputs native-inputs) + ,@(maybe-inputs inputs) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,(beautify-description description)) + (license ,(match license + (() #f) + ((license) license) + (_ `(list ,@license))))))) + (close-port port) + pkg)) + +(define (crate->guix-package crate-name) + "Fetch the metadata for CRATE-NAME from crates.io, and return the +`package' s-expression corresponding to that package, or #f on failure." + (crate-fetch crate-name make-crate-sexp)) + +(define (guix-package->crate-name package) + "Return the crate name of PACKAGE." + (and-let* ((origin (package-source package)) + (uri (origin-uri origin)) + (crate-url? uri) + (len (string-length crate-url)) + (path (xsubstring uri len)) + (parts (string-split path #\/))) + (match parts + ((name _ ...) name)))) + +(define (crate-name->package-name name) + (string-append "rust-" (string-join (string-split name #\_) "-"))) + diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index e54744feca..c671686043 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -73,7 +73,7 @@ rather than \\n." ;;; Entry point. ;;; -(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran")) +(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran" "crate")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm new file mode 100644 index 0000000000..4337a0b623 --- /dev/null +++ b/guix/scripts/import/crate.scm @@ -0,0 +1,94 @@ + +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson +;;; Copyright © 2016 David Craven +;;; +;;; 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 . + +(define-module (guix scripts import crate) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import crate) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-crate)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import crate PACKAGE-NAME +Import and convert the crate.io package for PACKAGE-NAME.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import crate"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-crate . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (let ((sexp (crate->guix-package package-name))) + (unless sexp + (leave (_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp)) + (() + (leave (_ "too few arguments~%"))) + ((many ...) + (leave (_ "too many arguments~%")))))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index f8fb3f80ca..72f51cbff8 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -39,6 +39,7 @@ %kernel.org-updater)) #:use-module (guix import elpa) #:use-module (guix import cran) + #:use-module (guix import crate) #:use-module (guix import hackage) #:use-module (guix gnupg) #:use-module (gnu packages) diff --git a/tests/crate.scm b/tests/crate.scm new file mode 100644 index 0000000000..18d5f72a8c --- /dev/null +++ b/tests/crate.scm @@ -0,0 +1,102 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson +;;; Copyright © 2016 David Craven +;;; +;;; 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 . + +(define-module (test-crate) + #:use-module (guix import crate) + #:use-module (guix base32) + #:use-module (guix build-system cargo) + #:use-module (guix hash) + #:use-module (guix tests) + #:use-module (ice-9 iconv) + #:use-module (ice-9 match) + #:use-module (srfi srfi-64)) + +(define test-crate + "{ + \"crate\": { + \"max_version\": \"1.0.0\", + \"name\": \"foo\", + \"license\": \"MIT/Apache-2.0\", + \"description\": \"summary\", + \"homepage\": \"http://example.com\", + } +}") + +(define test-dependencies + "{ + \"dependencies\": [ + { + \"crate_id\": \"bar\", + \"kind\": \"normal\", + } + ] +}") + +(define test-source-hash + "") + +(test-begin "crate") + +(test-equal "guix-package->crate-name" + "rustc-serialize" + (guix-package->crate-name + (dummy-package + "rust-rustc-serialize" + (source (dummy-origin + (uri (crate-uri "rustc-serialize" "1.0"))))))) + +(test-assert "crate->guix-package" + ;; Replace network resources with sample data. + (mock ((guix http-client) http-fetch + (lambda (url) + (match url + ("https://crates.io/api/v1/crates/foo" + (open-input-string test-crate)) + ("https://crates.io/api/v1/crates/foo/1.0.0/download" + (set! test-source-hash + (bytevector->nix-base32-string + (sha256 (string->bytevector "empty file\n" "utf-8")))) + (open-input-string "empty file\n")) + ("https://crates.io/api/v1/crates/foo/1.0.0/dependencies" + (open-input-string test-dependencies)) + (_ (error "Unexpected URL: " url))))) + (match (crate->guix-package "foo") + (('package + ('name "rust-foo") + ('version "1.0.0") + ('source ('origin + ('method 'url-fetch) + ('uri ('crate-uri "foo" 'version)) + ('file-name ('string-append 'name "-" 'version ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'cargo-build-system) + ('inputs + ('quasiquote + (("rust-bar" ('unquote 'rust-bar))))) + ('home-page "http://example.com") + ('synopsis "summary") + ('description "summary") + ('license ('list 'license:expat 'license:asl2.0))) + (string=? test-source-hash hash)) + (x + (pk 'fail x #f))))) + +(test-end "crate") -- cgit 1.4.1 From 8ac529878640de632356895fbcaeeed6c1cb335e Mon Sep 17 00:00:00 2001 From: David Craven Date: Thu, 22 Sep 2016 11:40:58 +0200 Subject: import: Add updater for rust crates. * guix/import/crate.scm (crate-package?, latest-release, %crate-updater): New variables. * guix/scripts/refresh.scm (%updaters): Add crate updater. * doc/guix.texi: Add crate updater to table. --- doc/guix.texi | 2 ++ guix/import/crate.scm | 36 +++++++++++++++++++++++++++++++++++- guix/scripts/refresh.scm | 3 ++- 3 files changed, 39 insertions(+), 2 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 5db20ecdfa..a5424b4e01 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5396,6 +5396,8 @@ the updater for @uref{https://rubygems.org, RubyGems} packages. the updater for @uref{https://github.com, GitHub} packages. @item hackage the updater for @uref{https://hackage.haskell.org, Hackage} packages. +@item crate +the updater for @uref{https://crates.io, Crates} packages. @end table For instance, the following command only checks for updates of Emacs diff --git a/guix/import/crate.scm b/guix/import/crate.scm index e78e3ad9ca..3a19fc70cf 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -36,7 +36,8 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-26) #:export (crate->guix-package - guix-package->crate-name)) + guix-package->crate-name + %crate-updater)) (define (crate-fetch crate-name callback) "Fetch the metadata for CRATE-NAME from crates.io and call the callback." @@ -123,3 +124,36 @@ VERSION, INPUTS, NATIVE-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (define (crate-name->package-name name) (string-append "rust-" (string-join (string-split name #\_) "-"))) +;;; +;;; Updater +;;; + +(define (crate-package? package) + "Return true if PACKAGE is a Rust crate from crates.io." + (let ((source-url (and=> (package-source package) origin-uri)) + (fetch-method (and=> (package-source package) origin-method))) + (and (eq? fetch-method download:url-fetch) + (match source-url + ((? string?) + (crate-url? source-url)) + ((source-url ...) + (any crate-url? source-url)))))) + +(define (latest-release package) + "Return an for the latest release of PACKAGE." + (let* ((crate-name (guix-package->crate-name package)) + (callback (lambda* (#:key version #:allow-other-keys) version)) + (version (crate-fetch crate-name callback)) + (url (crate-uri crate-name version))) + (upstream-source + (package (package-name package)) + (version version) + (urls (list url))))) + +(define %crate-updater + (upstream-updater + (name 'crates) + (description "Updater for crates.io packages") + (pred crate-package?) + (latest latest-release))) + diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 72f51cbff8..2a06405a14 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -210,7 +210,8 @@ unavailable optional dependencies such as Guile-JSON." ((guix import cpan) => %cpan-updater) ((guix import pypi) => %pypi-updater) ((guix import gem) => %gem-updater) - ((guix import github) => %github-updater))) + ((guix import github) => %github-updater) + ((guix import crate) => %crate-updater))) (define (lookup-updater-by-name name) "Return the updater called NAME." -- cgit 1.4.1 From 642339dc3fc6df33edd78f3cdc170c20a32a3c7d Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 21 Oct 2016 23:59:00 +0200 Subject: graph: Add "list-backend" and "backend" options. * guix/graph.scm (%graph-backends): New variable. * guix/scripts/graph.scm (lookup-backend, list-backends): New procedures. (%options): Add options for "backend" and "list-backends". (show-help): Add help texts for "backend" and "list-backend" options. (%default-options): Add "backend" default. (guix-graph): Pass backend argument to "export-graph". * doc/guix.texi (Invoking guix graph): Document the new options. --- doc/guix.texi | 7 +++++++ guix/graph.scm | 10 ++++++++++ guix/scripts/graph.scm | 36 ++++++++++++++++++++++++++++++++++-- 3 files changed, 51 insertions(+), 2 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index a5424b4e01..83f52484e6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5827,6 +5827,13 @@ the values listed above. @item --list-types List the supported graph types. +@item --backend=@var{backend} +@itemx -b @var{backend} +Produce a graph using the selected @var{backend}. + +@item --list-backends +List the supported graph backends. + @item --expression=@var{expr} @itemx -e @var{expr} Consider the package @var{expr} evaluates to. diff --git a/guix/graph.scm b/guix/graph.scm index 5cf98f0d54..d2c1fa6c48 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2016 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,6 +42,7 @@ node-transitive-edges node-reachable-count + %graph-backends %graphviz-backend graph-backend? graph-backend @@ -179,6 +181,14 @@ typically returned by 'node-edges' or 'node-back-edges'." emit-prologue emit-epilogue emit-node emit-edge)) + +;;; +;;; Shared. +;;; + +(define %graph-backends + (list %graphviz-backend)) + (define* (export-graph sinks port #:key reverse-edges? node-type diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 2f70d64c90..d96df5fbaf 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -337,6 +337,13 @@ substitutes." %node-types) (leave (_ "~a: unknown node type~%") name))) +(define (lookup-backend name) + "Return the graph backend called NAME. Raise an error if it is not found." + (or (find (lambda (backend) + (string=? (graph-backend-name backend) name)) + %graph-backends) + (leave (_ "~a: unknown backend~%") name))) + (define (list-node-types) "Print the available node types along with their synopsis." (display (_ "The available node types are:\n")) @@ -347,6 +354,16 @@ substitutes." (node-type-description type))) %node-types)) +(define (list-backends) + "Print the available backends along with their synopsis." + (display (_ "The available backend types are:\n")) + (newline) + (for-each (lambda (backend) + (format #t " - ~a: ~a~%" + (graph-backend-name backend) + (graph-backend-description backend))) + %graph-backends)) + ;;; ;;; Command-line options. @@ -361,6 +378,14 @@ substitutes." (lambda (opt name arg result) (list-node-types) (exit 0))) + (option '(#\b "backend") #t #f + (lambda (opt name arg result) + (alist-cons 'backend (lookup-backend arg) + result))) + (option '("list-backends") #f #f + (lambda (opt name arg result) + (list-backends) + (exit 0))) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) @@ -378,6 +403,10 @@ substitutes." (display (_ "Usage: guix graph PACKAGE... Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (display (_ " + -b, --backend=TYPE produce a graph with the given backend TYPE")) + (display (_ " + --list-backends list the available graph backends")) + (display (_ " -t, --type=TYPE represent nodes of the given TYPE")) (display (_ " --list-types list the available graph types")) @@ -392,7 +421,8 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (show-bug-report-information)) (define %default-options - `((node-type . ,%package-node-type))) + `((node-type . ,%package-node-type) + (backend . ,%graphviz-backend))) ;;; @@ -407,6 +437,7 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) + (backend (assoc-ref opts 'backend)) (type (assoc-ref opts 'node-type)) (items (filter-map (match-lambda (('argument . (? store-path? item)) @@ -429,7 +460,8 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) items))) (export-graph (concatenate nodes) (current-output-port) - #:node-type type))))))) + #:node-type type + #:backend backend))))))) #t) ;;; graph.scm ends here -- cgit 1.4.1 From ddf1cd519c7aea90e18accbbb62dd008390f713a Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Wed, 14 Dec 2016 20:37:27 +0100 Subject: doc: Replace dead Google Code home page for cryptsetup. * doc/guix.texi (Mapped Devices): Update cryptsetup home page. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 83f52484e6..f1e43c1e11 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7605,7 +7605,7 @@ for RAID-4, RAID-5 or RAID-6, or @code{raid10} for RAID-10. @cindex LUKS The following example specifies a mapping from @file{/dev/sda3} to @file{/dev/mapper/home} using LUKS---the -@url{http://code.google.com/p/cryptsetup,Linux Unified Key Setup}, a +@url{https://gitlab.com/cryptsetup/cryptsetup,Linux Unified Key Setup}, a standard mechanism for disk encryption. The @file{/dev/mapper/home} device can then be used as the @code{device} of a @code{file-system} -- cgit 1.4.1 From 200cdf81c6e5b92dc486b705d158a4a8565f5f40 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Wed, 14 Dec 2016 21:11:09 -0600 Subject: doc: mention cpan updater. * doc/guix.texi (Invoking guix refresh): Mention cpan updater. --- doc/guix.texi | 2 ++ 1 file changed, 2 insertions(+) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index f1e43c1e11..0a92bd6b5c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5388,6 +5388,8 @@ the updater for @uref{http://elpa.gnu.org/, ELPA} packages; the updater for @uref{http://cran.r-project.org/, CRAN} packages; @item bioconductor the updater for @uref{http://www.bioconductor.org/, Bioconductor} R packages; +@item cpan +the updater for @uref{http://www.cpan.org/, CPAN} packages; @item pypi the updater for @uref{https://pypi.python.org, PyPI} packages. @item gem -- cgit 1.4.1 From 2d3d5cc5ea9d4b991f2f640543ad70c902bc0191 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 14 Dec 2016 08:35:48 +0000 Subject: services: postgresql: Add port to configuration MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/databases.scm (): Add port field. (postgresql-shepherd-service): Pass port to postgres. (postgresql-service): Add port default. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 7 ++++--- gnu/services/databases.scm | 9 +++++++-- 2 files changed, 11 insertions(+), 5 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 0a92bd6b5c..cc90ca5775 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10166,13 +10166,14 @@ Users need to be in the @code{lp} group to access the D-Bus service. The @code{(gnu services databases)} module provides the following services. @deffn {Scheme Procedure} postgresql-service [#:postgresql postgresql] @ - [#:config-file] [#:data-directory ``/var/lib/postgresql/data''] + [#:config-file] [#:data-directory ``/var/lib/postgresql/data''] @ + [#:port 5432] Return a service that runs @var{postgresql}, the PostgreSQL database server. The PostgreSQL daemon loads its runtime configuration from -@var{config-file} and stores the database cluster in -@var{data-directory}. +@var{config-file}, stores the database cluster in @var{data-directory} and +listens on @var{port}. @end deffn @deffn {Scheme Procedure} mysql-service [#:config (mysql-configuration)] diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index f7e08e6967..7cdcfc4d79 100644 --- a/gnu/services/databases.scm +++ b/gnu/services/databases.scm @@ -48,6 +48,8 @@ postgresql-configuration? (postgresql postgresql-configuration-postgresql ; (default postgresql)) + (port postgresql-configuration-port + (default 5432)) (config-file postgresql-configuration-file) (data-directory postgresql-configuration-data-directory)) @@ -80,7 +82,7 @@ host all all ::1/128 trust")) (define postgresql-activation (match-lambda - (($ postgresql config-file data-directory) + (($ postgresql port config-file data-directory) #~(begin (use-modules (guix build utils) (ice-9 match)) @@ -108,7 +110,7 @@ host all all ::1/128 trust")) (define postgresql-shepherd-service (match-lambda - (($ postgresql config-file data-directory) + (($ postgresql port config-file data-directory) (let ((start-script ;; Wrapper script that switches to the 'postgres' user before ;; launching daemon. @@ -121,6 +123,7 @@ host all all ::1/128 trust")) (system* postgres (string-append "--config-file=" #$config-file) + "-p" (number->string #$port) "-D" #$data-directory))))) (list (shepherd-service (provision '(postgres)) @@ -140,6 +143,7 @@ host all all ::1/128 trust")) (const %postgresql-accounts)))))) (define* (postgresql-service #:key (postgresql postgresql) + (port 5432) (config-file %default-postgres-config) (data-directory "/var/lib/postgresql/data")) "Return a service that runs @var{postgresql}, the PostgreSQL database server. @@ -149,6 +153,7 @@ and stores the database cluster in @var{data-directory}." (service postgresql-service-type (postgresql-configuration (postgresql postgresql) + (port port) (config-file config-file) (data-directory data-directory)))) -- cgit 1.4.1 From e05b780a58d561080f71a81e9a388a5a4b26767a Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 14 Dec 2016 08:35:49 +0000 Subject: services: postgresql: Add locale to configuration MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/databases.scm (): Add locale field. (postgresql-shepherd-service): Pass locale to initdb. (postgresql-service): Add locale default. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 8 ++++---- gnu/services/databases.scm | 22 ++++++++++++++++++---- 2 files changed, 22 insertions(+), 8 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index cc90ca5775..46ed451d6b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10167,13 +10167,13 @@ The @code{(gnu services databases)} module provides the following services. @deffn {Scheme Procedure} postgresql-service [#:postgresql postgresql] @ [#:config-file] [#:data-directory ``/var/lib/postgresql/data''] @ - [#:port 5432] + [#:port 5432] [#:locale ``en_US.utf8''] Return a service that runs @var{postgresql}, the PostgreSQL database server. -The PostgreSQL daemon loads its runtime configuration from -@var{config-file}, stores the database cluster in @var{data-directory} and -listens on @var{port}. +The PostgreSQL daemon loads its runtime configuration from @var{config-file}, +creates a database cluster with @var{locale} as the default +locale, stored in @var{data-directory}. It then listens on @var{port}. @end deffn @deffn {Scheme Procedure} mysql-service [#:config (mysql-configuration)] diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index 7cdcfc4d79..d88c839f7d 100644 --- a/gnu/services/databases.scm +++ b/gnu/services/databases.scm @@ -50,6 +50,8 @@ (default postgresql)) (port postgresql-configuration-port (default 5432)) + (locale postgresql-configuration-locale + (default "en_US.utf8")) (config-file postgresql-configuration-file) (data-directory postgresql-configuration-data-directory)) @@ -82,13 +84,18 @@ host all all ::1/128 trust")) (define postgresql-activation (match-lambda - (($ postgresql port config-file data-directory) + (($ postgresql port locale config-file data-directory) #~(begin (use-modules (guix build utils) (ice-9 match)) (let ((user (getpwnam "postgres")) - (initdb (string-append #$postgresql "/bin/initdb"))) + (initdb (string-append #$postgresql "/bin/initdb")) + (initdb-args + (append + (if #$locale + (list (string-append "--locale=" #$locale)) + '())))) ;; Create db state directory. (mkdir-p #$data-directory) (chown #$data-directory (passwd:uid user) (passwd:gid user)) @@ -103,14 +110,19 @@ host all all ::1/128 trust")) (lambda () (setgid (passwd:gid user)) (setuid (passwd:uid user)) - (primitive-exit (system* initdb "-D" #$data-directory))) + (primitive-exit + (apply system* + initdb + "-D" + #$data-directory + initdb-args))) (lambda () (primitive-exit 1)))) (pid (waitpid pid)))))))) (define postgresql-shepherd-service (match-lambda - (($ postgresql port config-file data-directory) + (($ postgresql port locale config-file data-directory) (let ((start-script ;; Wrapper script that switches to the 'postgres' user before ;; launching daemon. @@ -144,6 +156,7 @@ host all all ::1/128 trust")) (define* (postgresql-service #:key (postgresql postgresql) (port 5432) + (locale "en_US.utf8") (config-file %default-postgres-config) (data-directory "/var/lib/postgresql/data")) "Return a service that runs @var{postgresql}, the PostgreSQL database server. @@ -154,6 +167,7 @@ and stores the database cluster in @var{data-directory}." (postgresql-configuration (postgresql postgresql) (port port) + (locale locale) (config-file config-file) (data-directory data-directory)))) -- cgit 1.4.1 From 5597b3ae0809abd9d94099ea5cd09c2a176e3f6f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 15 Dec 2016 22:46:09 +0100 Subject: doc: "Nar" now means "normalized archive". * doc/guix.texi (Invoking guix archive): Mention "normalized archive" and add index entries. --- doc/guix.texi | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 46ed451d6b..bd782cab03 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2403,10 +2403,12 @@ profile as well as all of their dependencies are transferred (due to target machine. The @code{--missing} option can help figure out which items are missing from the target store. -Archives are stored in the ``Nix archive'' or ``Nar'' format, which is -comparable in spirit to `tar', but with a few noteworthy differences +@cindex nar, archive format +@cindex normalized archive (nar) +Archives are stored in the ``normalized archive'' or ``nar'' format, which is +comparable in spirit to `tar', but with differences that make it more appropriate for our purposes. First, rather than -recording all Unix metadata for each file, the Nar format only mentions +recording all Unix metadata for each file, the nar format only mentions the file type (regular, directory, or symbolic link); Unix permissions and owner/group are dismissed. Second, the order in which directory entries are stored always follows the order of file names according to -- cgit 1.4.1 From 64ce53eb5e8347e93574bf02e183d668c33e250c Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 17 May 2016 16:41:13 +0200 Subject: import cran: Add "recursive" option. * guix/scripts/import/cran.scm: (%options): Add "recursive" option. (guix-import-cran): Handle "recursive" option. * doc/guix.texi (Invoking guix import): Document it. --- doc/guix.texi | 4 ++++ guix/scripts/import/cran.scm | 26 ++++++++++++++++++++------ 2 files changed, 24 insertions(+), 6 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index bd782cab03..5d3a1753bf 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5148,6 +5148,10 @@ R package: guix import cran Cairo @end example +When @code{--recursive} is added, the importer will traverse the +dependency graph of the given upstream package recursively and generate +package expressions for all those packages that are not yet in Guix. + When @code{--archive=bioconductor} is added, metadata is imported from @uref{http://www.bioconductor.org/, Bioconductor}, a repository of R packages for for the analysis and comprehension of high-throughput diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index ace1123b90..66c660ae14 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-cran)) @@ -63,6 +64,9 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (lambda (opt name arg result) (alist-cons 'repo (string->symbol arg) (alist-delete 'repo result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -88,12 +92,22 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (cran->guix-package package-name - (or (assoc-ref opts 'repo) 'cran)))) - (unless sexp - (leave (_ "failed to download description for package '~a'~%") - package-name)) - sexp)) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (stream->list (recursive-import package-name + (or (assoc-ref opts 'repo) 'cran)))) + ;; Single import + (let ((sexp (cran->guix-package package-name + (or (assoc-ref opts 'repo) 'cran)))) + (unless sexp + (leave (_ "failed to download description for package '~a'~%") + package-name)) + sexp))) (() (leave (_ "too few arguments~%"))) ((many ...) -- cgit 1.4.1 From 1ec34dd7e6ce92d887b259b0a5a17a7ac743c872 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 Dec 2016 16:55:05 +0100 Subject: doc: Document 'cargo-build-system'. * doc/guix.texi (Build Systems): Add 'cargo-build-system'. --- doc/guix.texi | 13 +++++++++++++ 1 file changed, 13 insertions(+) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 5d3a1753bf..3b2368b071 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3187,6 +3187,19 @@ which file the system is defined in. @end defvr +@defvr {Scheme Variable} cargo-build-system +@cindex Rust programming language +@cindex Cargo (Rust build system) +This variable is exported by @code{(guix build-system cargo)}. It +supports builds of packages using Cargo, the build tool of the +@uref{https://www.rust-lang.org, Rust programming language}. + +In its @code{configure} phase, this build system replaces dependencies +specified in the @file{Carto.toml} file with inputs to the Guix package. +The @code{install} phase installs the binaries, and it also installs the +source code and @file{Cargo.toml} file. +@end defvr + @defvr {Scheme Variable} cmake-build-system This variable is exported by @code{(guix build-system cmake)}. It implements the build procedure for packages using the -- cgit 1.4.1 From 9ea36197bec2a878e93b17686e2d5314359f0d54 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 Dec 2016 17:11:13 +0100 Subject: doc: Mention the d3.js backend of 'guix graph'. * doc/guix.texi (Invoking guix graph): Mention the d3.js backend. --- doc/guix.texi | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 3b2368b071..99bde4aca3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5726,11 +5726,13 @@ Consider packages for @var{system}---e.g., @code{x86_64-linux}. Packages and their dependencies form a @dfn{graph}, specifically a directed acyclic graph (DAG). It can quickly become difficult to have a mental model of the package DAG, so the @command{guix graph} command -provides a visual representation of the DAG. @command{guix graph} -emits a DAG representation in the input format of +provides a visual representation of the DAG. By default, +@command{guix graph} emits a DAG representation in the input format of @uref{http://www.graphviz.org/, Graphviz}, so its output can be passed -directly to the @command{dot} command of Graphviz. The general -syntax is: +directly to the @command{dot} command of Graphviz. It can also emit an +HTML page with embedded JavaScript code to display a ``chord diagram'' +in a Web browser, using the @uref{https://d3js.org/, d3.js} library. +The general syntax is: @example guix graph @var{options} @var{package}@dots{} @@ -5855,6 +5857,8 @@ Produce a graph using the selected @var{backend}. @item --list-backends List the supported graph backends. +Currently, the available backends are Graphviz and d3.js. + @item --expression=@var{expr} @itemx -e @var{expr} Consider the package @var{expr} evaluates to. -- cgit 1.4.1 From b2ff76a0106a4f5a91c63d75627b64a53b7b31d4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Dec 2016 14:55:31 +0100 Subject: doc: Mention 'swapon'. Suggested by David Braun at . * doc/guix.texi (Preparing for Installation): Add 'swapon'. --- doc/guix.texi | 1 + 1 file changed, 1 insertion(+) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 99bde4aca3..e3c4524b21 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6868,6 +6868,7 @@ swap partition on @file{/dev/sda2}, you would run: @example mkswap /dev/sda2 +swapon /dev/sda2 @end example @node Proceeding with the Installation -- cgit 1.4.1 From 7fcf2a0b94ce3316611be959bc9e78d9ac962b89 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Dec 2016 15:07:58 +0100 Subject: doc: Make 'guix pull' more visible. Suggested by Dave Love . Fixes . * doc/guix.texi (Installation): Mention 'guix pull'. (Proceeding with the Installation): Mention updates with 'guix pull' and 'guix system reconfigure'. (Invoking guix pull): Add "updating" to the concept index. --- doc/guix.texi | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index e3c4524b21..b5592e0029 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -359,6 +359,9 @@ without interference. Its data lives exclusively in two directories, usually @file{/gnu/store} and @file{/var/guix}; other files on your system, such as @file{/etc}, are left untouched. +Once installed, Guix can be updated by running @command{guix pull} +(@pxref{Invoking guix pull}). + @menu * Binary Installation:: Getting Guix running in no time! * Requirements:: Software needed to build and run Guix. @@ -2308,6 +2311,7 @@ this option is primarily useful when the daemon was running with @section Invoking @command{guix pull} @cindex upgrading Guix +@cindex updating Guix @cindex @command{guix pull} @cindex pull Packages are installed or upgraded to the latest version available in @@ -6949,6 +6953,14 @@ initialized by running the @command{passwd} command as @code{root}, unless your configuration specifies otherwise (@pxref{user-account-password, user account passwords}). +@cindex upgrading GuixSD +From then on, you can update GuixSD whenever you want by running +@command{guix pull} as @code{root} (@pxref{Invoking guix pull}), and +then running @command{guix system reconfigure} to build a new system +generation with the latest packages and services (@pxref{Invoking guix +system}). We recommend doing that regularly so that your system +includes the latest security updates (@pxref{Security Updates}). + Join us on @code{#guix} on the Freenode IRC network or on @file{guix-devel@@gnu.org} to share your experience---good or not so good. -- cgit 1.4.1 From 9b06f503f406fc51dcf400bce97b37fd5970dd95 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Dec 2016 15:40:04 +0100 Subject: doc: Mention 'grub' field of 'grub-configuration'. * doc/guix.texi (GRUB Configuration): Add 'grub' field. --- doc/guix.texi | 3 +++ 1 file changed, 3 insertions(+) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index b5592e0029..a9f9851394 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -12562,6 +12562,9 @@ The number of seconds to wait for keyboard input before booting. Set to @item @code{theme} (default: @var{%default-theme}) The @code{grub-theme} object describing the theme to use. + +@item @code{grub} (default: @code{grub}) +The GRUB package to use. @end table @end deftp -- cgit 1.4.1 From b17e326f1731d7170a48cfad4d9d4c91bad7b8a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Dec 2016 23:01:04 +0100 Subject: services: cuirass: Add 'log-file' option. * gnu/services/cuirass.scm ()[log-file]: New field. (cuirass-shepherd-service): Pass it to 'make-forkexec-constructor'. --- doc/guix.texi | 3 +++ gnu/services/cuirass.scm | 6 +++++- 2 files changed, 8 insertions(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index a9f9851394..46d006df8c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11990,6 +11990,9 @@ accessible in other @code{cuirass-configuration} fields. Data type representing the configuration of Cuirass. @table @asis +@item @code{log-file} (default: @code{"/var/log/cuirass.log"}) +Location of the log file. + @item @code{cache-directory} (default: @code{""}) Location of the repository cache. diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index 4975a7e16e..8e9316ffc7 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -42,6 +42,8 @@ (define-record-type* cuirass-configuration make-cuirass-configuration cuirass-configuration? + (log-file cuirass-configuration-log-file ;string + (default "/var/log/cuirass.log")) (cache-directory cuirass-configuration-cache-directory ;string (dir-name) (default "")) (user cuirass-configuration-user ;string @@ -64,6 +66,7 @@ (and (cuirass-configuration? config) (let ((cache-directory (cuirass-configuration-cache-directory config)) + (log-file (cuirass-configuration-log-file config)) (interval (cuirass-configuration-interval config)) (database (cuirass-configuration-database config)) (specs (cuirass-configuration-specifications config)) @@ -86,7 +89,8 @@ "--database" #$database "--interval" #$(number->string interval) #$@(if use-substitutes? '("--use-substitutes") '()) - #$@(if one-shot? '("--one-shot") '())))) + #$@(if one-shot? '("--one-shot") '())) + #:log-file #$log-file)) (stop #~(make-kill-destructor))))))) (define (cuirass-account config) -- cgit 1.4.1 From 463995da0c8ae95654a6184c0a7ff0d1e0914c83 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Dec 2016 23:29:09 +0100 Subject: services: cuirass: Cache defaults to /var/cache/cuirass. The previous default value depended on the 'HOME' environment variable, which happened to be unset. Thus, /.cache was being used. * gnu/services/cuirass.scm ()[cache-directory]: Change default value to "/var/cache/cuirass". (cuirass-shepherd-service): Always pass "--cache-directory". (cuirass-activation): New procedure. (cuirass-service-type): Use it as an extension to ACTIVATION-SERVICE-TYPE. * doc/guix.texi (Continuous Integration): Adjust accordingly. --- doc/guix.texi | 2 +- gnu/services/cuirass.scm | 23 +++++++++++++++++++---- 2 files changed, 20 insertions(+), 5 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 46d006df8c..c2182093dd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11993,7 +11993,7 @@ Data type representing the configuration of Cuirass. @item @code{log-file} (default: @code{"/var/log/cuirass.log"}) Location of the log file. -@item @code{cache-directory} (default: @code{""}) +@item @code{cache-directory} (default: @code{"/var/cache/cuirass"}) Location of the repository cache. @item @code{user} (default: @code{"cuirass"}) diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index c2fe9d9bf7..d585e26538 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Mathieu Lirzin +;;; Copyright © 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,7 +46,7 @@ (log-file cuirass-configuration-log-file ;string (default "/var/log/cuirass.log")) (cache-directory cuirass-configuration-cache-directory ;string (dir-name) - (default "")) + (default "/var/cache/cuirass")) (user cuirass-configuration-user ;string (default "cuirass")) (group cuirass-configuration-group ;string @@ -80,9 +81,7 @@ (requirement '(guix-daemon)) (start #~(make-forkexec-constructor (list (string-append #$cuirass "/bin/cuirass") - #$@(if (string=? "" cache-directory) - '() - (list "--cache-directory" cache-directory)) + "--cache-directory" #$cache-directory #$@(if (null? specs) '() (let ((str (format #f "'~S" specs))) @@ -112,11 +111,27 @@ (home-directory (string-append "/var/run/" cuirass-user)) (shell #~(string-append #$shadow "/sbin/nologin")))))) +(define (cuirass-activation config) + "Return the activation code for CONFIG." + (let ((cache (cuirass-configuration-cache-directory config)) + (user (cuirass-configuration-user config)) + (group (cuirass-configuration-group config))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (mkdir-p #$cache) + + (let ((uid (passwd:uid (getpw #$user))) + (gid (group:gid (getgr #$group)))) + (chown #$cache uid gid)))))) + (define cuirass-service-type (service-type (name 'cuirass) (extensions (list + (service-extension activation-service-type cuirass-activation) (service-extension shepherd-root-service-type cuirass-shepherd-service) (service-extension account-service-type cuirass-account))))) -- cgit 1.4.1 From f78903f36308081eeea52223fb3f5dca5096baef Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Dec 2016 23:39:43 +0100 Subject: services: guix: Remove dependency on lsh. * gnu/services/base.scm ()[lsh]: Remove. (guix-shepherd-service): Remove lsh from 'PATH'. * doc/guix.texi (Base Services): Adjust accordingly. --- doc/guix.texi | 3 +-- gnu/services/base.scm | 12 ++++-------- 2 files changed, 5 insertions(+), 10 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index c2182093dd..7c37468cdf 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8300,8 +8300,7 @@ The list of URLs where to look for substitutes by default. List of extra command-line options for @command{guix-daemon}. @item @code{lsof} (default: @var{lsof}) -@itemx @code{lsh} (default: @var{lsh}) -The lsof and lsh packages to use. +The lsof package to use. @end table @end deftp diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 8e686898c5..f2bac297aa 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -37,7 +37,6 @@ #:use-module ((gnu packages base) #:select (canonical-package glibc)) #:use-module (gnu packages package-management) - #:use-module (gnu packages ssh) #:use-module (gnu packages lsof) #:use-module (gnu packages terminals) #:use-module ((gnu build file-systems) @@ -1091,9 +1090,7 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (extra-options guix-configuration-extra-options ;list of strings (default '())) (lsof guix-configuration-lsof ; - (default lsof)) - (lsh guix-configuration-lsh ; - (default lsh))) + (default lsof))) (define %default-guix-configuration (guix-configuration)) @@ -1104,7 +1101,7 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (($ guix build-group build-accounts authorize-key? keys use-substitutes? substitute-urls extra-options - lsof lsh) + lsof) (list (shepherd-service (documentation "Run the Guix daemon.") (provision '(guix-daemon)) @@ -1119,10 +1116,9 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) "--substitute-urls" #$(string-join substitute-urls) #$@extra-options) - ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the - ;; daemon's $PATH. + ;; Add 'lsof' (for the GC) to the daemon's $PATH. #:environment-variables - (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin")))) + (list (string-append "PATH=" #$lsof "/bin")))) (stop #~(make-kill-destructor))))))) (define (guix-accounts config) -- cgit 1.4.1 From dc0ef095b32f57a935764d40530af0b32a01d715 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Dec 2016 23:54:39 +0100 Subject: services: guix: Add 'log-file' configuration option. * gnu/services/base.scm ()[log-file]: New field. (guix-shepherd-service): Pass #:log-file to 'make-forkexec-constructor'. * gnu/services/admin.scm (simple-rotation-config): Take a list of files and join them with commas. (%default-rotations): Add /var/log/guix-daemon.log. * doc/guix.texi (Base Services): Document it. --- doc/guix.texi | 4 ++++ gnu/services/admin.scm | 7 ++++--- gnu/services/base.scm | 8 ++++++-- 3 files changed, 14 insertions(+), 5 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 7c37468cdf..bb96385f84 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8299,6 +8299,10 @@ The list of URLs where to look for substitutes by default. @item @code{extra-options} (default: @code{'()}) List of extra command-line options for @command{guix-daemon}. +@item @code{log-file} (default: @code{"/var/log/guix-daemon.log"}) +File where @command{guix-daemon}'s standard output and standard error +are written. + @item @code{lsof} (default: @var{lsof}) The lsof package to use. diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm index d8086b78d4..deaf677bd9 100644 --- a/gnu/services/admin.scm +++ b/gnu/services/admin.scm @@ -58,8 +58,8 @@ } ")) -(define (simple-rotation-config file) - (string-append file " { +(define (simple-rotation-config files) + #~(string-append #$(string-join files ",") " { sharedscripts } ")) @@ -72,7 +72,8 @@ (display #$(syslog-rotation-config %rotated-files) port) (display #$(simple-rotation-config - "/var/log/shepherd.log") + '("/var/log/shepherd.log" + "/var/log/guix-daemon.log")) port))))))) (define (default-jobs rottlog) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index f2bac297aa..1b1ce0d5e8 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1089,6 +1089,8 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (default %default-substitute-urls)) (extra-options guix-configuration-extra-options ;list of strings (default '())) + (log-file guix-configuration-log-file ;string + (default "/var/log/guix-daemon.log")) (lsof guix-configuration-lsof ; (default lsof))) @@ -1101,7 +1103,7 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (($ guix build-group build-accounts authorize-key? keys use-substitutes? substitute-urls extra-options - lsof) + log-file lsof) (list (shepherd-service (documentation "Run the Guix daemon.") (provision '(guix-daemon)) @@ -1118,7 +1120,9 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) ;; Add 'lsof' (for the GC) to the daemon's $PATH. #:environment-variables - (list (string-append "PATH=" #$lsof "/bin")))) + (list (string-append "PATH=" #$lsof "/bin")) + + #:log-file #$log-file)) (stop #~(make-kill-destructor))))))) (define (guix-accounts config) -- cgit 1.4.1 From 379b6ba5a906b62252dd5bcb142ec050ae34bc74 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 Dec 2016 10:23:37 +0100 Subject: services: cuirass: Add 'cuirass' field. * gnu/services/cuirass.scm ()[cuirass]: New field. (cuirass-shepherd-service): Honor it. * doc/guix.texi (Continuous Integration): Document it. --- doc/guix.texi | 3 +++ gnu/services/cuirass.scm | 5 ++++- 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index bb96385f84..389afe0f29 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -12025,6 +12025,9 @@ from source. @item @code{one-shot?} (default: @code{#f}) Only evaluate specifications and build derivations once. + +@item @code{cuirass} (default: @code{cuirass}) +The Cuirass package to use. @end table @end deftp diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index 91d78d15ac..0ecdccfec7 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -43,6 +43,8 @@ (define-record-type* cuirass-configuration make-cuirass-configuration cuirass-configuration? + (cuirass cuirass-configuration-cuirass ;package + (default cuirass)) (log-file cuirass-configuration-log-file ;string (default "/var/log/cuirass.log")) (cache-directory cuirass-configuration-cache-directory ;string (dir-name) @@ -66,7 +68,8 @@ "Return a for the Cuirass service with CONFIG." (and (cuirass-configuration? config) - (let ((cache-directory (cuirass-configuration-cache-directory config)) + (let ((cuirass (cuirass-configuration-cuirass config)) + (cache-directory (cuirass-configuration-cache-directory config)) (log-file (cuirass-configuration-log-file config)) (user (cuirass-configuration-user config)) (group (cuirass-configuration-group config)) -- cgit 1.4.1 From cccbc63950ad061538b1132b3dfef21794d6b780 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 20 Dec 2016 12:10:57 +0100 Subject: doc: Replace fingerprint of OpenPGP signing key. * doc/guix.texi (OPENPGP-SIGNING-KEY-ID): Update to Ricardo's key for the 0.12.0 release. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 389afe0f29..512b3ae9ce 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10,7 +10,7 @@ @include version.texi @c Identifier of the OpenPGP key used to sign tarballs and such. -@set OPENPGP-SIGNING-KEY-ID 3CE464558A84FDC69DB40CFB090B11993D9AEBB5 +@set OPENPGP-SIGNING-KEY-ID BCA689B636553801C3C62150197A5888235FACAC @copying Copyright @copyright{} 2012, 2013, 2014, 2015, 2016 Ludovic Courtès@* -- cgit 1.4.1 From f943c317fb714075b455d4a30f631c8cb45732b4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 Dec 2016 19:06:22 +0100 Subject: environment: Add '--root' option. * guix/scripts/environment.scm (show-help, %options): Add --root. (register-gc-root): New procedure. (guix-environment): Call 'register-gc-root' when OPTS has a 'gc-root' option. * doc/guix.texi (Invoking guix environment): Document it. * tests/guix-environment.sh: Add tests. --- doc/guix.texi | 15 +++++++++++++++ guix/scripts/environment.scm | 34 ++++++++++++++++++++++++++++++++-- tests/guix-environment.sh | 17 ++++++++++++++++- 3 files changed, 63 insertions(+), 3 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 512b3ae9ce..69129d5835 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5997,6 +5997,21 @@ The @code{--container} option requires Linux-libre 3.19 or newer. The available options are summarized below. @table @code +@item --root=@var{file} +@itemx -r @var{file} +@cindex persistent environment +@cindex garbage collector root, for environments +Make @var{file} a symlink to the profile for this environment, and +register it as a garbage collector root. + +This is useful if you want to protect your environment from garbage +collection, to make it ``persistent''. + +When this option is omitted, the environment is protected from garbage +collection only for the duration of the @command{guix environment} +session. This means that next time you recreate the same environment, +you could have to rebuild or re-download packages. + @item --expression=@var{expr} @itemx -e @var{expr} Create an environment for the package or list of packages that diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 7201d98fea..1d3be6a84f 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -155,6 +155,9 @@ COMMAND or an interactive shell in that environment.\n")) (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " + -r, --root=FILE make FILE a symlink to the result, and register it + as a garbage collector root")) + (display (_ " -C, --container run command within an isolated container")) (display (_ " -N, --network allow containers to access the network")) @@ -247,6 +250,9 @@ COMMAND or an interactive shell in that environment.\n")) (alist-cons 'file-system-mapping (specification->file-system-mapping arg #f) result))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -523,7 +529,26 @@ message if any test fails." (report-error (_ "cannot create container: /proc/self/setgroups does not exist\n")) (leave (_ "is your kernel version < 3.19?\n")))) -;; Entry point. +(define (register-gc-root target root) + "Make ROOT an indirect root to TARGET. This is procedure is idempotent." + (let* ((root (string-append (canonicalize-path (dirname root)) + "/" root))) + (catch 'system-error + (lambda () + (symlink target root) + ((store-lift add-indirect-root) root)) + (lambda args + (if (and (= EEXIST (system-error-errno args)) + (equal? (false-if-exception (readlink root)) target)) + (with-monad %store-monad + (return #t)) + (apply throw args)))))) + + +;;; +;;; Entry point. +;;; + (define (guix-environment . args) (with-error-handling (let* ((opts (parse-args args)) @@ -579,7 +604,9 @@ message if any test fails." system)) (prof-drv (inputs->profile-derivation inputs system bootstrap?)) - (profile -> (derivation->output-path prof-drv))) + (profile -> (derivation->output-path prof-drv)) + (gc-root -> (assoc-ref opts 'gc-root))) + ;; First build the inputs. This is necessary even for ;; --search-paths. Additionally, we might need to build bash for ;; a container. @@ -588,6 +615,9 @@ message if any test fails." (list prof-drv bash) (list prof-drv)) opts) + (mwhen gc-root + (register-gc-root profile gc-root)) + (cond ((assoc-ref opts 'dry-run?) (return #t)) diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 68343520b0..2b3bbfe036 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -25,7 +25,8 @@ set -e guix environment --version tmpdir="t-guix-environment-$$" -trap 'rm -r "$tmpdir"' EXIT +gcroot="t-guix-environment-gc-root-$$" +trap 'rm -r "$tmpdir"; rm -f "$gcroot"' EXIT mkdir "$tmpdir" @@ -61,6 +62,20 @@ fi guix environment --bootstrap --ad-hoc guile-bootstrap --pure \ -- "$SHELL" -c 'test -f "$GUIX_ENVIRONMENT/bin/guile"' +# Make sure '-r' works as expected. +rm -f "$gcroot" +expected="`guix environment --bootstrap --ad-hoc guile-bootstrap \ + -- "$SHELL" -c 'echo $GUIX_ENVIRONMENT'`" +guix environment --bootstrap -r "$gcroot" --ad-hoc guile-bootstrap \ + -- guile -c 1 +test `readlink "$gcroot"` = "$expected" + +# Make sure '-r' is idempotent. +guix environment --bootstrap -r "$gcroot" --ad-hoc guile-bootstrap \ + -- guile -c 1 +test `readlink "$gcroot"` = "$expected" + + case "`uname -m`" in x86_64) # On x86_64, we should be able to create a 32-bit environment. -- cgit 1.4.1 From deb6276dda81a69da38e842d269c5370a28fa5cf Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Thu, 22 Dec 2016 12:47:28 +0300 Subject: Remove Emacs interface. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * emacs/guix-about.el: Remove file. * emacs/guix-backend.el: Likewise. * emacs/guix-base.el: Likewise. * emacs/guix-buffer.el: Likewise. * emacs/guix-build-log.el: Likewise. * emacs/guix-command.el: Likewise. * emacs/guix-config.el.in: Likewise. * emacs/guix-devel.el: Likewise. * emacs/guix-entry.el: Likewise. * emacs/guix-external.el: Likewise. * emacs/guix-geiser.el: Likewise. * emacs/guix-guile.el: Likewise. * emacs/guix-help-vars.el: Likewise. * emacs/guix-helper.scm.in: Likewise. * emacs/guix-history.el: Likewise. * emacs/guix-hydra-build.el: Likewise. * emacs/guix-hydra-jobset.el: Likewise. * emacs/guix-hydra.el: Likewise. * emacs/guix-info.el: Likewise. * emacs/guix-init.el: Likewise. * emacs/guix-license.el: Likewise. * emacs/guix-list.el: Likewise. * emacs/guix-location.el: Likewise. * emacs/guix-main.scm: Likewise. * emacs/guix-messages.el: Likewise. * emacs/guix-pcomplete.el: Likewise. * emacs/guix-popup.el: Likewise. * emacs/guix-prettify.el: Likewise. * emacs/guix-profiles.el: Likewise. * emacs/guix-read.el: Likewise. * emacs/guix-ui-generation.el: Likewise. * emacs/guix-ui-license.el: Likewise. * emacs/guix-ui-location.el: Likewise. * emacs/guix-ui-package.el: Likewise. * emacs/guix-ui-system-generation.el: Likewise. * emacs/guix-ui.el: Likewise. * emacs/guix-utils.el: Likewise. * emacs/local.mk: Likewise. * doc/emacs.texi: Likewise. * doc/guix.texi: Remove cross-references to Emacs nodes. (Package Management): Mention 'emacs-guix' package. * doc/contributing.texi (The Perfect Setup): Remove the reference. * doc/htmlxref.cnf: Add 'emacs-guix' URL. * Makefile.am: Remove Emacs stuff. * configure.ac: Likewise. * gnu/packages/package-management.scm (guix-0.12.0)[native-inputs]: Remove "emacs". [propagated-inputs]: Remove "geiser" and "emacs-magit-popup". Co-authored-by: Ludovic Courtès --- Makefile.am | 8 - configure.ac | 10 - doc/contributing.texi | 3 - doc/emacs.texi | 881 -------------------------- doc/guix.texi | 51 +- doc/htmlxref.cnf | 2 + emacs/guix-about.el | 37 -- emacs/guix-backend.el | 393 ------------ emacs/guix-base.el | 377 ----------- emacs/guix-buffer.el | 624 ------------------ emacs/guix-build-log.el | 381 ----------- emacs/guix-command.el | 830 ------------------------ emacs/guix-config.el.in | 44 -- emacs/guix-devel.el | 382 ----------- emacs/guix-entry.el | 59 -- emacs/guix-external.el | 88 --- emacs/guix-geiser.el | 126 ---- emacs/guix-guile.el | 98 --- emacs/guix-help-vars.el | 108 ---- emacs/guix-helper.scm.in | 65 -- emacs/guix-history.el | 92 --- emacs/guix-hydra-build.el | 362 ----------- emacs/guix-hydra-jobset.el | 162 ----- emacs/guix-hydra.el | 367 ----------- emacs/guix-info.el | 482 -------------- emacs/guix-init.el | 3 - emacs/guix-license.el | 65 -- emacs/guix-list.el | 585 ----------------- emacs/guix-location.el | 79 --- emacs/guix-main.scm | 1163 ---------------------------------- emacs/guix-messages.el | 247 -------- emacs/guix-pcomplete.el | 370 ----------- emacs/guix-popup.el | 48 -- emacs/guix-prettify.el | 210 ------ emacs/guix-profiles.el | 77 --- emacs/guix-read.el | 147 ----- emacs/guix-ui-generation.el | 456 -------------- emacs/guix-ui-license.el | 150 ----- emacs/guix-ui-location.el | 83 --- emacs/guix-ui-package.el | 1191 ----------------------------------- emacs/guix-ui-system-generation.el | 105 --- emacs/guix-ui.el | 323 ---------- emacs/guix-utils.el | 609 ------------------ emacs/local.mk | 77 --- gnu/packages/package-management.scm | 6 +- 45 files changed, 14 insertions(+), 12012 deletions(-) delete mode 100644 doc/emacs.texi delete mode 100644 emacs/guix-about.el delete mode 100644 emacs/guix-backend.el delete mode 100644 emacs/guix-base.el delete mode 100644 emacs/guix-buffer.el delete mode 100644 emacs/guix-build-log.el delete mode 100644 emacs/guix-command.el delete mode 100644 emacs/guix-config.el.in delete mode 100644 emacs/guix-devel.el delete mode 100644 emacs/guix-entry.el delete mode 100644 emacs/guix-external.el delete mode 100644 emacs/guix-geiser.el delete mode 100644 emacs/guix-guile.el delete mode 100644 emacs/guix-help-vars.el delete mode 100644 emacs/guix-helper.scm.in delete mode 100644 emacs/guix-history.el delete mode 100644 emacs/guix-hydra-build.el delete mode 100644 emacs/guix-hydra-jobset.el delete mode 100644 emacs/guix-hydra.el delete mode 100644 emacs/guix-info.el delete mode 100644 emacs/guix-init.el delete mode 100644 emacs/guix-license.el delete mode 100644 emacs/guix-list.el delete mode 100644 emacs/guix-location.el delete mode 100644 emacs/guix-main.scm delete mode 100644 emacs/guix-messages.el delete mode 100644 emacs/guix-pcomplete.el delete mode 100644 emacs/guix-popup.el delete mode 100644 emacs/guix-prettify.el delete mode 100644 emacs/guix-profiles.el delete mode 100644 emacs/guix-read.el delete mode 100644 emacs/guix-ui-generation.el delete mode 100644 emacs/guix-ui-license.el delete mode 100644 emacs/guix-ui-location.el delete mode 100644 emacs/guix-ui-package.el delete mode 100644 emacs/guix-ui-system-generation.el delete mode 100644 emacs/guix-ui.el delete mode 100644 emacs/guix-utils.el delete mode 100644 emacs/local.mk (limited to 'doc/guix.texi') diff --git a/Makefile.am b/Makefile.am index 6cc3114d56..15939af12a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -465,10 +465,6 @@ AM_DISTCHECK_CONFIGURE_FLAGS = \ --with-nix-prefix="$(NIX_PREFIX)" \ --enable-daemon -dist_emacsui_DATA = emacs/guix-main.scm -nodist_emacsui_DATA = emacs/guix-helper.scm -include emacs/local.mk - # The self-contained tarball. guix-binary.%.tar.xz: $(AM_V_GEN)GUIX_PACKAGE_PATH= \ @@ -548,10 +544,6 @@ AM_V_DOT = $(AM_V_DOT_$(V)) AM_V_DOT_ = $(AM_V_DOT_$(AM_DEFAULT_VERBOSITY)) AM_V_DOT_0 = @echo " DOT " $@; -AM_V_EMACS = $(AM_V_EMACS_$(V)) -AM_V_EMACS_ = $(AM_V_EMACS_$(AM_DEFAULT_VERBOSITY)) -AM_V_EMACS_0 = @echo " EMACS " $@; - AM_V_HELP2MAN = $(AM_V_HELP2MAN_$(V)) AM_V_HELP2MAN_ = $(AM_V_HELP2MAN_$(AM_DEFAULT_VERBOSITY)) AM_V_HELP2MAN_0 = @echo " HELP2MAN" $@; diff --git a/configure.ac b/configure.ac index 4888624ba9..c3173d60c5 100644 --- a/configure.ac +++ b/configure.ac @@ -237,14 +237,4 @@ AC_CONFIG_FILES([test-env:build-aux/test-env.in], [chmod +x test-env]) AC_CONFIG_FILES([pre-inst-env:build-aux/pre-inst-env.in], [chmod +x pre-inst-env]) -dnl Emacs interface. -AC_PATH_PROG([DOT_USER_PROGRAM], [dot], [dot]) -AM_PATH_LISPDIR -AM_CONDITIONAL([HAVE_EMACS], [test "x$EMACS" != "xno"]) - -emacsuidir="${guilemoduledir}/guix/emacs" -AC_SUBST([emacsuidir]) -AC_CONFIG_FILES([emacs/guix-config.el - emacs/guix-helper.scm]) - AC_OUTPUT diff --git a/doc/contributing.texi b/doc/contributing.texi index de08f9b351..24db9a89e6 100644 --- a/doc/contributing.texi +++ b/doc/contributing.texi @@ -187,9 +187,6 @@ facilities to directly operate on the syntax tree, such as raising an s-expression or wrapping it, swallowing or rejecting the following s-expression, etc. -GNU Guix also comes with a minor mode that provides some additional -functionality for Scheme buffers (@pxref{Emacs Development}). - @node Coding Style @section Coding Style diff --git a/doc/emacs.texi b/doc/emacs.texi deleted file mode 100644 index 1ffb9f636e..0000000000 --- a/doc/emacs.texi +++ /dev/null @@ -1,881 +0,0 @@ -@node Emacs Interface -@chapter Emacs Interface - -@cindex Emacs -GNU Guix comes with several useful modules (known as ``guix.el'') for -GNU@tie{}Emacs which are intended to make an Emacs user interaction with -Guix convenient and fun. - -@menu -* Initial Setup: Emacs Initial Setup. Preparing @file{~/.emacs}. -* Package Management: Emacs Package Management. Managing packages and generations. -* Licenses: Emacs Licenses. Interface for licenses of Guix packages. -* Package Source Locations: Emacs Package Locations. Interface for package location files. -* Popup Interface: Emacs Popup Interface. Magit-like interface for guix commands. -* Prettify Mode: Emacs Prettify. Abbreviating @file{/gnu/store/@dots{}} file names. -* Build Log Mode: Emacs Build Log. Highlighting Guix build logs. -* Completions: Emacs Completions. Completing @command{guix} shell command. -* Development: Emacs Development. Tools for Guix developers. -* Hydra: Emacs Hydra. Interface for Guix build farm. -@end menu - - -@node Emacs Initial Setup -@section Initial Setup - -On the Guix System Distribution (@pxref{GNU Distribution}), ``guix.el'' -is ready to use, provided Guix is installed system-wide, which is the -case by default. So if that is what you're using, you can happily skip -this section and read about the fun stuff. - -If you're not yet a happy user of GuixSD, a little bit of setup is needed. -To be able to use ``guix.el'', you need to install the following -packages: - -@itemize -@item -@uref{http://www.gnu.org/software/emacs/, GNU Emacs}, version 24.3 or -later; - -@item -@uref{http://nongnu.org/geiser/, Geiser}, version 0.3 or later: it is -used for interacting with the Guile process. - -@item -@uref{https://github.com/magit/magit/, magit-popup library}. You -already have this library if you use Magit 2.1.0 or later. This library -is an optional dependency---it is required only for @kbd{M-x@tie{}guix} -command (@pxref{Emacs Popup Interface}). - -@end itemize - -When it is done, ``guix.el'' may be configured by requiring -@code{guix-autoloads} file. If you install Guix in your user profile, -this auto-loading is done automatically by our Emacs package -(@pxref{Application Setup}), so a universal recipe for configuring -``guix.el'' is: @command{guix package -i guix}. If you do this, there -is no need to read further. - -For the manual installation, you need to add the following code into -your init file (@pxref{Init File,,, emacs, The GNU Emacs Manual}): - -@example -(add-to-list 'load-path "/path/to/directory-with-guix.el") -(require 'guix-autoloads nil t) -@end example - -So the only thing you need to figure out is where the directory with -elisp files for Guix is placed. It depends on how you installed Guix: - -@itemize -@item -If it was installed by a package manager of your distribution or by a -usual @code{./configure && make && make install} command sequence, then -elisp files are placed in a standard directory with Emacs packages -(usually it is @file{/usr/share/emacs/site-lisp/}), which is already in -@code{load-path}, so there is no need to add that directory there. Note -that if you don't update this installation periodically, you may get an -outdated Emacs code which does not work with the current Guile code of -Guix. - -@item -If you used a binary installation method (@pxref{Binary Installation}), -then Guix is installed somewhere in the store, so the elisp files are -placed in @file{/gnu/store/@dots{}-guix-0.8.2/share/emacs/site-lisp/} or -alike. However it is not recommended to refer directly to a store -directory, as it may be garbage-collected one day. So a better choice -would be to install Guix using Guix itself with @command{guix package -i -guix}. - -@item -If you did not install Guix at all and prefer a hacking way -(@pxref{Running Guix Before It Is Installed}), along with augmenting -@code{load-path} you need to set @code{guix-load-path} variable to the -same directory, so your final configuration will look like this: - -@example -(let ((dir "/path/to/your-guix-git-tree/emacs")) - (add-to-list 'load-path dir) - (setq guix-load-path dir)) -(require 'guix-autoloads nil t) -@end example -@end itemize - - -@node Emacs Package Management -@section Package Management - -Once ``guix.el'' has been successfully configured, you should be able to -use a visual interface for routine package management tasks, pretty much -like the @command{guix package} command (@pxref{Invoking guix package}). -Specifically, it makes it easy to: - -@itemize -@item browse and display packages and generations; -@item search, install, upgrade and remove packages; -@item display packages from previous generations; -@item do some other useful things. -@end itemize - -@menu -* Commands: Emacs Commands. @kbd{M-x guix-@dots{}} -* General information: Emacs General info. Common for both interfaces. -* ``List'' buffer: Emacs List buffer. List-like interface. -* ``Info'' buffer: Emacs Info buffer. Help-like interface. -* Configuration: Emacs Configuration. Configuring the interface. -@end menu - -@node Emacs Commands -@subsection Commands - -All commands for displaying packages and generations use the current -profile, which can be changed with -@kbd{M-x@tie{}guix-set-current-profile}. Alternatively, if you call any -of these commands with prefix argument (@kbd{C-u}), you will be prompted -for a profile just for that command. - -Commands for displaying packages: - -@table @kbd - -@item M-x guix-all-available-packages -@itemx M-x guix-newest-available-packages -Display all/newest available packages. - -@item M-x guix-installed-packages -@itemx M-x guix-installed-user-packages -@itemx M-x guix-installed-system-packages -Display installed packages. As described above, @kbd{M-x -guix-installed-packages} uses an arbitrary profile that you can specify, -while the other commands display packages installed in 2 special -profiles: @file{~/.guix-profile} and @file{/run/current-system/profile} -(only on GuixSD). - -@item M-x guix-obsolete-packages -Display obsolete packages (the packages that are installed in a profile -but cannot be found among available packages). - -@item M-x guix-packages-by-name -Display package(s) with the specified name. - -@item M-x guix-packages-by-license -Display package(s) with the specified license. - -@item M-x guix-packages-by-location -Display package(s) located in the specified file. These files usually -have the following form: @file{gnu/packages/emacs.scm}, but don't type -them manually! Press @key{TAB} to complete the file name. - -@item M-x guix-package-from-file -Display package that the code within the specified file evaluates to. -@xref{Invoking guix package, @code{--install-from-file}}, for an example -of what such a file may look like. - -@item M-x guix-search-by-regexp -Search for packages by a specified regexp. By default ``name'', -``synopsis'' and ``description'' of the packages will be searched. This -can be changed by modifying @code{guix-package-search-params} variable. - -@item M-x guix-search-by-name -Search for packages with names matching a specified regexp. This -command is the same as @code{guix-search-by-regexp}, except only a -package ``name'' is searched. - -@end table - -By default, these commands display each output on a separate line. If -you prefer to see a list of packages---i.e., a list with a package per -line, use the following setting: - -@example -(setq guix-package-list-type 'package) -@end example - -Commands for displaying generations: - -@table @kbd - -@item M-x guix-generations -List all the generations. - -@item M-x guix-last-generations -List the @var{N} last generations. You will be prompted for the number -of generations. - -@item M-x guix-generations-by-time -List generations matching time period. You will be prompted for the -period using Org mode time prompt based on Emacs calendar (@pxref{The -date/time prompt,,, org, The Org Manual}). - -@end table - -Analogously on GuixSD you can also display system generations: - -@table @kbd -@item M-x guix-system-generations -@item M-x guix-last-system-generations -@item M-x guix-system-generations-by-time -@end table - -You can also invoke the @command{guix pull} command (@pxref{Invoking -guix pull}) from Emacs using: - -@table @kbd -@item M-x guix-pull -With @kbd{C-u}, make it verbose. -@end table - -Once @command{guix pull} has succeeded, the Guix REPL is restarted. This -allows you to keep using the Emacs interface with the updated Guix. - - -@node Emacs General info -@subsection General information - -The following keys are available for both ``list'' and ``info'' types of -buffers: - -@table @kbd -@item l -@itemx r -Go backward/forward by the history of the displayed results (this -history is similar to the history of the Emacs @code{help-mode} or -@code{Info-mode}). - -@item g -Revert current buffer: update information about the displayed -packages/generations and redisplay it. - -@item R -Redisplay current buffer (without updating information). - -@item M -Apply manifest to the current profile or to a specified profile, if -prefix argument is used. This has the same meaning as @code{--manifest} -option (@pxref{Invoking guix package}). - -@item C-c C-z -@cindex REPL -@cindex read-eval-print loop -Go to the Guix REPL (@pxref{The REPL,,, geiser, Geiser User Manual}). - -@item h -@itemx ? -Describe current mode to see all available bindings. - -@end table - -@emph{Hint:} If you need several ``list'' or ``info'' buffers, you can -simply @kbd{M-x clone-buffer} them, and each buffer will have its own -history. - -@emph{Warning:} Name/version pairs cannot be used to identify packages -(because a name is not necessarily unique), so ``guix.el'' uses special -identifiers that live only during a guile session, so if the Guix REPL -was restarted, you may want to revert ``list'' buffer (by pressing -@kbd{g}). - -@node Emacs List buffer -@subsection ``List'' buffer - -An interface of a ``list'' buffer is similar to the interface provided -by ``package.el'' (@pxref{Package Menu,,, emacs, The GNU Emacs Manual}). - -Default key bindings available for both ``package-list'' and -``generation-list'' buffers: - -@table @kbd -@item m -Mark the current entry (with prefix, mark all entries). -@item u -Unmark the current entry (with prefix, unmark all entries). -@item @key{DEL} -Unmark backward. -@item S -Sort entries by a specified column. -@end table - -A ``package-list'' buffer additionally provides the following bindings: - -@table @kbd -@item @key{RET} -Describe marked packages (display available information in a -``package-info'' buffer). -@item i -Mark the current package for installation. -@item d -Mark the current package for deletion. -@item U -Mark the current package for upgrading. -@item ^ -Mark all obsolete packages for upgrading. -@item e -Edit the definition of the current package (go to its location). This is -similar to @command{guix edit} command (@pxref{Invoking guix edit}), but -for opening a package recipe in the current Emacs instance. -@item x -Execute actions on the marked packages. -@item B -Display latest builds of the current package (@pxref{Emacs Hydra}). -@end table - -A ``generation-list'' buffer additionally provides the following -bindings: - -@table @kbd -@item @key{RET} -List packages installed in the current generation. -@item i -Describe marked generations (display available information in a -``generation-info'' buffer). -@item s -Switch profile to the current generation. -@item d -Mark the current generation for deletion (with prefix, mark all -generations). -@item x -Execute actions on the marked generations---i.e., delete generations. -@item e -Run Ediff (@pxref{Top,,, ediff, The Ediff Manual}) on package outputs -installed in the 2 marked generations. With prefix argument, run Ediff -on manifests of the marked generations. -@item D -@itemx = -Run Diff (@pxref{Diff Mode,,, emacs, The GNU Emacs Manual}) on package -outputs installed in the 2 marked generations. With prefix argument, -run Diff on manifests of the marked generations. -@item + -List package outputs added to the latest marked generation comparing -with another marked generation. -@item - -List package outputs removed from the latest marked generation comparing -with another marked generation. -@end table - -@node Emacs Info buffer -@subsection ``Info'' buffer - -The interface of an ``info'' buffer is similar to the interface of -@code{help-mode} (@pxref{Help Mode,,, emacs, The GNU Emacs Manual}). - -``Info'' buffer contains some buttons (as usual you may use @key{TAB} / -@kbd{S-@key{TAB}} to move between buttons---@pxref{Mouse References,,, -emacs, The GNU Emacs Manual}) which can be used to: - -@itemize @bullet -@item (in a ``package-info'' buffer) - -@itemize @minus -@item install/remove a package; -@item jump to a package location; -@item browse home page of a package; -@item browse license URL; -@item describe packages from ``Inputs'' fields. -@end itemize - -@item (in a ``generation-info'' buffer) - -@itemize @minus -@item remove a generation; -@item switch to a generation; -@item list packages installed in a generation; -@item jump to a generation directory. -@end itemize - -@end itemize - -It is also possible to copy a button label (a link to an URL or a file) -by pressing @kbd{c} on a button. - - -@node Emacs Configuration -@subsection Configuration - -There are many variables you can modify to change the appearance or -behavior of Emacs user interface. Some of these variables are described -in this section. Also you can use Custom Interface (@pxref{Easy -Customization,,, emacs, The GNU Emacs Manual}) to explore/set variables -(not all) and faces. - -@menu -* Guile and Build Options: Emacs Build Options. Specifying how packages are built. -* Buffer Names: Emacs Buffer Names. Names of Guix buffers. -* Keymaps: Emacs Keymaps. Configuring key bindings. -* Appearance: Emacs Appearance. Settings for visual appearance. -@end menu - -@node Emacs Build Options -@subsubsection Guile and Build Options - -@table @code -@item guix-guile-program -If you have some special needs for starting a Guile process, you may set -this variable, for example: - -@example -(setq guix-guile-program '("/bin/guile" "--no-auto-compile")) -@end example - -@item guix-use-substitutes -If nil, has the same meaning as @code{--no-substitutes} option -(@pxref{Invoking guix build}). - -@item guix-dry-run -If non-nil, has the same meaning as @code{--dry-run} option -(@pxref{Invoking guix build}). - -@end table - -@node Emacs Buffer Names -@subsubsection Buffer Names - -Default names of ``guix.el'' buffers (``*Guix@tie{}@dots{}*'') may be -changed with the following variables: - -@table @code -@item guix-package-list-buffer-name -@item guix-output-list-buffer-name -@item guix-generation-list-buffer-name -@item guix-package-info-buffer-name -@item guix-output-info-buffer-name -@item guix-generation-info-buffer-name -@item guix-repl-buffer-name -@item guix-internal-repl-buffer-name -@end table - -By default, the name of a profile is also displayed in a ``list'' or -``info'' buffer name. To change this behavior, use -@code{guix-ui-buffer-name-function} variable. - -For example, if you want to display all types of results in a single -buffer (in such case you will probably use a history (@kbd{l}/@kbd{r}) -extensively), you may do it like this: - -@example -(let ((name "Guix Universal")) - (setq - guix-package-list-buffer-name name - guix-output-list-buffer-name name - guix-generation-list-buffer-name name - guix-package-info-buffer-name name - guix-output-info-buffer-name name - guix-generation-info-buffer-name name)) -@end example - -@node Emacs Keymaps -@subsubsection Keymaps - -If you want to change default key bindings, use the following keymaps -(@pxref{Init Rebinding,,, emacs, The GNU Emacs Manual}): - -@table @code -@item guix-buffer-map -Parent keymap with general keys for any buffer type. - -@item guix-ui-map -Parent keymap with general keys for buffers used for Guix package -management (for packages, outputs and generations). - -@item guix-list-mode-map -Parent keymap with general keys for ``list'' buffers. - -@item guix-package-list-mode-map -Keymap with specific keys for ``package-list'' buffers. - -@item guix-output-list-mode-map -Keymap with specific keys for ``output-list'' buffers. - -@item guix-generation-list-mode-map -Keymap with specific keys for ``generation-list'' buffers. - -@item guix-info-mode-map -Parent keymap with general keys for ``info'' buffers. - -@item guix-package-info-mode-map -Keymap with specific keys for ``package-info'' buffers. - -@item guix-output-info-mode-map -Keymap with specific keys for ``output-info'' buffers. - -@item guix-generation-info-mode-map -Keymap with specific keys for ``generation-info'' buffers. - -@item guix-info-button-map -Keymap with keys available when a point is placed on a button. - -@end table - -@node Emacs Appearance -@subsubsection Appearance - -You can change almost any aspect of ``list'' / ``info'' buffers using -the following variables (@dfn{ENTRY-TYPE} means @code{package}, -@code{output} or @code{generation}): - -@table @code -@item guix-ENTRY-TYPE-list-format -@itemx guix-ENTRY-TYPE-list-titles -Specify the columns, their names, what and how is displayed in ``list'' -buffers. - -@item guix-ENTRY-TYPE-info-format -@itemx guix-ENTRY-TYPE-info-titles -@itemx guix-info-ignore-empty-values -@itemx guix-info-param-title-format -@itemx guix-info-multiline-prefix -@itemx guix-info-indent -@itemx guix-info-fill -@itemx guix-info-delimiter -Various settings for ``info'' buffers. - -@end table - - -@node Emacs Licenses -@section Licenses - -If you want to browse the URL of a particular license, or to look at a -list of licenses, you may use the following commands: - -@table @kbd - -@item M-x guix-browse-license-url -Choose a license from a completion list to browse its URL using -@code{browse-url} function (@pxref{Browse-URL,,, emacs, The GNU Emacs -Manual}). - -@item M-x guix-licenses -Display a list of available licenses. You can press @kbd{@key{RET}} -there to display packages with this license in the same way as @kbd{M-x -guix-packages-by-license} would do (@pxref{Emacs Commands}). - -@item M-x guix-find-license-definition -Open @file{@dots{}/guix/licenses.scm} and move to the specified license. - -@end table - - -@node Emacs Package Locations -@section Package Source Locations - -As you know, package definitions are placed in Guile files, also known -as @dfn{package locations}. The following commands should help you not -get lost in these locations: - -@table @kbd - -@item M-x guix-locations -Display a list of package locations. You can press @key{RET} there to -display packages placed in the current location in the same way as -@kbd{M-x guix-packages-by-location} would do (@pxref{Emacs Commands}). -Note that when the point is on a location button, @key{RET} will open -this location file. - -@item M-x guix-find-location -Open the given package definition source file (press @key{TAB} to choose -a location from a completion list). - -@item M-x guix-edit -Find location of a specified package. This is an Emacs analog of -@command{guix edit} command (@pxref{Invoking guix edit}). As with -@kbd{M-x guix-packages-by-name}, you can press @key{TAB} to complete a -package name. - -@end table - -If you are contributing to Guix, you may find it useful for @kbd{M-x -guix-find-location} and @kbd{M-x guix-edit} to open locations from your -Git checkout. This can be done by setting @code{guix-directory} -variable. For example, after this: - -@example -(setq guix-directory "~/src/guix") -@end example - -@kbd{M-x guix-edit guix} opens -@file{~/src/guix/gnu/packages/package-management.scm} file. - -Also you can use @kbd{C-u} prefix argument to specify a directory just -for the current @kbd{M-x guix-find-location} or @kbd{M-x guix-edit} -command. - - -@node Emacs Popup Interface -@section Popup Interface - -If you ever used Magit, you know what ``popup interface'' is -(@pxref{Top,,, magit-popup, Magit-Popup User Manual}). Even if you are -not acquainted with Magit, there should be no worries as it is very -intuitive. - -So @kbd{M-x@tie{}guix} command provides a top-level popup interface for -all available guix commands. When you select an option, you'll be -prompted for a value in the minibuffer. Many values have completions, -so don't hesitate to press @key{TAB} key. Multiple values (for example, -packages or lint checkers) should be separated by commas. - -After specifying all options and switches for a command, you may choose -one of the available actions. The following default actions are -available for all commands: - -@itemize - -@item -Run the command in the Guix REPL. It is faster than running -@code{guix@tie{}@dots{}} command directly in shell, as there is no -need to run another guile process and to load required modules there. - -@item -Run the command in a shell buffer. You can set -@code{guix-run-in-shell-function} variable to fine tune the shell buffer -you want to use. - -@item -Add the command line to the kill ring (@pxref{Kill Ring,,, emacs, The -GNU Emacs Manual}). - -@end itemize - -Several commands (@command{guix graph}, @command{guix system shepherd-graph} -and @command{guix system extension-graph}) also have a ``View graph'' -action, which allows you to view a generated graph using @command{dot} -command (specified by @code{guix-dot-program} variable). By default a -PNG file will be saved in @file{/tmp} directory and will be opened -directly in Emacs. This behavior may be changed with the following -variables: - -@table @code - -@item guix-find-file-function -Function used to open a generated graph. If you want to open a graph in -an external program, you can do it by modifying this variable---for -example, you can use a functionality provided by the Org Mode -(@pxref{Top,,, org, The Org Manual}): - -@example -(setq guix-find-file-function 'org-open-file) -(add-to-list 'org-file-apps '("\\.png\\'" . "sxiv %s")) -@end example - -@item guix-dot-default-arguments -Command line arguments to run @command{dot} command. If you change an -output format (for example, into @code{-Tpdf}), you also need to change -the next variable. - -@item guix-dot-file-name-function -Function used to define a name of the generated graph file. Default -name is @file{/tmp/guix-emacs-graph-XXXXXX.png}. - -@end table - -So, for example, if you want to generate and open a PDF file in your -Emacs, you may change the settings like this: - -@example -(defun my-guix-pdf-graph () - "/tmp/my-current-guix-graph.pdf") - -(setq guix-dot-default-arguments '("-Tpdf") - guix-dot-file-name-function 'my-guix-pdf-graph) -@end example - - -@node Emacs Prettify -@section Guix Prettify Mode - -GNU@tie{}Guix also comes with ``guix-prettify.el''. It provides a minor -mode for abbreviating store file names by replacing hash sequences of -symbols with ``@dots{}'': - -@example -/gnu/store/72f54nfp6g1hz873w8z3gfcah0h4nl9p-foo-0.1 -@result{} /gnu/store/…-foo-0.1 -@end example - -Once you set up ``guix.el'' (@pxref{Emacs Initial Setup}), the following -commands become available: - -@table @kbd - -@item M-x guix-prettify-mode -Enable/disable prettifying for the current buffer. - -@item M-x global-guix-prettify-mode -Enable/disable prettifying globally. - -@end table - -To automatically enable @code{guix-prettify-mode} globally on Emacs -start, add the following line to your init file: - -@example -(global-guix-prettify-mode) -@end example - -If you want to enable it only for specific major modes, add it to the -mode hooks (@pxref{Hooks,,, emacs, The GNU Emacs Manual}), for example: - -@example -(add-hook 'shell-mode-hook 'guix-prettify-mode) -(add-hook 'dired-mode-hook 'guix-prettify-mode) -@end example - - -@node Emacs Build Log -@section Build Log Mode - -GNU@tie{}Guix provides major and minor modes for highlighting build -logs. So when you have a file with a package build output---for -example, a file returned by @command{guix build --log-file @dots{}} -command (@pxref{Invoking guix build}), you may call @kbd{M-x -guix-build-log-mode} command in the buffer with this file. This major -mode highlights some lines specific to build output and provides the -following key bindings: - -@table @kbd - -@item M-n -Move to the next build phase. - -@item M-p -Move to the previous build phase. - -@item @key{TAB} -Toggle (show/hide) the body of the current build phase. - -@item S-@key{TAB} -Toggle (show/hide) the bodies of all build phases. - -@end table - -There is also @kbd{M-x guix-build-log-minor-mode} which also provides -the same highlighting and the same key bindings as the major mode, but -prefixed with @kbd{C-c}. By default, this minor mode is enabled in -shell buffers (@pxref{Interactive Shell,,, emacs, The GNU Emacs -Manual}). If you don't like it, set -@code{guix-build-log-minor-mode-activate} to nil. - - -@node Emacs Completions -@section Shell Completions - -Another feature that becomes available after configuring Emacs interface -(@pxref{Emacs Initial Setup}) is completing of @command{guix} -subcommands, options, packages and other things in @code{shell} -(@pxref{Interactive Shell,,, emacs, The GNU Emacs Manual}) and -@code{eshell} (@pxref{Top,,, eshell, Eshell: The Emacs Shell}). - -It works the same way as other completions do. Just press @key{TAB} -when your intuition tells you. - -And here are some examples, where pressing @key{TAB} may complete -something: - -@itemize @w{} - -@item @code{guix pa}@key{TAB} -@item @code{guix package -}@key{TAB} -@item @code{guix package --}@key{TAB} -@item @code{guix package -i gei}@key{TAB} -@item @code{guix build -L/tm}@key{TAB} -@item @code{guix build --sy}@key{TAB} -@item @code{guix build --system=i}@key{TAB} -@item @code{guix system rec}@key{TAB} -@item @code{guix lint --checkers=sy}@key{TAB} -@item @code{guix lint --checkers=synopsis,des}@key{TAB} - -@end itemize - - -@node Emacs Development -@section Development - -By default, when you open a Scheme file, @code{guix-devel-mode} will be -activated (if you don't want it, set @code{guix-devel-activate-mode} to -nil). This minor mode provides the following key bindings: - -@table @kbd - -@item C-c . k -Copy the name of the current Guile module into kill ring -(@code{guix-devel-copy-module-as-kill}). - -@item C-c . u -Use the current Guile module. Often after opening a Scheme file, you -want to use a module it defines, so you switch to the Geiser REPL and -write @code{,use (some module)} there. You may just use this command -instead (@code{guix-devel-use-module}). - -@item C-c . b -Build a package defined by the current variable definition. The -building process is run in the current Geiser REPL. If you modified the -current package definition, don't forget to reevaluate it before calling -this command---for example, with @kbd{C-M-x} (@pxref{To eval or not to -eval,,, geiser, Geiser User Manual}) -(@code{guix-devel-build-package-definition}). - -@item C-c . s -Build a source derivation of the package defined by the current variable -definition. This command has the same meaning as @code{guix build -S} -shell command (@pxref{Invoking guix build}) -(@code{guix-devel-build-package-source}). - -@item C-c . l -Lint (check) a package defined by the current variable definition -(@pxref{Invoking guix lint}) (@code{guix-devel-lint-package}). - -@end table - -Unluckily, there is a limitation related to long-running REPL commands. -When there is a running process in a Geiser REPL, you are not supposed -to evaluate anything in a scheme buffer, because this will ``freeze'' -the REPL: it will stop producing any output (however, the evaluating -process will continue---you will just not see any progress anymore). Be -aware: even moving the point in a scheme buffer may ``break'' the REPL -if Autodoc (@pxref{Autodoc and friends,,, geiser, Geiser User Manual}) -is enabled (which is the default). - -So you have to postpone editing your scheme buffers until the running -evaluation will be finished in the REPL. - -Alternatively, to avoid this limitation, you may just run another Geiser -REPL, and while something is being evaluated in the previous REPL, you -can continue editing a scheme file with the help of the current one. - - -@node Emacs Hydra -@section Hydra - -The continuous integration server at @code{hydra.gnu.org} builds all -the distribution packages on the supported architectures and serves -them as substitutes (@pxref{Substitutes}). Continuous integration is -currently orchestrated by @uref{https://nixos.org/hydra/, Hydra}. - -This section describes an Emacs interface to query Hydra to know the -build status of specific packages, discover recent and ongoing builds, -view build logs, and so on. This interface is mostly the same as the -``list''/``info'' interface for displaying packages and generations -(@pxref{Emacs Package Management}). - -The following commands are available: - -@table @kbd - -@item M-x guix-hydra-latest-builds -Display latest failed or successful builds (you will be prompted for a -number of builds). With @kbd{C-u}, you will also be prompted for other -parameters (project, jobset, job and system). - -@item M-x guix-hydra-queued-builds -Display scheduled or currently running builds (you will be prompted for -a number of builds). - -@item M-x guix-hydra-jobsets -Display available jobsets (you will be prompted for a project). - -@end table - -In a list of builds you can press @kbd{L} key to display a build log of -the current build. Also both a list of builds and a list of jobsets -provide @kbd{B} key to display latest builds of the current job or -jobset (don't forget about @kbd{C-u}). diff --git a/doc/guix.texi b/doc/guix.texi index 69129d5835..8756061a46 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -54,12 +54,6 @@ Documentation License''. * guix environment: (guix)Invoking guix environment. Building development environments with Guix. @end direntry -@dircategory Emacs -@direntry -* Guix user interface: (guix)Emacs Interface. Package management from the comfort of Emacs. -@end direntry - - @titlepage @title GNU Guix Reference Manual @subtitle Using the GNU Guix Functional Package Manager @@ -86,7 +80,6 @@ package management tool written for the GNU system. * Introduction:: What is Guix about? * Installation:: Installing Guix. * Package Management:: Package installation, upgrade, etc. -* Emacs Interface:: Using Guix from Emacs. * Programming Interface:: Using Guix in Scheme. * Utilities:: Package management commands. * GNU Distribution:: Software for your friendly GNU system. @@ -124,19 +117,6 @@ Package Management * Invoking guix pull:: Fetching the latest Guix and distribution. * Invoking guix archive:: Exporting and importing store files. -Emacs Interface - -* Initial Setup: Emacs Initial Setup. Preparing @file{~/.emacs}. -* Package Management: Emacs Package Management. Managing packages and generations. -* Licenses: Emacs Licenses. Interface for licenses of Guix packages. -* Package Source Locations: Emacs Package Locations. Interface for package location files. -* Popup Interface: Emacs Popup Interface. Magit-like interface for guix commands. -* Prettify Mode: Emacs Prettify. Abbreviating @file{/gnu/store/@dots{}} file names. -* Build Log Mode: Emacs Build Log. Highlighting Guix build logs. -* Completions: Emacs Completions. Completing @command{guix} shell command. -* Development: Emacs Development. Tools for Guix developers. -* Hydra: Emacs Hydra. Interface for Guix build farm. - Programming Interface * Defining Packages:: Defining new packages. @@ -278,8 +258,7 @@ assists with the creation and maintenance of software environments. @cindex user interfaces Guix provides a command-line package management interface (@pxref{Invoking guix package}), a set of command-line utilities -(@pxref{Utilities}), a visual user interface in Emacs (@pxref{Emacs -Interface}), as well as Scheme programming interfaces +(@pxref{Utilities}), as well as Scheme programming interfaces (@pxref{Programming Interface}). @cindex build daemon Its @dfn{build daemon} is responsible for building packages on behalf of @@ -1414,10 +1393,14 @@ procedures or dependencies. Guix also goes beyond this obvious set of features. This chapter describes the main features of Guix, as well as the package -management tools it provides. Two user interfaces are provided for -routine package management tasks: A command-line interface described below -(@pxref{Invoking guix package, @code{guix package}}), as well as a visual user -interface in Emacs described in a subsequent chapter (@pxref{Emacs Interface}). +management tools it provides. Along with the command-line interface +described below (@pxref{Invoking guix package, @code{guix package}}), +you may also use Emacs Interface, after installing @code{emacs-guix} +package (run @kbd{M-x guix-help} command to start with it): + +@example +guix package -i emacs-guix +@end example @menu * Features:: How Guix will make your life brighter. @@ -1434,9 +1417,7 @@ interface in Emacs described in a subsequent chapter (@pxref{Emacs Interface}). When using Guix, each package ends up in the @dfn{package store}, in its own directory---something that resembles -@file{/gnu/store/xxx-package-1.2}, where @code{xxx} is a base32 string -(note that Guix comes with an Emacs extension to shorten those file -names, @pxref{Emacs Prettify}.) +@file{/gnu/store/xxx-package-1.2}, where @code{xxx} is a base32 string. Instead of referring to these directories, users have their own @dfn{profile}, which points to the packages that they actually want to @@ -1982,9 +1963,7 @@ also result from derivation builds, can be available as substitutes. The @code{hydra.gnu.org} server is a front-end to a build farm that builds packages from the GNU distribution continuously for some -architectures, and makes them available as substitutes (@pxref{Emacs -Hydra}, for information on how to query the continuous integration -server). This is the +architectures, and makes them available as substitutes. This is the default source of substitutes; it can be overridden by passing the @option{--substitute-urls} option either to @command{guix-daemon} (@pxref{daemon-substitute-urls,, @code{guix-daemon --substitute-urls}}) @@ -2509,9 +2488,6 @@ archive contents coming from possibly untrusted substitute servers. @end table -@c ********************************************************************* -@include emacs.texi - @c ********************************************************************* @node Programming Interface @chapter Programming Interface @@ -4923,11 +4899,6 @@ have created your own packages on @code{GUIX_PACKAGE_PATH} recipes. Otherwise, you will be able to examine the read-only recipes for packages currently in the store. -If you are using Emacs, note that the Emacs user interface provides the -@kbd{M-x guix-edit} command and a similar functionality in the ``package -info'' and ``package list'' buffers created by the @kbd{M-x -guix-search-by-name} and similar commands (@pxref{Emacs Commands}). - @node Invoking guix download @section Invoking @command{guix download} diff --git a/doc/htmlxref.cnf b/doc/htmlxref.cnf index bd2eb5f147..93e214fcc5 100644 --- a/doc/htmlxref.cnf +++ b/doc/htmlxref.cnf @@ -219,6 +219,8 @@ emacs node ${EMACS}/html_node/emacs/ easejs mono ${GS}/easejs/manual/easejs.html easejs node ${GS}/easejs/manual/ +emacs-guix mono https://notabug.org/alezost/emacs-guix + emacs-muse node ${GS}/emacs-muse/manual/muse.html emacs-muse node ${GS}/emacs-muse/manual/html_node/ diff --git a/emacs/guix-about.el b/emacs/guix-about.el deleted file mode 100644 index 27a79fe162..0000000000 --- a/emacs/guix-about.el +++ /dev/null @@ -1,37 +0,0 @@ -;;; guix-about.el --- Various info about Guix - -;; Copyright © 2016 Alex Kost - -;; 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 Location as published by -;; the Free Software Foundation, either version 3 of the Location, 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 Location for more details. - -;; You should have received a copy of the GNU General Public Location -;; along with this program. If not, see . - -;;; Commentary: - -;; This file provides the code to display various info about Guix (e.g., its -;; version). - -;;; Code: - -(require 'guix-config) - -;;;###autoload -(defun guix-version () - "Display Guix version in the echo area." - (interactive) - (message "%s %s" guix-config-name guix-config-version)) - -(provide 'guix-about) - -;;; guix-about.el ends here diff --git a/emacs/guix-backend.el b/emacs/guix-backend.el deleted file mode 100644 index 6341aacae1..0000000000 --- a/emacs/guix-backend.el +++ /dev/null @@ -1,393 +0,0 @@ -;;; guix-backend.el --- Making and using Guix REPL - -;; Copyright © 2014, 2015, 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides the code for interacting with Guile using Guix REPL -;; (Geiser REPL with some guix-specific additions). - -;; By default (if `guix-use-guile-server' is non-nil) 2 Guix REPLs are -;; started. The main one (with "guile --listen" process) is used for -;; "interacting" with a user - for showing a progress of -;; installing/deleting Guix packages. The second (internal) REPL is -;; used for synchronous evaluating, e.g. when information about -;; packages/generations should be received for a list/info buffer. -;; -;; This "2 REPLs concept" makes it possible to have a running process of -;; installing/deleting packages and to continue to search/list/get info -;; about other packages at the same time. If you prefer to use a single -;; Guix REPL, do not try to receive any information while there is a -;; running code in the REPL (see -;; ). -;; -;; Guix REPLs (unlike the usual Geiser REPLs) are not added to -;; `geiser-repl--repls' variable, and thus cannot be used for evaluating -;; while editing scm-files. The only purpose of Guix REPLs is to be an -;; intermediate between "Guix/Guile level" and "Emacs interface level". -;; That being said you can still want to use a Guix REPL while hacking -;; auxiliary scheme-files for "guix.el". You can just use -;; `geiser-connect-local' command with `guix-repl-current-socket' to -;; have a usual Geiser REPL with all stuff defined by "guix.el" package. - -;;; Code: - -(require 'geiser-mode) -(require 'geiser-guile) -(require 'guix-geiser) -(require 'guix-config) -(require 'guix-external) -(require 'guix-emacs) -(require 'guix-profiles) - -(defvar guix-load-path guix-config-emacs-interface-directory - "Directory with scheme files for \"guix.el\" package.") - -(defvar guix-helper-file - (expand-file-name "guix-helper.scm" guix-load-path) - "Auxiliary scheme file for loading.") - - -;;; REPL - -(defgroup guix-repl nil - "Settings for Guix REPLs." - :prefix "guix-repl-" - :group 'guix) - -(defcustom guix-repl-startup-time 30000 - "Time, in milliseconds, to wait for Guix REPL to startup. -Same as `geiser-repl-startup-time' but is used for Guix REPL. -If you have a slow system, try to increase this time." - :type 'integer - :group 'guix-repl) - -(defcustom guix-repl-buffer-name "*Guix REPL*" - "Default name of a Geiser REPL buffer used for Guix." - :type 'string - :group 'guix-repl) - -(defcustom guix-after-start-repl-hook '(guix-set-directory) - "Hook called after Guix REPL is started." - :type 'hook - :group 'guix-repl) - -(defcustom guix-use-guile-server t - "If non-nil, start guile with '--listen' argument. -This allows to receive information about packages using an additional -REPL while some packages are being installed/removed in the main REPL." - :type 'boolean - :group 'guix-repl) - -(defcustom guix-repl-socket-file-name-function - #'guix-repl-socket-file-name - "Function used to define a socket file name used by Guix REPL. -The function is called without arguments." - :type '(choice (function-item guix-repl-socket-file-name) - (function :tag "Other function")) - :group 'guix-repl) - -(defcustom guix-emacs-activate-after-operation t - "Activate Emacs packages after installing. -If nil, do not load autoloads of the Emacs packages after -they are successfully installed." - :type 'boolean - :group 'guix-repl) - -(defvar guix-repl-current-socket nil - "Name of a socket file used by the current Guix REPL.") - -(defvar guix-repl-buffer nil - "Main Geiser REPL buffer used for communicating with Guix. -This REPL is used for processing package actions and for -receiving information if `guix-use-guile-server' is nil.") - -(defvar guix-internal-repl-buffer nil - "Additional Geiser REPL buffer used for communicating with Guix. -This REPL is used for receiving information only if -`guix-use-guile-server' is non-nil.") - -(defvar guix-internal-repl-buffer-name "*Guix Internal REPL*" - "Default name of an internal Guix REPL buffer.") - -(defvar guix-before-repl-operation-hook nil - "Hook run before executing an operation in Guix REPL.") - -(defvar guix-after-repl-operation-hook - '(guix-repl-autoload-emacs-packages-maybe - guix-repl-operation-success-message) - "Hook run after executing successful operation in Guix REPL.") - -(defvar guix-repl-operation-p nil - "Non-nil, if current operation is performed by `guix-eval-in-repl'. -This internal variable is used to distinguish Guix operations -from operations performed in Guix REPL by a user.") - -(defvar guix-repl-operation-type nil - "Type of the current operation performed by `guix-eval-in-repl'. -This internal variable is used to define what actions should be -executed after the current operation succeeds. -See `guix-eval-in-repl' for details.") - -(defun guix-repl-autoload-emacs-packages-maybe () - "Load autoloads for Emacs packages if needed. -See `guix-emacs-activate-after-operation' for details." - (and guix-emacs-activate-after-operation - ;; FIXME Since a user can work with a non-current profile (using - ;; C-u before `guix-search-by-name' and other commands), emacs - ;; packages can be installed to another profile, and the - ;; following code will not work (i.e., the autoloads for this - ;; profile will not be loaded). - (guix-emacs-autoload-packages guix-current-profile))) - -(defun guix-repl-operation-success-message () - "Message telling about successful Guix operation." - (message "Guix operation has been performed.")) - -(defun guix-get-guile-program (&optional socket) - "Return a value suitable for `geiser-guile-binary'." - (if (null socket) - guix-guile-program - (append (if (listp guix-guile-program) - guix-guile-program - (list guix-guile-program)) - (list (concat "--listen=" socket))))) - -(defun guix-repl-socket-file-name () - "Return a name of a socket file used by Guix REPL." - (make-temp-name - (concat (file-name-as-directory temporary-file-directory) - "guix-repl-"))) - -(defun guix-repl-delete-socket-maybe () - "Delete `guix-repl-current-socket' file if it exists." - (and guix-repl-current-socket - (file-exists-p guix-repl-current-socket) - (delete-file guix-repl-current-socket))) - -(add-hook 'kill-emacs-hook 'guix-repl-delete-socket-maybe) - -(defun guix-start-process-maybe (&optional start-msg end-msg) - "Start Geiser REPL configured for Guix if needed. -START-MSG and END-MSG are strings displayed in the minibuffer in -the beginning and in the end of the starting process. If nil, -display default messages." - (guix-start-repl-maybe nil - (or start-msg "Starting Guix REPL ...") - (or end-msg "Guix REPL has been started.")) - (if guix-use-guile-server - (guix-start-repl-maybe 'internal) - (setq guix-internal-repl-buffer guix-repl-buffer))) - -(defun guix-start-repl-maybe (&optional internal start-msg end-msg) - "Start Guix REPL if needed. -If INTERNAL is non-nil, start an internal REPL. - -START-MSG and END-MSG are strings displayed in the minibuffer in -the beginning and in the end of the process. If nil, do not -display messages." - (let* ((repl-var (guix-get-repl-buffer-variable internal)) - (repl (symbol-value repl-var))) - (unless (and (buffer-live-p repl) - (get-buffer-process repl)) - (and start-msg (message start-msg)) - (setq guix-repl-operation-p nil) - (unless internal - ;; Guile leaves socket file after exit, so remove it if it - ;; exists (after the REPL restart). - (guix-repl-delete-socket-maybe) - (setq guix-repl-current-socket - (and guix-use-guile-server - (or guix-repl-current-socket - (funcall guix-repl-socket-file-name-function))))) - (let ((geiser-guile-binary (guix-get-guile-program - (unless internal - guix-repl-current-socket))) - (geiser-guile-init-file (unless internal guix-helper-file)) - (repl (get-buffer-create - (guix-get-repl-buffer-name internal)))) - (guix-start-repl repl (and internal guix-repl-current-socket)) - (set repl-var repl) - (and end-msg (message end-msg)) - (unless internal - (run-hooks 'guix-after-start-repl-hook)))))) - -(defun guix-start-repl (buffer &optional address) - "Start Guix REPL in BUFFER. -If ADDRESS is non-nil, connect to a remote guile process using -this address (it should be defined by -`geiser-repl--read-address')." - ;; A mix of the code from `geiser-repl--start-repl' and - ;; `geiser-repl--to-repl-buffer'. - (let ((impl 'guile) - (geiser-guile-load-path (cons (expand-file-name guix-load-path) - geiser-guile-load-path)) - (geiser-repl-startup-time guix-repl-startup-time)) - (with-current-buffer buffer - (geiser-repl-mode) - (geiser-impl--set-buffer-implementation impl) - (geiser-repl--autodoc-mode -1) - (goto-char (point-max)) - (let ((prompt (geiser-con--combined-prompt - geiser-guile--prompt-regexp - geiser-guile--debugger-prompt-regexp))) - (geiser-repl--save-remote-data address) - (geiser-repl--start-scheme impl address prompt) - (geiser-repl--quit-setup) - (geiser-repl--history-setup) - (setq-local geiser-repl--repls (list buffer)) - (geiser-repl--set-this-buffer-repl buffer) - (setq geiser-repl--connection - (geiser-con--make-connection - (get-buffer-process (current-buffer)) - geiser-guile--prompt-regexp - geiser-guile--debugger-prompt-regexp)) - (geiser-repl--startup impl address) - (geiser-repl--autodoc-mode 1) - (geiser-company--setup geiser-repl-company-p) - (add-hook 'comint-output-filter-functions - 'guix-repl-output-filter - nil t) - (set-process-query-on-exit-flag - (get-buffer-process (current-buffer)) - geiser-repl-query-on-kill-p))))) - -(defun guix-repl-output-filter (str) - "Filter function suitable for `comint-output-filter-functions'. -This is a replacement for `geiser-repl--output-filter'." - (cond - ((string-match-p geiser-guile--prompt-regexp str) - (geiser-autodoc--disinhibit-autodoc) - (when guix-repl-operation-p - (setq guix-repl-operation-p nil) - (run-hooks 'guix-after-repl-operation-hook) - ;; Run hooks specific to the current operation type. - (when guix-repl-operation-type - (let ((type-hook (intern - (concat "guix-after-" - (symbol-name guix-repl-operation-type) - "-hook")))) - (setq guix-repl-operation-type nil) - (and (boundp type-hook) - (run-hooks type-hook)))))) - ((string-match geiser-guile--debugger-prompt-regexp str) - (setq guix-repl-operation-p nil) - (geiser-con--connection-set-debugging geiser-repl--connection - (match-beginning 0)) - (geiser-autodoc--disinhibit-autodoc)))) - -(defun guix-repl-exit (&optional internal no-wait) - "Exit the current Guix REPL. -If INTERNAL is non-nil, exit the internal REPL. -If NO-WAIT is non-nil, do not wait for the REPL process to exit: -send a kill signal to it and return immediately." - (let ((repl (symbol-value (guix-get-repl-buffer-variable internal)))) - (when (get-buffer-process repl) - (with-current-buffer repl - (geiser-con--connection-deactivate geiser-repl--connection t) - (comint-kill-subjob) - (unless no-wait - (while (get-buffer-process repl) - (sleep-for 0.1))))))) - -(defun guix-get-repl-buffer (&optional internal) - "Return Guix REPL buffer; start REPL if needed. -If INTERNAL is non-nil, return an additional internal REPL." - (guix-start-process-maybe) - (let ((repl (symbol-value (guix-get-repl-buffer-variable internal)))) - ;; If a new Geiser REPL is started, `geiser-repl--repl' variable may - ;; be set to the new value in a Guix REPL, so set it back to a - ;; proper value here. - (with-current-buffer repl - (geiser-repl--set-this-buffer-repl repl)) - repl)) - -(defun guix-get-repl-buffer-variable (&optional internal) - "Return the name of a variable with a REPL buffer." - (if internal - 'guix-internal-repl-buffer - 'guix-repl-buffer)) - -(defun guix-get-repl-buffer-name (&optional internal) - "Return the name of a REPL buffer." - (if internal - guix-internal-repl-buffer-name - guix-repl-buffer-name)) - -(defun guix-switch-to-repl (&optional internal) - "Switch to Guix REPL. -If INTERNAL is non-nil (interactively with prefix), switch to the -additional internal REPL if it exists." - (interactive "P") - (geiser-repl--switch-to-buffer (guix-get-repl-buffer internal))) - - -;;; Guix directory - -(defvar guix-directory nil - "Default directory with Guix source. -If it is not set by a user, it is set after starting Guile REPL. -This directory is used to define package locations.") - -(defun guix-read-directory () - "Return `guix-directory' or prompt for it. -This function is intended for using in `interactive' forms." - (if current-prefix-arg - (read-directory-name "Directory with Guix modules: " - guix-directory) - guix-directory)) - -(defun guix-set-directory () - "Set `guix-directory' if needed." - (or guix-directory - (setq guix-directory - (guix-eval-read "%guix-dir")))) - - -;;; Evaluating expressions - -(defvar guix-operation-buffer nil - "Buffer from which the latest Guix operation was performed.") - -(defun guix-eval (str) - "Evaluate STR with guile expression using Guix REPL. -See `guix-geiser-eval' for details." - (guix-geiser-eval str (guix-get-repl-buffer 'internal))) - -(defun guix-eval-read (str) - "Evaluate STR with guile expression using Guix REPL. -See `guix-geiser-eval-read' for details." - (guix-geiser-eval-read str (guix-get-repl-buffer 'internal))) - -(defun guix-eval-in-repl (str &optional operation-buffer operation-type) - "Switch to Guix REPL and evaluate STR with guile expression there. -If OPERATION-BUFFER is non-nil, it should be a buffer from which -the current operation was performed. - -If OPERATION-TYPE is non-nil, it should be a symbol. After -successful executing of the current operation, -`guix-after-OPERATION-TYPE-hook' is called." - (run-hooks 'guix-before-repl-operation-hook) - (setq guix-repl-operation-p t - guix-repl-operation-type operation-type - guix-operation-buffer operation-buffer) - (guix-geiser-eval-in-repl str (guix-get-repl-buffer))) - -(provide 'guix-backend) - -;;; guix-backend.el ends here diff --git a/emacs/guix-base.el b/emacs/guix-base.el deleted file mode 100644 index 658cfdb5fa..0000000000 --- a/emacs/guix-base.el +++ /dev/null @@ -1,377 +0,0 @@ -;;; guix-base.el --- Common definitions -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015, 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides some base and common definitions for guix.el -;; package. - -;;; Code: - -(require 'cl-lib) -(require 'guix-backend) -(require 'guix-guile) -(require 'guix-read) -(require 'guix-utils) -(require 'guix-ui) -(require 'guix-profiles) - -(defgroup guix nil - "Settings for Guix package manager and friends." - :prefix "guix-" - :group 'external) - -(defgroup guix-faces nil - "Guix faces." - :group 'guix - :group 'faces) - -(defun guix-package-name-specification (name version &optional output) - "Return Guix package specification by its NAME, VERSION and OUTPUT." - (concat name "@" version - (when output (concat ":" output)))) - - -;;; Location of profiles and manifests - -(defun guix-generation-file (profile generation) - "Return the file name of a PROFILE's GENERATION." - (format "%s-%s-link" profile generation)) - -(defun guix-packages-profile (profile &optional generation system?) - "Return a directory where packages are installed for the -PROFILE's GENERATION. - -If SYSTEM? is non-nil, then PROFILE is considered to be a system -profile. Unlike usual profiles, for a system profile, packages -are placed in 'profile' subdirectory." - (let ((profile (if generation - (guix-generation-file profile generation) - profile))) - (if system? - (expand-file-name "profile" profile) - profile))) - -(defun guix-manifest-file (profile &optional generation system?) - "Return the file name of a PROFILE's manifest. -See `guix-packages-profile'." - (expand-file-name "manifest" - (guix-packages-profile profile generation system?))) - - -;;; Actions on packages and generations - -(defface guix-operation-option-key - '((t :inherit font-lock-warning-face)) - "Face used for the keys of operation options." - :group 'guix-faces) - -(defcustom guix-operation-confirm t - "If nil, do not prompt to confirm an operation." - :type 'boolean - :group 'guix) - -(defcustom guix-use-substitutes t - "If non-nil, use substitutes for the Guix packages." - :type 'boolean - :group 'guix) - -(defvar guix-dry-run nil - "If non-nil, do not perform the real actions, just simulate.") - -(defvar guix-temp-buffer-name " *Guix temp*" - "Name of a buffer used for displaying info before executing operation.") - -(defvar guix-operation-option-true-string "yes" - "String displayed in the mode-line when operation option is t.") - -(defvar guix-operation-option-false-string "no " - "String displayed in the mode-line when operation option is nil.") - -(defvar guix-operation-option-separator " | " - "String used in the mode-line to separate operation options.") - -(defvar guix-operation-options - '((?s "substitutes" guix-use-substitutes) - (?d "dry-run" guix-dry-run)) - "List of available operation options. -Each element of the list has a form: - - (KEY NAME VARIABLE) - -KEY is a character that may be pressed during confirmation to -toggle the option. -NAME is a string displayed in the mode-line. -VARIABLE is a name of an option variable.") - -(defun guix-operation-option-by-key (key) - "Return operation option by KEY (character)." - (assq key guix-operation-options)) - -(defun guix-operation-option-key (option) - "Return key (character) of the operation OPTION." - (car option)) - -(defun guix-operation-option-name (option) - "Return name of the operation OPTION." - (nth 1 option)) - -(defun guix-operation-option-variable (option) - "Return name of the variable of the operation OPTION." - (nth 2 option)) - -(defun guix-operation-option-value (option) - "Return boolean value of the operation OPTION." - (symbol-value (guix-operation-option-variable option))) - -(defun guix-operation-option-string-value (option) - "Convert boolean value of the operation OPTION to string and return it." - (if (guix-operation-option-value option) - guix-operation-option-true-string - guix-operation-option-false-string)) - -(defun guix-operation-prompt (&optional prompt) - "Prompt a user for continuing the current operation. -Return non-nil, if the operation should be continued; nil otherwise. -Ask a user with PROMPT for continuing an operation." - (let* ((option-keys (mapcar #'guix-operation-option-key - guix-operation-options)) - (keys (append '(?y ?n) option-keys)) - (prompt (concat (propertize (or prompt "Continue operation?") - 'face 'minibuffer-prompt) - " (" - (mapconcat - (lambda (key) - (propertize (string key) - 'face 'guix-operation-option-key)) - keys - ", ") - ") "))) - (let ((mode-line mode-line-format)) - (prog1 (guix-operation-prompt-1 prompt keys) - (setq mode-line-format mode-line) - ;; Clear the minibuffer after prompting. - (message ""))))) - -(defun guix-operation-prompt-1 (prompt keys) - "This function is internal for `guix-operation-prompt'." - (guix-operation-set-mode-line) - (let ((key (read-char-choice prompt (cons ?\C-g keys) t))) - (cl-case key - (?y t) - ((?n ?\C-g) nil) - (t (let* ((option (guix-operation-option-by-key key)) - (var (guix-operation-option-variable option))) - (set var (not (symbol-value var))) - (guix-operation-prompt-1 prompt keys)))))) - -(defun guix-operation-set-mode-line () - "Display operation options in the mode-line of the current buffer." - (setq mode-line-format - (concat (propertize " Options: " - 'face 'mode-line-buffer-id) - (mapconcat - (lambda (option) - (let ((key (guix-operation-option-key option)) - (name (guix-operation-option-name option)) - (val (guix-operation-option-string-value option))) - (concat name - " (" - (propertize (string key) - 'face 'guix-operation-option-key) - "): " val))) - guix-operation-options - guix-operation-option-separator))) - (force-mode-line-update)) - -(defun guix-package-source-path (package-id) - "Return a store file path to a source of a package PACKAGE-ID." - (message "Calculating the source derivation ...") - (guix-eval-read - (guix-make-guile-expression - 'package-source-path package-id))) - -(defun guix-package-store-path (package-id) - "Return a list of store directories of outputs of package PACKAGE-ID." - (message "Calculating the package derivation ...") - (guix-eval-read - (guix-make-guile-expression - 'package-store-path package-id))) - -(defvar guix-after-source-download-hook nil - "Hook run after successful performing a 'source-download' operation.") - -(defun guix-package-source-build-derivation (package-id &optional prompt) - "Build source derivation of a package PACKAGE-ID. -Ask a user with PROMPT for continuing an operation." - (when (or (not guix-operation-confirm) - (guix-operation-prompt (or prompt - "Build the source derivation?"))) - (guix-eval-in-repl - (guix-make-guile-expression - 'package-source-build-derivation - package-id - :use-substitutes? (or guix-use-substitutes 'f) - :dry-run? (or guix-dry-run 'f)) - nil 'source-download))) - -(defun guix-build-package (package-id &optional prompt) - "Build package with PACKAGE-ID. -Ask a user with PROMPT for continuing the build operation." - (when (or (not guix-operation-confirm) - (guix-operation-prompt (or prompt "Build package?"))) - (guix-eval-in-repl - (format (concat ",run-in-store " - "(build-package (package-by-id %d)" - " #:use-substitutes? %s" - " #:dry-run? %s)") - package-id - (guix-guile-boolean guix-use-substitutes) - (guix-guile-boolean guix-dry-run))))) - -;;;###autoload -(defun guix-apply-manifest (profile file &optional operation-buffer) - "Apply manifest from FILE to PROFILE. -This function has the same meaning as 'guix package --manifest' command. -See Info node `(guix) Invoking guix package' for details. - -Interactively, use the current profile and prompt for manifest -FILE. With a prefix argument, also prompt for PROFILE." - (interactive - (let* ((current-profile (guix-ui-current-profile)) - (profile (if current-prefix-arg - (guix-profile-prompt) - (or current-profile guix-current-profile))) - (file (read-file-name "File with manifest: ")) - (buffer (and current-profile (current-buffer)))) - (list profile file buffer))) - (when (or (not guix-operation-confirm) - (y-or-n-p (format "Apply manifest from '%s' to profile '%s'? " - file profile))) - (guix-eval-in-repl - (guix-make-guile-expression - 'guix-command - "package" - (concat "--profile=" (expand-file-name profile)) - (concat "--manifest=" (expand-file-name file))) - operation-buffer))) - - -;;; Executing guix commands - -(defcustom guix-run-in-shell-function #'guix-run-in-shell - "Function used to run guix command. -The function is called with a single argument - a command line string." - :type '(choice (function-item guix-run-in-shell) - (function-item guix-run-in-eshell) - (function :tag "Other function")) - :group 'guix) - -(defcustom guix-shell-buffer-name "*shell*" - "Default name of a shell buffer used for running guix commands." - :type 'string - :group 'guix) - -(declare-function comint-send-input "comint" t) - -(defun guix-run-in-shell (string) - "Run command line STRING in `guix-shell-buffer-name' buffer." - (shell guix-shell-buffer-name) - (goto-char (point-max)) - (insert string) - (comint-send-input)) - -(declare-function eshell-send-input "esh-mode" t) - -(defun guix-run-in-eshell (string) - "Run command line STRING in eshell buffer." - (eshell) - (goto-char (point-max)) - (insert string) - (eshell-send-input)) - -(defun guix-run-command-in-shell (args) - "Execute 'guix ARGS ...' command in a shell buffer." - (funcall guix-run-in-shell-function - (guix-command-string args))) - -(defun guix-run-command-in-repl (args) - "Execute 'guix ARGS ...' command in Guix REPL." - (guix-eval-in-repl - (apply #'guix-make-guile-expression - 'guix-command args))) - -(defun guix-command-output (args) - "Return string with 'guix ARGS ...' output." - (cl-multiple-value-bind (output error) - (guix-eval (apply #'guix-make-guile-expression - 'guix-command-output args)) - ;; Remove trailing new space from the error string. - (message (replace-regexp-in-string "\n\\'" "" (read error))) - (read output))) - -(defun guix-help-string (&optional commands) - "Return string with 'guix COMMANDS ... --help' output." - (guix-eval-read - (apply #'guix-make-guile-expression - 'help-string commands))) - - -;;; Pull - -(defcustom guix-update-after-pull t - "If non-nil, update Guix buffers after performing \\[guix-pull]." - :type 'boolean - :group 'guix) - -(defvar guix-after-pull-hook - '(guix-restart-repl-after-pull guix-update-buffers-maybe-after-pull) - "Hook run after successful performing `guix-pull' operation.") - -(defun guix-restart-repl-after-pull () - "Restart Guix REPL after `guix-pull' operation." - (guix-repl-exit) - (guix-start-process-maybe - "Restarting Guix REPL after pull operation ...")) - -(defun guix-update-buffers-maybe-after-pull () - "Update buffers depending on `guix-update-after-pull'." - (when guix-update-after-pull - (mapc #'guix-ui-update-buffer - ;; No need to update "generation" buffers. - (guix-ui-buffers '(guix-package-list-mode - guix-package-info-mode - guix-output-list-mode - guix-output-info-mode))) - (message "Guix buffers have been updated."))) - -;;;###autoload -(defun guix-pull (&optional verbose) - "Run Guix pull operation. -If VERBOSE is non-nil (with prefix argument), produce verbose output." - (interactive "P") - (let ((args (and verbose '("--verbose")))) - (guix-eval-in-repl - (apply #'guix-make-guile-expression - 'guix-command "pull" args) - nil 'pull))) - -(provide 'guix-base) - -;;; guix-base.el ends here diff --git a/emacs/guix-buffer.el b/emacs/guix-buffer.el deleted file mode 100644 index 4cefe9989e..0000000000 --- a/emacs/guix-buffer.el +++ /dev/null @@ -1,624 +0,0 @@ -;;; guix-buffer.el --- Buffer interface for displaying data -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides a general 'buffer' interface for displaying an -;; arbitrary data. - -;;; Code: - -(require 'cl-lib) -(require 'guix-history) -(require 'guix-utils) - -(defvar guix-buffer-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "l") 'guix-history-back) - (define-key map (kbd "r") 'guix-history-forward) - (define-key map (kbd "g") 'revert-buffer) - (define-key map (kbd "R") 'guix-buffer-redisplay) - map) - "Parent keymap for Guix buffer modes.") - - -;;; Buffer item - -(cl-defstruct (guix-buffer-item - (:constructor nil) - (:constructor guix-buffer-make-item - (entries buffer-type entry-type args)) - (:copier nil)) - entries buffer-type entry-type args) - -(defvar-local guix-buffer-item nil - "Data (structure) for the current Guix buffer. -The structure consists of the following elements: - -- `entries': list of the currently displayed entries. - - Each element of the list is an alist with an entry data of the - following form: - - ((PARAM . VAL) ...) - - PARAM is a name of the entry parameter. - VAL is a value of this parameter. - -- `entry-type': type of the currently displayed entries. - -- `buffer-type': type of the current buffer. - -- `args': search arguments used to get the current entries.") -(put 'guix-buffer-item 'permanent-local t) - -(defmacro guix-buffer-with-item (item &rest body) - "Evaluate BODY using buffer ITEM. -The following local variables are available inside BODY: -`%entries', `%buffer-type', `%entry-type', `%args'. -See `guix-buffer-item' for details." - (declare (indent 1) (debug t)) - (let ((item-var (make-symbol "item"))) - `(let ((,item-var ,item)) - (let ((%entries (guix-buffer-item-entries ,item-var)) - (%buffer-type (guix-buffer-item-buffer-type ,item-var)) - (%entry-type (guix-buffer-item-entry-type ,item-var)) - (%args (guix-buffer-item-args ,item-var))) - ,@body)))) - -(defmacro guix-buffer-with-current-item (&rest body) - "Evaluate BODY using `guix-buffer-item'. -See `guix-buffer-with-item' for details." - (declare (indent 0) (debug t)) - `(guix-buffer-with-item guix-buffer-item - ,@body)) - -(defmacro guix-buffer-define-current-item-accessor (name) - "Define `guix-buffer-current-NAME' function to access NAME -element of `guix-buffer-item' structure. -NAME should be a symbol." - (let* ((name-str (symbol-name name)) - (accessor (intern (concat "guix-buffer-item-" name-str))) - (fun-name (intern (concat "guix-buffer-current-" name-str))) - (doc (format "\ -Return '%s' of the current Guix buffer. -See `guix-buffer-item' for details." - name-str))) - `(defun ,fun-name () - ,doc - (and guix-buffer-item - (,accessor guix-buffer-item))))) - -(defmacro guix-buffer-define-current-item-accessors (&rest names) - "Define `guix-buffer-current-NAME' functions for NAMES. -See `guix-buffer-define-current-item-accessor' for details." - `(progn - ,@(mapcar (lambda (name) - `(guix-buffer-define-current-item-accessor ,name)) - names))) - -(guix-buffer-define-current-item-accessors - entries entry-type buffer-type args) - -(defmacro guix-buffer-define-current-args-accessor (n prefix name) - "Define `PREFIX-NAME' function to access Nth element of 'args' -field of `guix-buffer-item' structure. -PREFIX and NAME should be strings." - (let ((fun-name (intern (concat prefix "-" name))) - (doc (format "\ -Return '%s' of the current Guix buffer. -'%s' is the element number %d in 'args' of `guix-buffer-item'." - name name n))) - `(defun ,fun-name () - ,doc - (nth ,n (guix-buffer-current-args))))) - -(defmacro guix-buffer-define-current-args-accessors (prefix &rest names) - "Define `PREFIX-NAME' functions for NAMES. -See `guix-buffer-define-current-args-accessor' for details." - `(progn - ,@(cl-loop for name in names - for i from 0 - collect `(guix-buffer-define-current-args-accessor - ,i ,prefix ,name)))) - - -;;; Wrappers for defined variables - -(defvar guix-buffer-data nil - "Alist with 'buffer' data. -This alist is filled by `guix-buffer-define-interface' macro.") - -(defun guix-buffer-value (buffer-type entry-type symbol) - "Return SYMBOL's value for BUFFER-TYPE/ENTRY-TYPE from `guix-buffer-data'." - (symbol-value - (guix-assq-value guix-buffer-data buffer-type entry-type symbol))) - -(defun guix-buffer-get-entries (buffer-type entry-type args) - "Return ENTRY-TYPE entries. -Call an appropriate 'get-entries' function from `guix-buffer' -using ARGS as its arguments." - (apply (guix-buffer-value buffer-type entry-type 'get-entries) - args)) - -(defun guix-buffer-mode-enable (buffer-type entry-type) - "Turn on major mode to display ENTRY-TYPE ENTRIES in BUFFER-TYPE buffer." - (funcall (guix-buffer-value buffer-type entry-type 'mode))) - -(defun guix-buffer-mode-initialize (buffer-type entry-type) - "Set up the current BUFFER-TYPE buffer to display ENTRY-TYPE entries." - (let ((fun (guix-buffer-value buffer-type entry-type 'mode-init))) - (when fun - (funcall fun)))) - -(defun guix-buffer-insert-entries (entries buffer-type entry-type) - "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." - (funcall (guix-buffer-value buffer-type entry-type 'insert-entries) - entries)) - -(defun guix-buffer-show-entries-default (entries buffer-type entry-type) - "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." - (let ((inhibit-read-only t)) - (erase-buffer) - (guix-buffer-mode-enable buffer-type entry-type) - (guix-buffer-insert-entries entries buffer-type entry-type) - (goto-char (point-min)))) - -(defun guix-buffer-show-entries (entries buffer-type entry-type) - "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." - (funcall (guix-buffer-value buffer-type entry-type 'show-entries) - entries)) - -(defun guix-buffer-message (entries buffer-type entry-type args) - "Display a message for BUFFER-ITEM after showing entries." - (let ((fun (guix-buffer-value buffer-type entry-type 'message))) - (when fun - (apply fun entries args)))) - -(defun guix-buffer-name (buffer-type entry-type args) - "Return name of BUFFER-TYPE buffer for displaying ENTRY-TYPE entries." - (let ((str-or-fun (guix-buffer-value buffer-type entry-type - 'buffer-name))) - (if (stringp str-or-fun) - str-or-fun - (apply str-or-fun args)))) - -(defun guix-buffer-param-title (buffer-type entry-type param) - "Return PARAM title for BUFFER-TYPE/ENTRY-TYPE." - (or (guix-assq-value (guix-buffer-value buffer-type entry-type 'titles) - param) - ;; Fallback to a title defined in 'info' interface. - (unless (eq buffer-type 'info) - (guix-assq-value (guix-buffer-value 'info entry-type 'titles) - param)) - (guix-symbol-title param))) - -(defun guix-buffer-history-size (buffer-type entry-type) - "Return history size for BUFFER-TYPE/ENTRY-TYPE." - (guix-buffer-value buffer-type entry-type 'history-size)) - -(defun guix-buffer-revert-confirm? (buffer-type entry-type) - "Return 'revert-confirm' value for BUFFER-TYPE/ENTRY-TYPE." - (guix-buffer-value buffer-type entry-type 'revert-confirm)) - - -;;; Displaying entries - -(defun guix-buffer-display (buffer) - "Switch to a Guix BUFFER." - (pop-to-buffer buffer - '((display-buffer-reuse-window - display-buffer-same-window)))) - -(defun guix-buffer-history-item (buffer-item) - "Make and return a history item for displaying BUFFER-ITEM." - (list #'guix-buffer-set buffer-item)) - -(defun guix-buffer-set (buffer-item &optional history) - "Set up the current buffer for displaying BUFFER-ITEM. -HISTORY should be one of the following: - - `nil' - do not save BUFFER-ITEM in history, - - `add' - add it to history, - - `replace' - replace the current history item." - (guix-buffer-with-item buffer-item - (when %entries - ;; Set buffer item before showing entries, so that its value can - ;; be used by the code for displaying entries. - (setq guix-buffer-item buffer-item) - (guix-buffer-show-entries %entries %buffer-type %entry-type) - (when history - (funcall (cl-ecase history - (add #'guix-history-add) - (replace #'guix-history-replace)) - (guix-buffer-history-item buffer-item)))) - (guix-buffer-message %entries %buffer-type %entry-type %args))) - -(defun guix-buffer-display-entries-current - (entries buffer-type entry-type args &optional history) - "Show ENTRIES in the current Guix buffer. -See `guix-buffer-item' for the meaning of BUFFER-TYPE, ENTRY-TYPE -and ARGS, and `guix-buffer-set' for the meaning of HISTORY." - (let ((item (guix-buffer-make-item entries buffer-type - entry-type args))) - (guix-buffer-set item history))) - -(defun guix-buffer-get-display-entries-current - (buffer-type entry-type args &optional history) - "Search for entries and show them in the current Guix buffer. -See `guix-buffer-display-entries-current' for details." - (guix-buffer-display-entries-current - (guix-buffer-get-entries buffer-type entry-type args) - buffer-type entry-type args history)) - -(defun guix-buffer-display-entries - (entries buffer-type entry-type args &optional history) - "Show ENTRIES in a BUFFER-TYPE buffer. -See `guix-buffer-display-entries-current' for details." - (let ((buffer (get-buffer-create - (guix-buffer-name buffer-type entry-type args)))) - (with-current-buffer buffer - (guix-buffer-display-entries-current - entries buffer-type entry-type args history)) - (when entries - (guix-buffer-display buffer)))) - -(defun guix-buffer-get-display-entries - (buffer-type entry-type args &optional history) - "Search for entries and show them in a BUFFER-TYPE buffer. -See `guix-buffer-display-entries-current' for details." - (guix-buffer-display-entries - (guix-buffer-get-entries buffer-type entry-type args) - buffer-type entry-type args history)) - -(defun guix-buffer-revert (_ignore-auto noconfirm) - "Update the data in the current Guix buffer. -This function is suitable for `revert-buffer-function'. -See `revert-buffer' for the meaning of NOCONFIRM." - (guix-buffer-with-current-item - (when (or noconfirm - (not (guix-buffer-revert-confirm? %buffer-type %entry-type)) - (y-or-n-p "Update the current buffer? ")) - (guix-buffer-get-display-entries-current - %buffer-type %entry-type %args 'replace)))) - -(defvar guix-buffer-after-redisplay-hook nil - "Hook run by `guix-buffer-redisplay'. -This hook is called before seting up a window position.") - -(defun guix-buffer-redisplay () - "Redisplay the current Guix buffer. -Restore the point and window positions after redisplaying. - -This function does not update the buffer data, use -'\\[revert-buffer]' if you want the full update." - (interactive) - (let* ((old-point (point)) - ;; For simplicity, ignore an unlikely case when multiple - ;; windows display the same buffer. - (window (car (get-buffer-window-list (current-buffer) nil t))) - (window-start (and window (window-start window)))) - (guix-buffer-set guix-buffer-item) - (goto-char old-point) - (run-hooks 'guix-buffer-after-redisplay-hook) - (when window - (set-window-point window (point)) - (set-window-start window window-start)))) - -(defun guix-buffer-redisplay-goto-button () - "Redisplay the current buffer and go to the next button, if needed." - (let ((guix-buffer-after-redisplay-hook - (cons (lambda () - (unless (button-at (point)) - (forward-button 1))) - guix-buffer-after-redisplay-hook))) - (guix-buffer-redisplay))) - - -;;; Interface definers - -(defmacro guix-define-groups (type &rest args) - "Define `guix-TYPE' and `guix-TYPE-faces' custom groups. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Optional keywords: - - - `:parent-group' - name of a parent custom group. - - - `:parent-faces-group' - name of a parent custom faces group. - - - `:group-doc' - docstring of a `guix-TYPE' group. - - - `:faces-group-doc' - docstring of a `guix-TYPE-faces' group." - (declare (indent 1)) - (let* ((type-str (symbol-name type)) - (prefix (concat "guix-" type-str)) - (group (intern prefix)) - (faces-group (intern (concat prefix "-faces")))) - (guix-keyword-args-let args - ((parent-group :parent-group 'guix) - (parent-faces-group :parent-faces-group 'guix-faces) - (group-doc :group-doc - (format "Settings for '%s' buffers." - type-str)) - (faces-group-doc :faces-group-doc - (format "Faces for '%s' buffers." - type-str))) - `(progn - (defgroup ,group nil - ,group-doc - :group ',parent-group) - - (defgroup ,faces-group nil - ,faces-group-doc - :group ',group - :group ',parent-faces-group))))) - -(defmacro guix-define-entry-type (entry-type &rest args) - "Define general code for ENTRY-TYPE. -See `guix-define-groups'." - (declare (indent 1)) - `(guix-define-groups ,entry-type - ,@args)) - -(defmacro guix-define-buffer-type (buffer-type &rest args) - "Define general code for BUFFER-TYPE. -See `guix-define-groups'." - (declare (indent 1)) - `(guix-define-groups ,buffer-type - ,@args)) - -(defmacro guix-buffer-define-interface (buffer-type entry-type &rest args) - "Define BUFFER-TYPE interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... -In the following description TYPE means ENTRY-TYPE-BUFFER-TYPE. - -Required keywords: - - - `:buffer-name' - default value of the generated - `guix-TYPE-buffer-name' variable. - - - `:get-entries-function' - default value of the generated - `guix-TYPE-get-function' variable. - - - `:show-entries-function' - default value of the generated - `guix-TYPE-show-function' variable. - - Alternatively, if `:show-entries-function' is not specified, a - default `guix-TYPE-show-entries' will be generated, and the - following keyword should be specified instead: - - - `:insert-entries-function' - default value of the generated - `guix-TYPE-insert-function' variable. - -Optional keywords: - - - `:message-function' - default value of the generated - `guix-TYPE-message-function' variable. - - - `:titles' - default value of the generated - `guix-TYPE-titles' variable. - - - `:history-size' - default value of the generated - `guix-TYPE-history-size' variable. - - - `:revert-confirm?' - default value of the generated - `guix-TYPE-revert-confirm' variable. - - - `:mode-name' - name (a string appeared in the mode-line) of - the generated `guix-TYPE-mode'. - - - `:mode-init-function' - default value of the generated - `guix-TYPE-mode-initialize-function' variable. - - - `:reduced?' - if non-nil, generate only group, faces group - and titles variable (if specified); all keywords become - optional." - (declare (indent 2)) - (let* ((entry-type-str (symbol-name entry-type)) - (buffer-type-str (symbol-name buffer-type)) - (prefix (concat "guix-" entry-type-str "-" - buffer-type-str)) - (group (intern prefix)) - (faces-group (intern (concat prefix "-faces"))) - (get-entries-var (intern (concat prefix "-get-function"))) - (show-entries-var (intern (concat prefix "-show-function"))) - (show-entries-fun (intern (concat prefix "-show-entries"))) - (message-var (intern (concat prefix "-message-function"))) - (buffer-name-var (intern (concat prefix "-buffer-name"))) - (titles-var (intern (concat prefix "-titles"))) - (history-size-var (intern (concat prefix "-history-size"))) - (revert-confirm-var (intern (concat prefix "-revert-confirm")))) - (guix-keyword-args-let args - ((get-entries-val :get-entries-function) - (show-entries-val :show-entries-function) - (insert-entries-val :insert-entries-function) - (mode-name :mode-name (capitalize prefix)) - (mode-init-val :mode-init-function) - (message-val :message-function) - (buffer-name-val :buffer-name) - (titles-val :titles) - (history-size-val :history-size 20) - (revert-confirm-val :revert-confirm? t) - (reduced? :reduced?)) - `(progn - (defgroup ,group nil - ,(format "Displaying '%s' entries in '%s' buffer." - entry-type-str buffer-type-str) - :group ',(intern (concat "guix-" entry-type-str)) - :group ',(intern (concat "guix-" buffer-type-str))) - - (defgroup ,faces-group nil - ,(format "Faces for displaying '%s' entries in '%s' buffer." - entry-type-str buffer-type-str) - :group ',group - :group ',(intern (concat "guix-" entry-type-str "-faces")) - :group ',(intern (concat "guix-" buffer-type-str "-faces"))) - - (defcustom ,titles-var ,titles-val - ,(format "Alist of titles of '%s' parameters." - entry-type-str) - :type '(alist :key-type symbol :value-type string) - :group ',group) - - ,(unless reduced? - `(progn - (defvar ,get-entries-var ,get-entries-val - ,(format "\ -Function used to receive '%s' entries for '%s' buffer." - entry-type-str buffer-type-str)) - - (defvar ,show-entries-var - ,(or show-entries-val `',show-entries-fun) - ,(format "\ -Function used to show '%s' entries in '%s' buffer." - entry-type-str buffer-type-str)) - - (defvar ,message-var ,message-val - ,(format "\ -Function used to display a message after showing '%s' entries. -If nil, do not display messages." - entry-type-str)) - - (defcustom ,buffer-name-var ,buffer-name-val - ,(format "\ -Default name of '%s' buffer for displaying '%s' entries. -May be a string or a function returning a string. The function -is called with the same arguments as `%S'." - buffer-type-str entry-type-str get-entries-var) - :type '(choice string function) - :group ',group) - - (defcustom ,history-size-var ,history-size-val - ,(format "\ -Maximum number of items saved in history of `%S' buffer. -If 0, the history is disabled." - buffer-name-var) - :type 'integer - :group ',group) - - (defcustom ,revert-confirm-var ,revert-confirm-val - ,(format "\ -If non-nil, ask to confirm for reverting `%S' buffer." - buffer-name-var) - :type 'boolean - :group ',group) - - (guix-alist-put! - '((get-entries . ,get-entries-var) - (show-entries . ,show-entries-var) - (message . ,message-var) - (buffer-name . ,buffer-name-var) - (history-size . ,history-size-var) - (revert-confirm . ,revert-confirm-var)) - 'guix-buffer-data ',buffer-type ',entry-type) - - ,(unless show-entries-val - `(defun ,show-entries-fun (entries) - ,(format "\ -Show '%s' ENTRIES in the current '%s' buffer." - entry-type-str buffer-type-str) - (guix-buffer-show-entries-default - entries ',buffer-type ',entry-type))) - - ,(when (or insert-entries-val - (null show-entries-val)) - (let ((insert-entries-var - (intern (concat prefix "-insert-function")))) - `(progn - (defvar ,insert-entries-var ,insert-entries-val - ,(format "\ -Function used to print '%s' entries in '%s' buffer." - entry-type-str buffer-type-str)) - - (guix-alist-put! - ',insert-entries-var 'guix-buffer-data - ',buffer-type ',entry-type - 'insert-entries)))) - - ,(when (or mode-name - mode-init-val - (null show-entries-val)) - (let* ((mode-str (concat prefix "-mode")) - (mode-map-str (concat mode-str "-map")) - (mode (intern mode-str)) - (parent-mode (intern - (concat "guix-" buffer-type-str - "-mode"))) - (mode-var (intern - (concat mode-str "-function"))) - (mode-init-var (intern - (concat mode-str - "-initialize-function")))) - `(progn - (defvar ,mode-var ',mode - ,(format "\ -Major mode for displaying '%s' entries in '%s' buffer." - entry-type-str buffer-type-str)) - - (defvar ,mode-init-var ,mode-init-val - ,(format "\ -Function used to set up '%s' buffer for displaying '%s' entries." - buffer-type-str entry-type-str)) - - (define-derived-mode ,mode ,parent-mode ,mode-name - ,(format "\ -Major mode for displaying '%s' entries in '%s' buffer. - -\\{%s}" - entry-type-str buffer-type-str mode-map-str) - (setq-local revert-buffer-function - 'guix-buffer-revert) - (setq-local guix-history-size - (guix-buffer-history-size - ',buffer-type ',entry-type)) - (guix-buffer-mode-initialize - ',buffer-type ',entry-type)) - - (guix-alist-put! - ',mode-var 'guix-buffer-data - ',buffer-type ',entry-type 'mode) - (guix-alist-put! - ',mode-init-var 'guix-buffer-data - ',buffer-type ',entry-type - 'mode-init)))))) - - (guix-alist-put! - ',titles-var 'guix-buffer-data - ',buffer-type ',entry-type 'titles))))) - - -(defvar guix-buffer-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group (or "guix-buffer-with-item" - "guix-buffer-with-current-item" - "guix-buffer-define-interface" - "guix-define-groups" - "guix-define-entry-type" - "guix-define-buffer-type")) - symbol-end) - . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-buffer-font-lock-keywords) - -(provide 'guix-buffer) - -;;; guix-buffer.el ends here diff --git a/emacs/guix-build-log.el b/emacs/guix-build-log.el deleted file mode 100644 index f67be16326..0000000000 --- a/emacs/guix-build-log.el +++ /dev/null @@ -1,381 +0,0 @@ -;;; guix-build-log.el --- Major and minor modes for build logs -*- lexical-binding: t -*- - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides a major mode (`guix-build-log-mode') and a minor mode -;; (`guix-build-log-minor-mode') for highlighting Guix build logs. - -;;; Code: - -(require 'guix-utils) - -(defgroup guix-build-log nil - "Settings for `guix-build-log-mode'." - :group 'guix) - -(defgroup guix-build-log-faces nil - "Faces for `guix-build-log-mode'." - :group 'guix-build-log - :group 'guix-faces) - -(defface guix-build-log-title-head - '((t :inherit font-lock-keyword-face)) - "Face for '@' symbol of a log title." - :group 'guix-build-log-faces) - -(defface guix-build-log-title-start - '((t :inherit guix-build-log-title-head)) - "Face for a log title denoting a start of a process." - :group 'guix-build-log-faces) - -(defface guix-build-log-title-success - '((t :inherit guix-build-log-title-head)) - "Face for a log title denoting a successful end of a process." - :group 'guix-build-log-faces) - -(defface guix-build-log-title-fail - '((t :inherit error)) - "Face for a log title denoting a failed end of a process." - :group 'guix-build-log-faces) - -(defface guix-build-log-title-end - '((t :inherit guix-build-log-title-head)) - "Face for a log title denoting an undefined end of a process." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-name - '((t :inherit font-lock-function-name-face)) - "Face for a phase name." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-start - '((default :weight bold) - (((class grayscale) (background light)) :foreground "Gray90") - (((class grayscale) (background dark)) :foreground "DimGray") - (((class color) (min-colors 16) (background light)) - :foreground "DarkGreen") - (((class color) (min-colors 16) (background dark)) - :foreground "LimeGreen") - (((class color) (min-colors 8)) :foreground "green")) - "Face for the start line of a phase." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-end - '((((class grayscale) (background light)) :foreground "Gray90") - (((class grayscale) (background dark)) :foreground "DimGray") - (((class color) (min-colors 16) (background light)) - :foreground "ForestGreen") - (((class color) (min-colors 16) (background dark)) - :foreground "LightGreen") - (((class color) (min-colors 8)) :foreground "green") - (t :weight bold)) - "Face for the end line of a phase." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-success - '((t)) - "Face for the 'succeeded' word of a phase line." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-fail - '((t :inherit error)) - "Face for the 'failed' word of a phase line." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-seconds - '((t :inherit font-lock-constant-face)) - "Face for the number of seconds for a phase." - :group 'guix-build-log-faces) - -(defcustom guix-build-log-minor-mode-activate t - "If non-nil, then `guix-build-log-minor-mode' is automatically -activated in `shell-mode' buffers." - :type 'boolean - :group 'guix-build-log) - -(defcustom guix-build-log-mode-hook '() - "Hook run after `guix-build-log-mode' is entered." - :type 'hook - :group 'guix-build-log) - -(defvar guix-build-log-phase-name-regexp "`\\([^']+\\)'" - "Regexp for a phase name.") - -(defvar guix-build-log-phase-start-regexp - (concat "^starting phase " guix-build-log-phase-name-regexp) - "Regexp for the start line of a 'build' phase.") - -(defun guix-build-log-title-regexp (&optional state) - "Return regexp for the log title. -STATE is a symbol denoting a state of the title. It should be -`start', `fail', `success' or `nil' (for a regexp matching any -state)." - (let* ((word-rx (rx (1+ (any word "-")))) - (state-rx (cond ((eq state 'start) (concat word-rx "started")) - ((eq state 'success) (concat word-rx "succeeded")) - ((eq state 'fail) (concat word-rx "failed")) - (t word-rx)))) - (rx-to-string - `(and bol (group "@") " " (group (regexp ,state-rx))) - t))) - -(defun guix-build-log-phase-end-regexp (&optional state) - "Return regexp for the end line of a 'build' phase. -STATE is a symbol denoting how a build phase was ended. It should be -`fail', `success' or `nil' (for a regexp matching any state)." - (let ((state-rx (cond ((eq state 'success) "succeeded") - ((eq state 'fail) "failed") - (t (regexp-opt '("succeeded" "failed")))))) - (rx-to-string - `(and bol "phase " (regexp ,guix-build-log-phase-name-regexp) - " " (group (regexp ,state-rx)) " after " - (group (1+ (or digit "."))) " seconds") - t))) - -(defvar guix-build-log-phase-end-regexp - ;; For efficiency, it is better to have a regexp for the general line - ;; of the phase end, then to call the function all the time. - (guix-build-log-phase-end-regexp) - "Regexp for the end line of a 'build' phase.") - -(defvar guix-build-log-font-lock-keywords - `((,(guix-build-log-title-regexp 'start) - (1 'guix-build-log-title-head) - (2 'guix-build-log-title-start)) - (,(guix-build-log-title-regexp 'success) - (1 'guix-build-log-title-head) - (2 'guix-build-log-title-success)) - (,(guix-build-log-title-regexp 'fail) - (1 'guix-build-log-title-head) - (2 'guix-build-log-title-fail)) - (,(guix-build-log-title-regexp) - (1 'guix-build-log-title-head) - (2 'guix-build-log-title-end)) - (,guix-build-log-phase-start-regexp - (0 'guix-build-log-phase-start) - (1 'guix-build-log-phase-name prepend)) - (,(guix-build-log-phase-end-regexp 'success) - (0 'guix-build-log-phase-end) - (1 'guix-build-log-phase-name prepend) - (2 'guix-build-log-phase-success prepend) - (3 'guix-build-log-phase-seconds prepend)) - (,(guix-build-log-phase-end-regexp 'fail) - (0 'guix-build-log-phase-end) - (1 'guix-build-log-phase-name prepend) - (2 'guix-build-log-phase-fail prepend) - (3 'guix-build-log-phase-seconds prepend))) - "A list of `font-lock-keywords' for `guix-build-log-mode'.") - -(defvar guix-build-log-common-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "M-n") 'guix-build-log-next-phase) - (define-key map (kbd "M-p") 'guix-build-log-previous-phase) - (define-key map (kbd "TAB") 'guix-build-log-phase-toggle) - (define-key map (kbd "") 'guix-build-log-phase-toggle) - (define-key map (kbd "") 'guix-build-log-phase-toggle-all) - (define-key map [(shift tab)] 'guix-build-log-phase-toggle-all) - map) - "Parent keymap for 'build-log' buffers. -For `guix-build-log-mode' this map is used as is. -For `guix-build-log-minor-mode' this map is prefixed with 'C-c'.") - -(defvar guix-build-log-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent - map (make-composed-keymap (list guix-build-log-common-map) - special-mode-map)) - (define-key map (kbd "c") 'compilation-shell-minor-mode) - (define-key map (kbd "v") 'view-mode) - map) - "Keymap for `guix-build-log-mode' buffers.") - -(defvar guix-build-log-minor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c") guix-build-log-common-map) - map) - "Keymap for `guix-build-log-minor-mode' buffers.") - -(defun guix-build-log-phase-start (&optional with-header?) - "Return the start point of the current build phase. -If WITH-HEADER? is non-nil, do not skip 'starting phase ...' header. -Return nil, if there is no phase start before the current point." - (save-excursion - (end-of-line) - (when (re-search-backward guix-build-log-phase-start-regexp nil t) - (unless with-header? (end-of-line)) - (point)))) - -(defun guix-build-log-phase-end () - "Return the end point of the current build phase." - (save-excursion - (beginning-of-line) - (when (re-search-forward guix-build-log-phase-end-regexp nil t) - (point)))) - -(defun guix-build-log-phase-hide () - "Hide the body of the current build phase." - (interactive) - (let ((beg (guix-build-log-phase-start)) - (end (guix-build-log-phase-end))) - (when (and beg end) - ;; If not on the header line, move to it. - (when (and (> (point) beg) - (< (point) end)) - (goto-char (guix-build-log-phase-start t))) - (remove-overlays beg end 'invisible t) - (let ((o (make-overlay beg end))) - (overlay-put o 'evaporate t) - (overlay-put o 'invisible t))))) - -(defun guix-build-log-phase-show () - "Show the body of the current build phase." - (interactive) - (let ((beg (guix-build-log-phase-start)) - (end (guix-build-log-phase-end))) - (when (and beg end) - (remove-overlays beg end 'invisible t)))) - -(defun guix-build-log-phase-hidden-p () - "Return non-nil, if the body of the current build phase is hidden." - (let ((beg (guix-build-log-phase-start))) - (and beg - (cl-some (lambda (o) - (overlay-get o 'invisible)) - (overlays-at beg))))) - -(defun guix-build-log-phase-toggle-function () - "Return a function to toggle the body of the current build phase." - (if (guix-build-log-phase-hidden-p) - #'guix-build-log-phase-show - #'guix-build-log-phase-hide)) - -(defun guix-build-log-phase-toggle () - "Show/hide the body of the current build phase." - (interactive) - (funcall (guix-build-log-phase-toggle-function))) - -(defun guix-build-log-phase-toggle-all () - "Show/hide the bodies of all build phases." - (interactive) - (save-excursion - ;; Some phases may be hidden, and some shown. Whether to hide or to - ;; show them, it is determined by the state of the first phase here. - (goto-char (point-min)) - (let ((fun (save-excursion - (re-search-forward guix-build-log-phase-start-regexp nil t) - (guix-build-log-phase-toggle-function)))) - (while (re-search-forward guix-build-log-phase-start-regexp nil t) - (funcall fun))))) - -(defun guix-build-log-next-phase (&optional arg) - "Move to the next build phase. -With ARG, do it that many times. Negative ARG means move -backward." - (interactive "^p") - (if arg - (when (zerop arg) (user-error "Try again")) - (setq arg 1)) - (let ((search-fun (if (> arg 0) - #'re-search-forward - #'re-search-backward)) - (n (abs arg)) - found last-found) - (save-excursion - (end-of-line (if (> arg 0) 1 0)) ; skip the current line - (while (and (not (zerop n)) - (setq found - (funcall search-fun - guix-build-log-phase-start-regexp - nil t))) - (setq n (1- n) - last-found found))) - (when last-found - (goto-char last-found) - (forward-line 0)) - (or found - (user-error (if (> arg 0) - "No next build phase" - "No previous build phase"))))) - -(defun guix-build-log-previous-phase (&optional arg) - "Move to the previous build phase. -With ARG, do it that many times. Negative ARG means move -forward." - (interactive "^p") - (guix-build-log-next-phase (- (or arg 1)))) - -;;;###autoload -(define-derived-mode guix-build-log-mode special-mode - "Guix-Build-Log" - "Major mode for viewing Guix build logs. - -\\{guix-build-log-mode-map}" - (setq font-lock-defaults '(guix-build-log-font-lock-keywords t))) - -;;;###autoload -(define-minor-mode guix-build-log-minor-mode - "Toggle Guix Build Log minor mode. - -With a prefix argument ARG, enable Guix Build Log minor mode if -ARG is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. - -When Guix Build Log minor mode is enabled, it highlights build -log in the current buffer. This mode can be enabled -programmatically using hooks: - - (add-hook 'shell-mode-hook 'guix-build-log-minor-mode) - -\\{guix-build-log-minor-mode-map}" - :init-value nil - :lighter " Guix-Build-Log" - :keymap guix-build-log-minor-mode-map - :group 'guix-build-log - (if guix-build-log-minor-mode - (font-lock-add-keywords nil guix-build-log-font-lock-keywords) - (font-lock-remove-keywords nil guix-build-log-font-lock-keywords)) - (when font-lock-mode - (font-lock-fontify-buffer))) - -;;;###autoload -(defun guix-build-log-minor-mode-activate-maybe () - "Activate `guix-build-log-minor-mode' depending on -`guix-build-log-minor-mode-activate' variable." - (when guix-build-log-minor-mode-activate - (guix-build-log-minor-mode))) - -(defun guix-build-log-find-file (file-or-url) - "Open FILE-OR-URL in `guix-build-log-mode'." - (guix-find-file-or-url file-or-url) - (guix-build-log-mode)) - -;;;###autoload -(add-hook 'shell-mode-hook 'guix-build-log-minor-mode-activate-maybe) - -;;;###autoload -(add-to-list 'auto-mode-alist - ;; Regexp for log files (usually placed in /var/log/guix/...) - (cons (rx "/guix/drvs/" (= 2 alnum) "/" (= 30 alnum) - "-" (+ (any alnum "-+.")) ".drv" string-end) - 'guix-build-log-mode)) - -(provide 'guix-build-log) - -;;; guix-build-log.el ends here diff --git a/emacs/guix-command.el b/emacs/guix-command.el deleted file mode 100644 index 7069c51649..0000000000 --- a/emacs/guix-command.el +++ /dev/null @@ -1,830 +0,0 @@ -;;; guix-command.el --- Popup interface for guix commands -*- lexical-binding: t -*- - -;; Copyright © 2015, 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides a magit-like popup interface for running guix -;; commands in Guix REPL. The entry point is "M-x guix". When it is -;; called the first time, "guix --help" output is parsed and -;; `guix-COMMAND-action' functions are generated for each available guix -;; COMMAND. Then a window with these commands is popped up. When a -;; particular COMMAND is called, "guix COMMAND --help" output is parsed, -;; and a user get a new popup window with available options for this -;; command and so on. - -;; To avoid hard-coding all guix options, actions, etc., as much data is -;; taken from "guix ... --help" outputs as possible. But this data is -;; still incomplete: not all long options have short analogs, also -;; special readers should be used for some options (for example, to -;; complete package names while prompting for a package). So after -;; parsing --help output, the arguments are "improved". All arguments -;; (switches, options and actions) are `guix-command-argument' -;; structures. - -;; Only "M-x guix" command is available after this file is loaded. The -;; rest commands/actions/popups are generated on the fly only when they -;; are needed (that's why there is a couple of `eval'-s in this file). - -;; COMMANDS argument is used by many functions in this file. It means a -;; list of guix commands without "guix" itself, e.g.: ("build"), -;; ("import" "gnu"). The empty list stands for the plain "guix" without -;; subcommands. - -;; All actions in popup windows are divided into 2 groups: -;; -;; - 'Popup' actions - used to pop up another window. For example, every -;; action in the 'guix' or 'guix import' window is a popup action. They -;; are defined by `guix-command-define-popup-action' macro. -;; -;; - 'Execute' actions - used to do something with the command line (to -;; run a command in Guix REPL or to copy it into kill-ring) constructed -;; with the current popup. They are defined by -;; `guix-command-define-execute-action' macro. - -;;; Code: - -(require 'cl-lib) -(require 'guix-popup) -(require 'guix-utils) -(require 'guix-help-vars) -(require 'guix-read) -(require 'guix-base) -(require 'guix-build-log) -(require 'guix-guile) -(require 'guix-external) - -(defgroup guix-commands nil - "Settings for guix popup windows." - :group 'guix) - -(defvar guix-command-complex-with-shared-arguments - '("system") - "List of guix commands which have subcommands with shared options. -I.e., 'guix foo --help' is the same as 'guix foo bar --help'.") - -(defun guix-command-action-name (&optional commands &rest name-parts) - "Return name of action function for guix COMMANDS." - (guix-command-symbol (append commands name-parts (list "action")))) - - -;;; Command arguments - -(cl-defstruct (guix-command-argument - (:constructor guix-command-make-argument) - (:copier guix-command-copy-argument)) - name char doc fun switch? option? action?) - -(cl-defun guix-command-modify-argument - (argument &key - (name nil name-bound?) - (char nil char-bound?) - (doc nil doc-bound?) - (fun nil fun-bound?) - (switch? nil switch?-bound?) - (option? nil option?-bound?) - (action? nil action?-bound?)) - "Return a modified version of ARGUMENT." - (declare (indent 1)) - (let ((copy (guix-command-copy-argument argument))) - (and name-bound? (setf (guix-command-argument-name copy) name)) - (and char-bound? (setf (guix-command-argument-char copy) char)) - (and doc-bound? (setf (guix-command-argument-doc copy) doc)) - (and fun-bound? (setf (guix-command-argument-fun copy) fun)) - (and switch?-bound? (setf (guix-command-argument-switch? copy) switch?)) - (and option?-bound? (setf (guix-command-argument-option? copy) option?)) - (and action?-bound? (setf (guix-command-argument-action? copy) action?)) - copy)) - -(defun guix-command-modify-argument-from-alist (argument alist) - "Return a modified version of ARGUMENT or nil if it wasn't modified. -Each assoc from ALIST have a form (NAME . PLIST). NAME is an -argument name. PLIST is a property list of argument parameters -to be modified." - (let* ((name (guix-command-argument-name argument)) - (plist (guix-assoc-value alist name))) - (when plist - (apply #'guix-command-modify-argument - argument plist)))) - -(defmacro guix-command-define-argument-improver (name alist) - "Define NAME variable and function to modify an argument from ALIST." - (declare (indent 1)) - `(progn - (defvar ,name ,alist) - (defun ,name (argument) - (guix-command-modify-argument-from-alist argument ,name)))) - -(guix-command-define-argument-improver - guix-command-improve-action-argument - '(("container" :char ?C) - ("graph" :char ?G) - ("environment" :char ?E) - ("publish" :char ?u) - ("pull" :char ?P) - ("size" :char ?z))) - -(guix-command-define-argument-improver - guix-command-improve-common-argument - '(("--help" :switch? nil) - ("--version" :switch? nil))) - -(guix-command-define-argument-improver - guix-command-improve-target-argument - '(("--target" :char ?T))) - -(guix-command-define-argument-improver - guix-command-improve-system-type-argument - '(("--system" :fun guix-read-system-type))) - -(guix-command-define-argument-improver - guix-command-improve-load-path-argument - '(("--load-path" :fun read-directory-name))) - -(guix-command-define-argument-improver - guix-command-improve-search-paths-argument - '(("--search-paths" :char ?P))) - -(guix-command-define-argument-improver - guix-command-improve-substitute-urls-argument - '(("--substitute-urls" :char ?U))) - -(guix-command-define-argument-improver - guix-command-improve-hash-argument - '(("--format" :fun guix-read-hash-format))) - -(guix-command-define-argument-improver - guix-command-improve-key-policy-argument - '(("--key-download" :fun guix-read-key-policy))) - -(defvar guix-command-improve-common-build-argument - '(("--no-substitutes" :char ?s) - ("--no-build-hook" :char ?h) - ("--max-silent-time" :char ?x) - ("--rounds" :char ?R :fun read-number) - ("--with-input" :char ?W))) - -(defun guix-command-improve-common-build-argument (argument) - (guix-command-modify-argument-from-alist - argument - (append guix-command-improve-load-path-argument - guix-command-improve-substitute-urls-argument - guix-command-improve-common-build-argument))) - -(guix-command-define-argument-improver - guix-command-improve-archive-argument - '(("--generate-key" :char ?k))) - -(guix-command-define-argument-improver - guix-command-improve-build-argument - '(("--no-grafts" :char ?g) - ("--file" :fun guix-read-file-name) - ("--root" :fun guix-read-file-name) - ("--sources" :char ?S :fun guix-read-source-type :switch? nil) - ("--with-source" :fun guix-read-file-name))) - -(guix-command-define-argument-improver - guix-command-improve-environment-argument - '(("--ad-hoc" - :name "--ad-hoc " :fun guix-read-package-names-string - :switch? nil :option? t) - ("--expose" :char ?E) - ("--share" :char ?S) - ("--load" :fun guix-read-file-name))) - -(guix-command-define-argument-improver - guix-command-improve-gc-argument - '(("--list-dead" :char ?D) - ("--list-live" :char ?L) - ("--referrers" :char ?f) - ("--verify" :fun guix-read-verify-options-string))) - -(guix-command-define-argument-improver - guix-command-improve-graph-argument - '(("--type" :fun guix-read-graph-type))) - -(guix-command-define-argument-improver - guix-command-improve-import-argument - '(("cran" :char ?r))) - -(guix-command-define-argument-improver - guix-command-improve-import-elpa-argument - '(("--archive" :fun guix-read-elpa-archive))) - -(guix-command-define-argument-improver - guix-command-improve-lint-argument - '(("--checkers" :fun guix-read-lint-checker-names-string))) - -(guix-command-define-argument-improver - guix-command-improve-package-argument - ;; Unlike all other options, --install/--remove do not have a form - ;; '--install=foo,bar' but '--install foo bar' instead, so we need - ;; some tweaks. - '(("--install" - :name "--install " :fun guix-read-package-names-string - :switch? nil :option? t) - ("--remove" - :name "--remove " :fun guix-read-package-names-string - :switch? nil :option? t) - ("--install-from-file" :fun guix-read-file-name) - ("--manifest" :fun guix-read-file-name) - ("--profile" :fun guix-read-file-name) - ("--do-not-upgrade" :char ?U) - ("--roll-back" :char ?R) - ("--show" :char ?w :fun guix-read-package-name))) - -(guix-command-define-argument-improver - guix-command-improve-refresh-argument - '(("--select" :fun guix-read-refresh-subset) - ("--type" :fun guix-read-refresh-updater-names-string) - ("--key-server" :char ?S))) - -(guix-command-define-argument-improver - guix-command-improve-size-argument - '(("--map-file" :fun guix-read-file-name))) - -(guix-command-define-argument-improver - guix-command-improve-system-argument - '(("disk-image" :char ?D) - ("vm-image" :char ?V) - ("--on-error" :char ?E) - ("--no-grub" :char ?g) - ("--full-boot" :char ?b))) - -(defvar guix-command-argument-improvers - '((() - guix-command-improve-action-argument) - (("archive") - guix-command-improve-common-build-argument - guix-command-improve-target-argument - guix-command-improve-system-type-argument - guix-command-improve-archive-argument) - (("build") - guix-command-improve-common-build-argument - guix-command-improve-target-argument - guix-command-improve-system-type-argument - guix-command-improve-build-argument) - (("download") - guix-command-improve-hash-argument) - (("hash") - guix-command-improve-hash-argument) - (("environment") - guix-command-improve-common-build-argument - guix-command-improve-search-paths-argument - guix-command-improve-system-type-argument - guix-command-improve-environment-argument) - (("gc") - guix-command-improve-gc-argument) - (("graph") - guix-command-improve-graph-argument) - (("import") - guix-command-improve-import-argument) - (("import" "gnu") - guix-command-improve-key-policy-argument) - (("import" "elpa") - guix-command-improve-import-elpa-argument) - (("lint") - guix-command-improve-lint-argument) - (("package") - guix-command-improve-common-build-argument - guix-command-improve-search-paths-argument - guix-command-improve-package-argument) - (("refresh") - guix-command-improve-key-policy-argument - guix-command-improve-refresh-argument) - (("size") - guix-command-improve-system-type-argument - guix-command-improve-substitute-urls-argument - guix-command-improve-size-argument) - (("system") - guix-command-improve-common-build-argument - guix-command-improve-system-argument)) - "Alist of guix commands and argument improvers for them.") - -(defun guix-command-improve-argument (argument improvers) - "Return ARGUMENT modified with IMPROVERS." - (or (cl-some (lambda (improver) - (funcall improver argument)) - improvers) - argument)) - -(defun guix-command-improve-arguments (arguments commands) - "Return ARGUMENTS for 'guix COMMANDS ...' modified for popup interface." - (let ((improvers (cons 'guix-command-improve-common-argument - (guix-assoc-value guix-command-argument-improvers - commands)))) - (mapcar (lambda (argument) - (guix-command-improve-argument argument improvers)) - arguments))) - -(defun guix-command-parse-arguments (&optional commands) - "Return a list of parsed 'guix COMMANDS ...' arguments." - (with-temp-buffer - (insert (guix-help-string commands)) - (let (args) - (guix-while-search guix-help-parse-option-regexp - (let* ((short (match-string-no-properties 1)) - (name (match-string-no-properties 2)) - (arg (match-string-no-properties 3)) - (doc (match-string-no-properties 4)) - (char (if short - (elt short 1) ; short option letter - (elt name 2))) ; first letter of the long option - ;; If "--foo=bar" or "--foo[=bar]" then it is 'option'. - (option? (not (string= "" arg))) - ;; If "--foo" or "--foo[=bar]" then it is 'switch'. - (switch? (or (string= "" arg) - (eq ?\[ (elt arg 0))))) - (push (guix-command-make-argument - :name name - :char char - :doc doc - :switch? switch? - :option? option?) - args))) - (guix-while-search guix-help-parse-command-regexp - (let* ((name (match-string-no-properties 1)) - (char (elt name 0))) - (push (guix-command-make-argument - :name name - :char char - :fun (guix-command-action-name commands name) - :action? t) - args))) - args))) - -(defun guix-command-rest-argument (&optional commands) - "Return '--' argument for COMMANDS." - (cl-flet ((argument (&rest args) - (apply #'guix-command-make-argument - :name "-- " :char ?= :option? t args))) - (let ((command (car commands))) - (cond - ((member command - '("archive" "build" "challenge" "edit" - "graph" "lint" "refresh")) - (argument :doc "Packages" :fun 'guix-read-package-names-string)) - ((equal commands '("container" "exec")) - (argument :doc "PID Command [Args...]")) - ((string= command "download") - (argument :doc "URL")) - ((string= command "environment") - (argument :doc "Command [Args...]" :fun 'read-shell-command)) - ((string= command "gc") - (argument :doc "Paths" :fun 'guix-read-file-name)) - ((member command '("hash" "system")) - (argument :doc "File" :fun 'guix-read-file-name)) - ((string= command "size") - (argument :doc "Package" :fun 'guix-read-package-name)) - ((equal commands '("import" "nix")) - (argument :doc "Nixpkgs Attribute")) - ;; Other 'guix import' subcommands, but not 'import' itself. - ((and (cdr commands) - (string= command "import")) - (argument :doc "Package name")))))) - -(defvar guix-command-additional-arguments - `((("environment") - ,(guix-command-make-argument - :name "++packages " :char ?p :option? t - :doc "build inputs of the specified packages" - :fun 'guix-read-package-names-string))) - "Alist of guix commands and additional arguments for them. -These are 'fake' arguments that are not presented in 'guix' shell -commands.") - -(defun guix-command-additional-arguments (&optional commands) - "Return additional arguments for COMMANDS." - (let ((rest-arg (guix-command-rest-argument commands))) - (append (guix-assoc-value guix-command-additional-arguments - commands) - (and rest-arg (list rest-arg))))) - -;; Ideally only `guix-command-arguments' function should exist with the -;; contents of `guix-command-all-arguments', but we need to make a -;; special case for `guix-command-complex-with-shared-arguments' commands. - -(defun guix-command-all-arguments (&optional commands) - "Return list of all arguments for 'guix COMMANDS ...'." - (let ((parsed (guix-command-parse-arguments commands))) - (append (guix-command-improve-arguments parsed commands) - (guix-command-additional-arguments commands)))) - -(guix-memoized-defalias guix-command-all-arguments-memoize - guix-command-all-arguments) - -(defun guix-command-arguments (&optional commands) - "Return list of arguments for 'guix COMMANDS ...'." - (let ((command (car commands))) - (if (member command - guix-command-complex-with-shared-arguments) - ;; Take actions only for 'guix system', and switches+options for - ;; 'guix system foo'. - (funcall (if (null (cdr commands)) - #'cl-remove-if-not - #'cl-remove-if) - #'guix-command-argument-action? - (guix-command-all-arguments-memoize (list command))) - (guix-command-all-arguments commands)))) - -(defun guix-command-switch->popup-switch (switch) - "Return popup switch from command SWITCH argument." - (list (guix-command-argument-char switch) - (or (guix-command-argument-doc switch) - "Unknown") - (guix-command-argument-name switch))) - -(defun guix-command-option->popup-option (option) - "Return popup option from command OPTION argument." - (list (guix-command-argument-char option) - (or (guix-command-argument-doc option) - "Unknown") - (let ((name (guix-command-argument-name option))) - (if (string-match-p " \\'" name) ; ends with space - name - (concat name "="))) - (or (guix-command-argument-fun option) - 'read-from-minibuffer))) - -(defun guix-command-action->popup-action (action) - "Return popup action from command ACTION argument." - (list (guix-command-argument-char action) - (or (guix-command-argument-doc action) - (guix-command-argument-name action) - "Unknown") - (guix-command-argument-fun action))) - -(defun guix-command-sort-arguments (arguments) - "Sort ARGUMENTS by name in alphabetical order." - (sort arguments - (lambda (a1 a2) - (let ((name1 (guix-command-argument-name a1)) - (name2 (guix-command-argument-name a2))) - (cond ((null name1) nil) - ((null name2) t) - (t (string< name1 name2))))))) - -(defun guix-command-switches (arguments) - "Return switches from ARGUMENTS." - (cl-remove-if-not #'guix-command-argument-switch? arguments)) - -(defun guix-command-options (arguments) - "Return options from ARGUMENTS." - (cl-remove-if-not #'guix-command-argument-option? arguments)) - -(defun guix-command-actions (arguments) - "Return actions from ARGUMENTS." - (cl-remove-if-not #'guix-command-argument-action? arguments)) - - -;;; Post processing popup arguments - -(defvar guix-command-post-processors - '(("environment" - guix-command-post-process-environment-packages - guix-command-post-process-environment-ad-hoc - guix-command-post-process-rest-multiple-leave) - ("hash" - guix-command-post-process-rest-single) - ("package" - guix-command-post-process-package-args) - ("system" - guix-command-post-process-rest-single)) - "Alist of guix commands and functions for post-processing -a list of arguments returned from popup interface. -Each function is called on the returned arguments in turn.") - -(defvar guix-command-rest-arg-regexp - (rx string-start "-- " (group (+ any))) - "Regexp to match a string with the 'rest' arguments.") - -(defun guix-command-replace-args (args predicate modifier) - "Replace arguments matching PREDICATE from ARGS. -Call MODIFIER on each argument matching PREDICATE and append the -returned list of strings to the end of ARGS. Remove the original -arguments." - (let* ((rest nil) - (args (mapcar (lambda (arg) - (if (funcall predicate arg) - (progn - (push (funcall modifier arg) rest) - nil) - arg)) - args))) - (if rest - (apply #'append (delq nil args) rest) - args))) - -(cl-defun guix-command-post-process-matching-args (args regexp - &key group split?) - "Modify arguments from ARGS matching REGEXP by moving them to -the end of ARGS list. If SPLIT? is non-nil, split matching -arguments into multiple subarguments." - (guix-command-replace-args - args - (lambda (arg) - (string-match regexp arg)) - (lambda (arg) - (let ((val (match-string (or group 0) arg)) - (fun (if split? #'split-string #'list))) - (funcall fun val))))) - -(defun guix-command-post-process-rest-single (args) - "Modify ARGS by moving '-- ARG' argument to the end of ARGS list." - (guix-command-post-process-matching-args - args guix-command-rest-arg-regexp - :group 1)) - -(defun guix-command-post-process-rest-multiple (args) - "Modify ARGS by splitting '-- ARG ...' into multiple subarguments -and moving them to the end of ARGS list. -Remove '-- ' string." - (guix-command-post-process-matching-args - args guix-command-rest-arg-regexp - :group 1 - :split? t)) - -(defun guix-command-post-process-rest-multiple-leave (args) - "Modify ARGS by splitting '-- ARG ...' into multiple subarguments -and moving them to the end of ARGS list. -Leave '--' string as a separate argument." - (guix-command-post-process-matching-args - args guix-command-rest-arg-regexp - :split? t)) - -(defun guix-command-post-process-package-args (args) - "Adjust popup ARGS for 'guix package' command." - (guix-command-post-process-matching-args - args (rx string-start (or "--install " "--remove ") (+ any)) - :split? t)) - -(defun guix-command-post-process-environment-packages (args) - "Adjust popup ARGS for specified packages of 'guix environment' -command." - (guix-command-post-process-matching-args - args (rx string-start "++packages " (group (+ any))) - :group 1 - :split? t)) - -(defun guix-command-post-process-environment-ad-hoc (args) - "Adjust popup ARGS for '--ad-hoc' argument of 'guix environment' -command." - (guix-command-post-process-matching-args - args (rx string-start "--ad-hoc " (+ any)) - :split? t)) - -(defun guix-command-post-process-args (commands args) - "Adjust popup ARGS for guix COMMANDS." - (let* ((command (car commands)) - (processors - (append (guix-assoc-value guix-command-post-processors commands) - (guix-assoc-value guix-command-post-processors command)))) - (guix-modify args - (or processors - (list #'guix-command-post-process-rest-multiple))))) - - -;;; 'Execute' actions - -(defvar guix-command-default-execute-arguments - (list - (guix-command-make-argument - :name "repl" :char ?r :doc "Run in Guix REPL") - (guix-command-make-argument - :name "shell" :char ?s :doc "Run in shell") - (guix-command-make-argument - :name "copy" :char ?c :doc "Copy command line")) - "List of default 'execute' action arguments.") - -(defvar guix-command-additional-execute-arguments - (let ((graph-arg (guix-command-make-argument - :name "view" :char ?v :doc "View graph"))) - `((("build") - ,(guix-command-make-argument - :name "log" :char ?l :doc "View build log")) - (("graph") ,graph-arg) - (("size") - ,(guix-command-make-argument - :name "view" :char ?v :doc "View map")) - (("system" "shepherd-graph") ,graph-arg) - (("system" "extension-graph") ,graph-arg))) - "Alist of guix commands and additional 'execute' action arguments.") - -(defun guix-command-execute-arguments (commands) - "Return a list of 'execute' action arguments for COMMANDS." - (mapcar (lambda (arg) - (guix-command-modify-argument arg - :action? t - :fun (guix-command-action-name - commands (guix-command-argument-name arg)))) - (append guix-command-default-execute-arguments - (guix-assoc-value - guix-command-additional-execute-arguments commands)))) - -(defvar guix-command-special-executors - '((("environment") - ("repl" . guix-run-environment-command-in-repl)) - (("pull") - ("repl" . guix-run-pull-command-in-repl)) - (("build") - ("log" . guix-run-view-build-log)) - (("graph") - ("view" . guix-run-view-graph)) - (("size") - ("view" . guix-run-view-size-map)) - (("system" "shepherd-graph") - ("view" . guix-run-view-graph)) - (("system" "extension-graph") - ("view" . guix-run-view-graph))) - "Alist of guix commands and alists of special executers for them. -See also `guix-command-default-executors'.") - -(defvar guix-command-default-executors - '(("repl" . guix-run-command-in-repl) - ("shell" . guix-run-command-in-shell) - ("copy" . guix-copy-command-as-kill)) - "Alist of default executers for action names.") - -(defun guix-command-executor (commands name) - "Return function to run command line arguments for guix COMMANDS." - (or (guix-assoc-value guix-command-special-executors commands name) - (guix-assoc-value guix-command-default-executors name))) - -(defun guix-run-environment-command-in-repl (args) - "Run 'guix ARGS ...' environment command in Guix REPL." - ;; As 'guix environment' usually tries to run another process, it may - ;; be fun but not wise to run this command in Geiser REPL. - (when (or (member "--dry-run" args) - (member "--search-paths" args) - (when (y-or-n-p - (format "'%s' command will spawn an external process. -Do you really want to execute this command in Geiser REPL? " - (guix-command-string args))) - (message "May \"M-x shell-mode\" be with you!") - t)) - (guix-run-command-in-repl args))) - -(defun guix-run-pull-command-in-repl (args) - "Run 'guix ARGS ...' pull command in Guix REPL. -Perform pull-specific actions after operation, see -`guix-after-pull-hook' and `guix-update-after-pull'." - (guix-eval-in-repl - (apply #'guix-make-guile-expression 'guix-command args) - nil 'pull)) - -(defun guix-run-view-build-log (args) - "Add --log-file to ARGS, run 'guix ARGS ...' build command, and -open the log file(s)." - (let* ((args (if (member "--log-file" args) - args - (cl-list* (car args) "--log-file" (cdr args)))) - (output (guix-command-output args)) - (files (split-string output "\n" t))) - (dolist (file files) - (guix-build-log-find-file file)))) - -(defun guix-run-view-graph (args) - "Run 'guix ARGS ...' graph command, make the image and open it." - (let* ((graph-file (guix-dot-file-name)) - (dot-args (guix-dot-arguments graph-file))) - (if (guix-eval-read (guix-make-guile-expression - 'pipe-guix-output args dot-args)) - (guix-find-file graph-file) - (error "Couldn't create a graph")))) - -(defun guix-run-view-size-map (args) - "Run 'guix ARGS ...' size command, and open the map file." - (let* ((wished-map-file - (cl-some (lambda (arg) - (and (string-match "--map-file=\\(.+\\)" arg) - (match-string 1 arg))) - args)) - (map-file (or wished-map-file (guix-png-file-name))) - (args (if wished-map-file - args - (cl-list* (car args) - (concat "--map-file=" map-file) - (cdr args))))) - (guix-command-output args) - (guix-find-file map-file))) - - -;;; Generating popups, actions, etc. - -(defmacro guix-command-define-popup-action (name &optional commands) - "Define NAME function to generate (if needed) and run popup for COMMANDS." - (declare (indent 1) (debug t)) - (let* ((popup-fun (guix-command-symbol `(,@commands "popup"))) - (doc (format "Call `%s' (generate it if needed)." - popup-fun))) - `(defun ,name (&optional arg) - ,doc - (interactive "P") - (unless (fboundp ',popup-fun) - (guix-command-generate-popup ',popup-fun ',commands)) - (,popup-fun arg)))) - -(defmacro guix-command-define-execute-action (name executor - &optional commands) - "Define NAME function to execute the current action for guix COMMANDS. -EXECUTOR function is called with the current command line arguments." - (declare (indent 1) (debug t)) - (let* ((arguments-fun (guix-command-symbol `(,@commands "arguments"))) - (doc (format "Call `%s' with the current popup arguments." - executor))) - `(defun ,name (&rest args) - ,doc - (interactive (,arguments-fun)) - (,executor (append ',commands - (guix-command-post-process-args - ',commands args)))))) - -(defun guix-command-generate-popup-actions (actions &optional commands) - "Generate 'popup' commands from ACTIONS arguments for guix COMMANDS." - (dolist (action actions) - (let ((fun (guix-command-argument-fun action))) - (unless (fboundp fun) - (eval `(guix-command-define-popup-action ,fun - ,(append commands - (list (guix-command-argument-name action))))))))) - -(defun guix-command-generate-execute-actions (actions &optional commands) - "Generate 'execute' commands from ACTIONS arguments for guix COMMANDS." - (dolist (action actions) - (let ((fun (guix-command-argument-fun action))) - (unless (fboundp fun) - (eval `(guix-command-define-execute-action ,fun - ,(guix-command-executor - commands (guix-command-argument-name action)) - ,commands)))))) - -(defun guix-command-generate-popup (name &optional commands) - "Define NAME popup with 'guix COMMANDS ...' interface." - (let* ((command (car commands)) - (man-page (concat "guix" (and command (concat "-" command)))) - (doc (format "Popup window for '%s' command." - (guix-concat-strings (cons "guix" commands) - " "))) - (args (guix-command-arguments commands)) - (switches (guix-command-sort-arguments - (guix-command-switches args))) - (options (guix-command-sort-arguments - (guix-command-options args))) - (popup-actions (guix-command-sort-arguments - (guix-command-actions args))) - (execute-actions (unless popup-actions - (guix-command-execute-arguments commands))) - (actions (or popup-actions execute-actions))) - (if popup-actions - (guix-command-generate-popup-actions popup-actions commands) - (guix-command-generate-execute-actions execute-actions commands)) - (eval - `(guix-define-popup ,name - ,doc - 'guix-commands - :man-page ,man-page - :switches ',(mapcar #'guix-command-switch->popup-switch switches) - :options ',(mapcar #'guix-command-option->popup-option options) - :actions ',(mapcar #'guix-command-action->popup-action actions) - :max-action-columns 4)))) - -;;;###autoload (autoload 'guix "guix-command" "Popup window for 'guix'." t) -(guix-command-define-popup-action guix) - -(defalias 'guix-edit-action #'guix-edit) - - -(defvar guix-command-font-lock-keywords - (eval-when-compile - `((,(rx "(" - (group "guix-command-define-" - (or "popup-action" - "execute-action" - "argument-improver")) - symbol-end - (zero-or-more blank) - (zero-or-one - (group (one-or-more (or (syntax word) (syntax symbol)))))) - (1 font-lock-keyword-face) - (2 font-lock-function-name-face nil t))))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-command-font-lock-keywords) - -(provide 'guix-command) - -;;; guix-command.el ends here diff --git a/emacs/guix-config.el.in b/emacs/guix-config.el.in deleted file mode 100644 index c09c2fe86a..0000000000 --- a/emacs/guix-config.el.in +++ /dev/null @@ -1,44 +0,0 @@ -;;; guix-config.el --- Compile-time configuration of Guix. - -;; Copyright © 2015 Mathieu Lirzin -;; Copyright © 2015, 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Code: - -(defconst guix-config-name "@PACKAGE_NAME@" - "Guix full name.") - -(defconst guix-config-version "@PACKAGE_VERSION@" - "Guix version.") - -(defconst guix-config-emacs-interface-directory - (replace-regexp-in-string "${prefix}" "@prefix@" "@emacsuidir@")) - -(defconst guix-config-state-directory - ;; This must match `NIX_STATE_DIR' as defined in `nix/local.mk'. - (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/guix")) - -(defconst guix-config-guile-program "@GUILE@" - "Name of the 'guile' executable defined at configure time.") - -(defconst guix-config-dot-program "@DOT_USER_PROGRAM@" - "Name of the 'dot' executable defined at configure time.") - -(provide 'guix-config) - -;;; guix-config.el ends here diff --git a/emacs/guix-devel.el b/emacs/guix-devel.el deleted file mode 100644 index b71670cdfb..0000000000 --- a/emacs/guix-devel.el +++ /dev/null @@ -1,382 +0,0 @@ -;;; guix-devel.el --- Development tools -*- lexical-binding: t -*- - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides commands useful for developing Guix (or even -;; arbitrary Guile code) with Geiser. - -;;; Code: - -(require 'lisp-mode) -(require 'guix-guile) -(require 'guix-geiser) -(require 'guix-utils) -(require 'guix-base) - -(defgroup guix-devel nil - "Settings for Guix development utils." - :group 'guix) - -(defgroup guix-devel-faces nil - "Faces for `guix-devel-mode'." - :group 'guix-devel - :group 'guix-faces) - -(defface guix-devel-modify-phases-keyword - '((t :inherit font-lock-preprocessor-face)) - "Face for a `modify-phases' keyword ('delete', 'replace', etc.)." - :group 'guix-devel-faces) - -(defface guix-devel-gexp-symbol - '((t :inherit font-lock-keyword-face)) - "Face for gexp symbols ('#~', '#$', etc.). -See Info node `(guix) G-Expressions'." - :group 'guix-devel-faces) - -(defcustom guix-devel-activate-mode t - "If non-nil, then `guix-devel-mode' is automatically activated -in Scheme buffers." - :type 'boolean - :group 'guix-devel) - -(defun guix-devel-use-modules (&rest modules) - "Use guile MODULES." - (apply #'guix-geiser-call "use-modules" modules)) - -(defun guix-devel-use-module (&optional module) - "Use guile MODULE in the current Geiser REPL. -MODULE is a string with the module name - e.g., \"(ice-9 match)\". -Interactively, use the module defined by the current scheme file." - (interactive (list (guix-guile-current-module))) - (guix-devel-use-modules module) - (message "Using %s module." module)) - -(defun guix-devel-copy-module-as-kill () - "Put the name of the current guile module into `kill-ring'." - (interactive) - (guix-copy-as-kill (guix-guile-current-module))) - -(defun guix-devel-setup-repl (&optional repl) - "Setup REPL for using `guix-devel-...' commands." - (guix-devel-use-modules "(guix monad-repl)" - "(guix scripts)" - "(guix store)" - "(guix ui)") - ;; Without this workaround, the warning/build output disappears. See - ;; for details. - (guix-geiser-eval-in-repl-synchronously - "(begin - (guix-warning-port (current-warning-port)) - (current-build-output-port (current-error-port)))" - repl 'no-history 'no-display)) - -(defvar guix-devel-repl-processes nil - "List of REPL processes configured by `guix-devel-setup-repl'.") - -(defun guix-devel-setup-repl-maybe (&optional repl) - "Setup (if needed) REPL for using `guix-devel-...' commands." - (let ((process (get-buffer-process (or repl (guix-geiser-repl))))) - (when (and process - (not (memq process guix-devel-repl-processes))) - (guix-devel-setup-repl repl) - (push process guix-devel-repl-processes)))) - -(defmacro guix-devel-with-definition (def-var &rest body) - "Run BODY with the current guile definition bound to DEF-VAR. -Bind DEF-VAR variable to the name of the current top-level -definition, setup the current REPL, use the current module, and -run BODY." - (declare (indent 1) (debug (symbolp body))) - `(let ((,def-var (guix-guile-current-definition))) - (guix-devel-setup-repl-maybe) - (guix-devel-use-modules (guix-guile-current-module)) - ,@body)) - -(defun guix-devel-build-package-definition () - "Build a package defined by the current top-level variable definition." - (interactive) - (guix-devel-with-definition def - (when (or (not guix-operation-confirm) - (guix-operation-prompt (format "Build '%s'?" def))) - (guix-geiser-eval-in-repl - (concat ",run-in-store " - (guix-guile-make-call-expression - "build-package" def - "#:use-substitutes?" (guix-guile-boolean - guix-use-substitutes) - "#:dry-run?" (guix-guile-boolean guix-dry-run))))))) - -(defun guix-devel-build-package-source () - "Build the source of the current package definition." - (interactive) - (guix-devel-with-definition def - (when (or (not guix-operation-confirm) - (guix-operation-prompt - (format "Build '%s' package source?" def))) - (guix-geiser-eval-in-repl - (concat ",run-in-store " - (guix-guile-make-call-expression - "build-package-source" def - "#:use-substitutes?" (guix-guile-boolean - guix-use-substitutes) - "#:dry-run?" (guix-guile-boolean guix-dry-run))))))) - -(defun guix-devel-lint-package () - "Check the current package. -See Info node `(guix) Invoking guix lint' for details." - (interactive) - (guix-devel-with-definition def - (guix-devel-use-modules "(guix scripts lint)") - (when (or (not guix-operation-confirm) - (y-or-n-p (format "Lint '%s' package?" def))) - (guix-geiser-eval-in-repl - (format "(run-checkers %s)" def))))) - - -;;; Font-lock - -(defvar guix-devel-modify-phases-keyword-regexp - (rx (+ word)) - "Regexp for a 'modify-phases' keyword ('delete', 'replace', etc.).") - -(defun guix-devel-modify-phases-font-lock-matcher (limit) - "Find a 'modify-phases' keyword. -This function is used as a MATCHER for `font-lock-keywords'." - (ignore-errors - (down-list) - (or (re-search-forward guix-devel-modify-phases-keyword-regexp - limit t) - (set-match-data nil)) - (up-list) - t)) - -(defun guix-devel-modify-phases-font-lock-pre () - "Skip the next sexp, and return the end point of the current list. -This function is used as a PRE-MATCH-FORM for `font-lock-keywords' -to find 'modify-phases' keywords." - (let ((in-comment? (nth 4 (syntax-ppss)))) - ;; If 'modify-phases' is commented, do not try to search for its - ;; keywords. - (unless in-comment? - (ignore-errors (forward-sexp)) - (save-excursion (up-list) (point))))) - -(defconst guix-devel-keywords - '("call-with-compressed-output-port" - "call-with-container" - "call-with-decompressed-port" - "call-with-derivation-narinfo" - "call-with-derivation-substitute" - "call-with-error-handling" - "call-with-temporary-directory" - "call-with-temporary-output-file" - "define-enumerate-type" - "define-gexp-compiler" - "define-lift" - "define-monad" - "define-operation" - "define-record-type*" - "emacs-substitute-sexps" - "emacs-substitute-variables" - "mbegin" - "mlet" - "mlet*" - "modify-services" - "munless" - "mwhen" - "run-with-state" - "run-with-store" - "signature-case" - "substitute*" - "substitute-keyword-arguments" - "test-assertm" - "use-package-modules" - "use-service-modules" - "use-system-modules" - "with-atomic-file-output" - "with-atomic-file-replacement" - "with-derivation-narinfo" - "with-derivation-substitute" - "with-directory-excursion" - "with-error-handling" - "with-imported-modules" - "with-monad" - "with-mutex" - "with-store")) - -(defvar guix-devel-font-lock-keywords - `((,(rx (or "#~" "#$" "#$@" "#+" "#+@")) . - 'guix-devel-gexp-symbol) - (,(guix-guile-keyword-regexp (regexp-opt guix-devel-keywords)) - (1 'font-lock-keyword-face)) - (,(guix-guile-keyword-regexp "modify-phases") - (1 'font-lock-keyword-face) - (guix-devel-modify-phases-font-lock-matcher - (guix-devel-modify-phases-font-lock-pre) - nil - (0 'guix-devel-modify-phases-keyword nil t)))) - "A list of `font-lock-keywords' for `guix-devel-mode'.") - - -;;; Indentation - -(defmacro guix-devel-scheme-indent (&rest rules) - "Set `scheme-indent-function' according to RULES. -Each rule should have a form (SYMBOL VALUE). See `put' for details." - (declare (indent 0)) - `(progn - ,@(mapcar (lambda (rule) - `(put ',(car rule) 'scheme-indent-function ,(cadr rule))) - rules))) - -(defun guix-devel-indent-package (state indent-point normal-indent) - "Indentation rule for 'package' form." - (let* ((package-eol (line-end-position)) - (count (if (and (ignore-errors (down-list) t) - (< (point) package-eol) - (looking-at "inherit\\>")) - 1 - 0))) - (lisp-indent-specform count state indent-point normal-indent))) - -(defun guix-devel-indent-modify-phases-keyword (count) - "Return indentation function for 'modify-phases' keywords." - (lambda (state indent-point normal-indent) - (when (ignore-errors - (goto-char (nth 1 state)) ; start of keyword sexp - (backward-up-list) - (looking-at "(modify-phases\\>")) - (lisp-indent-specform count state indent-point normal-indent)))) - -(defalias 'guix-devel-indent-modify-phases-keyword-1 - (guix-devel-indent-modify-phases-keyword 1)) -(defalias 'guix-devel-indent-modify-phases-keyword-2 - (guix-devel-indent-modify-phases-keyword 2)) - -(guix-devel-scheme-indent - (bag 0) - (build-system 0) - (call-with-compressed-output-port 2) - (call-with-container 1) - (call-with-decompressed-port 2) - (call-with-error-handling 0) - (container-excursion 1) - (emacs-batch-edit-file 1) - (emacs-batch-eval 0) - (emacs-substitute-sexps 1) - (emacs-substitute-variables 1) - (file-system 0) - (graft 0) - (manifest-entry 0) - (manifest-pattern 0) - (mbegin 1) - (mlet 2) - (mlet* 2) - (modify-phases 1) - (modify-services 1) - (munless 1) - (mwhen 1) - (operating-system 0) - (origin 0) - (package 'guix-devel-indent-package) - (run-with-state 1) - (run-with-store 1) - (signature-case 1) - (substitute* 1) - (substitute-keyword-arguments 1) - (test-assertm 1) - (with-atomic-file-output 1) - (with-derivation-narinfo 1) - (with-derivation-substitute 2) - (with-directory-excursion 1) - (with-error-handling 0) - (with-imported-modules 1) - (with-monad 1) - (with-mutex 1) - (with-store 1) - (wrap-program 1) - - ;; 'modify-phases' keywords: - (replace 'guix-devel-indent-modify-phases-keyword-1) - (add-after 'guix-devel-indent-modify-phases-keyword-2) - (add-before 'guix-devel-indent-modify-phases-keyword-2)) - - -(defvar guix-devel-keys-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "b") 'guix-devel-build-package-definition) - (define-key map (kbd "s") 'guix-devel-build-package-source) - (define-key map (kbd "l") 'guix-devel-lint-package) - (define-key map (kbd "k") 'guix-devel-copy-module-as-kill) - (define-key map (kbd "u") 'guix-devel-use-module) - map) - "Keymap with subkeys for `guix-devel-mode-map'.") - -(defvar guix-devel-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c .") guix-devel-keys-map) - map) - "Keymap for `guix-devel-mode'.") - -;;;###autoload -(define-minor-mode guix-devel-mode - "Minor mode for `scheme-mode' buffers. - -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. - -When Guix Devel mode is enabled, it provides the following key -bindings: - -\\{guix-devel-mode-map}" - :init-value nil - :lighter " Guix" - :keymap guix-devel-mode-map - (if guix-devel-mode - (progn - (setq-local font-lock-multiline t) - (font-lock-add-keywords nil guix-devel-font-lock-keywords)) - (setq-local font-lock-multiline nil) - (font-lock-remove-keywords nil guix-devel-font-lock-keywords)) - (when font-lock-mode - (font-lock-fontify-buffer))) - -;;;###autoload -(defun guix-devel-activate-mode-maybe () - "Activate `guix-devel-mode' depending on -`guix-devel-activate-mode' variable." - (when guix-devel-activate-mode - (guix-devel-mode))) - -;;;###autoload -(add-hook 'scheme-mode-hook 'guix-devel-activate-mode-maybe) - - -(defvar guix-devel-emacs-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group "guix-devel-with-definition") symbol-end) . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode - guix-devel-emacs-font-lock-keywords) - -(provide 'guix-devel) - -;;; guix-devel.el ends here diff --git a/emacs/guix-entry.el b/emacs/guix-entry.el deleted file mode 100644 index 5eed2ed015..0000000000 --- a/emacs/guix-entry.el +++ /dev/null @@ -1,59 +0,0 @@ -;;; guix-entry.el --- 'Entry' type -*- lexical-binding: t -*- - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides an API for 'entry' type which is just an alist of -;; KEY/VALUE pairs (KEY should be a symbol) with the required 'id' KEY. - -;;; Code: - -(require 'cl-lib) -(require 'guix-utils) - -(defalias 'guix-entry-value #'guix-assq-value) - -(defun guix-entry-id (entry) - "Return ENTRY ID." - (guix-entry-value entry 'id)) - -(defun guix-entry-by-id (id entries) - "Return an entry from ENTRIES by its ID." - (cl-find-if (lambda (entry) - (equal (guix-entry-id entry) id)) - entries)) - -(defun guix-entries-by-ids (ids entries) - "Return entries with IDS (a list of identifiers) from ENTRIES." - (cl-remove-if-not (lambda (entry) - (member (guix-entry-id entry) ids)) - entries)) - -(defun guix-replace-entry (id new-entry entries) - "Replace an entry with ID from ENTRIES by NEW-ENTRY. -Return a list of entries with the replaced entry." - (cl-substitute-if new-entry - (lambda (entry) - (equal id (guix-entry-id entry))) - entries - :count 1)) - -(provide 'guix-entry) - -;;; guix-entry.el ends here diff --git a/emacs/guix-external.el b/emacs/guix-external.el deleted file mode 100644 index f571ffd845..0000000000 --- a/emacs/guix-external.el +++ /dev/null @@ -1,88 +0,0 @@ -;;; guix-external.el --- External programs -*- lexical-binding: t -*- - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides auxiliary code for running external programs. - -;;; Code: - -(require 'cl-lib) -(require 'guix-config) - -(defgroup guix-external nil - "Settings for external programs." - :group 'guix) - -(defcustom guix-guile-program guix-config-guile-program - "Name of the 'guile' executable used for Guix REPL. -May be either a string (the name of the executable) or a list of -strings of the form: - - (NAME . ARGS) - -Where ARGS is a list of arguments to the guile program." - :type 'string - :group 'guix-external) - -(defcustom guix-dot-program - (if (file-name-absolute-p guix-config-dot-program) - guix-config-dot-program - (executable-find "dot")) - "Name of the 'dot' executable." - :type 'string - :group 'guix-external) - -(defcustom guix-dot-default-arguments - '("-Tpng") - "Default arguments for 'dot' program." - :type '(repeat string) - :group 'guix-external) - -(defcustom guix-dot-file-name-function #'guix-png-file-name - "Function used to define a file name of a temporary 'dot' file. -The function is called without arguments." - :type '(choice (function-item guix-png-file-name) - (function :tag "Other function")) - :group 'guix-external) - -(defun guix-dot-arguments (output-file &rest args) - "Return a list of dot arguments for writing a graph into OUTPUT-FILE. -If ARGS is nil, use `guix-dot-default-arguments'." - (or guix-dot-program - (error (concat "Couldn't find 'dot'.\n" - "Set guix-dot-program to a proper value"))) - (cl-list* guix-dot-program - (concat "-o" output-file) - (or args guix-dot-default-arguments))) - -(defun guix-dot-file-name () - "Call `guix-dot-file-name-function'." - (funcall guix-dot-file-name-function)) - -(defun guix-png-file-name () - "Return '.png' file name in the `temporary-file-directory'." - (concat (make-temp-name - (concat (file-name-as-directory temporary-file-directory) - "guix-emacs-graph-")) - ".png")) - -(provide 'guix-external) - -;;; guix-external.el ends here diff --git a/emacs/guix-geiser.el b/emacs/guix-geiser.el deleted file mode 100644 index 833f5bb2b3..0000000000 --- a/emacs/guix-geiser.el +++ /dev/null @@ -1,126 +0,0 @@ -;;; guix-geiser.el --- Interacting with Geiser -*- lexical-binding: t -*- - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides functions to evaluate guile code using Geiser. - -;;; Code: - -(require 'geiser-mode) -(require 'guix-guile) - -(defun guix-geiser-repl () - "Return the current Geiser REPL." - (or geiser-repl--repl - (geiser-repl--repl/impl 'guile) - (error "Geiser REPL not found"))) - -(defun guix-geiser-eval (str &optional repl) - "Evaluate STR with guile expression using Geiser REPL. -If REPL is nil, use the current Geiser REPL. -Return a list of strings with result values of evaluation." - (with-current-buffer (or repl (guix-geiser-repl)) - (let ((res (geiser-eval--send/wait `(:eval (:scm ,str))))) - (if (geiser-eval--retort-error res) - (error "Error in evaluating guile expression: %s" - (geiser-eval--retort-output res)) - (cdr (assq 'result res)))))) - -(defun guix-geiser-eval-read (str &optional repl) - "Evaluate STR with guile expression using Geiser REPL. -Return elisp expression of the first result value of evaluation." - ;; The goal is to convert a string with scheme expression into elisp - ;; expression. - (let ((result (car (guix-geiser-eval str repl)))) - (cond - ((or (string= result "#f") - (string= result "#")) - nil) - ((string= result "#t") - t) - (t - (read (replace-regexp-in-string - "[ (]\\(#f\\)" "nil" - (replace-regexp-in-string - "[ (]\\(#t\\)" "t" - result - nil nil 1) - nil nil 1)))))) - -(defun guix-repl-send (cmd &optional save-history) - "Send CMD input string to the current REPL buffer. -This is the same as `geiser-repl--send', but with SAVE-HISTORY -argument. If SAVE-HISTORY is non-nil, save CMD in the REPL -history." - (when (and cmd (eq major-mode 'geiser-repl-mode)) - (geiser-repl--prepare-send) - (goto-char (point-max)) - (comint-kill-input) - (insert cmd) - (let ((comint-input-filter (if save-history - comint-input-filter - 'ignore))) - (comint-send-input nil t)))) - -(defun guix-geiser-eval-in-repl (str &optional repl no-history no-display) - "Switch to Geiser REPL and evaluate STR with guile expression there. -If NO-HISTORY is non-nil, do not save STR in the REPL history. -If NO-DISPLAY is non-nil, do not switch to the REPL buffer." - (let ((repl (or repl (guix-geiser-repl)))) - (with-current-buffer repl - ;; XXX Since Geiser 0.8, `geiser-repl--send' has SAVE-HISTORY - ;; argument, so use this function eventually and remove - ;; `guix-repl-send'. - (guix-repl-send str (not no-history))) - (unless no-display - (geiser-repl--switch-to-buffer repl)))) - -(defun guix-geiser-eval-in-repl-synchronously (str &optional repl - no-history no-display) - "Evaluate STR in Geiser REPL synchronously, i.e. wait until the -REPL operation will be finished. -See `guix-geiser-eval-in-repl' for the meaning of arguments." - (let* ((repl (if repl (get-buffer repl) (guix-geiser-repl))) - (running? nil) - (filter (lambda (output) - (setq running? - (and (get-buffer-process repl) - (not (guix-guile-prompt? output)))))) - (comint-output-filter-functions - (cons filter comint-output-filter-functions))) - (guix-geiser-eval-in-repl str repl no-history no-display) - (while running? - (sleep-for 0.1)))) - -(defun guix-geiser-call (proc &rest args) - "Call (PROC ARGS ...) synchronously using the current Geiser REPL. -PROC and ARGS should be strings." - (guix-geiser-eval - (apply #'guix-guile-make-call-expression proc args))) - -(defun guix-geiser-call-in-repl (proc &rest args) - "Call (PROC ARGS ...) in the current Geiser REPL. -PROC and ARGS should be strings." - (guix-geiser-eval-in-repl - (apply #'guix-guile-make-call-expression proc args))) - -(provide 'guix-geiser) - -;;; guix-geiser.el ends here diff --git a/emacs/guix-guile.el b/emacs/guix-guile.el deleted file mode 100644 index 792f825ca5..0000000000 --- a/emacs/guix-guile.el +++ /dev/null @@ -1,98 +0,0 @@ -;;; guix-guile.el --- Auxiliary tools for working with guile code -*- lexical-binding: t -*- - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides functions for parsing guile code, making guile -;; expressions, etc. - -;;; Code: - -(require 'geiser-guile) - -(defvar guix-guile-definition-regexp - (rx bol "(define" - (zero-or-one "*") - (zero-or-one "-public") - (one-or-more space) - (zero-or-one "(") - (group (one-or-more (or word (syntax symbol))))) - "Regexp used to find the guile definition.") - -(defun guix-guile-current-definition () - "Return string with name of the current top-level guile definition." - (save-excursion - (beginning-of-defun) - (if (looking-at guix-guile-definition-regexp) - (match-string-no-properties 1) - (error "Couldn't find the current definition")))) - -(defun guix-guile-current-module () - "Return a string with the current guile module. -Return nil, if current buffer does not define a module." - ;; Modified version of `geiser-guile--get-module'. - (save-excursion - (geiser-syntax--pop-to-top) - (when (or (re-search-backward geiser-guile--module-re nil t) - (looking-at geiser-guile--library-re) - (re-search-forward geiser-guile--module-re nil t)) - (match-string-no-properties 1)))) - -(defun guix-guile-boolean (arg) - "Return a string with guile boolean value. -Transform elisp ARG (nil or non-nil) to the guile boolean (#f or #t)." - (if arg "#t" "#f")) - -(defun guix-guile-keyword-regexp (keyword) - "Return regexp to find guile KEYWORD." - (format "(\\(%s\\)\\_>" keyword)) - -(defun guix-guile-make-call-expression (proc &rest args) - "Return \"(PROC ARGS ...)\" string. -PROC and ARGS should be strings." - (format "(%s %s)" - proc - (mapconcat #'identity args " "))) - -(defun guix-make-guile-expression (fun &rest args) - "Return string containing a guile expression for calling FUN with ARGS." - (format "(%S %s)" fun - (mapconcat - (lambda (arg) - (cond - ((null arg) "'()") - ((or (eq arg t) - ;; An ugly hack to separate 'false' from nil. - (equal arg 'f) - (keywordp arg)) - (concat "#" (prin1-to-string arg t))) - ((or (symbolp arg) (listp arg)) - (concat "'" (prin1-to-string arg))) - (t (prin1-to-string arg)))) - args - " "))) - -(defun guix-guile-prompt? (string) - "Return non-nil, if STRING contains a Guile prompt." - (or (string-match-p geiser-guile--prompt-regexp string) - (string-match-p geiser-guile--debugger-prompt-regexp string))) - -(provide 'guix-guile) - -;;; guix-guile.el ends here diff --git a/emacs/guix-help-vars.el b/emacs/guix-help-vars.el deleted file mode 100644 index 8117d28f3e..0000000000 --- a/emacs/guix-help-vars.el +++ /dev/null @@ -1,108 +0,0 @@ -;;; guix-help-vars.el --- Variables related to --help output - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides regular expressions to parse various "guix -;; ... --help" outputs and lists of non-receivable items (system types, -;; hash formats, etc.). - -;;; Code: - - -;;; Regexps for parsing "guix ..." outputs - -(defvar guix-help-parse-option-regexp - (rx bol " " - (zero-or-one (group "-" (not (any "- "))) - ",") - (one-or-more " ") - (group "--" (one-or-more (or wordchar "-"))) - (group (zero-or-one "[") - (zero-or-one "=")) - (zero-or-more (not space)) - (one-or-more space) - (group (one-or-more any))) - "Common regexp used to find command options.") - -(defvar guix-help-parse-command-regexp - (rx bol " " - (group wordchar (one-or-more (or wordchar "-")))) - "Regexp used to find guix commands. -'Command' means any option not prefixed with '-'. For example, -guix subcommand, system action, importer, etc.") - -(defvar guix-help-parse-long-option-regexp - (rx (or " " ", ") - (group "--" (one-or-more (or wordchar "-")) - (zero-or-one "="))) - "Regexp used to find long options.") - -(defvar guix-help-parse-short-option-regexp - (rx bol (one-or-more blank) - "-" (group (not (any "- ")))) - "Regexp used to find short options.") - -(defvar guix-help-parse-package-regexp - (rx bol (group (one-or-more (not blank)))) - "Regexp used to find names of the packages.") - -(defvar guix-help-parse-list-regexp - (rx bol (zero-or-more blank) "- " - (group (one-or-more (or wordchar "-")))) - "Regexp used to find various lists (lint checkers, graph types).") - -(defvar guix-help-parse-regexp-group 1 - "Parenthesized expression of regexps used to find commands and -options.") - - -;;; Non-receivable lists of system types, hash formats, etc. - -(defvar guix-help-system-types - '("x86_64-linux" "i686-linux" "armhf-linux" "mips64el-linux") - "List of supported systems.") - -(defvar guix-help-source-types - '("package" "all" "transitive") - "List of supported sources types.") - -(defvar guix-help-hash-formats - '("nix-base32" "base32" "base16" "hex" "hexadecimal") - "List of supported hash formats.") - -(defvar guix-help-refresh-subsets - '("core" "non-core") - "List of supported 'refresh' subsets.") - -(defvar guix-help-key-policies - '("interactive" "always" "never") - "List of supported key download policies.") - -(defvar guix-help-verify-options - '("repair" "contents") - "List of supported 'verify' options") - -(defvar guix-help-elpa-archives - '("gnu" "melpa" "melpa-stable") - "List of supported ELPA archives.") - -(provide 'guix-help-vars) - -;;; guix-help-vars.el ends here diff --git a/emacs/guix-helper.scm.in b/emacs/guix-helper.scm.in deleted file mode 100644 index 0bbd36be21..0000000000 --- a/emacs/guix-helper.scm.in +++ /dev/null @@ -1,65 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Alex Kost -;;; -;;; 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 . - -;;; Commentary: - -;; This is an auxiliary file for the Emacs UI. It is used to add Guix -;; directories to path variables and to load the main code. - -;;; Code: - -(use-modules (ice-9 regex) - (srfi srfi-26)) - -(define %guix-dir) - -;; The code is taken from ‘guix’ executable script -(define (set-paths!) - (define-syntax-rule (push! elt v) (set! v (cons elt v))) - - (define config-lookup - (let ((config '(("prefix" . "@prefix@") - ("guilemoduledir" . "@guilemoduledir@"))) - (var-ref-regexp (make-regexp "\\$\\{([a-z]+)\\}"))) - (define (expand-var-ref match) - (lookup (match:substring match 1))) - (define (expand str) - (regexp-substitute/global #f var-ref-regexp str - 'pre expand-var-ref 'post)) - (define (lookup name) - (expand (assoc-ref config name))) - lookup)) - - (let ((module-dir (config-lookup "guilemoduledir")) - (updates-dir (and=> (or (getenv "XDG_CONFIG_HOME") - (and=> (getenv "HOME") - (cut string-append <> "/.config"))) - (cut string-append <> "/guix/latest")))) - (push! module-dir %load-path) - (push! module-dir %load-compiled-path) - (if (and updates-dir (file-exists? updates-dir)) - (begin - (set! %guix-dir updates-dir) - (push! updates-dir %load-path) - (push! updates-dir %load-compiled-path)) - (set! %guix-dir module-dir)))) - -(set-paths!) - -(load-from-path "guix-main") - diff --git a/emacs/guix-history.el b/emacs/guix-history.el deleted file mode 100644 index 5d301a689e..0000000000 --- a/emacs/guix-history.el +++ /dev/null @@ -1,92 +0,0 @@ -;;; guix-history.el --- History of buffer information - -;; Copyright © 2014 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides support for history of buffers similar to the -;; history of a `help-mode' buffer. - -;;; Code: - -(require 'cl-macs) - -(defvar-local guix-history-stack-item nil - "Current item of the history. -A list of the form (FUNCTION [ARGS ...]). -The item is used by calling (apply FUNCTION ARGS).") -(put 'guix-history-stack-item 'permanent-local t) - -(defvar-local guix-history-back-stack nil - "Stack (list) of visited items. -Each element of the list has a form of `guix-history-stack-item'.") -(put 'guix-history-back-stack 'permanent-local t) - -(defvar-local guix-history-forward-stack nil - "Stack (list) of items visited with `guix-history-back'. -Each element of the list has a form of `guix-history-stack-item'.") -(put 'guix-history-forward-stack 'permanent-local t) - -(defvar guix-history-size 0 - "Maximum number of items saved in history. -If 0, the history is disabled.") - -(defun guix-history-add (item) - "Add ITEM to history." - (and guix-history-stack-item - (push guix-history-stack-item guix-history-back-stack)) - (setq guix-history-forward-stack nil - guix-history-stack-item item) - (when (>= (length guix-history-back-stack) - guix-history-size) - (setq guix-history-back-stack - (cl-loop for elt in guix-history-back-stack - for i from 1 to guix-history-size - collect elt)))) - -(defun guix-history-replace (item) - "Replace current item in history with ITEM." - (setq guix-history-stack-item item)) - -(defun guix-history-goto (item) - "Go to the ITEM of history. -ITEM should have the form of `guix-history-stack-item'." - (or (listp item) - (error "Wrong value of history element")) - (setq guix-history-stack-item item) - (apply (car item) (cdr item))) - -(defun guix-history-back () - "Go back to the previous element of history in the current buffer." - (interactive) - (or guix-history-back-stack - (user-error "No previous element in history")) - (push guix-history-stack-item guix-history-forward-stack) - (guix-history-goto (pop guix-history-back-stack))) - -(defun guix-history-forward () - "Go forward to the next element of history in the current buffer." - (interactive) - (or guix-history-forward-stack - (user-error "No next element in history")) - (push guix-history-stack-item guix-history-back-stack) - (guix-history-goto (pop guix-history-forward-stack))) - -(provide 'guix-history) - -;;; guix-history.el ends here diff --git a/emacs/guix-hydra-build.el b/emacs/guix-hydra-build.el deleted file mode 100644 index 232221e773..0000000000 --- a/emacs/guix-hydra-build.el +++ /dev/null @@ -1,362 +0,0 @@ -;;; guix-hydra-build.el --- Interface for Hydra builds -*- lexical-binding: t -*- - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides an interface for displaying Hydra builds in -;; 'list' and 'info' buffers. - -;;; Code: - -(require 'cl-lib) -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-info) -(require 'guix-hydra) -(require 'guix-build-log) -(require 'guix-utils) - -(guix-hydra-define-entry-type hydra-build - :search-types '((latest . guix-hydra-build-latest-api-url) - (queue . guix-hydra-build-queue-api-url)) - :filters '(guix-hydra-build-filter-status) - :filter-names '((nixname . name) - (buildstatus . build-status) - (timestamp . time)) - :filter-boolean-params '(finished busy)) - -(defun guix-hydra-build-get-display (search-type &rest args) - "Search for Hydra builds and show results." - (apply #'guix-list-get-display-entries - 'hydra-build search-type args)) - -(cl-defun guix-hydra-build-latest-prompt-args (&key project jobset - job system) - "Prompt for and return a list of 'latest builds' arguments." - (let* ((number (read-number "Number of latest builds: ")) - (project (if current-prefix-arg - (guix-hydra-read-project nil project) - project)) - (jobset (if current-prefix-arg - (guix-hydra-read-jobset nil jobset) - jobset)) - (job-or-name (if current-prefix-arg - (guix-hydra-read-job nil job) - job)) - (job (and job-or-name - (string-match-p guix-hydra-job-regexp - job-or-name) - job-or-name)) - (system (if (and (not job) - (or current-prefix-arg - (and job-or-name (not system)))) - (if job-or-name - (guix-while-null - (guix-hydra-read-system - (concat job-or-name ".") system)) - (guix-hydra-read-system nil system)) - system)) - (job (or job - (and job-or-name - (concat job-or-name "." system))))) - (list number - :project project - :jobset jobset - :job job - :system system))) - -(defun guix-hydra-build-view-log (id) - "View build log of a hydra build ID." - (guix-build-log-find-file (guix-hydra-build-log-url id))) - - -;;; Defining URLs - -(defun guix-hydra-build-url (id) - "Return Hydra URL of a build ID." - (guix-hydra-url "build/" (number-to-string id))) - -(defun guix-hydra-build-log-url (id) - "Return Hydra URL of the log file of a build ID." - (concat (guix-hydra-build-url id) "/log/raw")) - -(cl-defun guix-hydra-build-latest-api-url - (number &key project jobset job system) - "Return Hydra API URL to receive latest NUMBER of builds." - (guix-hydra-api-url "latestbuilds" - `(("nr" . ,number) - ("project" . ,project) - ("jobset" . ,jobset) - ("job" . ,job) - ("system" . ,system)))) - -(defun guix-hydra-build-queue-api-url (number) - "Return Hydra API URL to receive the NUMBER of queued builds." - (guix-hydra-api-url "queue" - `(("nr" . ,number)))) - - -;;; Filters for processing raw entries - -(defun guix-hydra-build-filter-status (entry) - "Add 'status' parameter to 'hydra-build' ENTRY." - (let ((status (if (guix-entry-value entry 'finished) - (guix-hydra-build-status-number->name - (guix-entry-value entry 'build-status)) - (if (guix-entry-value entry 'busy) - 'running - 'scheduled)))) - (cons `(status . ,status) - entry))) - - -;;; Build status - -(defface guix-hydra-build-status-running - '((t :inherit bold)) - "Face used if hydra build is not finished." - :group 'guix-hydra-build-faces) - -(defface guix-hydra-build-status-scheduled - '((t)) - "Face used if hydra build is scheduled." - :group 'guix-hydra-build-faces) - -(defface guix-hydra-build-status-succeeded - '((t :inherit success)) - "Face used if hydra build succeeded." - :group 'guix-hydra-build-faces) - -(defface guix-hydra-build-status-cancelled - '((t :inherit warning)) - "Face used if hydra build was cancelled." - :group 'guix-hydra-build-faces) - -(defface guix-hydra-build-status-failed - '((t :inherit error)) - "Face used if hydra build failed." - :group 'guix-hydra-build-faces) - -(defvar guix-hydra-build-status-alist - '((0 . succeeded) - (1 . failed-build) - (2 . failed-dependency) - (3 . failed-other) - (4 . cancelled)) - "Alist of hydra build status numbers and status names. -Status numbers are returned by Hydra API, names (symbols) are -used internally by the elisp code of this package.") - -(defun guix-hydra-build-status-number->name (number) - "Convert build status number to a name. -See `guix-hydra-build-status-alist'." - (guix-assq-value guix-hydra-build-status-alist number)) - -(defun guix-hydra-build-status-string (status) - "Return a human readable string for build STATUS." - (cl-case status - (scheduled - (guix-get-string "Scheduled" 'guix-hydra-build-status-scheduled)) - (running - (guix-get-string "Running" 'guix-hydra-build-status-running)) - (succeeded - (guix-get-string "Succeeded" 'guix-hydra-build-status-succeeded)) - (cancelled - (guix-get-string "Cancelled" 'guix-hydra-build-status-cancelled)) - (failed-build - (guix-hydra-build-status-fail-string)) - (failed-dependency - (guix-hydra-build-status-fail-string "dependency")) - (failed-other - (guix-hydra-build-status-fail-string "other")))) - -(defun guix-hydra-build-status-fail-string (&optional reason) - "Return a string for a failed build." - (let ((base (guix-get-string "Failed" 'guix-hydra-build-status-failed))) - (if reason - (concat base " (" reason ")") - base))) - -(defun guix-hydra-build-finished? (entry) - "Return non-nil, if hydra build was finished." - (guix-entry-value entry 'finished)) - -(defun guix-hydra-build-running? (entry) - "Return non-nil, if hydra build is running." - (eq (guix-entry-value entry 'status) - 'running)) - -(defun guix-hydra-build-scheduled? (entry) - "Return non-nil, if hydra build is scheduled." - (eq (guix-entry-value entry 'status) - 'scheduled)) - -(defun guix-hydra-build-succeeded? (entry) - "Return non-nil, if hydra build succeeded." - (eq (guix-entry-value entry 'status) - 'succeeded)) - -(defun guix-hydra-build-cancelled? (entry) - "Return non-nil, if hydra build was cancelled." - (eq (guix-entry-value entry 'status) - 'cancelled)) - -(defun guix-hydra-build-failed? (entry) - "Return non-nil, if hydra build failed." - (memq (guix-entry-value entry 'status) - '(failed-build failed-dependency failed-other))) - - -;;; Hydra build 'info' - -(guix-hydra-info-define-interface hydra-build - :mode-name "Hydra-Build-Info" - :buffer-name "*Guix Hydra Build Info*" - :format '((name ignore (simple guix-info-heading)) - ignore - guix-hydra-build-info-insert-url - (time format (time)) - (status format guix-hydra-build-info-insert-status) - (project format (format guix-hydra-build-project)) - (jobset format (format guix-hydra-build-jobset)) - (job format (format guix-hydra-build-job)) - (system format (format guix-hydra-build-system)) - (priority format (format)))) - -(defface guix-hydra-build-info-project - '((t :inherit link)) - "Face for project names." - :group 'guix-hydra-build-info-faces) - -(defface guix-hydra-build-info-jobset - '((t :inherit link)) - "Face for jobsets." - :group 'guix-hydra-build-info-faces) - -(defface guix-hydra-build-info-job - '((t :inherit link)) - "Face for jobs." - :group 'guix-hydra-build-info-faces) - -(defface guix-hydra-build-info-system - '((t :inherit link)) - "Face for system names." - :group 'guix-hydra-build-info-faces) - -(defmacro guix-hydra-build-define-button (name) - "Define `guix-hydra-build-NAME' button." - (let* ((name-str (symbol-name name)) - (button-name (intern (concat "guix-hydra-build-" name-str))) - (face-name (intern (concat "guix-hydra-build-info-" name-str))) - (keyword (intern (concat ":" name-str)))) - `(define-button-type ',button-name - :supertype 'guix - 'face ',face-name - 'help-echo ,(format "\ -Show latest builds for this %s (with prefix, prompt for all parameters)" - name-str) - 'action (lambda (btn) - (let ((args (guix-hydra-build-latest-prompt-args - ,keyword (button-label btn)))) - (apply #'guix-hydra-build-get-display - 'latest args)))))) - -(guix-hydra-build-define-button project) -(guix-hydra-build-define-button jobset) -(guix-hydra-build-define-button job) -(guix-hydra-build-define-button system) - -(defun guix-hydra-build-info-insert-url (entry) - "Insert Hydra URL for the build ENTRY." - (guix-insert-button (guix-hydra-build-url (guix-entry-id entry)) - 'guix-url) - (when (guix-hydra-build-finished? entry) - (guix-info-insert-indent) - (guix-info-insert-action-button - "Build log" - (lambda (btn) - (guix-hydra-build-view-log (button-get btn 'id))) - "View build log" - 'id (guix-entry-id entry)))) - -(defun guix-hydra-build-info-insert-status (status &optional _) - "Insert a string with build STATUS." - (insert (guix-hydra-build-status-string status))) - - -;;; Hydra build 'list' - -(guix-hydra-list-define-interface hydra-build - :mode-name "Hydra-Build-List" - :buffer-name "*Guix Hydra Build List*" - :format '((name nil 30 t) - (system nil 16 t) - (status guix-hydra-build-list-get-status 20 t) - (project nil 10 t) - (jobset nil 17 t) - (time guix-list-get-time 20 t))) - -(let ((map guix-hydra-build-list-mode-map)) - (define-key map (kbd "B") 'guix-hydra-build-list-latest-builds) - (define-key map (kbd "L") 'guix-hydra-build-list-view-log)) - -(defun guix-hydra-build-list-get-status (status &optional _) - "Return a string for build STATUS." - (guix-hydra-build-status-string status)) - -(defun guix-hydra-build-list-latest-builds (number &rest args) - "Display latest NUMBER of Hydra builds of the current job. -Interactively, prompt for NUMBER. With prefix argument, prompt -for all ARGS." - (interactive - (let ((entry (guix-list-current-entry))) - (guix-hydra-build-latest-prompt-args - :project (guix-entry-value entry 'project) - :jobset (guix-entry-value entry 'name) - :job (guix-entry-value entry 'job) - :system (guix-entry-value entry 'system)))) - (apply #'guix-hydra-latest-builds number args)) - -(defun guix-hydra-build-list-view-log () - "View build log of the current Hydra build." - (interactive) - (guix-hydra-build-view-log (guix-list-current-id))) - - -;;; Interactive commands - -;;;###autoload -(defun guix-hydra-latest-builds (number &rest args) - "Display latest NUMBER of Hydra builds. -ARGS are the same arguments as for `guix-hydra-build-latest-api-url'. -Interactively, prompt for NUMBER. With prefix argument, prompt -for all ARGS." - (interactive (guix-hydra-build-latest-prompt-args)) - (apply #'guix-hydra-build-get-display - 'latest number args)) - -;;;###autoload -(defun guix-hydra-queued-builds (number) - "Display the NUMBER of queued Hydra builds." - (interactive "NNumber of queued builds: ") - (guix-hydra-build-get-display 'queue number)) - -(provide 'guix-hydra-build) - -;;; guix-hydra-build.el ends here diff --git a/emacs/guix-hydra-jobset.el b/emacs/guix-hydra-jobset.el deleted file mode 100644 index a4a55a36f2..0000000000 --- a/emacs/guix-hydra-jobset.el +++ /dev/null @@ -1,162 +0,0 @@ -;;; guix-hydra-jobset.el --- Interface for Hydra jobsets -*- lexical-binding: t -*- - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides an interface for displaying Hydra jobsets in -;; 'list' and 'info' buffers. - -;;; Code: - -(require 'cl-lib) -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-info) -(require 'guix-hydra) -(require 'guix-hydra-build) -(require 'guix-utils) - -(guix-hydra-define-entry-type hydra-jobset - :search-types '((project . guix-hydra-jobset-api-url)) - :filters '(guix-hydra-jobset-filter-id) - :filter-names '((nrscheduled . scheduled) - (nrsucceeded . succeeded) - (nrfailed . failed) - (nrtotal . total))) - -(defun guix-hydra-jobset-get-display (search-type &rest args) - "Search for Hydra builds and show results." - (apply #'guix-list-get-display-entries - 'hydra-jobset search-type args)) - - -;;; Defining URLs - -(defun guix-hydra-jobset-url (project jobset) - "Return Hydra URL of a PROJECT's JOBSET." - (guix-hydra-url "jobset/" project "/" jobset)) - -(defun guix-hydra-jobset-api-url (project) - "Return Hydra API URL for jobsets by PROJECT." - (guix-hydra-api-url "jobsets" - `(("project" . ,project)))) - - -;;; Filters for processing raw entries - -(defun guix-hydra-jobset-filter-id (entry) - "Add 'ID' parameter to 'hydra-jobset' ENTRY." - (cons `(id . ,(guix-entry-value entry 'name)) - entry)) - - -;;; Hydra jobset 'info' - -(guix-hydra-info-define-interface hydra-jobset - :mode-name "Hydra-Jobset-Info" - :buffer-name "*Guix Hydra Jobset Info*" - :format '((name ignore (simple guix-info-heading)) - ignore - guix-hydra-jobset-info-insert-url - (project format guix-hydra-jobset-info-insert-project) - (scheduled format (format guix-hydra-jobset-info-scheduled)) - (succeeded format (format guix-hydra-jobset-info-succeeded)) - (failed format (format guix-hydra-jobset-info-failed)) - (total format (format guix-hydra-jobset-info-total)))) - -(defface guix-hydra-jobset-info-scheduled - '((t)) - "Face used for the number of scheduled builds." - :group 'guix-hydra-jobset-info-faces) - -(defface guix-hydra-jobset-info-succeeded - '((t :inherit guix-hydra-build-status-succeeded)) - "Face used for the number of succeeded builds." - :group 'guix-hydra-jobset-info-faces) - -(defface guix-hydra-jobset-info-failed - '((t :inherit guix-hydra-build-status-failed)) - "Face used for the number of failed builds." - :group 'guix-hydra-jobset-info-faces) - -(defface guix-hydra-jobset-info-total - '((t)) - "Face used for the total number of builds." - :group 'guix-hydra-jobset-info-faces) - -(defun guix-hydra-jobset-info-insert-project (project entry) - "Insert PROJECT button for the jobset ENTRY." - (let ((jobset (guix-entry-value entry 'name))) - (guix-insert-button - project 'guix-hydra-build-project - 'action (lambda (btn) - (let ((args (guix-hydra-build-latest-prompt-args - :project (button-get btn 'project) - :jobset (button-get btn 'jobset)))) - (apply #'guix-hydra-build-get-display - 'latest args))) - 'project project - 'jobset jobset))) - -(defun guix-hydra-jobset-info-insert-url (entry) - "Insert Hydra URL for the jobset ENTRY." - (guix-insert-button (guix-hydra-jobset-url - (guix-entry-value entry 'project) - (guix-entry-value entry 'name)) - 'guix-url)) - - -;;; Hydra jobset 'list' - -(guix-hydra-list-define-interface hydra-jobset - :mode-name "Hydra-Jobset-List" - :buffer-name "*Guix Hydra Jobset List*" - :format '((name nil 25 t) - (project nil 10 t) - (scheduled nil 12 t) - (succeeded nil 12 t) - (failed nil 9 t) - (total nil 10 t))) - -(let ((map guix-hydra-jobset-list-mode-map)) - (define-key map (kbd "B") 'guix-hydra-jobset-list-latest-builds)) - -(defun guix-hydra-jobset-list-latest-builds (number &rest args) - "Display latest NUMBER of Hydra builds of the current jobset. -Interactively, prompt for NUMBER. With prefix argument, prompt -for all ARGS." - (interactive - (let ((entry (guix-list-current-entry))) - (guix-hydra-build-latest-prompt-args - :project (guix-entry-value entry 'project) - :jobset (guix-entry-value entry 'name)))) - (apply #'guix-hydra-latest-builds number args)) - - -;;; Interactive commands - -;;;###autoload -(defun guix-hydra-jobsets (project) - "Display jobsets of PROJECT." - (interactive (list (guix-hydra-read-project))) - (guix-hydra-jobset-get-display 'project project)) - -(provide 'guix-hydra-jobset) - -;;; guix-hydra-jobset.el ends here diff --git a/emacs/guix-hydra.el b/emacs/guix-hydra.el deleted file mode 100644 index 9f876e7eea..0000000000 --- a/emacs/guix-hydra.el +++ /dev/null @@ -1,367 +0,0 @@ -;;; guix-hydra.el --- Common code for interacting with Hydra -*- lexical-binding: t -*- - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides some general code for 'list'/'info' interfaces for -;; Hydra (Guix build farm). - -;;; Code: - -(require 'json) -(require 'guix-buffer) -(require 'guix-entry) -(require 'guix-utils) -(require 'guix-help-vars) - -(guix-define-groups hydra) - -(defvar guix-hydra-job-regexp - (concat ".*\\." (regexp-opt guix-help-system-types) "\\'") - "Regexp matching a full name of Hydra job (including system).") - -(defun guix-hydra-job-name-specification (name version) - "Return Hydra's job name specification by NAME and VERSION." - (concat name "-" version)) - -(defun guix-hydra-message (entries search-type &rest _) - "Display a message after showing Hydra ENTRIES." - ;; XXX Add more messages maybe. - (when (null entries) - (if (eq search-type 'fake) - (message "The update is impossible due to lack of Hydra API.") - (message "Hydra has returned no results.")))) - -(defun guix-hydra-list-describe (ids) - "Describe 'hydra' entries with IDS (list of identifiers)." - (guix-buffer-display-entries - (guix-entries-by-ids ids (guix-buffer-current-entries)) - 'info (guix-buffer-current-entry-type) - ;; Hydra does not provide an API to receive builds/jobsets by - ;; IDs/names, so we use a 'fake' search type. - '(fake) - 'add)) - - -;;; Readers - -(defvar guix-hydra-projects - '("gnu" "guix") - "List of available Hydra projects.") - -(guix-define-readers - :completions-var guix-hydra-projects - :single-reader guix-hydra-read-project - :single-prompt "Project: ") - -(guix-define-readers - :single-reader guix-hydra-read-jobset - :single-prompt "Jobset: ") - -(guix-define-readers - :single-reader guix-hydra-read-job - :single-prompt "Job: ") - -(guix-define-readers - :completions-var guix-help-system-types - :single-reader guix-hydra-read-system - :single-prompt "System: ") - - -;;; Defining URLs - -(defvar guix-hydra-url "http://hydra.gnu.org" - "URL of the Hydra build farm.") - -(defun guix-hydra-url (&rest url-parts) - "Return Hydra URL." - (apply #'concat guix-hydra-url "/" url-parts)) - -(defun guix-hydra-api-url (type args) - "Return URL for receiving data using Hydra API. -TYPE is the name of an allowed method. -ARGS is alist of (KEY . VALUE) pairs. -Skip ARG, if VALUE is nil or an empty string." - (declare (indent 1)) - (let* ((fields (mapcar - (lambda (arg) - (pcase arg - (`(,key . ,value) - (unless (or (null value) - (equal "" value)) - (concat (guix-hexify key) "=" - (guix-hexify value)))) - (_ (error "Wrong argument '%s'" arg)))) - args)) - (fields (mapconcat #'identity (delq nil fields) "&"))) - (guix-hydra-url "api/" type "?" fields))) - - -;;; Receiving data from Hydra - -(defun guix-hydra-receive-data (url) - "Return output received from URL and processed with `json-read'." - (with-temp-buffer - (url-insert-file-contents url) - (goto-char (point-min)) - (let ((json-key-type 'symbol) - (json-array-type 'list) - (json-object-type 'alist)) - (json-read)))) - -(defun guix-hydra-get-entries (entry-type search-type &rest args) - "Receive ENTRY-TYPE entries from Hydra. -SEARCH-TYPE is one of the types defined by `guix-hydra-define-interface'." - (unless (eq search-type 'fake) - (let* ((url (apply #'guix-hydra-search-url - entry-type search-type args)) - (raw-entries (guix-hydra-receive-data url)) - (entries (guix-hydra-filter-entries - raw-entries - (guix-hydra-filters entry-type)))) - entries))) - - -;;; Filters for processing raw entries - -(defun guix-hydra-filter-entries (entries filters) - "Filter ENTRIES using FILTERS. -Call `guix-modify' on each entry from ENTRIES." - (mapcar (lambda (entry) - (guix-modify entry filters)) - entries)) - -(defun guix-hydra-filter-names (entry name-alist) - "Replace names of ENTRY parameters using NAME-ALIST. -Each element of NAME-ALIST is (OLD-NAME . NEW-NAME) pair." - (mapcar (lambda (param) - (pcase param - (`(,name . ,val) - (let ((new-name (guix-assq-value name-alist name))) - (if new-name - (cons new-name val) - param))))) - entry)) - -(defun guix-hydra-filter-boolean (entry params) - "Convert number PARAMS (0/1) of ENTRY to boolean values (nil/t)." - (mapcar (lambda (param) - (pcase param - (`(,name . ,val) - (if (memq name params) - (cons name (guix-number->bool val)) - param)))) - entry)) - - -;;; Wrappers for defined variables - -(defvar guix-hydra-entry-type-data nil - "Alist with hydra entry type data. -This alist is filled by `guix-hydra-define-entry-type' macro.") - -(defun guix-hydra-entry-type-value (entry-type symbol) - "Return SYMBOL's value for ENTRY-TYPE from `guix-hydra'." - (symbol-value (guix-assq-value guix-hydra-entry-type-data - entry-type symbol))) - -(defun guix-hydra-search-url (entry-type search-type &rest args) - "Return URL to receive ENTRY-TYPE entries from Hydra." - (apply (guix-assq-value (guix-hydra-entry-type-value - entry-type 'search-types) - search-type) - args)) - -(defun guix-hydra-filters (entry-type) - "Return a list of filters for ENTRY-TYPE." - (guix-hydra-entry-type-value entry-type 'filters)) - - -;;; Interface definers - -(defmacro guix-hydra-define-entry-type (entry-type &rest args) - "Define general code for ENTRY-TYPE. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Required keywords: - - - `:search-types' - default value of the generated - `guix-ENTRY-TYPE-search-types' variable. - -Optional keywords: - - - `:filters' - default value of the generated - `guix-ENTRY-TYPE-filters' variable. - - - `:filter-names' - if specified, a generated - `guix-ENTRY-TYPE-filter-names' function for filtering these - names will be added to `guix-ENTRY-TYPE-filters' variable. - - - `:filter-boolean-params' - if specified, a generated - `guix-ENTRY-TYPE-filter-boolean' function for filtering these - names will be added to `guix-ENTRY-TYPE-filters' variable. - -The rest keyword arguments are passed to -`guix-define-entry-type' macro." - (declare (indent 1)) - (let* ((entry-type-str (symbol-name entry-type)) - (prefix (concat "guix-" entry-type-str)) - (search-types-var (intern (concat prefix "-search-types"))) - (filters-var (intern (concat prefix "-filters"))) - (get-fun (intern (concat prefix "-get-entries")))) - (guix-keyword-args-let args - ((search-types-val :search-types) - (filters-val :filters) - (filter-names-val :filter-names) - (filter-bool-val :filter-boolean-params)) - `(progn - (defvar ,search-types-var ,search-types-val - ,(format "\ -Alist of search types and according URL functions. -Functions are used to define URL to receive '%s' entries." - entry-type-str)) - - (defvar ,filters-var ,filters-val - ,(format "\ -List of filters for '%s' parameters. -Each filter is a function that should take an entry as a single -argument, and should also return an entry." - entry-type-str)) - - ,(when filter-bool-val - (let ((filter-bool-var (intern (concat prefix - "-filter-boolean-params"))) - (filter-bool-fun (intern (concat prefix - "-filter-boolean")))) - `(progn - (defvar ,filter-bool-var ,filter-bool-val - ,(format "\ -List of '%s' parameters that should be transformed to boolean values." - entry-type-str)) - - (defun ,filter-bool-fun (entry) - ,(format "\ -Run `guix-hydra-filter-boolean' with `%S' variable." - filter-bool-var) - (guix-hydra-filter-boolean entry ,filter-bool-var)) - - (setq ,filters-var - (cons ',filter-bool-fun ,filters-var))))) - - ;; Do not move this clause up!: name filtering should be - ;; performed before any other filtering, so this filter should - ;; be consed after the boolean filter. - ,(when filter-names-val - (let* ((filter-names-var (intern (concat prefix - "-filter-names"))) - (filter-names-fun filter-names-var)) - `(progn - (defvar ,filter-names-var ,filter-names-val - ,(format "\ -Alist of '%s' parameter names returned by Hydra API and names -used internally by the elisp code of this package." - entry-type-str)) - - (defun ,filter-names-fun (entry) - ,(format "\ -Run `guix-hydra-filter-names' with `%S' variable." - filter-names-var) - (guix-hydra-filter-names entry ,filter-names-var)) - - (setq ,filters-var - (cons ',filter-names-fun ,filters-var))))) - - (defun ,get-fun (search-type &rest args) - ,(format "\ -Receive '%s' entries. -See `guix-hydra-get-entries' for details." - entry-type-str) - (apply #'guix-hydra-get-entries - ',entry-type search-type args)) - - (guix-alist-put! - '((search-types . ,search-types-var) - (filters . ,filters-var)) - 'guix-hydra-entry-type-data ',entry-type) - - (guix-define-entry-type ,entry-type - :parent-group guix-hydra - :parent-faces-group guix-hydra-faces - ,@%foreign-args))))) - -(defmacro guix-hydra-define-interface (buffer-type entry-type &rest args) - "Define BUFFER-TYPE interface for displaying ENTRY-TYPE entries. - -This macro should be called after calling -`guix-hydra-define-entry-type' with the same ENTRY-TYPE. - -ARGS are passed to `guix-BUFFER-TYPE-define-interface' macro." - (declare (indent 2)) - (let* ((entry-type-str (symbol-name entry-type)) - (buffer-type-str (symbol-name buffer-type)) - (get-fun (intern (concat "guix-" entry-type-str - "-get-entries"))) - (definer (intern (concat "guix-" buffer-type-str - "-define-interface")))) - `(,definer ,entry-type - :get-entries-function ',get-fun - :message-function 'guix-hydra-message - ,@args))) - -(defmacro guix-hydra-info-define-interface (entry-type &rest args) - "Define 'info' interface for displaying ENTRY-TYPE entries. -See `guix-hydra-define-interface'." - (declare (indent 1)) - `(guix-hydra-define-interface info ,entry-type - ,@args)) - -(defmacro guix-hydra-list-define-interface (entry-type &rest args) - "Define 'list' interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Optional keywords: - - - `:describe-function' - default value of the generated - `guix-ENTRY-TYPE-list-describe-function' variable (if not - specified, use `guix-hydra-list-describe'). - -The rest keyword arguments are passed to -`guix-hydra-define-interface' macro." - (declare (indent 1)) - (guix-keyword-args-let args - ((describe-val :describe-function)) - `(guix-hydra-define-interface list ,entry-type - :describe-function ,(or describe-val ''guix-hydra-list-describe) - ,@args))) - - -(defvar guix-hydra-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group (or "guix-hydra-define-entry-type" - "guix-hydra-define-interface" - "guix-hydra-info-define-interface" - "guix-hydra-list-define-interface")) - symbol-end) - . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-hydra-font-lock-keywords) - -(provide 'guix-hydra) - -;;; guix-hydra.el ends here diff --git a/emacs/guix-info.el b/emacs/guix-info.el deleted file mode 100644 index 6aefd2f3f6..0000000000 --- a/emacs/guix-info.el +++ /dev/null @@ -1,482 +0,0 @@ -;;; guix-info.el --- 'Info' buffer interface for displaying data -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015 Alex Kost -;; Copyright © 2015 Ludovic Courtès - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides 'info' (help-like) buffer interface for displaying -;; an arbitrary data. - -;;; Code: - -(require 'guix-buffer) -(require 'guix-entry) -(require 'guix-utils) - -(guix-define-buffer-type info) - -(defface guix-info-heading - '((((type tty pc) (class color)) :weight bold) - (t :height 1.6 :weight bold :inherit variable-pitch)) - "Face for headings." - :group 'guix-info-faces) - -(defface guix-info-param-title - '((t :inherit font-lock-type-face)) - "Face used for titles of parameters." - :group 'guix-info-faces) - -(defface guix-info-file-name - '((t :inherit link)) - "Face used for file names." - :group 'guix-info-faces) - -(defface guix-info-url - '((t :inherit link)) - "Face used for URLs." - :group 'guix-info-faces) - -(defface guix-info-time - '((t :inherit font-lock-constant-face)) - "Face used for timestamps." - :group 'guix-info-faces) - -(defface guix-info-action-button - '((((type x w32 ns) (class color)) - :box (:line-width 2 :style released-button) - :background "lightgrey" :foreground "black") - (t :inherit button)) - "Face used for action buttons." - :group 'guix-info-faces) - -(defface guix-info-action-button-mouse - '((((type x w32 ns) (class color)) - :box (:line-width 2 :style released-button) - :background "grey90" :foreground "black") - (t :inherit highlight)) - "Mouse face used for action buttons." - :group 'guix-info-faces) - -(defcustom guix-info-ignore-empty-values nil - "If non-nil, do not display parameters with nil values." - :type 'boolean - :group 'guix-info) - -(defcustom guix-info-fill t - "If non-nil, fill string parameters to fit the window. -If nil, insert text parameters (like synopsis or description) in -a raw form." - :type 'boolean - :group 'guix-info) - -(defvar guix-info-param-title-format "%-18s: " - "String used to format a title of a parameter. -It should be a '%s'-sequence. After inserting a title formatted -with this string, a value of the parameter is inserted. -This string is used by `guix-info-insert-title-format'.") - -(defvar guix-info-multiline-prefix - (make-string (length (format guix-info-param-title-format " ")) - ?\s) - "String used to format multi-line parameter values. -If a value occupies more than one line, this string is inserted -in the beginning of each line after the first one. -This string is used by `guix-info-insert-value-format'.") - -(defvar guix-info-indent 2 - "Number of spaces used to indent various parts of inserted text.") - -(defvar guix-info-delimiter "\n\f\n" - "String used to separate entries.") - - -;;; Wrappers for 'info' variables - -(defvar guix-info-data nil - "Alist with 'info' data. -This alist is filled by `guix-info-define-interface' macro.") - -(defun guix-info-value (entry-type symbol) - "Return SYMBOL's value for ENTRY-TYPE from `guix-info-data'." - (symbol-value (guix-assq-value guix-info-data entry-type symbol))) - -(defun guix-info-param-title (entry-type param) - "Return a title of an ENTRY-TYPE parameter PARAM." - (guix-buffer-param-title 'info entry-type param)) - -(defun guix-info-format (entry-type) - "Return 'info' format for ENTRY-TYPE." - (guix-info-value entry-type 'format)) - -(defun guix-info-displayed-params (entry-type) - "Return a list of ENTRY-TYPE parameters that should be displayed." - (delq nil - (mapcar (lambda (spec) - (pcase spec - (`(,param . ,_) param))) - (guix-info-format entry-type)))) - - -;;; Inserting entries - -(defvar guix-info-title-aliases - '((format . guix-info-insert-title-format) - (simple . guix-info-insert-title-simple)) - "Alist of aliases and functions to insert titles.") - -(defvar guix-info-value-aliases - '((format . guix-info-insert-value-format) - (indent . guix-info-insert-value-indent) - (simple . guix-info-insert-value-simple) - (time . guix-info-insert-time)) - "Alist of aliases and functions to insert values.") - -(defun guix-info-title-function (fun-or-alias) - "Convert FUN-OR-ALIAS into a function to insert a title." - (or (guix-assq-value guix-info-title-aliases fun-or-alias) - fun-or-alias)) - -(defun guix-info-value-function (fun-or-alias) - "Convert FUN-OR-ALIAS into a function to insert a value." - (or (guix-assq-value guix-info-value-aliases fun-or-alias) - fun-or-alias)) - -(defun guix-info-title-method->function (method) - "Convert title METHOD into a function to insert a title." - (pcase method - ((pred null) #'ignore) - ((pred symbolp) (guix-info-title-function method)) - (`(,fun-or-alias . ,rest-args) - (lambda (title) - (apply (guix-info-title-function fun-or-alias) - title rest-args))) - (_ (error "Unknown title method '%S'" method)))) - -(defun guix-info-value-method->function (method) - "Convert value METHOD into a function to insert a value." - (pcase method - ((pred null) #'ignore) - ((pred functionp) method) - (`(,fun-or-alias . ,rest-args) - (lambda (value _) - (apply (guix-info-value-function fun-or-alias) - value rest-args))) - (_ (error "Unknown value method '%S'" method)))) - -(defun guix-info-fill-column () - "Return fill column for the current window." - (min (window-width) fill-column)) - -(defun guix-info-get-indent (&optional level) - "Return `guix-info-indent' \"multiplied\" by LEVEL spaces. -LEVEL is 1 by default." - (make-string (* guix-info-indent (or level 1)) ?\s)) - -(defun guix-info-insert-indent (&optional level) - "Insert `guix-info-indent' spaces LEVEL times (1 by default)." - (insert (guix-info-get-indent level))) - -(defun guix-info-insert-entries (entries entry-type) - "Display ENTRY-TYPE ENTRIES in the current info buffer." - (guix-mapinsert (lambda (entry) - (guix-info-insert-entry entry entry-type)) - entries - guix-info-delimiter)) - -(defun guix-info-insert-entry (entry entry-type &optional indent-level) - "Insert ENTRY of ENTRY-TYPE into the current info buffer. -If INDENT-LEVEL is non-nil, indent displayed data by this number -of `guix-info-indent' spaces." - (guix-with-indent (* (or indent-level 0) - guix-info-indent) - (dolist (spec (guix-info-format entry-type)) - (guix-info-insert-entry-unit spec entry entry-type)))) - -(defun guix-info-insert-entry-unit (format-spec entry entry-type) - "Insert title and value of a PARAM at point. -ENTRY is alist with parameters and their values. -ENTRY-TYPE is a type of ENTRY." - (pcase format-spec - ((pred functionp) - (funcall format-spec entry) - (insert "\n")) - (`(,param ,title-method ,value-method) - (let ((value (guix-entry-value entry param))) - (unless (and guix-info-ignore-empty-values (null value)) - (let ((title (guix-info-param-title entry-type param)) - (insert-title (guix-info-title-method->function title-method)) - (insert-value (guix-info-value-method->function value-method))) - (funcall insert-title title) - (funcall insert-value value entry) - (insert "\n"))))) - (_ (error "Unknown format specification '%S'" format-spec)))) - -(defun guix-info-insert-title-simple (title &optional face) - "Insert \"TITLE: \" string at point. -If FACE is nil, use `guix-info-param-title'." - (guix-format-insert title - (or face 'guix-info-param-title) - "%s: ")) - -(defun guix-info-insert-title-format (title &optional face) - "Insert TITLE using `guix-info-param-title-format' at point. -If FACE is nil, use `guix-info-param-title'." - (guix-format-insert title - (or face 'guix-info-param-title) - guix-info-param-title-format)) - -(defun guix-info-insert-value-simple (value &optional button-or-face indent) - "Format and insert parameter VALUE at point. - -VALUE may be split into several short lines to fit the current -window, depending on `guix-info-fill', and each line is indented -with INDENT number of spaces. - -If BUTTON-OR-FACE is a button type symbol, transform VALUE into -this (these) button(s) and insert each one on a new line. If it -is a face symbol, propertize inserted line(s) with this face." - (or indent (setq indent 0)) - (guix-with-indent indent - (let* ((button? (guix-button-type? button-or-face)) - (face (unless button? button-or-face)) - (fill-col (unless (or button? - (and (stringp value) - (not guix-info-fill))) - (- (guix-info-fill-column) indent))) - (value (if (and value button?) - (guix-buttonize value button-or-face "\n") - value))) - (guix-split-insert value face fill-col "\n")))) - -(defun guix-info-insert-value-indent (value &optional button-or-face) - "Format and insert parameter VALUE at point. - -This function is intended to be called after inserting a title -with `guix-info-insert-title-simple'. - -VALUE may be split into several short lines to fit the current -window, depending on `guix-info-fill', and each line is indented -with `guix-info-indent'. - -For the meaning of BUTTON-OR-FACE, see `guix-info-insert-value-simple'." - (when value (insert "\n")) - (guix-info-insert-value-simple value button-or-face guix-info-indent)) - -(defun guix-info-insert-value-format (value &optional button-or-face - &rest button-properties) - "Format and insert parameter VALUE at point. - -This function is intended to be called after inserting a title -with `guix-info-insert-title-format'. - -VALUE may be split into several short lines to fit the current -window, depending on `guix-info-fill' and -`guix-info-multiline-prefix'. If VALUE is a list, its elements -will be separated with `guix-list-separator'. - -If BUTTON-OR-FACE is a button type symbol, transform VALUE into -this (these) button(s). If it is a face symbol, propertize -inserted line(s) with this face. - -BUTTON-PROPERTIES are passed to `guix-buttonize' (only if -BUTTON-OR-FACE is a button type)." - (let* ((button? (guix-button-type? button-or-face)) - (face (unless button? button-or-face)) - (fill-col (when (or button? - guix-info-fill - (not (stringp value))) - (- (guix-info-fill-column) - (length guix-info-multiline-prefix)))) - (value (if (and value button?) - (apply #'guix-buttonize - value button-or-face guix-list-separator - button-properties) - value))) - (guix-split-insert value face fill-col - (concat "\n" guix-info-multiline-prefix)))) - -(defun guix-info-insert-time (seconds &optional face) - "Insert formatted time string using SECONDS at point." - (guix-format-insert (guix-get-time-string seconds) - (or face 'guix-info-time))) - - -;;; Buttons - -(defvar guix-info-button-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map button-map) - (define-key map (kbd "c") 'guix-info-button-copy-label) - map) - "Keymap for buttons in info buffers.") - -(define-button-type 'guix - 'keymap guix-info-button-map - 'follow-link t) - -(define-button-type 'guix-action - :supertype 'guix - 'face 'guix-info-action-button - 'mouse-face 'guix-info-action-button-mouse) - -(define-button-type 'guix-file - :supertype 'guix - 'face 'guix-info-file-name - 'help-echo "Find file" - 'action (lambda (btn) - (guix-find-file (button-label btn)))) - -(define-button-type 'guix-url - :supertype 'guix - 'face 'guix-info-url - 'help-echo "Browse URL" - 'action (lambda (btn) - (browse-url (button-label btn)))) - -(defun guix-info-button-copy-label (&optional pos) - "Copy a label of the button at POS into kill ring. -If POS is nil, use the current point position." - (interactive) - (let ((button (button-at (or pos (point))))) - (when button - (guix-copy-as-kill (button-label button))))) - -(defun guix-info-insert-action-button (label action &optional message - &rest properties) - "Make action button with LABEL and insert it at point. -ACTION is a function called when the button is pressed. It -should accept button as the argument. -MESSAGE is a button message. -See `insert-text-button' for the meaning of PROPERTIES." - (apply #'guix-insert-button - label 'guix-action - 'action action - 'help-echo message - properties)) - - -;;; Major mode and interface definer - -(defvar guix-info-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent - map (make-composed-keymap (list guix-buffer-map button-buffer-map) - special-mode-map)) - map) - "Keymap for `guix-info-mode' buffers.") - -(define-derived-mode guix-info-mode special-mode "Guix-Info" - "Parent mode for displaying data in 'info' form." - (setq-local revert-buffer-function 'guix-buffer-revert)) - -(defun guix-info-mode-initialize () - "Set up the current 'info' buffer." - ;; Without this, syntactic fontification is performed, and it may - ;; break our highlighting. For example, description of "emacs-typo" - ;; package contains a single " (double-quote) character, so the - ;; default syntactic fontification highlights the rest text after it - ;; as a string. See (info "(elisp) Font Lock Basics") for details. - (setq font-lock-defaults '(nil t))) - -(defmacro guix-info-define-interface (entry-type &rest args) - "Define 'info' interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Required keywords: - - - `:format' - default value of the generated - `guix-ENTRY-TYPE-info-format' variable. - -The rest keyword arguments are passed to -`guix-buffer-define-interface' macro." - (declare (indent 1)) - (let* ((entry-type-str (symbol-name entry-type)) - (prefix (concat "guix-" entry-type-str "-info")) - (group (intern prefix)) - (format-var (intern (concat prefix "-format")))) - (guix-keyword-args-let args - ((show-entries-val :show-entries-function) - (format-val :format)) - `(progn - (defcustom ,format-var ,format-val - ,(format "\ -List of methods for inserting '%s' entry. -Each METHOD should be either a function or should have the -following form: - - (PARAM INSERT-TITLE INSERT-VALUE) - -If METHOD is a function, it is called with an entry as argument. - -PARAM is a name of '%s' entry parameter. - -INSERT-TITLE may be either a symbol or a list. If it is a -symbol, it should be a function or an alias from -`guix-info-title-aliases', in which case it is called with title -as argument. If it is a list, it should have a -form (FUN-OR-ALIAS [ARGS ...]), in which case FUN-OR-ALIAS is -called with title and ARGS as arguments. - -INSERT-VALUE may be either a symbol or a list. If it is a -symbol, it should be a function or an alias from -`guix-info-value-aliases', in which case it is called with value -and entry as arguments. If it is a list, it should have a -form (FUN-OR-ALIAS [ARGS ...]), in which case FUN-OR-ALIAS is -called with value and ARGS as arguments. - -Parameters are inserted in the same order as defined by this list. -After calling each METHOD, a new line is inserted." - entry-type-str entry-type-str) - :type 'sexp - :group ',group) - - (guix-alist-put! - '((format . ,format-var)) - 'guix-info-data ',entry-type) - - ,(if show-entries-val - `(guix-buffer-define-interface info ,entry-type - :show-entries-function ,show-entries-val - ,@%foreign-args) - - (let ((insert-fun (intern (concat prefix "-insert-entries")))) - `(progn - (defun ,insert-fun (entries) - ,(format "\ -Print '%s' ENTRIES in the current 'info' buffer." - entry-type-str) - (guix-info-insert-entries entries ',entry-type)) - - (guix-buffer-define-interface info ,entry-type - :insert-entries-function ',insert-fun - :mode-init-function 'guix-info-mode-initialize - ,@%foreign-args)))))))) - - -(defvar guix-info-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group "guix-info-define-interface") - symbol-end) - . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-info-font-lock-keywords) - -(provide 'guix-info) - -;;; guix-info.el ends here diff --git a/emacs/guix-init.el b/emacs/guix-init.el deleted file mode 100644 index bd75e54e03..0000000000 --- a/emacs/guix-init.el +++ /dev/null @@ -1,3 +0,0 @@ -(require 'guix-autoloads) -(message "(require 'guix-init) is obsolete, use (require 'guix-autoloads) instead.") -(provide 'guix-init) diff --git a/emacs/guix-license.el b/emacs/guix-license.el deleted file mode 100644 index 6003a21aac..0000000000 --- a/emacs/guix-license.el +++ /dev/null @@ -1,65 +0,0 @@ -;;; guix-license.el --- Licenses - -;; Copyright © 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides the code to work with licenses of Guix packages. - -;;; Code: - -(require 'guix-read) -(require 'guix-backend) -(require 'guix-guile) - -(defun guix-license-file (&optional directory) - "Return name of the file with license definitions. -DIRECTORY is a directory with Guix source (`guix-directory' by default)." - (expand-file-name "guix/licenses.scm" - (or directory guix-directory))) - -(defun guix-lookup-license-url (license) - "Return URL of a LICENSE." - (or (guix-eval-read (guix-make-guile-expression - 'lookup-license-uri license)) - (error "Hm, I don't know URL of '%s' license" license))) - -;;;###autoload -(defun guix-find-license-definition (license &optional directory) - "Open licenses file from DIRECTORY and move to the LICENSE definition. -See `guix-license-file' for the meaning of DIRECTORY. -Interactively, with prefix argument, prompt for DIRECTORY." - (interactive - (list (guix-read-license-name) - (guix-read-directory))) - (find-file (guix-license-file directory)) - (goto-char (point-min)) - (when (re-search-forward (concat "\"" (regexp-quote license) "\"") - nil t) - (beginning-of-defun) - (recenter 1))) - -;;;###autoload -(defun guix-browse-license-url (license) - "Browse URL of a LICENSE." - (interactive (list (guix-read-license-name))) - (browse-url (guix-lookup-license-url license))) - -(provide 'guix-license) - -;;; guix-license.el ends here diff --git a/emacs/guix-list.el b/emacs/guix-list.el deleted file mode 100644 index c91c67cb29..0000000000 --- a/emacs/guix-list.el +++ /dev/null @@ -1,585 +0,0 @@ -;;; guix-list.el --- 'List' buffer interface for displaying data -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides 'list' buffer interface for displaying an arbitrary -;; data. - -;;; Code: - -(require 'cl-lib) -(require 'tabulated-list) -(require 'guix-buffer) -(require 'guix-info) -(require 'guix-entry) -(require 'guix-utils) - -(guix-define-buffer-type list) - -(defface guix-list-file-name - '((t :inherit guix-info-file-name)) - "Face used for file names." - :group 'guix-list-faces) - -(defface guix-list-url - '((t :inherit guix-info-url)) - "Face used for URLs." - :group 'guix-list-faces) - -(defface guix-list-time - '((t :inherit guix-info-time)) - "Face used for time stamps." - :group 'guix-list-faces) - -(defun guix-list-describe (&optional mark-names) - "Describe entries marked with a general mark. -'Describe' means display entries in 'info' buffer. -If no entries are marked, describe the current entry. -With prefix argument, describe entries marked with any mark." - (interactive (list (unless current-prefix-arg '(general)))) - (let* ((ids (or (apply #'guix-list-get-marked-id-list mark-names) - (list (guix-list-current-id)))) - (count (length ids)) - (entry-type (guix-buffer-current-entry-type))) - (when (or (<= count (guix-list-describe-warning-count entry-type)) - (y-or-n-p (format "Do you really want to describe %d entries? " - count))) - (guix-list-describe-entries entry-type ids)))) - - -;;; Wrappers for 'list' variables - -(defvar guix-list-data nil - "Alist with 'list' data. -This alist is filled by `guix-list-define-interface' macro.") - -(defun guix-list-value (entry-type symbol) - "Return SYMBOL's value for ENTRY-TYPE from `guix-list-data'." - (symbol-value (guix-assq-value guix-list-data entry-type symbol))) - -(defun guix-list-param-title (entry-type param) - "Return column title of an ENTRY-TYPE parameter PARAM." - (guix-buffer-param-title 'list entry-type param)) - -(defun guix-list-format (entry-type) - "Return column format for ENTRY-TYPE." - (guix-list-value entry-type 'format)) - -(defun guix-list-displayed-params (entry-type) - "Return a list of ENTRY-TYPE parameters that should be displayed." - (mapcar #'car (guix-list-format entry-type))) - -(defun guix-list-sort-key (entry-type) - "Return sort key for ENTRY-TYPE." - (guix-list-value entry-type 'sort-key)) - -(defun guix-list-additional-marks (entry-type) - "Return alist of additional marks for ENTRY-TYPE." - (guix-list-value entry-type 'marks)) - -(defun guix-list-single-entry? (entry-type) - "Return non-nil, if a single entry of ENTRY-TYPE should be listed." - (guix-list-value entry-type 'list-single)) - -(defun guix-list-describe-warning-count (entry-type) - "Return the maximum number of ENTRY-TYPE entries to describe." - (guix-list-value entry-type 'describe-count)) - -(defun guix-list-describe-entries (entry-type ids) - "Describe ENTRY-TYPE entries with IDS in 'info' buffer" - (funcall (guix-list-value entry-type 'describe) - ids)) - - -;;; Tabulated list internals - -(defun guix-list-sort-numerically (column a b) - "Compare COLUMN of tabulated entries A and B numerically. -This function is used for sort predicates for `tabulated-list-format'. -Return non-nil, if B is bigger than A." - (cl-flet ((num (entry) - (string-to-number (aref (cadr entry) column)))) - (> (num b) (num a)))) - -(defmacro guix-list-define-numerical-sorter (column) - "Define numerical sort predicate for COLUMN. -See `guix-list-sort-numerically' for details." - (let ((name (intern (format "guix-list-sort-numerically-%d" column))) - (doc (format "\ -Predicate to sort tabulated list by column %d numerically. -See `guix-list-sort-numerically' for details." - column))) - `(defun ,name (a b) - ,doc - (guix-list-sort-numerically ,column a b)))) - -(defmacro guix-list-define-numerical-sorters (n) - "Define numerical sort predicates for columns from 0 to N. -See `guix-list-define-numerical-sorter' for details." - `(progn - ,@(mapcar (lambda (i) - `(guix-list-define-numerical-sorter ,i)) - (number-sequence 0 n)))) - -(guix-list-define-numerical-sorters 9) - -(defun guix-list-tabulated-sort-key (entry-type) - "Return ENTRY-TYPE sort key for `tabulated-list-sort-key'." - (let ((sort-key (guix-list-sort-key entry-type))) - (and sort-key - (cons (guix-list-param-title entry-type (car sort-key)) - (cdr sort-key))))) - -(defun guix-list-tabulated-vector (entry-type fun) - "Call FUN on each column specification for ENTRY-TYPE. - -FUN is applied to column specification as arguments (see -`guix-list-format'). - -Return a vector made of values of FUN calls." - (apply #'vector - (mapcar (lambda (col-spec) - (apply fun col-spec)) - (guix-list-format entry-type)))) - -(defun guix-list-tabulated-format (entry-type) - "Return ENTRY-TYPE list specification for `tabulated-list-format'." - (guix-list-tabulated-vector - entry-type - (lambda (param _ &rest rest-spec) - (cons (guix-list-param-title entry-type param) - rest-spec)))) - -(defun guix-list-tabulated-entries (entries entry-type) - "Return a list of ENTRY-TYPE values for `tabulated-list-entries'." - (mapcar (lambda (entry) - (list (guix-entry-id entry) - (guix-list-tabulated-entry entry entry-type))) - entries)) - -(defun guix-list-tabulated-entry (entry entry-type) - "Return array of values for `tabulated-list-entries'. -Parameters are taken from ENTRY-TYPE ENTRY." - (guix-list-tabulated-vector - entry-type - (lambda (param fun &rest _) - (let ((val (guix-entry-value entry param))) - (if fun - (funcall fun val entry) - (guix-get-string val)))))) - - -;;; Displaying entries - -(defun guix-list-get-display-entries (entry-type &rest args) - "Search for entries and show them in a 'list' buffer preferably." - (let ((entries (guix-buffer-get-entries 'list entry-type args))) - (if (or (null entries) ; = 0 - (cdr entries) ; > 1 - (guix-list-single-entry? entry-type) - (null (guix-buffer-value 'info entry-type 'show-entries))) - (guix-buffer-display-entries entries 'list entry-type args 'add) - (if (equal (guix-buffer-value 'info entry-type 'get-entries) - (guix-buffer-value 'list entry-type 'get-entries)) - (guix-buffer-display-entries entries 'info entry-type args 'add) - (guix-buffer-get-display-entries 'info entry-type args 'add))))) - -(defun guix-list-insert-entries (entries entry-type) - "Print ENTRY-TYPE ENTRIES in the current buffer." - (setq tabulated-list-entries - (guix-list-tabulated-entries entries entry-type)) - (tabulated-list-print)) - -(defun guix-list-get-one-line (val &optional _) - "Return one-line string from a multi-line string VAL. -VAL may be nil." - (if val - (guix-get-one-line val) - (guix-get-string nil))) - -(defun guix-list-get-time (seconds &optional _) - "Return formatted time string from SECONDS." - (guix-get-string (guix-get-time-string seconds) - 'guix-list-time)) - -(defun guix-list-get-file-name (file-name &optional _) - "Return FILE-NAME button specification for `tabulated-list-entries'." - (list file-name - 'face 'guix-list-file-name - 'action (lambda (btn) (find-file (button-label btn))) - 'follow-link t - 'help-echo "Find file")) - -(defun guix-list-get-url (url &optional _) - "Return URL button specification for `tabulated-list-entries'." - (list url - 'face 'guix-list-url - 'action (lambda (btn) (browse-url (button-label btn))) - 'follow-link t - 'help-echo "Browse URL")) - - -;;; 'List' lines - -(defun guix-list-current-id () - "Return ID of the entry at point." - (or (tabulated-list-get-id) - (user-error "No entry here"))) - -(defun guix-list-current-entry () - "Return entry at point." - (guix-entry-by-id (guix-list-current-id) - (guix-buffer-current-entries))) - -(defun guix-list-for-each-line (fun &rest args) - "Call FUN with ARGS for each entry line." - (or (derived-mode-p 'guix-list-mode) - (error "The current buffer is not in Guix List mode")) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (apply fun args) - (forward-line)))) - -(defun guix-list-fold-lines (fun init) - "Fold over entry lines in the current list buffer. -Call FUN with RESULT as argument for each line, using INIT as -the initial value of RESULT. Return the final result." - (let ((res init)) - (guix-list-for-each-line - (lambda () (setq res (funcall fun res)))) - res)) - - -;;; Marking and sorting - -(defvar-local guix-list-marked nil - "List of the marked entries. -Each element of the list has a form: - - (ID MARK-NAME . ARGS) - -ID is an entry ID. -MARK-NAME is a symbol from `guix-list-marks'. -ARGS is a list of additional values.") - -(defvar-local guix-list-marks nil - "Alist of available mark names and mark characters.") - -(defvar guix-list-default-marks - '((empty . ?\s) - (general . ?*)) - "Alist of default mark names and mark characters.") - -(defun guix-list-marks (entry-type) - "Return alist of available marks for ENTRY-TYPE." - (append guix-list-default-marks - (guix-list-additional-marks entry-type))) - -(defun guix-list-get-mark (name) - "Return mark character by its NAME." - (or (guix-assq-value guix-list-marks name) - (error "Mark '%S' not found" name))) - -(defun guix-list-get-mark-string (name) - "Return mark string by its NAME." - (string (guix-list-get-mark name))) - -(defun guix-list-current-mark () - "Return mark character of the current line." - (char-after (line-beginning-position))) - -(defun guix-list-get-marked (&rest mark-names) - "Return list of specs of entries marked with any mark from MARK-NAMES. -Entry specs are elements from `guix-list-marked' list. -If MARK-NAMES are not specified, use all marks from -`guix-list-marks' except the `empty' one." - (or mark-names - (setq mark-names - (delq 'empty - (mapcar #'car guix-list-marks)))) - (cl-remove-if-not (lambda (assoc) - (memq (cadr assoc) mark-names)) - guix-list-marked)) - -(defun guix-list-get-marked-args (mark-name) - "Return list of (ID . ARGS) elements from lines marked with MARK-NAME. -See `guix-list-marked' for the meaning of ARGS." - (mapcar (lambda (spec) - (let ((id (car spec)) - (args (cddr spec))) - (cons id args))) - (guix-list-get-marked mark-name))) - -(defun guix-list-get-marked-id-list (&rest mark-names) - "Return list of IDs of entries marked with any mark from MARK-NAMES. -See `guix-list-get-marked' for details." - (mapcar #'car (apply #'guix-list-get-marked mark-names))) - -(defun guix-list--mark (mark-name &optional advance &rest args) - "Put a mark on the current line. -Also add the current entry to `guix-list-marked' using its ID and ARGS. -MARK-NAME is a symbol from `guix-list-marks'. -If ADVANCE is non-nil, move forward by one line after marking." - (let ((id (guix-list-current-id))) - (if (eq mark-name 'empty) - (setq guix-list-marked (assq-delete-all id guix-list-marked)) - (let ((assoc (assq id guix-list-marked)) - (val (cons mark-name args))) - (if assoc - (setcdr assoc val) - (push (cons id val) guix-list-marked))))) - (tabulated-list-put-tag (guix-list-get-mark-string mark-name) - advance)) - -(defun guix-list-mark (&optional arg) - "Mark the current line and move to the next line. -With ARG, mark all lines." - (interactive "P") - (if arg - (guix-list-mark-all) - (guix-list--mark 'general t))) - -(defun guix-list-mark-all (&optional mark-name) - "Mark all lines with MARK-NAME mark. -MARK-NAME is a symbol from `guix-list-marks'. -Interactively, put a general mark on all lines." - (interactive) - (or mark-name (setq mark-name 'general)) - (guix-list-for-each-line #'guix-list--mark mark-name)) - -(defun guix-list-unmark (&optional arg) - "Unmark the current line and move to the next line. -With ARG, unmark all lines." - (interactive "P") - (if arg - (guix-list-unmark-all) - (guix-list--mark 'empty t))) - -(defun guix-list-unmark-backward () - "Move up one line and unmark it." - (interactive) - (forward-line -1) - (guix-list--mark 'empty)) - -(defun guix-list-unmark-all () - "Unmark all lines." - (interactive) - (guix-list-mark-all 'empty)) - -(defun guix-list-restore-marks () - "Put marks according to `guix-list-marked'." - (guix-list-for-each-line - (lambda () - (let ((mark-name (car (guix-assq-value guix-list-marked - (guix-list-current-id))))) - (tabulated-list-put-tag - (guix-list-get-mark-string (or mark-name 'empty))))))) - -(defun guix-list-sort (&optional n) - "Sort guix list entries by the column at point. -With a numeric prefix argument N, sort the Nth column. -Same as `tabulated-list-sort', but also restore marks after sorting." - (interactive "P") - (tabulated-list-sort n) - (guix-list-restore-marks)) - - -;;; Major mode and interface definer - -(defvar guix-list-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent - map (make-composed-keymap guix-buffer-map - tabulated-list-mode-map)) - (define-key map (kbd "RET") 'guix-list-describe) - (define-key map (kbd "i") 'guix-list-describe) - (define-key map (kbd "m") 'guix-list-mark) - (define-key map (kbd "*") 'guix-list-mark) - (define-key map (kbd "u") 'guix-list-unmark) - (define-key map (kbd "DEL") 'guix-list-unmark-backward) - (define-key map [remap tabulated-list-sort] 'guix-list-sort) - map) - "Keymap for `guix-list-mode' buffers.") - -(define-derived-mode guix-list-mode tabulated-list-mode "Guix-List" - "Parent mode for displaying data in 'list' form.") - -(defun guix-list-mode-initialize (entry-type) - "Set up the current 'list' buffer for displaying ENTRY-TYPE entries." - (setq tabulated-list-padding 2 - tabulated-list-format (guix-list-tabulated-format entry-type) - tabulated-list-sort-key (guix-list-tabulated-sort-key entry-type)) - (setq-local guix-list-marks (guix-list-marks entry-type)) - (tabulated-list-init-header)) - -(defmacro guix-list-define-interface (entry-type &rest args) - "Define 'list' interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Required keywords: - - - `:format' - default value of the generated - `guix-ENTRY-TYPE-list-format' variable. - -Optional keywords: - - - `:sort-key' - default value of the generated - `guix-ENTRY-TYPE-list-sort-key' variable. - - - `:describe-function' - default value of the generated - `guix-ENTRY-TYPE-describe-function' variable. - - - `:list-single?' - default value of the generated - `guix-ENTRY-TYPE-list-single' variable. - - - `:marks' - default value of the generated - `guix-ENTRY-TYPE-list-marks' variable. - -The rest keyword arguments are passed to -`guix-buffer-define-interface' macro." - (declare (indent 1)) - (let* ((entry-type-str (symbol-name entry-type)) - (prefix (concat "guix-" entry-type-str "-list")) - (group (intern prefix)) - (describe-var (intern (concat prefix "-describe-function"))) - (describe-count-var (intern (concat prefix - "-describe-warning-count"))) - (format-var (intern (concat prefix "-format"))) - (sort-key-var (intern (concat prefix "-sort-key"))) - (list-single-var (intern (concat prefix "-single"))) - (marks-var (intern (concat prefix "-marks")))) - (guix-keyword-args-let args - ((show-entries-val :show-entries-function) - (describe-val :describe-function) - (describe-count-val :describe-count 10) - (format-val :format) - (sort-key-val :sort-key) - (list-single-val :list-single?) - (marks-val :marks)) - `(progn - (defcustom ,format-var ,format-val - ,(format "\ -List of format values of the displayed columns. -Each element of the list has a form: - - (PARAM VALUE-FUN WIDTH SORT . PROPS) - -PARAM is a name of '%s' entry parameter. - -VALUE-FUN may be either nil or a function returning a value that -will be inserted. The function is called with 2 arguments: the -first one is the value of the parameter; the second one is an -entry (alist of parameter names and values). - -For the meaning of WIDTH, SORT and PROPS, see -`tabulated-list-format'." - entry-type-str) - :type 'sexp - :group ',group) - - (defcustom ,sort-key-var ,sort-key-val - ,(format "\ -Default sort key for 'list' buffer with '%s' entries. -Should be nil (no sort) or have a form: - - (PARAM . FLIP) - -PARAM is the name of '%s' entry parameter. For the meaning of -FLIP, see `tabulated-list-sort-key'." - entry-type-str entry-type-str) - :type '(choice (const :tag "No sort" nil) - (cons symbol boolean)) - :group ',group) - - (defvar ,marks-var ,marks-val - ,(format "\ -Alist of additional marks for 'list' buffer with '%s' entries. -Marks from this list are used along with `guix-list-default-marks'." - entry-type-str)) - - (defcustom ,list-single-var ,list-single-val - ,(format "\ -If non-nil, list '%s' entry even if it is the only matching result. -If nil, show a single '%s' entry in the 'info' buffer." - entry-type-str entry-type-str) - :type 'boolean - :group ',group) - - (defcustom ,describe-count-var ,describe-count-val - ,(format "\ -The maximum number of '%s' entries to describe without a warning. -If a user wants to describe more than this number of marked -entries, he will be prompted for confirmation. -See also `guix-list-describe'." - entry-type-str) - :type 'integer - :group ',group) - - (defvar ,describe-var ,describe-val - ,(format "Function used to describe '%s' entries." - entry-type-str)) - - (guix-alist-put! - '((describe . ,describe-var) - (describe-count . ,describe-count-var) - (format . ,format-var) - (sort-key . ,sort-key-var) - (list-single . ,list-single-var) - (marks . ,marks-var)) - 'guix-list-data ',entry-type) - - ,(if show-entries-val - `(guix-buffer-define-interface list ,entry-type - :show-entries-function ,show-entries-val - ,@%foreign-args) - - (let ((insert-fun (intern (concat prefix "-insert-entries"))) - (mode-init-fun (intern (concat prefix "-mode-initialize")))) - `(progn - (defun ,insert-fun (entries) - ,(format "\ -Print '%s' ENTRIES in the current 'list' buffer." - entry-type-str) - (guix-list-insert-entries entries ',entry-type)) - - (defun ,mode-init-fun () - ,(format "\ -Set up the current 'list' buffer for displaying '%s' entries." - entry-type-str) - (guix-list-mode-initialize ',entry-type)) - - (guix-buffer-define-interface list ,entry-type - :insert-entries-function ',insert-fun - :mode-init-function ',mode-init-fun - ,@%foreign-args)))))))) - - -(defvar guix-list-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group "guix-list-define-interface") - symbol-end) - . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-list-font-lock-keywords) - -(provide 'guix-list) - -;;; guix-list.el ends here diff --git a/emacs/guix-location.el b/emacs/guix-location.el deleted file mode 100644 index 81396b4017..0000000000 --- a/emacs/guix-location.el +++ /dev/null @@ -1,79 +0,0 @@ -;;; guix-location.el --- Package locations - -;; Copyright © 2016 Alex Kost - -;; 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 Location as published by -;; the Free Software Foundation, either version 3 of the Location, 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 Location for more details. - -;; You should have received a copy of the GNU General Public Location -;; along with this program. If not, see . - -;;; Commentary: - -;; This file provides the code to work with locations of Guix packages. - -;;; Code: - -(require 'cl-lib) -(require 'guix-backend) -(require 'guix-read) -(require 'guix-guile) - -(defun guix-package-location (id-or-name) - "Return location of a package with ID-OR-NAME. -For the meaning of location, see `guix-find-location'." - (guix-eval-read (guix-make-guile-expression - 'package-location-string id-or-name))) - -;;;###autoload -(defun guix-find-location (location &optional directory) - "Go to LOCATION of a package. -LOCATION is a string of the form: - - \"FILE:LINE:COLUMN\" - -If FILE is relative, it is considered to be relative to -DIRECTORY (`guix-directory' by default). - -Interactively, prompt for LOCATION. With prefix argument, prompt -for DIRECTORY as well." - (interactive - (list (guix-read-package-location) - (guix-read-directory))) - (cl-multiple-value-bind (file line column) - (split-string location ":") - (find-file (expand-file-name file (or directory guix-directory))) - (when (and line column) - (let ((line (string-to-number line)) - (column (string-to-number column))) - (goto-char (point-min)) - (forward-line (- line 1)) - (move-to-column column) - (recenter 1))))) - -;;;###autoload -(defun guix-edit (id-or-name &optional directory) - "Edit (go to location of) package with ID-OR-NAME. -See `guix-find-location' for the meaning of package location and -DIRECTORY. -Interactively, with prefix argument, prompt for DIRECTORY." - (interactive - (list (guix-read-package-name) - (guix-read-directory))) - (let ((loc (guix-package-location id-or-name))) - (if loc - (guix-find-location loc directory) - (message "Couldn't find package location.")))) - -(provide 'guix-location) - -;;; guix-location.el ends here diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm deleted file mode 100644 index 040932f307..0000000000 --- a/emacs/guix-main.scm +++ /dev/null @@ -1,1163 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Alex Kost -;;; -;;; 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 . - -;;; Commentary: - -;; Information about packages and generations is passed to the elisp -;; side in the form of alists of parameters (such as ‘name’ or -;; ‘version’) and their values. - -;; ‘entries’ procedure is the “entry point” for the elisp side to get -;; information about packages and generations. - -;; Since name/version pair is not necessarily unique, we use -;; `object-address' to identify a package (for ‘id’ parameter), if -;; possible. However for the obsolete packages (that can be found in -;; installed manifest but not in a package directory), ‘id’ parameter is -;; still "name-version" string. So ‘id’ package parameter in the code -;; below is either an object-address number or a full-name string. - -;;; Code: - -(use-modules - (ice-9 vlist) - (ice-9 match) - (ice-9 popen) - (srfi srfi-1) - (srfi srfi-2) - (srfi srfi-11) - (srfi srfi-19) - (srfi srfi-26) - (guix) - (guix combinators) - (guix git-download) - (guix grafts) - (guix packages) - (guix profiles) - (guix licenses) - (guix utils) - (guix ui) - (guix scripts) - (guix scripts package) - (gnu packages) - (gnu system)) - -(define-syntax-rule (first-or-false lst) - (and (not (null? lst)) - (first lst))) - -(define (list-maybe obj) - (if (list? obj) obj (list obj))) - -(define (output+error thunk) - "Call THUNK and return 2 values: output and error output as strings." - (let ((output-port (open-output-string)) - (error-port (open-output-string))) - (with-output-to-port output-port - (lambda () (with-error-to-port error-port thunk))) - (let ((strings (list (get-output-string output-port) - (get-output-string error-port)))) - (close-output-port output-port) - (close-output-port error-port) - (apply values strings)))) - -(define (full-name->name+version spec) - "Given package specification SPEC with or without output, -return two values: name and version. For example, for SPEC -\"foo@0.9.1b:lib\", return \"foo\" and \"0.9.1b\"." - (let-values (((name version output) - (package-specification->name+version+output spec))) - (values name version))) - -(define (name+version->full-name name version) - (string-append name "@" version)) - -(define* (make-package-specification name #:optional version output) - (let ((full-name (if version - (name+version->full-name name version) - name))) - (if output - (string-append full-name ":" output) - full-name))) - -(define (manifest-entry->name+version+output entry) - (values - (manifest-entry-name entry) - (manifest-entry-version entry) - (manifest-entry-output entry))) - -(define (manifest-entry->package-specification entry) - (call-with-values - (lambda () (manifest-entry->name+version+output entry)) - make-package-specification)) - -(define (manifest-entries->package-specifications entries) - (map manifest-entry->package-specification entries)) - -(define (profile-package-specifications profile) - "Return a list of package specifications for PROFILE." - (let ((manifest (profile-manifest profile))) - (manifest-entries->package-specifications - (manifest-entries manifest)))) - -(define (profile->specifications+paths profile) - "Return a list of package specifications and paths for PROFILE. -Each element of the list is a list of the package specification and its path." - (let ((manifest (profile-manifest profile))) - (map (lambda (entry) - (list (manifest-entry->package-specification entry) - (manifest-entry-item entry))) - (manifest-entries manifest)))) - -(define (profile-difference profile1 profile2) - "Return a list of package specifications for outputs installed in PROFILE1 -and not installed in PROFILE2." - (let ((specs1 (profile-package-specifications profile1)) - (specs2 (profile-package-specifications profile2))) - (lset-difference string=? specs1 specs2))) - -(define (manifest-entries->hash-table entries) - "Return a hash table of name keys and lists of matching manifest ENTRIES." - (let ((table (make-hash-table (length entries)))) - (for-each (lambda (entry) - (let* ((key (manifest-entry-name entry)) - (ref (hash-ref table key))) - (hash-set! table key - (if ref (cons entry ref) (list entry))))) - entries) - table)) - -(define (manifest=? m1 m2) - (or (eq? m1 m2) - (equal? m1 m2))) - -(define manifest->hash-table - (let ((current-manifest #f) - (current-table #f)) - (lambda (manifest) - "Return a hash table of name keys and matching MANIFEST entries." - (unless (manifest=? manifest current-manifest) - (set! current-manifest manifest) - (set! current-table (manifest-entries->hash-table - (manifest-entries manifest)))) - current-table))) - -(define* (manifest-entries-by-name manifest name #:optional version output) - "Return a list of MANIFEST entries matching NAME, VERSION and OUTPUT." - (let ((entries (or (hash-ref (manifest->hash-table manifest) name) - '()))) - (if (or version output) - (filter (lambda (entry) - (and (or (not version) - (equal? version (manifest-entry-version entry))) - (or (not output) - (equal? output (manifest-entry-output entry))))) - entries) - entries))) - -(define (manifest-entry-by-output entries output) - "Return a manifest entry from ENTRIES matching OUTPUT." - (find (lambda (entry) - (string= output (manifest-entry-output entry))) - entries)) - -(define (fold-manifest-by-name manifest proc init) - "Fold over MANIFEST entries. -Call (PROC NAME VERSION ENTRIES RESULT), using INIT as the initial value -of RESULT. ENTRIES is a list of manifest entries with NAME/VERSION." - (hash-fold (lambda (name entries res) - (proc name (manifest-entry-version (car entries)) - entries res)) - init - (manifest->hash-table manifest))) - -(define* (object-transformer param-alist #:optional (params '())) - "Return procedure transforming objects into alist of parameter/value pairs. - -PARAM-ALIST is alist of available parameters (symbols) and procedures -returning values of these parameters. Each procedure is applied to -objects. - -PARAMS is list of parameters from PARAM-ALIST that should be returned by -a resulting procedure. If PARAMS is not specified or is an empty list, -use all available parameters. - -Example: - - (let* ((alist `((plus1 . ,1+) (minus1 . ,1-) (mul2 . ,(cut * 2 <>)))) - (number->alist (object-transformer alist '(plus1 mul2)))) - (number->alist 8)) - => - ((plus1 . 9) (mul2 . 16)) -" - (let* ((use-all-params (null? params)) - (alist (filter-map (match-lambda - ((param . proc) - (and (or use-all-params - (memq param params)) - (cons param proc))) - (_ #f)) - param-alist))) - (lambda objects - (map (match-lambda - ((param . proc) - (cons param (apply proc objects)))) - alist)))) - -(define %manifest-entry-param-alist - `((output . ,manifest-entry-output) - (path . ,manifest-entry-item) - (dependencies . ,manifest-entry-dependencies))) - -(define manifest-entry->sexp - (object-transformer %manifest-entry-param-alist)) - -(define (manifest-entries->sexps entries) - (map manifest-entry->sexp entries)) - -(define (package-inputs-names inputs) - "Return a list of full names of the packages from package INPUTS." - (filter-map (match-lambda - ((_ (? package? package)) - (make-package-specification (package-name package) - (package-version package))) - ((_ (? package? package) output) - (make-package-specification (package-name package) - (package-version package) - output)) - (_ #f)) - inputs)) - -(define (package-license-names package) - "Return a list of license names of the PACKAGE." - (filter-map (lambda (license) - (and (license? license) - (license-name license))) - (list-maybe (package-license package)))) - -(define (package-source-names package) - "Return a list of source names (URLs) of the PACKAGE." - (let ((source (package-source package))) - (and (origin? source) - (filter-map (lambda (uri) - (cond ((string? uri) - uri) - ((git-reference? uri) - (git-reference-url uri)) - (else "Unknown source type"))) - (list-maybe (origin-uri source)))))) - -(define (package-unique? package) - "Return #t if PACKAGE is a single package with such name/version." - (match (packages-by-name (package-name package) - (package-version package)) - ((package) #t) - (_ #f))) - -(define %package-param-alist - `((id . ,object-address) - (package-id . ,object-address) - (name . ,package-name) - (version . ,package-version) - (license . ,package-license-names) - (source . ,package-source-names) - (synopsis . ,package-synopsis) - (description . ,package-description-string) - (home-url . ,package-home-page) - (outputs . ,package-outputs) - (systems . ,package-supported-systems) - (non-unique . ,(negate package-unique?)) - (inputs . ,(lambda (pkg) - (package-inputs-names - (package-inputs pkg)))) - (native-inputs . ,(lambda (pkg) - (package-inputs-names - (package-native-inputs pkg)))) - (propagated-inputs . ,(lambda (pkg) - (package-inputs-names - (package-propagated-inputs pkg)))) - (location . ,(lambda (pkg) - (location->string (package-location pkg)))))) - -(define (package-param package param) - "Return a value of a PACKAGE PARAM." - (and=> (assq-ref %package-param-alist param) - (cut <> package))) - - -;;; Finding packages. - -(define-values (package-by-address - register-package) - (let ((table (delay (fold-packages - (lambda (package table) - (vhash-consq (object-address package) - package table)) - vlist-null)))) - (values - (lambda (address) - "Return package by its object ADDRESS." - (match (vhash-assq address (force table)) - ((_ . package) package) - (_ #f))) - (lambda (package) - "Register PACKAGE by its 'object-address', so that later -'package-by-address' can be used to access it." - (let ((table* (force table))) - (set! table - (delay (vhash-consq (object-address package) - package table*)))))))) - -(define packages-by-name+version - (let ((table (delay (fold-packages - (lambda (package table) - (let ((file (location-file - (package-location package)))) - (vhash-cons (cons (package-name package) - (package-version package)) - package table))) - vlist-null)))) - (lambda (name version) - "Return packages matching NAME and VERSION." - (vhash-fold* cons '() (cons name version) (force table))))) - -(define (packages-by-full-name full-name) - (call-with-values - (lambda () (full-name->name+version full-name)) - packages-by-name+version)) - -(define (packages-by-id id) - (if (integer? id) - (let ((pkg (package-by-address id))) - (if pkg (list pkg) '())) - (packages-by-full-name id))) - -(define (id->name+version id) - (if (integer? id) - (and=> (package-by-address id) - (lambda (pkg) - (values (package-name pkg) - (package-version pkg)))) - (full-name->name+version id))) - -(define (package-by-id id) - (first-or-false (packages-by-id id))) - -(define (newest-package-by-id id) - (and=> (id->name+version id) - (lambda (name) - (first-or-false (find-best-packages-by-name name #f))))) - -(define (matching-packages predicate) - (fold-packages (lambda (pkg res) - (if (predicate pkg) - (cons pkg res) - res)) - '())) - -(define (filter-packages-by-output packages output) - (filter (lambda (package) - (member output (package-outputs package))) - packages)) - -(define* (packages-by-name name #:optional version output) - "Return a list of packages matching NAME, VERSION and OUTPUT." - (let ((packages (if version - (packages-by-name+version name version) - (matching-packages - (lambda (pkg) (string=? name (package-name pkg))))))) - (if output - (filter-packages-by-output packages output) - packages))) - -(define (manifest-entry->packages entry) - (call-with-values - (lambda () (manifest-entry->name+version+output entry)) - packages-by-name)) - -(define (packages-by-regexp regexp match-params) - "Return a list of packages matching REGEXP string. -MATCH-PARAMS is a list of parameters that REGEXP can match." - (define (package-match? package regexp) - (any (lambda (param) - (let ((val (package-param package param))) - (and (string? val) (regexp-exec regexp val)))) - match-params)) - - (let ((re (make-regexp regexp regexp/icase))) - (matching-packages (cut package-match? <> re)))) - -(define (packages-by-license license) - "Return a list of packages with LICENSE." - (matching-packages - (lambda (package) - (memq license (list-maybe (package-license package)))))) - -(define (all-available-packages) - "Return a list of all available packages." - (matching-packages (const #t))) - -(define (newest-available-packages) - "Return a list of the newest available packages." - (vhash-fold (lambda (name elem res) - (match elem - ((_ newest pkgs ...) - (cons newest res)))) - '() - (find-newest-available-packages))) - -(define (packages-from-file file) - "Return a list of packages from FILE." - (let ((package (load (canonicalize-path file)))) - (if (package? package) - (begin - (register-package package) - (list package)) - '()))) - - -;;; Making package/output patterns. - -(define (specification->package-pattern specification) - (call-with-values - (lambda () - (full-name->name+version specification)) - list)) - -(define (specification->output-pattern specification) - (call-with-values - (lambda () - (package-specification->name+version+output specification #f)) - list)) - -(define (id->package-pattern id) - (if (integer? id) - (package-by-address id) - (specification->package-pattern id))) - -(define (id->output-pattern id) - "Return an output pattern by output ID. -ID should be ':' or '-:'." - (let-values (((name version output) - (package-specification->name+version+output id))) - (if version - (list name version output) - (list (package-by-address (string->number name)) - output)))) - -(define (specifications->package-patterns . specifications) - (map specification->package-pattern specifications)) - -(define (specifications->output-patterns . specifications) - (map specification->output-pattern specifications)) - -(define (ids->package-patterns . ids) - (map id->package-pattern ids)) - -(define (ids->output-patterns . ids) - (map id->output-pattern ids)) - -(define* (manifest-patterns-result packages res obsolete-pattern - #:optional installed-pattern) - "Auxiliary procedure for 'manifest-package-patterns' and -'manifest-output-patterns'." - (if (null? packages) - (cons (obsolete-pattern) res) - (if installed-pattern - ;; We don't need duplicates for a list of installed packages, - ;; so just take any (car) package. - (cons (installed-pattern (car packages)) res) - res))) - -(define* (manifest-package-patterns manifest #:optional obsolete-only?) - "Return a list of package patterns for MANIFEST entries. -If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only -for obsolete packages." - (fold-manifest-by-name - manifest - (lambda (name version entries res) - (manifest-patterns-result (packages-by-name name version) - res - (lambda () (list name version entries)) - (and (not obsolete-only?) - (cut list <> entries)))) - '())) - -(define* (manifest-output-patterns manifest #:optional obsolete-only?) - "Return a list of output patterns for MANIFEST entries. -If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only -for obsolete packages." - (fold (lambda (entry res) - (manifest-patterns-result (manifest-entry->packages entry) - res - (lambda () entry) - (and (not obsolete-only?) - (cut list <> entry)))) - '() - (manifest-entries manifest))) - -(define (obsolete-package-patterns manifest) - (manifest-package-patterns manifest #t)) - -(define (obsolete-output-patterns manifest) - (manifest-output-patterns manifest #t)) - - -;;; Transforming package/output patterns into alists. - -(define (obsolete-package-sexp name version entries) - "Return an alist with information about obsolete package. -ENTRIES is a list of installed manifest entries." - `((id . ,(name+version->full-name name version)) - (name . ,name) - (version . ,version) - (outputs . ,(map manifest-entry-output entries)) - (obsolete . #t) - (installed . ,(manifest-entries->sexps entries)))) - -(define (package-pattern-transformer manifest params) - "Return 'package-pattern->package-sexps' procedure." - (define package->sexp - (object-transformer %package-param-alist params)) - - (define* (sexp-by-package package #:optional - (entries (manifest-entries-by-name - manifest - (package-name package) - (package-version package)))) - (cons (cons 'installed (manifest-entries->sexps entries)) - (package->sexp package))) - - (define (->sexps pattern) - (match pattern - ((? package? package) - (list (sexp-by-package package))) - (((? package? package) entries) - (list (sexp-by-package package entries))) - ((name version entries) - (list (obsolete-package-sexp - name version entries))) - ((name version) - (let ((packages (packages-by-name name version))) - (if (null? packages) - (let ((entries (manifest-entries-by-name - manifest name version))) - (if (null? entries) - '() - (list (obsolete-package-sexp - name version entries)))) - (map sexp-by-package packages)))) - (_ '()))) - - ->sexps) - -(define (output-pattern-transformer manifest params) - "Return 'output-pattern->output-sexps' procedure." - (define package->sexp - (object-transformer (alist-delete 'id %package-param-alist) - params)) - - (define manifest-entry->sexp - (object-transformer (alist-delete 'output %manifest-entry-param-alist) - params)) - - (define* (output-sexp pkg-alist pkg-address output - #:optional entry) - (let ((entry-alist (if entry - (manifest-entry->sexp entry) - '())) - (base `((id . ,(string-append - (number->string pkg-address) - ":" output)) - (output . ,output) - (installed . ,(->bool entry))))) - (append entry-alist base pkg-alist))) - - (define (obsolete-output-sexp entry) - (let-values (((name version output) - (manifest-entry->name+version+output entry))) - (let ((base `((id . ,(make-package-specification - name version output)) - (package-id . ,(name+version->full-name name version)) - (name . ,name) - (version . ,version) - (output . ,output) - (obsolete . #t) - (installed . #t)))) - (append (manifest-entry->sexp entry) base)))) - - (define* (sexps-by-package package #:optional output - (entries (manifest-entries-by-name - manifest - (package-name package) - (package-version package)))) - ;; Assuming that PACKAGE has this OUTPUT. - (let ((pkg-alist (package->sexp package)) - (address (object-address package)) - (outputs (if output - (list output) - (package-outputs package)))) - (map (lambda (output) - (output-sexp pkg-alist address output - (manifest-entry-by-output entries output))) - outputs))) - - (define* (sexps-by-manifest-entry entry #:optional - (packages (manifest-entry->packages - entry))) - (if (null? packages) - (list (obsolete-output-sexp entry)) - (map (lambda (package) - (output-sexp (package->sexp package) - (object-address package) - (manifest-entry-output entry) - entry)) - packages))) - - (define (->sexps pattern) - (match pattern - ((? package? package) - (sexps-by-package package)) - ((package (? string? output)) - (sexps-by-package package output)) - ((? manifest-entry? entry) - (list (obsolete-output-sexp entry))) - ((package entry) - (sexps-by-manifest-entry entry (list package))) - ((name version output) - (let ((packages (packages-by-name name version output))) - (if (null? packages) - (let ((entries (manifest-entries-by-name - manifest name version output))) - (append-map (cut sexps-by-manifest-entry <>) - entries)) - (append-map (cut sexps-by-package <> output) - packages)))) - (_ '()))) - - ->sexps) - -(define (entry-type-error entry-type) - (error (format #f "Wrong entry-type '~a'" entry-type))) - -(define (search-type-error entry-type search-type) - (error (format #f "Wrong search type '~a' for entry-type '~a'" - search-type entry-type))) - -(define %pattern-transformers - `((package . ,package-pattern-transformer) - (output . ,output-pattern-transformer))) - -(define (pattern-transformer entry-type) - (assq-ref %pattern-transformers entry-type)) - -;; All procedures from inner alists are called with (MANIFEST . SEARCH-VALS) -;; as arguments; see `package/output-sexps'. -(define %patterns-makers - (let* ((apply-to-rest (lambda (proc) - (lambda (_ . rest) (apply proc rest)))) - (apply-to-first (lambda (proc) - (lambda (first . _) (proc first)))) - (manifest-package-proc (apply-to-first manifest-package-patterns)) - (manifest-output-proc (apply-to-first manifest-output-patterns)) - (regexp-proc (lambda (_ regexp params . __) - (packages-by-regexp regexp params))) - (license-proc (lambda (_ license-name) - (packages-by-license - (lookup-license license-name)))) - (location-proc (lambda (_ location) - (packages-by-location-file location))) - (file-proc (lambda (_ file) - (packages-from-file file))) - (all-proc (lambda _ (all-available-packages))) - (newest-proc (lambda _ (newest-available-packages)))) - `((package - (id . ,(apply-to-rest ids->package-patterns)) - (name . ,(apply-to-rest specifications->package-patterns)) - (installed . ,manifest-package-proc) - (obsolete . ,(apply-to-first obsolete-package-patterns)) - (regexp . ,regexp-proc) - (license . ,license-proc) - (location . ,location-proc) - (from-file . ,file-proc) - (all-available . ,all-proc) - (newest-available . ,newest-proc)) - (output - (id . ,(apply-to-rest ids->output-patterns)) - (name . ,(apply-to-rest specifications->output-patterns)) - (installed . ,manifest-output-proc) - (obsolete . ,(apply-to-first obsolete-output-patterns)) - (regexp . ,regexp-proc) - (license . ,license-proc) - (location . ,location-proc) - (from-file . ,file-proc) - (all-available . ,all-proc) - (newest-available . ,newest-proc))))) - -(define (patterns-maker entry-type search-type) - (or (and=> (assq-ref %patterns-makers entry-type) - (cut assq-ref <> search-type)) - (search-type-error entry-type search-type))) - -(define (package/output-sexps profile params entry-type - search-type search-vals) - "Return information about packages or package outputs. -See 'entry-sexps' for details." - (let* ((manifest (profile-manifest profile)) - (patterns (if (and (eq? entry-type 'output) - (eq? search-type 'profile-diff)) - (match search-vals - ((p1 p2) - (map specification->output-pattern - (profile-difference p1 p2))) - (_ '())) - (apply (patterns-maker entry-type search-type) - manifest search-vals))) - (->sexps ((pattern-transformer entry-type) manifest params))) - (append-map ->sexps patterns))) - - -;;; Getting information about generations. - -(define (generation-param-alist profile) - "Return an alist of generation parameters and procedures for PROFILE." - (let ((current (generation-number profile))) - `((id . ,identity) - (number . ,identity) - (prev-number . ,(cut previous-generation-number profile <>)) - (current . ,(cut = current <>)) - (path . ,(cut generation-file-name profile <>)) - (time . ,(lambda (gen) - (time-second (generation-time profile gen))))))) - -(define (matching-generations profile predicate) - "Return a list of PROFILE generations matching PREDICATE." - (filter predicate (profile-generations profile))) - -(define (last-generations profile number) - "Return a list of last NUMBER generations. -If NUMBER is 0 or less, return all generations." - (let ((generations (profile-generations profile)) - (number (if (<= number 0) +inf.0 number))) - (if (> (length generations) number) - (list-head (reverse generations) number) - generations))) - -(define (find-generations profile search-type search-vals) - "Find PROFILE's generations matching SEARCH-TYPE and SEARCH-VALS." - (case search-type - ((id) - (matching-generations profile (cut memq <> search-vals))) - ((last) - (last-generations profile (car search-vals))) - ((all) - (last-generations profile +inf.0)) - ((time) - (match search-vals - ((from to) - (matching-generations - profile - (lambda (gen) - (let ((time (time-second (generation-time profile gen)))) - (< from time to))))) - (_ '()))) - (else (search-type-error "generation" search-type)))) - -(define (generation-sexps profile params search-type search-vals) - "Return information about generations. -See 'entry-sexps' for details." - (let ((generations (find-generations profile search-type search-vals)) - (->sexp (object-transformer (generation-param-alist profile) - params))) - (map ->sexp generations))) - -(define system-generation-boot-parameters - (memoize - (lambda (profile generation) - "Return boot parameters for PROFILE's system GENERATION." - (let* ((gen-file (generation-file-name profile generation)) - (param-file (string-append gen-file "/parameters"))) - (call-with-input-file param-file read-boot-parameters))))) - -(define (system-generation-param-alist profile) - "Return an alist of system generation parameters and procedures for -PROFILE." - (append (generation-param-alist profile) - `((label . ,(lambda (gen) - (boot-parameters-label - (system-generation-boot-parameters - profile gen)))) - (root-device . ,(lambda (gen) - (boot-parameters-root-device - (system-generation-boot-parameters - profile gen)))) - (kernel . ,(lambda (gen) - (boot-parameters-kernel - (system-generation-boot-parameters - profile gen))))))) - -(define (system-generation-sexps profile params search-type search-vals) - "Return an alist with information about system generations." - (let ((generations (find-generations profile search-type search-vals)) - (->sexp (object-transformer (system-generation-param-alist profile) - params))) - (map ->sexp generations))) - - -;;; Getting package/output/generation entries (alists). - -(define (entries profile params entry-type search-type search-vals) - "Return information about entries. - -ENTRY-TYPE is a symbol defining a type of returning information. Should -be: 'package', 'output' or 'generation'. - -SEARCH-TYPE and SEARCH-VALS define how to get the information. -SEARCH-TYPE should be one of the following symbols: - -- If ENTRY-TYPE is 'package' or 'output': - 'id', 'name', 'regexp', 'all-available', 'newest-available', - 'installed', 'obsolete', 'generation'. - -- If ENTRY-TYPE is 'generation': - 'id', 'last', 'all', 'time'. - -PARAMS is a list of parameters for receiving. If it is an empty list, -get information with all available parameters, which are: - -- If ENTRY-TYPE is 'package': - 'id', 'name', 'version', 'outputs', 'license', 'synopsis', - 'description', 'home-url', 'inputs', 'native-inputs', - 'propagated-inputs', 'location', 'installed'. - -- If ENTRY-TYPE is 'output': - 'id', 'package-id', 'name', 'version', 'output', 'license', - 'synopsis', 'description', 'home-url', 'inputs', 'native-inputs', - 'propagated-inputs', 'location', 'installed', 'path', 'dependencies'. - -- If ENTRY-TYPE is 'generation': - 'id', 'number', 'prev-number', 'path', 'time'. - -Returning value is a list of alists. Each alist consists of -parameter/value pairs." - (case entry-type - ((package output) - (package/output-sexps profile params entry-type - search-type search-vals)) - ((generation) - (generation-sexps profile params - search-type search-vals)) - ((system-generation) - (system-generation-sexps profile params - search-type search-vals)) - (else (entry-type-error entry-type)))) - - -;;; Package actions. - -(define* (package->manifest-entry* package #:optional output) - (and package - (package->manifest-entry package output))) - -(define* (make-install-manifest-entries id #:optional output) - (package->manifest-entry* (package-by-id id) output)) - -(define* (make-upgrade-manifest-entries id #:optional output) - (package->manifest-entry* (newest-package-by-id id) output)) - -(define* (make-manifest-pattern id #:optional output) - "Make manifest pattern from a package ID and OUTPUT." - (let-values (((name version) - (id->name+version id))) - (and name version - (manifest-pattern - (name name) - (version version) - (output output))))) - -(define (convert-action-pattern pattern proc) - "Convert action PATTERN into a list of objects returned by PROC. -PROC is called: (PROC ID) or (PROC ID OUTPUT)." - (match pattern - ((id . outputs) - (if (null? outputs) - (let ((obj (proc id))) - (if obj (list obj) '())) - (filter-map (cut proc id <>) - outputs))) - (_ '()))) - -(define (convert-action-patterns patterns proc) - (append-map (cut convert-action-pattern <> proc) - patterns)) - -(define* (process-package-actions - profile #:key (install '()) (upgrade '()) (remove '()) - (use-substitutes? #t) dry-run?) - "Perform package actions. - -INSTALL, UPGRADE, REMOVE are lists of 'package action patterns'. -Each pattern should have the following form: - - (ID . OUTPUTS) - -ID is an object address or a full-name of a package. -OUTPUTS is a list of package outputs (may be an empty list)." - (format #t "The process begins ...~%") - (let* ((install (append - (convert-action-patterns - install make-install-manifest-entries) - (convert-action-patterns - upgrade make-upgrade-manifest-entries))) - (remove (convert-action-patterns remove make-manifest-pattern)) - (transaction (manifest-transaction (install install) - (remove remove))) - (manifest (profile-manifest profile)) - (new-manifest (manifest-perform-transaction - manifest transaction))) - (unless (and (null? install) (null? remove)) - (parameterize ((%graft? (not dry-run?))) - (with-store store - (set-build-options store - #:print-build-trace #f - #:use-substitutes? use-substitutes?) - (show-manifest-transaction store manifest transaction - #:dry-run? dry-run?) - (build-and-use-profile store profile new-manifest - #:use-substitutes? use-substitutes? - #:dry-run? dry-run?)))))) - -(define (delete-generations* profile generations) - "Delete GENERATIONS from PROFILE. -GENERATIONS is a list of generation numbers." - (with-store store - (delete-generations store profile generations))) - -(define (package-location-string id-or-name) - "Return a location string of a package with ID-OR-NAME." - (and=> (or (package-by-id id-or-name) - (match (packages-by-name id-or-name) - (() #f) - ((package _ ...) package))) - (compose location->string package-location))) - -(define (package-store-path package-id) - "Return a list of store directories of outputs of package PACKAGE-ID." - (match (package-by-id package-id) - (#f '()) - (package - (with-store store - (map (match-lambda - ((_ . drv) - (derivation-output-path drv))) - (derivation-outputs (package-derivation store package))))))) - -(define (package-source-derivation->store-path derivation) - "Return a store path of the package source DERIVATION." - (match (derivation-outputs derivation) - ;; Source derivation is always (("out" . derivation)). - (((_ . output-drv)) - (derivation-output-path output-drv)) - (_ #f))) - -(define (package-source-path package-id) - "Return a store file path to a source of a package PACKAGE-ID." - (and-let* ((package (package-by-id package-id)) - (source (package-source package))) - (with-store store - (package-source-derivation->store-path - (package-source-derivation store source))))) - -(define* (package-source-build-derivation package-id #:key dry-run? - (use-substitutes? #t)) - "Build source derivation of a package PACKAGE-ID." - (and-let* ((package (package-by-id package-id)) - (source (package-source package))) - (with-store store - (let* ((derivation (package-source-derivation store source)) - (derivations (list derivation))) - (set-build-options store - #:print-build-trace #f - #:use-substitutes? use-substitutes?) - (show-what-to-build store derivations - #:use-substitutes? use-substitutes? - #:dry-run? dry-run?) - (unless dry-run? - (build-derivations store derivations)) - (format #t "The source store path: ~a~%" - (package-source-derivation->store-path derivation)))))) - -(define (package-build-log-file package-id) - "Return the build log file of a package PACKAGE-ID. -Return #f if the build log is not found." - (and-let* ((package (package-by-id package-id))) - (with-store store - (let* ((derivation (package-derivation store package)) - (file (derivation-file-name derivation))) - (or (log-file store file) - ((@@ (guix scripts build) log-url) store file)))))) - - -;;; Executing guix commands - -(define (guix-command . args) - "Run 'guix ARGS ...' command." - (catch 'quit - (lambda () (apply run-guix args)) - (const #t))) - -(define (guix-command-output . args) - "Return 2 strings with 'guix ARGS ...' output and error output." - (output+error - (lambda () - (parameterize ((guix-warning-port (current-error-port))) - (apply guix-command args))))) - -(define (help-string . commands) - "Return string with 'guix COMMANDS ... --help' output." - (apply guix-command-output `(,@commands "--help"))) - -(define (pipe-guix-output guix-args command-args) - "Run 'guix GUIX-ARGS ...' command and pipe its output to a shell command -defined by COMMAND-ARGS. -Return #t if the shell command was executed successfully." - (let ((pipe (apply open-pipe* OPEN_WRITE command-args))) - (with-output-to-port pipe - (lambda () (apply guix-command guix-args))) - (zero? (status:exit-val (close-pipe pipe))))) - - -;;; Lists of packages, lint checkers, etc. - -(define (graph-type-names) - "Return a list of names of available graph node types." - (map (@ (guix graph) node-type-name) - (@ (guix scripts graph) %node-types))) - -(define (refresh-updater-names) - "Return a list of names of available refresh updater types." - (map (@ (guix upstream) upstream-updater-name) - (@ (guix scripts refresh) %updaters))) - -(define (lint-checker-names) - "Return a list of names of available lint checkers." - (map (lambda (checker) - (symbol->string ((@ (guix scripts lint) lint-checker-name) - checker))) - (@ (guix scripts lint) %checkers))) - -(define (package-names) - "Return a list of names of available packages." - (delete-duplicates - (fold-packages (lambda (pkg res) - (cons (package-name pkg) res)) - '()))) - -;; See the comment to 'guix-package-names' function in "guix-popup.el". -(define (package-names-lists) - (map list (package-names))) - - -;;; Licenses - -(define %licenses - (delay - (filter license? - (module-map (lambda (_ var) - (variable-ref var)) - (resolve-interface '(guix licenses)))))) - -(define (licenses) - (force %licenses)) - -(define (license-names) - "Return a list of names of available licenses." - (map license-name (licenses))) - -(define lookup-license - (memoize - (lambda (name) - "Return a license by its name." - (find (lambda (l) - (string=? name (license-name l))) - (licenses))))) - -(define (lookup-license-uri name) - "Return a license URI by its name." - (and=> (lookup-license name) - license-uri)) - -(define %license-param-alist - `((id . ,license-name) - (name . ,license-name) - (url . ,license-uri) - (comment . ,license-comment))) - -(define license->sexp - (object-transformer %license-param-alist)) - -(define (find-licenses search-type . search-values) - "Return a list of licenses depending on SEARCH-TYPE and SEARCH-VALUES." - (case search-type - ((id name) - (let ((names search-values)) - (filter-map lookup-license names))) - ((all) - (licenses)))) - -(define (license-entries search-type . search-values) - (map license->sexp - (apply find-licenses search-type search-values))) - - -;;; Package locations - -(define-values (packages-by-location-file - package-location-files) - (let* ((table (delay (fold-packages - (lambda (package table) - (let ((file (location-file - (package-location package)))) - (vhash-cons file package table))) - vlist-null))) - (files (delay (vhash-fold - (lambda (file _ result) - (if (member file result) - result - (cons file result))) - '() - (force table))))) - (values - (lambda (file) - "Return the (possibly empty) list of packages defined in location FILE." - (vhash-fold* cons '() file (force table))) - (lambda () - "Return the list of file names of all package locations." - (force files))))) - -(define %package-location-param-alist - `((id . ,identity) - (location . ,identity) - (number-of-packages . ,(lambda (location) - (length (packages-by-location-file location)))))) - -(define package-location->sexp - (object-transformer %package-location-param-alist)) - -(define (package-location-entries) - (map package-location->sexp (package-location-files))) diff --git a/emacs/guix-messages.el b/emacs/guix-messages.el deleted file mode 100644 index 52436af9e4..0000000000 --- a/emacs/guix-messages.el +++ /dev/null @@ -1,247 +0,0 @@ -;;; guix-messages.el --- Minibuffer messages - -;; Copyright © 2014, 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides `guix-result-message' function used to show a -;; minibuffer message after displaying packages/generations in a -;; list/info buffer. - -;;; Code: - -(require 'cl-lib) -(require 'guix-utils) - -(defvar guix-messages - `((package - (id - ,(lambda (_ entries ids) - (guix-message-packages-by-id entries 'package ids))) - (name - ,(lambda (_ entries names) - (guix-message-packages-by-name entries 'package names))) - (license - ,(lambda (_ entries licenses) - (apply #'guix-message-packages-by-license - entries 'package licenses))) - (location - ,(lambda (_ entries locations) - (apply #'guix-message-packages-by-location - entries 'package locations))) - (from-file - (0 "No package in file '%s'." val) - (1 "Package from file '%s'." val)) - (regexp - (0 "No packages matching '%s'." val) - (1 "A single package matching '%s'." val) - (many "%d packages matching '%s'." count val)) - (all-available - (0 "No packages are available for some reason.") - (1 "A single available package (that's strange).") - (many "%d available packages." count)) - (newest-available - (0 "No packages are available for some reason.") - (1 "A single newest available package (that's strange).") - (many "%d newest available packages." count)) - (installed - (0 "No packages installed in profile '%s'." profile) - (1 "A single package installed in profile '%s'." profile) - (many "%d packages installed in profile '%s'." count profile)) - (obsolete - (0 "No obsolete packages in profile '%s'." profile) - (1 "A single obsolete package in profile '%s'." profile) - (many "%d obsolete packages in profile '%s'." count profile))) - - (output - (id - ,(lambda (_ entries ids) - (guix-message-packages-by-id entries 'output ids))) - (name - ,(lambda (_ entries names) - (guix-message-packages-by-name entries 'output names))) - (license - ,(lambda (_ entries licenses) - (apply #'guix-message-packages-by-license - entries 'output licenses))) - (location - ,(lambda (_ entries locations) - (apply #'guix-message-packages-by-location - entries 'output locations))) - (from-file - (0 "No package in file '%s'." val) - (1 "Package from file '%s'." val) - (many "Package outputs from file '%s'." val)) - (regexp - (0 "No package outputs matching '%s'." val) - (1 "A single package output matching '%s'." val) - (many "%d package outputs matching '%s'." count val)) - (all-available - (0 "No package outputs are available for some reason.") - (1 "A single available package output (that's strange).") - (many "%d available package outputs." count)) - (newest-available - (0 "No package outputs are available for some reason.") - (1 "A single newest available package output (that's strange).") - (many "%d newest available package outputs." count)) - (installed - (0 "No package outputs installed in profile '%s'." profile) - (1 "A single package output installed in profile '%s'." profile) - (many "%d package outputs installed in profile '%s'." count profile)) - (obsolete - (0 "No obsolete package outputs in profile '%s'." profile) - (1 "A single obsolete package output in profile '%s'." profile) - (many "%d obsolete package outputs in profile '%s'." count profile)) - (profile-diff - guix-message-outputs-by-diff)) - - (generation - (id - (0 "Generations not found.") - (1 "") - (many "%d generations." count)) - (last - (0 "No generations in profile '%s'." profile) - (1 "The last generation of profile '%s'." profile) - (many "%d last generations of profile '%s'." count profile)) - (all - (0 "No generations in profile '%s'." profile) - (1 "A single generation available in profile '%s'." profile) - (many "%d generations available in profile '%s'." count profile)) - (time - guix-message-generations-by-time)))) - -(defun guix-message-string-name (name) - "Return a quoted name string." - (concat "'" name "'")) - -(defun guix-message-string-entry-type (entry-type &optional plural) - "Return a string denoting an ENTRY-TYPE." - (cl-ecase entry-type - (package - (if plural "packages" "package")) - (output - (if plural "package outputs" "package output")) - (generation - (if plural "generations" "generation")))) - -(defun guix-message-string-entries (count entry-type) - "Return a string denoting the COUNT of ENTRY-TYPE entries." - (cl-case count - (0 (concat "No " - (guix-message-string-entry-type - entry-type 'plural))) - (1 (concat "A single " - (guix-message-string-entry-type - entry-type))) - (t (format "%d %s" - count - (guix-message-string-entry-type - entry-type 'plural))))) - -(defun guix-message-packages-by-id (entries entry-type ids) - "Display a message for packages or outputs searched by IDS." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count entry-type)) - (str-end (if (> count 1) - (concat "with the following IDs: " - (mapconcat #'guix-get-string ids ", ")) - (concat "with ID " (guix-get-string (car ids)))))) - (if (zerop count) - (message "%s %s. -Most likely, Guix REPL was restarted, so IDs are not actual -anymore, because they live only during the REPL process. -Try \"M-x guix-search-by-name\"." - str-beg str-end) - (message "%s %s." str-beg str-end)))) - -(defun guix-message-packages-by-name (entries entry-type names) - "Display a message for packages or outputs searched by NAMES." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count entry-type)) - (str-end (if (cdr names) - (concat "matching the following names: " - (mapconcat #'guix-message-string-name - names ", ")) - (concat "with name " - (guix-message-string-name (car names)))))) - (message "%s %s." str-beg str-end))) - -(defun guix-message-packages-by-license (entries entry-type license) - "Display a message for packages or outputs searched by LICENSE." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count entry-type)) - (str-end (format "with license '%s'" license))) - (message "%s %s." str-beg str-end))) - -(defun guix-message-packages-by-location (entries entry-type location) - "Display a message for packages or outputs searched by LOCATION." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count entry-type)) - (str-end (format "placed in '%s'" location))) - (message "%s %s." str-beg str-end))) - -(defun guix-message-generations-by-time (profile entries times) - "Display a message for generations searched by TIMES." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count 'generation)) - (time-beg (guix-get-time-string (car times))) - (time-end (guix-get-time-string (cadr times)))) - (message (concat "%s of profile '%s'\n" - "matching time period '%s' - '%s'.") - str-beg profile time-beg time-end))) - -(defun guix-message-outputs-by-diff (_ entries profiles) - "Display a message for outputs searched by PROFILES difference." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count 'output)) - (profile1 (car profiles)) - (profile2 (cadr profiles))) - (cl-multiple-value-bind (new old str-action) - (if (string-lessp profile2 profile1) - (list profile1 profile2 "added to") - (list profile2 profile1 "removed from")) - (message "%s %s profile '%s' comparing with profile '%s'." - str-beg str-action new old)))) - -(defun guix-result-message (profile entries entry-type - search-type search-vals) - "Display an appropriate message after displaying ENTRIES." - (let* ((type-spec (guix-assq-value guix-messages - (if (eq entry-type 'system-generation) - 'generation - entry-type) - search-type)) - (fun-or-count-spec (car type-spec))) - (if (functionp fun-or-count-spec) - (funcall fun-or-count-spec profile entries search-vals) - (let* ((count (length entries)) - (count-key (if (> count 1) 'many count)) - (msg-spec (guix-assq-value type-spec count-key)) - (msg (car msg-spec)) - (args (cdr msg-spec))) - (mapc (lambda (subst) - (setq args (cl-substitute (cdr subst) (car subst) args))) - `((count . ,count) - (val . ,(car search-vals)) - (profile . ,profile))) - (apply #'message msg args))))) - -(provide 'guix-messages) - -;;; guix-messages.el ends here diff --git a/emacs/guix-pcomplete.el b/emacs/guix-pcomplete.el deleted file mode 100644 index 785e54ef6d..0000000000 --- a/emacs/guix-pcomplete.el +++ /dev/null @@ -1,370 +0,0 @@ -;;; guix-pcomplete.el --- Functions for completing guix commands -*- lexical-binding: t -*- - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides completions for "guix" command that may be used in -;; `shell', `eshell' and wherever `pcomplete' works. - -;;; Code: - -(require 'pcomplete) -(require 'pcmpl-unix) -(require 'cl-lib) -(require 'guix-utils) -(require 'guix-help-vars) - - -;;; Interacting with guix - -(defcustom guix-pcomplete-guix-program (executable-find "guix") - "Name of the 'guix' program. -It is used to find guix commands, options, packages, etc." - :type 'file - :group 'pcomplete - :group 'guix) - -(defun guix-pcomplete-run-guix (&rest args) - "Run `guix-pcomplete-guix-program' with ARGS. -Insert the output to the current buffer." - (apply #'call-process - guix-pcomplete-guix-program nil t nil args)) - -(defun guix-pcomplete-run-guix-and-search (regexp &optional group - &rest args) - "Run `guix-pcomplete-guix-program' with ARGS and search for matches. -Return a list of strings matching REGEXP. -GROUP specifies a parenthesized expression used in REGEXP." - (with-temp-buffer - (apply #'guix-pcomplete-run-guix args) - (let (result) - (guix-while-search regexp - (push (match-string-no-properties group) result)) - (nreverse result)))) - -(defmacro guix-pcomplete-define-options-finder (name docstring regexp - &optional filter) - "Define function NAME to receive guix options and commands. - -The defined function takes an optional COMMAND argument. This -function will run 'guix COMMAND --help' (or 'guix --help' if -COMMAND is nil) using `guix-pcomplete-run-guix-and-search' and -return its result. - -If FILTER is specified, it should be a function. The result is -passed to this FILTER as argument and the result value of this -function call is returned." - (declare (doc-string 2) (indent 1)) - `(guix-memoized-defun ,name (&optional command) - ,docstring - (let* ((args '("--help")) - (args (if command (cons command args) args)) - (res (apply #'guix-pcomplete-run-guix-and-search - ,regexp guix-help-parse-regexp-group args))) - ,(if filter - `(funcall ,filter res) - 'res)))) - -(guix-pcomplete-define-options-finder guix-pcomplete-commands - "If COMMAND is nil, return a list of available guix commands. -If COMMAND is non-nil (it should be a string), return available -subcommands, actions, etc. for this guix COMMAND." - guix-help-parse-command-regexp) - -(guix-pcomplete-define-options-finder guix-pcomplete-long-options - "Return a list of available long options for guix COMMAND." - guix-help-parse-long-option-regexp) - -(guix-pcomplete-define-options-finder guix-pcomplete-short-options - "Return a string with available short options for guix COMMAND." - guix-help-parse-short-option-regexp - (lambda (list) - (guix-concat-strings list ""))) - -(guix-memoized-defun guix-pcomplete-all-packages () - "Return a list of all available Guix packages." - (guix-pcomplete-run-guix-and-search - guix-help-parse-package-regexp - guix-help-parse-regexp-group - "package" "--list-available")) - -(guix-memoized-defun guix-pcomplete-installed-packages (&optional profile) - "Return a list of Guix packages installed in PROFILE." - (let* ((args (and profile - (list (concat "--profile=" profile)))) - (args (append '("package" "--list-installed") args))) - (apply #'guix-pcomplete-run-guix-and-search - guix-help-parse-package-regexp - guix-help-parse-regexp-group - args))) - -(guix-memoized-defun guix-pcomplete-lint-checkers () - "Return a list of all available lint checkers." - (guix-pcomplete-run-guix-and-search - guix-help-parse-list-regexp - guix-help-parse-regexp-group - "lint" "--list-checkers")) - -(guix-memoized-defun guix-pcomplete-graph-types () - "Return a list of all available graph types." - (guix-pcomplete-run-guix-and-search - guix-help-parse-list-regexp - guix-help-parse-regexp-group - "graph" "--list-types")) - -(guix-memoized-defun guix-pcomplete-refresh-updaters () - "Return a list of all available refresh updater types." - (guix-pcomplete-run-guix-and-search - guix-help-parse-list-regexp - guix-help-parse-regexp-group - "refresh" "--list-updaters")) - - -;;; Completing - -(defvar guix-pcomplete-option-regexp (rx string-start "-") - "Regexp to match an option.") - -(defvar guix-pcomplete-long-option-regexp (rx string-start "--") - "Regexp to match a long option.") - -(defvar guix-pcomplete-long-option-with-arg-regexp - (rx string-start - (group "--" (one-or-more any)) "=" - (group (zero-or-more any))) - "Regexp to match a long option with its argument. -The first parenthesized group defines the option and the second -group - the argument.") - -(defvar guix-pcomplete-short-option-with-arg-regexp - (rx string-start - (group "-" (not (any "-"))) - (group (zero-or-more any))) - "Regexp to match a short option with its argument. -The first parenthesized group defines the option and the second -group - the argument.") - -(defun guix-pcomplete-match-option () - "Return non-nil, if the current argument is an option." - (pcomplete-match guix-pcomplete-option-regexp 0)) - -(defun guix-pcomplete-match-long-option () - "Return non-nil, if the current argument is a long option." - (pcomplete-match guix-pcomplete-long-option-regexp 0)) - -(defun guix-pcomplete-match-long-option-with-arg () - "Return non-nil, if the current argument is a long option with value." - (pcomplete-match guix-pcomplete-long-option-with-arg-regexp 0)) - -(defun guix-pcomplete-match-short-option-with-arg () - "Return non-nil, if the current argument is a short option with value." - (pcomplete-match guix-pcomplete-short-option-with-arg-regexp 0)) - -(defun guix-pcomplete-long-option-arg (option args) - "Return a long OPTION's argument from a list of arguments ARGS." - (let* ((re (concat "\\`" option "=\\(.*\\)")) - (args (cl-member-if (lambda (arg) - (string-match re arg)) - args)) - (cur (car args))) - (when cur - (match-string-no-properties 1 cur)))) - -(defun guix-pcomplete-short-option-arg (option args) - "Return a short OPTION's argument from a list of arguments ARGS." - (let* ((re (concat "\\`" option "\\(.*\\)")) - (args (cl-member-if (lambda (arg) - (string-match re arg)) - args)) - (cur (car args))) - (when cur - (let ((arg (match-string-no-properties 1 cur))) - (if (string= "" arg) - (cadr args) ; take the next arg - arg))))) - -(defun guix-pcomplete-complete-comma-args (entries) - "Complete comma separated arguments using ENTRIES." - (let ((index pcomplete-index)) - (while (= index pcomplete-index) - (let* ((args (if (or (guix-pcomplete-match-long-option-with-arg) - (guix-pcomplete-match-short-option-with-arg)) - (pcomplete-match-string 2 0) - (pcomplete-arg 0))) - (input (if (string-match ".*,\\(.*\\)" args) - (match-string-no-properties 1 args) - args))) - (pcomplete-here* entries input))))) - -(defun guix-pcomplete-complete-command-arg (command) - "Complete argument for guix COMMAND." - (cond - ((member command - '("archive" "build" "challenge" "edit" "environment" - "graph" "lint" "refresh" "size")) - (while t - (pcomplete-here (guix-pcomplete-all-packages)))) - (t (pcomplete-here* (pcomplete-entries))))) - -(defun guix-pcomplete-complete-option-arg (command option &optional input) - "Complete argument for COMMAND's OPTION. -INPUT is the current partially completed string." - (cl-flet ((option? (short long) - (or (string= option short) - (string= option long))) - (command? (&rest commands) - (member command commands)) - (complete (entries) - (pcomplete-here entries input nil t)) - (complete* (entries) - (pcomplete-here* entries input t))) - (cond - ((option? "-L" "--load-path") - (complete* (pcomplete-dirs))) - ((string= "--key-download" option) - (complete* guix-help-key-policies)) - - ((command? "package") - (cond - ;; For '--install[=]' and '--remove[=]', try to complete a package - ;; name (INPUT) after the "=" sign, and then the rest packages - ;; separated with spaces. - ((option? "-i" "--install") - (complete (guix-pcomplete-all-packages)) - (while (not (guix-pcomplete-match-option)) - (pcomplete-here (guix-pcomplete-all-packages)))) - ((option? "-r" "--remove") - (let* ((profile (or (guix-pcomplete-short-option-arg - "-p" pcomplete-args) - (guix-pcomplete-long-option-arg - "--profile" pcomplete-args))) - (profile (and profile (expand-file-name profile)))) - (complete (guix-pcomplete-installed-packages profile)) - (while (not (guix-pcomplete-match-option)) - (pcomplete-here (guix-pcomplete-installed-packages profile))))) - ((string= "--show" option) - (complete (guix-pcomplete-all-packages))) - ((option? "-p" "--profile") - (complete* (pcomplete-dirs))) - ((or (option? "-f" "--install-from-file") - (option? "-m" "--manifest")) - (complete* (pcomplete-entries))))) - - ((and (command? "archive" "build" "size") - (option? "-s" "--system")) - (complete* guix-help-system-types)) - - ((and (command? "build") - (or (option? "-f" "--file") - (option? "-r" "--root") - (string= "--with-source" option))) - (complete* (pcomplete-entries))) - - ((and (command? "graph") - (option? "-t" "--type")) - (complete* (guix-pcomplete-graph-types))) - - ((and (command? "environment") - (option? "-l" "--load")) - (complete* (pcomplete-entries))) - - ((and (command? "hash" "download") - (option? "-f" "--format")) - (complete* guix-help-hash-formats)) - - ((and (command? "lint") - (option? "-c" "--checkers")) - (guix-pcomplete-complete-comma-args - (guix-pcomplete-lint-checkers))) - - ((and (command? "publish") - (option? "-u" "--user")) - (complete* (pcmpl-unix-user-names))) - - ((command? "refresh") - (cond - ((option? "-s" "--select") - (complete* guix-help-refresh-subsets)) - ((option? "-t" "--type") - (guix-pcomplete-complete-comma-args - (guix-pcomplete-refresh-updaters))))) - - ((and (command? "size") - (option? "-m" "--map-file")) - (complete* (pcomplete-entries)))))) - -(defun guix-pcomplete-complete-options (command) - "Complete options (with their arguments) for guix COMMAND." - (while (guix-pcomplete-match-option) - (let ((index pcomplete-index)) - (if (guix-pcomplete-match-long-option) - - ;; Long options. - (if (guix-pcomplete-match-long-option-with-arg) - (let ((option (pcomplete-match-string 1 0)) - (arg (pcomplete-match-string 2 0))) - (guix-pcomplete-complete-option-arg - command option arg)) - - (pcomplete-here* (guix-pcomplete-long-options command)) - ;; We support '--opt arg' style (along with '--opt=arg'), - ;; because 'guix package --install/--remove' may be used this - ;; way. So try to complete an argument after the option has - ;; been completed. - (unless (guix-pcomplete-match-option) - (guix-pcomplete-complete-option-arg - command (pcomplete-arg 0 -1)))) - - ;; Short options. - (let ((arg (pcomplete-arg 0))) - (if (> (length arg) 2) - ;; Support specifying an argument after a short option without - ;; spaces (for example, '-L/tmp/foo'). - (guix-pcomplete-complete-option-arg - command - (substring-no-properties arg 0 2) - (substring-no-properties arg 2)) - (pcomplete-opt (guix-pcomplete-short-options command)) - (guix-pcomplete-complete-option-arg - command (pcomplete-arg 0 -1))))) - - ;; If there were no completions, move to the next argument and get - ;; out if the last argument is achieved. - (when (= index pcomplete-index) - (if (= pcomplete-index pcomplete-last) - (throw 'pcompleted nil) - (pcomplete-next-arg)))))) - -;;;###autoload -(defun pcomplete/guix () - "Completion for `guix'." - (let ((commands (guix-pcomplete-commands))) - (pcomplete-here* (cons "--help" commands)) - (let ((command (pcomplete-arg 'first 1))) - (when (member command commands) - (guix-pcomplete-complete-options command) - (let ((subcommands (guix-pcomplete-commands command))) - (when subcommands - (pcomplete-here* subcommands))) - (guix-pcomplete-complete-options command) - (guix-pcomplete-complete-command-arg command))))) - -(provide 'guix-pcomplete) - -;;; guix-pcomplete.el ends here diff --git a/emacs/guix-popup.el b/emacs/guix-popup.el deleted file mode 100644 index 59e98a352e..0000000000 --- a/emacs/guix-popup.el +++ /dev/null @@ -1,48 +0,0 @@ -;;; guix-popup.el --- Popup windows library - -;; Copyright © 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides `guix-define-popup' macro which is just an alias -;; to `magit-define-popup'. According to the manual (info -;; "(magit-popup) Defining prefix and suffix commands") `magit-popup' -;; library will eventually be superseded by a more general library. - -;;; Code: - -(require 'magit-popup) - -(defalias 'guix-define-popup 'magit-define-popup) - -(defvar guix-popup-font-lock-keywords - (eval-when-compile - `((,(rx "(" - (group "guix-define-popup") - symbol-end - (zero-or-more blank) - (zero-or-one - (group (one-or-more (or (syntax word) (syntax symbol)))))) - (1 font-lock-keyword-face) - (2 font-lock-function-name-face nil t))))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-popup-font-lock-keywords) - -(provide 'guix-popup) - -;;; guix-popup.el ends here diff --git a/emacs/guix-prettify.el b/emacs/guix-prettify.el deleted file mode 100644 index 38d72e860b..0000000000 --- a/emacs/guix-prettify.el +++ /dev/null @@ -1,210 +0,0 @@ -;;; guix-prettify.el --- Prettify Guix store file names - -;; Copyright © 2014, 2015 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This package provides minor-mode for prettifying Guix store file -;; names — i.e., after enabling `guix-prettify-mode', -;; '/gnu/store/72f54nfp6g1hz873w8z3gfcah0h4nl9p-foo-0.1' names will be -;; replaced with '/gnu/store/…-foo-0.1' in the current buffer. There is -;; also `global-guix-prettify-mode' for global prettifying. - -;; To install, add the following to your emacs init file: -;; -;; (add-to-list 'load-path "/path/to/dir-with-guix-prettify") -;; (autoload 'guix-prettify-mode "guix-prettify" nil t) -;; (autoload 'global-guix-prettify-mode "guix-prettify" nil t) - -;; If you want to enable/disable composition after "M-x font-lock-mode", -;; use the following setting: -;; -;; (setq font-lock-extra-managed-props -;; (cons 'composition font-lock-extra-managed-props)) - -;; Credits: -;; -;; Thanks to Ludovic Courtès for the idea of this package. -;; -;; Thanks to the authors of `prettify-symbols-mode' (part of Emacs 24.4) -;; and "pretty-symbols.el" -;; for the code. It helped to write this package. - -;;; Code: - -(require 'guix-utils) - -(defgroup guix-prettify nil - "Prettify Guix store file names." - :prefix "guix-prettify-" - :group 'guix - :group 'font-lock - :group 'convenience) - -(defcustom guix-prettify-char ?… - "Character used for prettifying." - :type 'character - :group 'guix-prettify) - -(defcustom guix-prettify-decompose-force nil - "If non-nil, remove any composition. - -By default, after disabling `guix-prettify-mode', -compositions (prettifying names with `guix-prettify-char') are -removed only from strings matching `guix-prettify-regexp', so -that compositions created by other modes are left untouched. - -Set this variable to non-nil, if you want to remove any -composition unconditionally (like `prettify-symbols-mode' does). -Most likely it will do no harm and will make the process of -disabling `guix-prettify-mode' a little faster." - :type 'boolean - :group 'guix-prettify) - -(defcustom guix-prettify-regexp - ;; The following file names / URLs should be abbreviated: - - ;; /gnu/store/…-foo-0.1 - ;; /nix/store/…-foo-0.1 - ;; http://hydra.gnu.org/nar/…-foo-0.1 - ;; http://hydra.gnu.org/log/…-foo-0.1 - - (rx "/" (or "store" "nar" "log") "/" - ;; Hash-parts do not include "e", "o", "u" and "t". See base32Chars - ;; at - (group (= 32 (any "0-9" "a-d" "f-n" "p-s" "v-z")))) - "Regexp matching file names for prettifying. - -Disable `guix-prettify-mode' before modifying this variable and -make sure to modify `guix-prettify-regexp-group' if needed. - -Example of a \"deeper\" prettifying: - - (setq guix-prettify-regexp \"store/[[:alnum:]]\\\\\\={32\\\\}\" - guix-prettify-regexp-group 0) - -This will transform -'/gnu/store/72f54nfp6g1hz873w8z3gfcah0h4nl9p-foo-0.1' into -'/gnu/…-foo-0.1'" - :type 'regexp - :group 'guix-prettify) - -(defcustom guix-prettify-regexp-group 1 - "Regexp group in `guix-prettify-regexp' for prettifying." - :type 'integer - :group 'guix-prettify) - -(defvar guix-prettify-special-modes - '(guix-info-mode ibuffer-mode) - "List of special modes that support font-locking. - -By default, \\[global-guix-prettify-mode] enables prettifying in -all buffers except the ones where `font-lock-defaults' is -nil (see Info node `(elisp) Font Lock Basics'), because it may -break the existing highlighting. - -Modes from this list and all derived modes are exceptions -\(`global-guix-prettify-mode' enables prettifying there).") - -(defvar guix-prettify-flush-function - (cond ((fboundp 'font-lock-flush) #'font-lock-flush) - ((fboundp 'jit-lock-refontify) #'jit-lock-refontify)) - "Function used to refontify buffer. -This function is called without arguments after -enabling/disabling `guix-prettify-mode'. If nil, do nothing.") - -(defun guix-prettify-compose () - "Compose matching region in the current buffer." - (let ((beg (match-beginning guix-prettify-regexp-group)) - (end (match-end guix-prettify-regexp-group))) - (compose-region beg end guix-prettify-char 'decompose-region)) - ;; Return nil because we're not adding any face property. - nil) - -(defun guix-prettify-decompose-buffer () - "Remove file names compositions from the current buffer." - (with-silent-modifications - (let ((inhibit-read-only t)) - (if guix-prettify-decompose-force - (remove-text-properties (point-min) - (point-max) - '(composition nil)) - (guix-while-search guix-prettify-regexp - (remove-text-properties - (match-beginning guix-prettify-regexp-group) - (match-end guix-prettify-regexp-group) - '(composition nil))))))) - -;;;###autoload -(define-minor-mode guix-prettify-mode - "Toggle Guix Prettify mode. - -With a prefix argument ARG, enable Guix Prettify mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. - -When Guix Prettify mode is enabled, hash-parts of the Guix store -file names (see `guix-prettify-regexp') are prettified, -i.e. displayed as `guix-prettify-char' character. This mode can -be enabled programmatically using hooks: - - (add-hook 'shell-mode-hook 'guix-prettify-mode) - -It is possible to enable the mode in any buffer, however not any -buffer's highlighting may survive after adding new elements to -`font-lock-keywords' (see `guix-prettify-special-modes' for -details). - -Also you can use `global-guix-prettify-mode' to enable Guix -Prettify mode for all modes that support font-locking." - :init-value nil - :lighter " …" - (let ((keywords `((,guix-prettify-regexp - (,guix-prettify-regexp-group - (guix-prettify-compose)))))) - (if guix-prettify-mode - ;; Turn on. - (font-lock-add-keywords nil keywords) - ;; Turn off. - (font-lock-remove-keywords nil keywords) - (guix-prettify-decompose-buffer)) - (and guix-prettify-flush-function - (funcall guix-prettify-flush-function)))) - -(defun guix-prettify-supported-p () - "Return non-nil, if the mode can be harmlessly enabled in current buffer." - (or font-lock-defaults - (apply #'derived-mode-p guix-prettify-special-modes))) - -(defun guix-prettify-turn-on () - "Enable `guix-prettify-mode' in the current buffer if needed. -See `guix-prettify-special-modes' for details." - (and (not guix-prettify-mode) - (guix-prettify-supported-p) - (guix-prettify-mode))) - -;;;###autoload -(define-globalized-minor-mode global-guix-prettify-mode - guix-prettify-mode guix-prettify-turn-on) - -;;;###autoload -(defalias 'guix-prettify-global-mode 'global-guix-prettify-mode) - -(provide 'guix-prettify) - -;;; guix-prettify.el ends here diff --git a/emacs/guix-profiles.el b/emacs/guix-profiles.el deleted file mode 100644 index 12cf46dbf8..0000000000 --- a/emacs/guix-profiles.el +++ /dev/null @@ -1,77 +0,0 @@ -;;; guix-profiles.el --- Guix profiles - -;; Copyright © 2014, 2015, 2016 Alex Kost -;; Copyright © 2015 Mathieu Lirzin - -;; 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 this program. If not, see . - -;;; Code: - -(require 'guix-config) - -(defvar guix-user-profile - (expand-file-name "~/.guix-profile") - "User profile.") - -(defvar guix-system-profile - (concat guix-config-state-directory "/profiles/system") - "System profile.") - -(defvar guix-default-profile - (concat guix-config-state-directory - "/profiles/per-user/" - (getenv "USER") - "/guix-profile") - "Default Guix profile.") - -(defvar guix-current-profile guix-default-profile - "Current profile.") - -(defvar guix-system-profile-regexp - (concat "\\`" (regexp-quote guix-system-profile)) - "Regexp matching system profiles.") - -(defun guix-system-profile? (profile) - "Return non-nil, if PROFILE is a system one." - (string-match-p guix-system-profile-regexp profile)) - -(defun guix-profile-prompt (&optional default) - "Prompt for profile and return it. -Use DEFAULT as a start directory. If it is nil, use -`guix-current-profile'." - (let* ((path (read-file-name "Profile: " - (file-name-directory - (or default guix-current-profile)))) - (path (directory-file-name (expand-file-name path)))) - (if (string= path guix-user-profile) - guix-default-profile - path))) - -(defun guix-set-current-profile (path) - "Set `guix-current-profile' to PATH. -Interactively, prompt for PATH. With prefix, use -`guix-default-profile'." - (interactive - (list (if current-prefix-arg - guix-default-profile - (guix-profile-prompt)))) - (setq guix-current-profile path) - (message "Current profile has been set to '%s'." - guix-current-profile)) - -(provide 'guix-profiles) - -;;; guix-profiles.el ends here diff --git a/emacs/guix-read.el b/emacs/guix-read.el deleted file mode 100644 index 5423c9bcfa..0000000000 --- a/emacs/guix-read.el +++ /dev/null @@ -1,147 +0,0 @@ -;;; guix-read.el --- Minibuffer readers - -;; Copyright © 2015, 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides functions to prompt a user for packages, system -;; types, hash formats and other guix related stuff. - -;;; Code: - -(require 'guix-help-vars) -(require 'guix-utils) -(require 'guix-backend) -(require 'guix-guile) - - -;;; Receivable lists of packages, lint checkers, etc. - -(guix-memoized-defun guix-graph-type-names () - "Return a list of names of available graph node types." - (guix-eval-read (guix-make-guile-expression 'graph-type-names))) - -(guix-memoized-defun guix-refresh-updater-names () - "Return a list of names of available refresh updater types." - (guix-eval-read (guix-make-guile-expression 'refresh-updater-names))) - -(guix-memoized-defun guix-lint-checker-names () - "Return a list of names of available lint checkers." - (guix-eval-read (guix-make-guile-expression 'lint-checker-names))) - -(guix-memoized-defun guix-package-names () - "Return a list of names of available packages." - (sort - ;; Work around : - ;; list of strings is parsed much slower than list of lists, - ;; so we use 'package-names-lists' instead of 'package-names'. - - ;; (guix-eval-read (guix-make-guile-expression 'package-names)) - - (mapcar #'car - (guix-eval-read (guix-make-guile-expression - 'package-names-lists))) - #'string<)) - -(guix-memoized-defun guix-license-names () - "Return a list of names of available licenses." - (guix-eval-read (guix-make-guile-expression 'license-names))) - -(guix-memoized-defun guix-package-locations () - "Return a list of available package locations." - (sort (guix-eval-read (guix-make-guile-expression - 'package-location-files)) - #'string<)) - - -;;; Readers - -(guix-define-readers - :completions-var guix-help-system-types - :single-reader guix-read-system-type - :single-prompt "System type: ") - -(guix-define-readers - :completions-var guix-help-source-types - :single-reader guix-read-source-type - :single-prompt "Source type: ") - -(guix-define-readers - :completions-var guix-help-hash-formats - :single-reader guix-read-hash-format - :single-prompt "Hash format: ") - -(guix-define-readers - :completions-var guix-help-refresh-subsets - :single-reader guix-read-refresh-subset - :single-prompt "Refresh subset: ") - -(guix-define-readers - :completions-getter guix-refresh-updater-names - :multiple-reader guix-read-refresh-updater-names - :multiple-prompt "Refresh updater,s: " - :multiple-separator ",") - -(guix-define-readers - :completions-var guix-help-key-policies - :single-reader guix-read-key-policy - :single-prompt "Key policy: ") - -(guix-define-readers - :completions-var guix-help-elpa-archives - :single-reader guix-read-elpa-archive - :single-prompt "ELPA archive: ") - -(guix-define-readers - :completions-var guix-help-verify-options - :multiple-reader guix-read-verify-options - :multiple-prompt "Verify option,s: " - :multiple-separator ",") - -(guix-define-readers - :completions-getter guix-graph-type-names - :single-reader guix-read-graph-type - :single-prompt "Graph node type: ") - -(guix-define-readers - :completions-getter guix-lint-checker-names - :multiple-reader guix-read-lint-checker-names - :multiple-prompt "Linter,s: " - :multiple-separator ",") - -(guix-define-readers - :completions-getter guix-package-names - :single-reader guix-read-package-name - :single-prompt "Package: " - :multiple-reader guix-read-package-names - :multiple-prompt "Package,s: " - :multiple-separator " ") - -(guix-define-readers - :completions-getter guix-license-names - :single-reader guix-read-license-name - :single-prompt "License: ") - -(guix-define-readers - :completions-getter guix-package-locations - :single-reader guix-read-package-location - :single-prompt "Location: ") - -(provide 'guix-read) - -;;; guix-read.el ends here diff --git a/emacs/guix-ui-generation.el b/emacs/guix-ui-generation.el deleted file mode 100644 index 67cf6294fb..0000000000 --- a/emacs/guix-ui-generation.el +++ /dev/null @@ -1,456 +0,0 @@ -;;; guix-ui-generation.el --- Interface for displaying generations -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015, 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides an interface for displaying profile generations in -;; 'list' and 'info' buffers, and commands for working with them. - -;;; Code: - -(require 'cl-lib) -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-info) -(require 'guix-ui) -(require 'guix-ui-package) -(require 'guix-base) -(require 'guix-backend) -(require 'guix-guile) -(require 'guix-entry) -(require 'guix-utils) -(require 'guix-profiles) - -(guix-ui-define-entry-type generation) - -(defun guix-generation-get-display (profile search-type &rest search-values) - "Search for generations and show results. - -If PROFILE is nil, use `guix-current-profile'. - -See `guix-ui-get-entries' for the meaning of SEARCH-TYPE and -SEARCH-VALUES." - (apply #'guix-list-get-display-entries - 'generation - (or profile guix-current-profile) - search-type search-values)) - -(defun guix-delete-generations (profile generations - &optional operation-buffer) - "Delete GENERATIONS from PROFILE. -Each element from GENERATIONS is a generation number." - (when (or (not guix-operation-confirm) - (y-or-n-p - (let ((count (length generations))) - (if (> count 1) - (format "Delete %d generations from profile '%s'? " - count profile) - (format "Delete generation %d from profile '%s'? " - (car generations) profile))))) - (guix-eval-in-repl - (guix-make-guile-expression - 'delete-generations* profile generations) - operation-buffer))) - -(defun guix-switch-to-generation (profile generation - &optional operation-buffer) - "Switch PROFILE to GENERATION." - (when (or (not guix-operation-confirm) - (y-or-n-p (format "Switch profile '%s' to generation %d? " - profile generation))) - (guix-eval-in-repl - (guix-make-guile-expression - 'switch-to-generation* profile generation) - operation-buffer))) - -(defun guix-system-generation? () - "Return non-nil, if current generation is a system one." - (eq (guix-buffer-current-entry-type) - 'system-generation)) - -(defun guix-generation-current-packages-profile (&optional generation) - "Return a directory where packages are installed for the -current profile's GENERATION." - (guix-packages-profile (guix-ui-current-profile) - generation - (guix-system-generation?))) - - -;;; Generation 'info' - -(guix-ui-info-define-interface generation - :buffer-name "*Guix Generation Info*" - :format '((number format guix-generation-info-insert-number) - (prev-number format (format)) - (current format guix-generation-info-insert-current) - (path simple (indent guix-file)) - (time format (time))) - :titles '((path . "File name") - (prev-number . "Previous number"))) - -(defface guix-generation-info-number - '((t :inherit font-lock-keyword-face)) - "Face used for a number of a generation." - :group 'guix-generation-info-faces) - -(defface guix-generation-info-current - '((t :inherit guix-package-info-installed-outputs)) - "Face used if a generation is the current one." - :group 'guix-generation-info-faces) - -(defface guix-generation-info-not-current - '((t nil)) - "Face used if a generation is not the current one." - :group 'guix-generation-info-faces) - -(defun guix-generation-info-insert-number (number &optional _) - "Insert generation NUMBER and action buttons." - (guix-info-insert-value-format number 'guix-generation-info-number) - (guix-info-insert-indent) - (guix-info-insert-action-button - "Packages" - (lambda (btn) - (guix-buffer-get-display-entries - 'list guix-package-list-type - (list (guix-generation-current-packages-profile - (button-get btn 'number)) - 'installed) - 'add)) - "Show installed packages for this generation" - 'number number) - (guix-info-insert-indent) - (guix-info-insert-action-button - "Delete" - (lambda (btn) - (guix-delete-generations (guix-ui-current-profile) - (list (button-get btn 'number)) - (current-buffer))) - "Delete this generation" - 'number number)) - -(defun guix-generation-info-insert-current (val entry) - "Insert boolean value VAL showing whether this generation is current." - (if val - (guix-info-insert-value-format "Yes" 'guix-generation-info-current) - (guix-info-insert-value-format "No" 'guix-generation-info-not-current) - (guix-info-insert-indent) - (guix-info-insert-action-button - "Switch" - (lambda (btn) - (guix-switch-to-generation (guix-ui-current-profile) - (button-get btn 'number) - (current-buffer))) - "Switch to this generation (make it the current one)" - 'number (guix-entry-value entry 'number)))) - - -;;; Generation 'list' - -(guix-ui-list-define-interface generation - :buffer-name "*Guix Generation List*" - :format '((number nil 5 guix-list-sort-numerically-0 :right-align t) - (current guix-generation-list-get-current 10 t) - (time guix-list-get-time 20 t) - (path guix-list-get-file-name 30 t)) - :titles '((number . "N.")) - :sort-key '(number . t) - :marks '((delete . ?D))) - -(let ((map guix-generation-list-mode-map)) - (define-key map (kbd "RET") 'guix-generation-list-show-packages) - (define-key map (kbd "+") 'guix-generation-list-show-added-packages) - (define-key map (kbd "-") 'guix-generation-list-show-removed-packages) - (define-key map (kbd "=") 'guix-generation-list-diff) - (define-key map (kbd "D") 'guix-generation-list-diff) - (define-key map (kbd "e") 'guix-generation-list-ediff) - (define-key map (kbd "x") 'guix-generation-list-execute) - (define-key map (kbd "s") 'guix-generation-list-switch) - (define-key map (kbd "c") 'guix-generation-list-switch) - (define-key map (kbd "d") 'guix-generation-list-mark-delete)) - -(defun guix-generation-list-get-current (val &optional _) - "Return string from VAL showing whether this generation is current. -VAL is a boolean value." - (if val "(current)" "")) - -(defun guix-generation-list-switch () - "Switch current profile to the generation at point." - (interactive) - (let* ((entry (guix-list-current-entry)) - (current (guix-entry-value entry 'current)) - (number (guix-entry-value entry 'number))) - (if current - (user-error "This generation is already the current one") - (guix-switch-to-generation (guix-ui-current-profile) - number (current-buffer))))) - -(defun guix-generation-list-show-packages () - "List installed packages for the generation at point." - (interactive) - (guix-package-get-display - (guix-generation-current-packages-profile (guix-list-current-id)) - 'installed)) - -(defun guix-generation-list-generations-to-compare () - "Return a sorted list of 2 marked generations for comparing." - (let ((numbers (guix-list-get-marked-id-list 'general))) - (if (/= (length numbers) 2) - (user-error "2 generations should be marked for comparing") - (sort numbers #'<)))) - -(defun guix-generation-list-profiles-to-compare () - "Return a sorted list of 2 marked generation profiles for comparing." - (mapcar #'guix-generation-current-packages-profile - (guix-generation-list-generations-to-compare))) - -(defun guix-generation-list-show-added-packages () - "List package outputs added to the latest marked generation. -If 2 generations are marked with \\[guix-list-mark], display -outputs installed in the latest marked generation that were not -installed in the other one." - (interactive) - (guix-buffer-get-display-entries - 'list 'output - (cl-list* (guix-ui-current-profile) - 'profile-diff - (reverse (guix-generation-list-profiles-to-compare))) - 'add)) - -(defun guix-generation-list-show-removed-packages () - "List package outputs removed from the latest marked generation. -If 2 generations are marked with \\[guix-list-mark], display -outputs not installed in the latest marked generation that were -installed in the other one." - (interactive) - (guix-buffer-get-display-entries - 'list 'output - (cl-list* (guix-ui-current-profile) - 'profile-diff - (guix-generation-list-profiles-to-compare)) - 'add)) - -(defun guix-generation-list-compare (diff-fun gen-fun) - "Run GEN-FUN on the 2 marked generations and run DIFF-FUN on the results." - (cl-multiple-value-bind (gen1 gen2) - (guix-generation-list-generations-to-compare) - (funcall diff-fun - (funcall gen-fun gen1) - (funcall gen-fun gen2)))) - -(defun guix-generation-list-ediff-manifests () - "Run Ediff on manifests of the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'ediff-files - #'guix-profile-generation-manifest-file)) - -(defun guix-generation-list-diff-manifests () - "Run Diff on manifests of the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'guix-diff - #'guix-profile-generation-manifest-file)) - -(defun guix-generation-list-ediff-packages () - "Run Ediff on package outputs installed in the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'ediff-buffers - #'guix-profile-generation-packages-buffer)) - -(defun guix-generation-list-diff-packages () - "Run Diff on package outputs installed in the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'guix-diff - #'guix-profile-generation-packages-buffer)) - -(defun guix-generation-list-ediff (arg) - "Run Ediff on package outputs installed in the 2 marked generations. -With ARG, run Ediff on manifests of the marked generations." - (interactive "P") - (if arg - (guix-generation-list-ediff-manifests) - (guix-generation-list-ediff-packages))) - -(defun guix-generation-list-diff (arg) - "Run Diff on package outputs installed in the 2 marked generations. -With ARG, run Diff on manifests of the marked generations." - (interactive "P") - (if arg - (guix-generation-list-diff-manifests) - (guix-generation-list-diff-packages))) - -(defun guix-generation-list-mark-delete (&optional arg) - "Mark the current generation for deletion and move to the next line. -With ARG, mark all generations for deletion." - (interactive "P") - (if arg - (guix-list-mark-all 'delete) - (guix-list--mark 'delete t))) - -(defun guix-generation-list-execute () - "Delete marked generations." - (interactive) - (let ((marked (guix-list-get-marked-id-list 'delete))) - (or marked - (user-error "No generations marked for deletion")) - (guix-delete-generations (guix-ui-current-profile) - marked (current-buffer)))) - - -;;; Inserting packages to compare generations - -(defcustom guix-generation-packages-buffer-name-function - #'guix-generation-packages-buffer-name-default - "Function used to define name of a buffer with generation packages. -This function is called with 2 arguments: PROFILE (string) and -GENERATION (number)." - :type '(choice (function-item guix-generation-packages-buffer-name-default) - (function-item guix-generation-packages-buffer-name-long) - (function :tag "Other function")) - :group 'guix-generation) - -(defcustom guix-generation-packages-update-buffer t - "If non-nil, always update list of packages during comparing generations. -If nil, generation packages are received only once. So when you -compare generation 1 and generation 2, the packages for both -generations will be received. Then if you compare generation 1 -and generation 3, only the packages for generation 3 will be -received. Thus if you use comparing of different generations a -lot, you may set this variable to nil to improve the -performance." - :type 'boolean - :group 'guix-generation) - -(defvar guix-generation-output-name-width 30 - "Width of an output name \"column\". -This variable is used in auxiliary buffers for comparing generations.") - -(defun guix-generation-packages (profile) - "Return a list of sorted packages installed in PROFILE. -Each element of the list is a list of the package specification -and its store path." - (let ((names+paths (guix-eval-read - (guix-make-guile-expression - 'profile->specifications+paths profile)))) - (sort names+paths - (lambda (a b) - (string< (car a) (car b)))))) - -(defun guix-generation-packages-buffer-name-default (profile generation) - "Return name of a buffer for displaying GENERATION's package outputs. -Use base name of PROFILE file name." - (let ((profile-name (file-name-base (directory-file-name profile)))) - (format "*Guix %s: generation %s*" - profile-name generation))) - -(defun guix-generation-packages-buffer-name-long (profile generation) - "Return name of a buffer for displaying GENERATION's package outputs. -Use the full PROFILE file name." - (format "*Guix generation %s (%s)*" - generation profile)) - -(defun guix-generation-packages-buffer-name (profile generation) - "Return name of a buffer for displaying GENERATION's package outputs." - (funcall guix-generation-packages-buffer-name-function - profile generation)) - -(defun guix-generation-insert-package (name path) - "Insert package output NAME and store PATH at point." - (insert name) - (indent-to guix-generation-output-name-width 2) - (insert path "\n")) - -(defun guix-generation-insert-packages (buffer profile) - "Insert package outputs installed in PROFILE in BUFFER." - (with-current-buffer buffer - (setq buffer-read-only nil - indent-tabs-mode nil) - (erase-buffer) - (mapc (lambda (name+path) - (guix-generation-insert-package - (car name+path) (cadr name+path))) - (guix-generation-packages profile)))) - -(defun guix-generation-packages-buffer (profile generation &optional system?) - "Return buffer with package outputs installed in PROFILE's GENERATION. -Create the buffer if needed." - (let ((buf-name (guix-generation-packages-buffer-name - profile generation))) - (or (and (null guix-generation-packages-update-buffer) - (get-buffer buf-name)) - (let ((buf (get-buffer-create buf-name))) - (guix-generation-insert-packages - buf - (guix-packages-profile profile generation system?)) - buf)))) - -(defun guix-profile-generation-manifest-file (generation) - "Return the file name of a GENERATION's manifest. -GENERATION is a generation number of the current profile." - (guix-manifest-file (guix-ui-current-profile) - generation - (guix-system-generation?))) - -(defun guix-profile-generation-packages-buffer (generation) - "Insert GENERATION's package outputs in a buffer and return it. -GENERATION is a generation number of the current profile." - (guix-generation-packages-buffer (guix-ui-current-profile) - generation - (guix-system-generation?))) - - -;;; Interactive commands - -;;;###autoload -(defun guix-generations (&optional profile) - "Display information about all generations. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive (list (guix-ui-read-profile))) - (guix-generation-get-display profile 'all)) - -;;;###autoload -(defun guix-last-generations (number &optional profile) - "Display information about last NUMBER generations. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (read-number "The number of last generations: ") - (guix-ui-read-profile))) - (guix-generation-get-display profile 'last number)) - -;;;###autoload -(defun guix-generations-by-time (from to &optional profile) - "Display information about generations created between FROM and TO. -FROM and TO should be time values. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (guix-read-date "Find generations (from): ") - (guix-read-date "Find generations (to): ") - (guix-ui-read-profile))) - (guix-generation-get-display profile 'time - (float-time from) - (float-time to))) - -(provide 'guix-ui-generation) - -;;; guix-ui-generation.el ends here diff --git a/emacs/guix-ui-license.el b/emacs/guix-ui-license.el deleted file mode 100644 index cf1b5cd357..0000000000 --- a/emacs/guix-ui-license.el +++ /dev/null @@ -1,150 +0,0 @@ -;;; guix-ui-license.el --- Interface for displaying licenses - -;; Copyright © 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides 'list'/'info' interface for displaying licenses of -;; Guix packages. - -;;; Code: - -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-info) -(require 'guix-backend) -(require 'guix-guile) -(require 'guix-license) - -(guix-define-entry-type license) - -(defun guix-license-get-entries (search-type &rest args) - "Receive 'license' entries. -SEARCH-TYPE may be one of the following symbols: `all', `id', `name'." - (guix-eval-read - (apply #'guix-make-guile-expression - 'license-entries search-type args))) - -(defun guix-license-get-display (search-type &rest args) - "Search for licenses and show results." - (apply #'guix-list-get-display-entries - 'license search-type args)) - -(defun guix-license-message (entries search-type &rest args) - "Display a message after showing license ENTRIES." - ;; Some objects in (guix licenses) module are procedures (e.g., - ;; 'non-copyleft' or 'x11-style'). Such licenses cannot be "described". - (when (null entries) - (if (cdr args) - (message "Unknown licenses.") - (message "Unknown license.")))) - - -;;; License 'info' - -(guix-info-define-interface license - :buffer-name "*Guix License Info*" - :get-entries-function 'guix-license-get-entries - :message-function 'guix-license-message - :format '((name ignore (simple guix-info-heading)) - ignore - guix-license-insert-packages-button - (url ignore (simple guix-url)) - guix-license-insert-comment - ignore - guix-license-insert-file) - :titles '((url . "URL"))) - -(declare-function guix-packages-by-license "guix-ui-package") - -(defun guix-license-insert-packages-button (entry) - "Insert button to display packages by license ENTRY." - (let ((license (guix-entry-value entry 'name))) - (guix-info-insert-action-button - "Packages" - (lambda (btn) - (guix-packages-by-license (button-get btn 'license))) - (format "Display packages with license '%s'" license) - 'license license))) - -(defun guix-license-insert-comment (entry) - "Insert 'comment' of a license ENTRY." - (let ((comment (guix-entry-value entry 'comment))) - (if (and comment - (string-match-p "^http" comment)) - (guix-info-insert-value-simple comment 'guix-url) - (guix-info-insert-title-simple - (guix-info-param-title 'license 'comment)) - (guix-info-insert-value-indent comment)))) - -(defun guix-license-insert-file (entry) - "Insert button to open license definition." - (let ((license (guix-entry-value entry 'name))) - (guix-insert-button - (guix-license-file) 'guix-file - 'help-echo (format "Open definition of license '%s'" license) - 'action (lambda (btn) - (guix-find-license-definition (button-get btn 'license))) - 'license license))) - - -;;; License 'list' - -(guix-list-define-interface license - :buffer-name "*Guix Licenses*" - :get-entries-function 'guix-license-get-entries - :describe-function 'guix-license-list-describe - :message-function 'guix-license-message - :format '((name nil 40 t) - (url guix-list-get-url 50 t)) - :titles '((name . "License")) - :sort-key '(name)) - -(let ((map guix-license-list-mode-map)) - (define-key map (kbd "e") 'guix-license-list-edit) - (define-key map (kbd "RET") 'guix-license-list-show-packages)) - -(defun guix-license-list-describe (ids) - "Describe licenses with IDS (list of identifiers)." - (guix-buffer-display-entries - (guix-entries-by-ids ids (guix-buffer-current-entries)) - 'info 'license (cl-list* 'id ids) 'add)) - -(defun guix-license-list-show-packages () - "Display packages with the license at point." - (interactive) - (guix-packages-by-license (guix-list-current-id))) - -(defun guix-license-list-edit (&optional directory) - "Go to the location of the current license definition. -See `guix-license-file' for the meaning of DIRECTORY." - (interactive (list (guix-read-directory))) - (guix-find-license-definition (guix-list-current-id) directory)) - - -;;; Interactive commands - -;;;###autoload -(defun guix-licenses () - "Display licenses of the Guix packages." - (interactive) - (guix-license-get-display 'all)) - -(provide 'guix-ui-license) - -;;; guix-ui-license.el ends here diff --git a/emacs/guix-ui-location.el b/emacs/guix-ui-location.el deleted file mode 100644 index 0027c1fba8..0000000000 --- a/emacs/guix-ui-location.el +++ /dev/null @@ -1,83 +0,0 @@ -;;; guix-ui-location.el --- Interface for displaying package locations - -;; Copyright © 2016 Alex Kost - -;; 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 Location as published by -;; the Free Software Foundation, either version 3 of the Location, 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 Location for more details. - -;; You should have received a copy of the GNU General Public Location -;; along with this program. If not, see . - -;;; Commentary: - -;; This file provides a 'list' interface for displaying locations of Guix -;; packages. - -;;; Code: - -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-location) -(require 'guix-backend) - -(guix-define-entry-type location) - -(defun guix-location-get-entries () - "Receive 'package location' entries." - (guix-eval-read "(package-location-entries)")) - - -;;; Location 'list' - -(guix-list-define-interface location - :buffer-name "*Guix Package Locations*" - :get-entries-function 'guix-location-get-entries - :format '((location guix-location-list-file-name-specification 50 t) - (number-of-packages nil 10 guix-list-sort-numerically-1 - :right-align t)) - :sort-key '(location)) - -(let ((map guix-location-list-mode-map)) - (define-key map (kbd "RET") 'guix-location-list-show-packages) - ;; "Location Info" buffer is not defined (it would be useless), so - ;; unbind "i" key (by default, it is used to display Info buffer). - (define-key map (kbd "i") nil)) - -(defun guix-location-list-file-name-specification (location &optional _) - "Return LOCATION button specification for `tabulated-list-entries'." - (list location - 'face 'guix-list-file-name - 'action (lambda (btn) - (guix-find-location (button-get btn 'location))) - 'follow-link t - 'help-echo (concat "Find location: " location) - 'location location)) - -(declare-function guix-packages-by-location "guix-ui-package") - -(defun guix-location-list-show-packages () - "Display packages placed in the location at point." - (interactive) - (guix-packages-by-location (guix-list-current-id))) - - -;;; Interactive commands - -;;;###autoload -(defun guix-locations () - "Display locations of the Guix packages." - (interactive) - (guix-list-get-display-entries 'location)) - -(provide 'guix-ui-location) - -;;; guix-ui-location.el ends here diff --git a/emacs/guix-ui-package.el b/emacs/guix-ui-package.el deleted file mode 100644 index 4280246bb8..0000000000 --- a/emacs/guix-ui-package.el +++ /dev/null @@ -1,1191 +0,0 @@ -;;; guix-ui-package.el --- Interface for displaying packages -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015, 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides an interface for displaying packages and outputs -;; in 'list' and 'info' buffers, and commands for working with them. - -;;; Code: - -(require 'cl-lib) -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-info) -(require 'guix-ui) -(require 'guix-base) -(require 'guix-backend) -(require 'guix-guile) -(require 'guix-entry) -(require 'guix-utils) -(require 'guix-hydra) -(require 'guix-hydra-build) -(require 'guix-read) -(require 'guix-license) -(require 'guix-location) -(require 'guix-profiles) - -(guix-ui-define-entry-type package) -(guix-ui-define-entry-type output) - -(defcustom guix-package-list-type 'output - "Define how to display packages in 'list' buffer. -Should be a symbol `package' or `output' (if `output', display each -output on a separate line; if `package', display each package on -a separate line)." - :type '(choice (const :tag "List of packages" package) - (const :tag "List of outputs" output)) - :group 'guix-package) - -(defcustom guix-package-info-type 'package - "Define how to display packages in 'info' buffer. -Should be a symbol `package' or `output' (if `output', display -each output separately; if `package', display outputs inside -package data)." - :type '(choice (const :tag "Display packages" package) - (const :tag "Display outputs" output)) - :group 'guix-package) - -(defun guix-package-get-display (profile search-type &rest search-values) - "Search for packages/outputs and show results. - -If PROFILE is nil, use `guix-current-profile'. - -See `guix-ui-get-entries' for the meaning of SEARCH-TYPE and -SEARCH-VALUES. - -Results are displayed in the list buffer, unless a single package -is found and `guix-package-list-single' is nil." - (let* ((args (cl-list* (or profile guix-current-profile) - search-type search-values)) - (entries (guix-buffer-get-entries - 'list guix-package-list-type args))) - (if (or guix-package-list-single - (null entries) - (cdr entries)) - (guix-buffer-display-entries - entries 'list guix-package-list-type args 'add) - (guix-buffer-get-display-entries - 'info guix-package-info-type args 'add)))) - -(defun guix-package-entry->name-specification (entry &optional output) - "Return name specification of the package ENTRY and OUTPUT." - (guix-package-name-specification - (guix-entry-value entry 'name) - (guix-entry-value entry 'version) - (or output (guix-entry-value entry 'output)))) - -(defun guix-package-entries->name-specifications (entries) - "Return name specifications by the package or output ENTRIES." - (cl-remove-duplicates (mapcar #'guix-package-entry->name-specification - entries) - :test #'string=)) - -(defun guix-package-installed-outputs (entry) - "Return a list of installed outputs for the package ENTRY." - (mapcar (lambda (installed-entry) - (guix-entry-value installed-entry 'output)) - (guix-entry-value entry 'installed))) - -(defun guix-package-id-and-output-by-output-id (output-id) - "Return a list (PACKAGE-ID OUTPUT) by OUTPUT-ID." - (cl-multiple-value-bind (package-id-str output) - (split-string output-id ":") - (let ((package-id (string-to-number package-id-str))) - (list (if (= 0 package-id) package-id-str package-id) - output)))) - -(defun guix-package-build-log-file (id) - "Return build log file name of a package defined by ID." - (guix-eval-read - (guix-make-guile-expression 'package-build-log-file id))) - -(defun guix-package-find-build-log (id) - "Show build log of a package defined by ID." - (require 'guix-build-log) - (let ((file (guix-package-build-log-file id))) - (if file - (guix-build-log-find-file file) - (message "Couldn't find the package build log.")))) - - -;;; Processing package actions - -(defun guix-process-package-actions (profile actions - &optional operation-buffer) - "Process package ACTIONS on PROFILE. -Each action is a list of the form: - - (ACTION-TYPE PACKAGE-SPEC ...) - -ACTION-TYPE is one of the following symbols: `install', -`upgrade', `remove'/`delete'. -PACKAGE-SPEC should have the following form: (ID [OUTPUT] ...)." - (let (install upgrade remove) - (mapc (lambda (action) - (let ((action-type (car action)) - (specs (cdr action))) - (cl-case action-type - (install (setq install (append install specs))) - (upgrade (setq upgrade (append upgrade specs))) - ((remove delete) (setq remove (append remove specs)))))) - actions) - (when (guix-continue-package-operation-p - profile - :install install :upgrade upgrade :remove remove) - (guix-eval-in-repl - (guix-make-guile-expression - 'process-package-actions profile - :install install :upgrade upgrade :remove remove - :use-substitutes? (or guix-use-substitutes 'f) - :dry-run? (or guix-dry-run 'f)) - (and (not guix-dry-run) operation-buffer))))) - -(cl-defun guix-continue-package-operation-p (profile - &key install upgrade remove) - "Return non-nil if a package operation should be continued. -Ask a user if needed (see `guix-operation-confirm'). -INSTALL, UPGRADE, REMOVE are 'package action specifications'. -See `guix-process-package-actions' for details." - (or (null guix-operation-confirm) - (let* ((entries (guix-ui-get-entries - profile 'package 'id - (append (mapcar #'car install) - (mapcar #'car upgrade) - (mapcar #'car remove)) - '(id name version location))) - (install-strings (guix-get-package-strings install entries)) - (upgrade-strings (guix-get-package-strings upgrade entries)) - (remove-strings (guix-get-package-strings remove entries))) - (if (or install-strings upgrade-strings remove-strings) - (let ((buf (get-buffer-create guix-temp-buffer-name))) - (with-current-buffer buf - (setq-local cursor-type nil) - (setq buffer-read-only nil) - (erase-buffer) - (insert "Profile: " profile "\n\n") - (guix-insert-package-strings install-strings "install") - (guix-insert-package-strings upgrade-strings "upgrade") - (guix-insert-package-strings remove-strings "remove") - (let ((win (temp-buffer-window-show - buf - '((display-buffer-reuse-window - display-buffer-at-bottom) - (window-height . fit-window-to-buffer))))) - (prog1 (guix-operation-prompt) - (quit-window nil win))))) - (message "Nothing to be done. -If Guix REPL was restarted, the data is not up-to-date.") - nil)))) - -(defun guix-get-package-strings (specs entries) - "Return short package descriptions for performing package actions. -See `guix-process-package-actions' for the meaning of SPECS. -ENTRIES is a list of package entries to get info about packages." - (delq nil - (mapcar - (lambda (spec) - (let* ((id (car spec)) - (outputs (cdr spec)) - (entry (guix-entry-by-id id entries))) - (when entry - (let ((location (guix-entry-value entry 'location))) - (concat (guix-package-entry->name-specification entry) - (when outputs - (concat ":" - (guix-concat-strings outputs ","))) - (when location - (concat "\t(" location ")"))))))) - specs))) - -(defun guix-insert-package-strings (strings action) - "Insert information STRINGS at point for performing package ACTION." - (when strings - (insert "Package(s) to " (propertize action 'face 'bold) ":\n") - (mapc (lambda (str) - (insert " " str "\n")) - strings) - (insert "\n"))) - - -;;; Package 'info' - -(guix-ui-info-define-interface package - :buffer-name "*Guix Package Info*" - :format '(guix-package-info-insert-heading - ignore - (synopsis ignore (simple guix-package-info-synopsis)) - ignore - (description ignore (simple guix-package-info-description)) - ignore - (outputs simple guix-package-info-insert-outputs) - guix-package-info-insert-misc - (source simple guix-package-info-insert-source) - (location simple guix-package-info-insert-location) - (home-url format (format guix-url)) - (license format (format guix-package-license)) - (systems format guix-package-info-insert-systems) - (inputs format (format guix-package-input)) - (native-inputs format (format guix-package-native-input)) - (propagated-inputs format - (format guix-package-propagated-input))) - :titles '((home-url . "Home page") - (systems . "Supported systems")) - :required '(id name version installed non-unique)) - -(guix-info-define-interface installed-output - :format '((path simple (indent guix-file)) - (dependencies simple (indent guix-file))) - :titles '((path . "Store directory")) - :reduced? t) - -(defface guix-package-info-heading - '((t :inherit guix-info-heading)) - "Face for package name and version headings." - :group 'guix-package-info-faces) - -(defface guix-package-info-name - '((t :inherit font-lock-keyword-face)) - "Face used for a name of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-name-button - '((t :inherit button)) - "Face used for a full name that can be used to describe a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-version - '((t :inherit font-lock-builtin-face)) - "Face used for a version of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-synopsis - '((((type tty pc) (class color)) :weight bold) - (t :height 1.1 :weight bold :inherit variable-pitch)) - "Face used for a synopsis of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-description - '((t)) - "Face used for a description of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-license - '((t :inherit font-lock-string-face)) - "Face used for a license of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-location - '((t :inherit link)) - "Face used for a location of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-source - '((t :inherit link :underline nil)) - "Face used for a source URL of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-installed-outputs - '((default :weight bold) - (((class color) (min-colors 88) (background light)) - :foreground "ForestGreen") - (((class color) (min-colors 88) (background dark)) - :foreground "PaleGreen") - (((class color) (min-colors 8)) - :foreground "green") - (t :underline t)) - "Face used for installed outputs of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-uninstalled-outputs - '((t :weight bold)) - "Face used for uninstalled outputs of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-obsolete - '((t :inherit error)) - "Face used if a package is obsolete." - :group 'guix-package-info-faces) - -(defcustom guix-package-info-auto-find-package t - "If non-nil, open store directory after pressing \"Show\" package button. -If nil, just display the store directory (or directories) without finding." - :type 'boolean - :group 'guix-package-info) - -(defcustom guix-package-info-auto-find-source nil - "If non-nil, open source file after pressing \"Show\" source button. -If nil, just display the source file name without finding." - :type 'boolean - :group 'guix-package-info) - -(defcustom guix-package-info-auto-download-source t - "If nil, do not automatically download a source file if it doesn't exist. -After pressing a \"Show\" button, a derivation of the package -source is calculated and a store file path is displayed. If this -variable is non-nil and the source file does not exist in the -store, it will be automatically downloaded (with a possible -prompt depending on `guix-operation-confirm' variable)." - :type 'boolean - :group 'guix-package-info) - -(defcustom guix-package-info-button-functions - '(guix-package-info-insert-build-button - guix-package-info-insert-build-log-button) - "List of functions used to insert package buttons in Info buffer. -Each function is called with 2 arguments: package ID and full name." - :type '(repeat function) - :group 'guix-package-info) - -(defvar guix-package-info-download-buffer nil - "Buffer from which a current download operation was performed.") - -(defvar guix-package-info-output-format "%-10s" - "String used to format output names of the packages. -It should be a '%s'-sequence. After inserting an output name -formatted with this string, an action button is inserted.") - -(defvar guix-package-info-obsolete-string "(This package is obsolete)" - "String used if a package is obsolete.") - -(define-button-type 'guix-package-location - :supertype 'guix - 'face 'guix-package-info-location - 'help-echo "Find location of this package" - 'action (lambda (btn) - (guix-find-location (button-label btn)))) - -(define-button-type 'guix-package-license - :supertype 'guix - 'face 'guix-package-info-license - 'help-echo "Display license info" - 'action (lambda (btn) - (require 'guix-ui-license) - (guix-buffer-get-display-entries - 'info 'license - (list 'name (button-label btn)) - 'add))) - -(define-button-type 'guix-package-name - :supertype 'guix - 'face 'guix-package-info-name-button - 'help-echo "Describe this package" - 'action (lambda (btn) - (guix-buffer-get-display-entries-current - 'info guix-package-info-type - (list (guix-ui-current-profile) - 'name (or (button-get btn 'spec) - (button-label btn))) - 'add))) - -(define-button-type 'guix-package-heading - :supertype 'guix-package-name - 'face 'guix-package-info-heading) - -(define-button-type 'guix-package-source - :supertype 'guix - 'face 'guix-package-info-source - 'help-echo "" - 'action (lambda (_) - ;; As a source may not be a real URL (e.g., "mirror://..."), - ;; no action is bound to a source button. - (message "Yes, this is the source URL. What did you expect?"))) - -(defun guix-package-info-insert-heading (entry) - "Insert package ENTRY heading (name and version) at point." - (guix-insert-button - (concat (guix-entry-value entry 'name) " " - (guix-entry-value entry 'version)) - 'guix-package-heading - 'spec (guix-package-entry->name-specification entry))) - -(defun guix-package-info-insert-location (location &optional _) - "Insert package LOCATION at point." - (if (null location) - (guix-format-insert nil) - (let ((location-file (car (split-string location ":")))) - (guix-info-insert-value-indent location 'guix-package-location) - ;; Do not show "Packages" button if a package 'from file' is displayed. - (unless (eq (guix-ui-current-search-type) 'from-file) - (guix-info-insert-indent) - (guix-info-insert-action-button - "Packages" - (lambda (btn) - (guix-package-get-display (guix-ui-current-profile) - 'location - (button-get btn 'location))) - (format "Display packages from location '%s'" location-file) - 'location location-file))))) - -(defun guix-package-info-insert-systems (systems entry) - "Insert supported package SYSTEMS at point." - (guix-info-insert-value-format - systems 'guix-hydra-build-system - 'action (lambda (btn) - (let ((args (guix-hydra-build-latest-prompt-args - :job (button-get btn 'job-name) - :system (button-label btn)))) - (apply #'guix-hydra-build-get-display - 'latest args))) - 'job-name (guix-hydra-job-name-specification - (guix-entry-value entry 'name) - (guix-entry-value entry 'version)))) - -(defmacro guix-package-info-define-insert-inputs (&optional type) - "Define a face and a function for inserting package inputs. -TYPE is a type of inputs. -Function name is `guix-package-info-insert-TYPE-inputs'. -Face name is `guix-package-info-TYPE-inputs'." - (let* ((type-str (symbol-name type)) - (type-name (and type (concat type-str "-"))) - (type-desc (and type (concat type-str " "))) - (face (intern (concat "guix-package-info-" type-name "inputs"))) - (btn (intern (concat "guix-package-" type-name "input")))) - `(progn - (defface ,face - '((t :inherit guix-package-info-name-button)) - ,(concat "Face used for " type-desc "inputs of a package.") - :group 'guix-package-info-faces) - - (define-button-type ',btn - :supertype 'guix-package-name - 'face ',face)))) - -(guix-package-info-define-insert-inputs) -(guix-package-info-define-insert-inputs native) -(guix-package-info-define-insert-inputs propagated) - -(defun guix-package-info-insert-outputs (outputs entry) - "Insert OUTPUTS from package ENTRY at point." - (and (guix-entry-value entry 'obsolete) - (guix-package-info-insert-obsolete-text)) - (and (guix-entry-value entry 'non-unique) - (guix-entry-value entry 'installed) - (guix-package-info-insert-non-unique-text - (guix-package-entry->name-specification entry))) - (insert "\n") - (dolist (output outputs) - (guix-package-info-insert-output output entry))) - -(defun guix-package-info-insert-obsolete-text () - "Insert a message about obsolete package at point." - (guix-info-insert-indent) - (guix-format-insert guix-package-info-obsolete-string - 'guix-package-info-obsolete)) - -(defun guix-package-info-insert-non-unique-text (full-name) - "Insert a message about non-unique package with FULL-NAME at point." - (insert "\n") - (guix-info-insert-indent) - (insert "Installed outputs are displayed for a non-unique ") - (guix-insert-button full-name 'guix-package-name) - (insert " package.")) - -(defun guix-package-info-insert-output (output entry) - "Insert OUTPUT at point. -Make some fancy text with buttons and additional stuff if the -current OUTPUT is installed (if there is such output in -`installed' parameter of a package ENTRY)." - (let* ((installed (guix-entry-value entry 'installed)) - (obsolete (guix-entry-value entry 'obsolete)) - (installed-entry (cl-find-if - (lambda (entry) - (string= (guix-entry-value entry 'output) - output)) - installed)) - (action-type (if installed-entry 'delete 'install)) - (profile (guix-ui-current-profile))) - (guix-info-insert-indent) - (guix-format-insert output - (if installed-entry - 'guix-package-info-installed-outputs - 'guix-package-info-uninstalled-outputs) - guix-package-info-output-format) - ;; Do not allow a user to install/delete anything to/from a system - ;; profile, so add action buttons only for non-system profiles. - (when (and profile - (not (guix-system-profile? profile))) - (guix-package-info-insert-action-button action-type entry output) - (when obsolete - (guix-info-insert-indent) - (guix-package-info-insert-action-button 'upgrade entry output))) - (insert "\n") - (when installed-entry - (guix-info-insert-entry installed-entry 'installed-output 2)))) - -(defun guix-package-info-insert-action-button (type entry output) - "Insert button to process an action on a package OUTPUT at point. -TYPE is one of the following symbols: `install', `delete', `upgrade'. -ENTRY is an alist with package info." - (let ((type-str (capitalize (symbol-name type))) - (full-name (guix-package-entry->name-specification entry output))) - (guix-info-insert-action-button - type-str - (lambda (btn) - (guix-process-package-actions - (guix-ui-current-profile) - `((,(button-get btn 'action-type) (,(button-get btn 'id) - ,(button-get btn 'output)))) - (current-buffer))) - (concat type-str " '" full-name "'") - 'action-type type - 'id (or (guix-entry-value entry 'package-id) - (guix-entry-id entry)) - 'output output))) - -(defun guix-package-info-show-store-path (entry-id package-id) - "Show store directories of the package outputs in the current buffer. -ENTRY-ID is an ID of the current entry (package or output). -PACKAGE-ID is an ID of the package which store path to show." - (let* ((entries (guix-buffer-current-entries)) - (entry (guix-entry-by-id entry-id entries)) - (dirs (guix-package-store-path package-id))) - (or dirs - (error "Couldn't define store directory of the package")) - (let* ((new-entry (cons (cons 'store-path dirs) - entry)) - (new-entries (guix-replace-entry entry-id new-entry entries))) - (setf (guix-buffer-item-entries guix-buffer-item) - new-entries) - (guix-buffer-redisplay-goto-button) - (let ((dir (car dirs))) - (if (file-exists-p dir) - (if guix-package-info-auto-find-package - (find-file dir) - (message nil)) - (message "'%s' does not exist.\nTry to build this package." - dir)))))) - -(defun guix-package-info-insert-misc (entry) - "Insert various buttons and other info for package ENTRY at point." - (if (guix-entry-value entry 'obsolete) - (guix-format-insert nil) - (let* ((entry-id (guix-entry-id entry)) - (package-id (or (guix-entry-value entry 'package-id) - entry-id)) - (full-name (guix-package-entry->name-specification entry)) - (store-path (guix-entry-value entry 'store-path))) - (guix-info-insert-title-simple "Package") - (if store-path - (guix-info-insert-value-indent store-path 'guix-file) - (guix-info-insert-action-button - "Show" - (lambda (btn) - (guix-package-info-show-store-path - (button-get btn 'entry-id) - (button-get btn 'package-id))) - "Show the store directory of the current package" - 'entry-id entry-id - 'package-id package-id)) - (when guix-package-info-button-functions - (insert "\n") - (guix-mapinsert (lambda (fun) - (funcall fun package-id full-name)) - guix-package-info-button-functions - (guix-info-get-indent) - :indent guix-info-indent - :column (guix-info-fill-column)))))) - -(defun guix-package-info-insert-build-button (id full-name) - "Insert button to build a package defined by ID." - (guix-info-insert-action-button - "Build" - (lambda (btn) - (guix-build-package (button-get btn 'id) - (format "Build '%s' package?" full-name))) - (format "Build the current package") - 'id id)) - -(defun guix-package-info-insert-build-log-button (id _name) - "Insert button to show build log of a package defined by ID." - (guix-info-insert-action-button - "Build Log" - (lambda (btn) - (guix-package-find-build-log (button-get btn 'id))) - "View build log of the current package" - 'id id)) - -(defun guix-package-info-show-source (entry-id package-id) - "Show file name of a package source in the current info buffer. -Find the file if needed (see `guix-package-info-auto-find-source'). -ENTRY-ID is an ID of the current entry (package or output). -PACKAGE-ID is an ID of the package which source to show." - (let* ((entries (guix-buffer-current-entries)) - (entry (guix-entry-by-id entry-id entries)) - (file (guix-package-source-path package-id))) - (or file - (error "Couldn't define file name of the package source")) - (let* ((new-entry (cons (cons 'source-file file) - entry)) - (new-entries (guix-replace-entry entry-id new-entry entries))) - (setf (guix-buffer-item-entries guix-buffer-item) - new-entries) - (guix-buffer-redisplay-goto-button) - (if (file-exists-p file) - (if guix-package-info-auto-find-source - (guix-find-file file) - (message "The source store path is displayed.")) - (if guix-package-info-auto-download-source - (guix-package-info-download-source package-id) - (message "The source does not exist in the store.")))))) - -(defun guix-package-info-download-source (package-id) - "Download a source of the package PACKAGE-ID." - (setq guix-package-info-download-buffer (current-buffer)) - (guix-package-source-build-derivation - package-id - "The source does not exist in the store. Download it?")) - -(defun guix-package-info-insert-source (source entry) - "Insert SOURCE from package ENTRY at point. -SOURCE is a list of URLs." - (if (null source) - (guix-format-insert nil) - (let* ((source-file (guix-entry-value entry 'source-file)) - (entry-id (guix-entry-id entry)) - (package-id (or (guix-entry-value entry 'package-id) - entry-id))) - (if (null source-file) - (guix-info-insert-action-button - "Show" - (lambda (btn) - (guix-package-info-show-source (button-get btn 'entry-id) - (button-get btn 'package-id))) - "Show the source store directory of the current package" - 'entry-id entry-id - 'package-id package-id) - (unless (file-exists-p source-file) - (guix-info-insert-action-button - "Download" - (lambda (btn) - (guix-package-info-download-source - (button-get btn 'package-id))) - "Download the source into the store" - 'package-id package-id)) - (guix-info-insert-value-indent source-file 'guix-file)) - (guix-info-insert-value-indent source 'guix-package-source)))) - -(defun guix-package-info-redisplay-after-download () - "Redisplay an 'info' buffer after downloading the package source. -This function is used to hide a \"Download\" button if needed." - (when (buffer-live-p guix-package-info-download-buffer) - (with-current-buffer guix-package-info-download-buffer - (guix-buffer-redisplay-goto-button)) - (setq guix-package-info-download-buffer nil))) - -(add-hook 'guix-after-source-download-hook - 'guix-package-info-redisplay-after-download) - - -;;; Package 'list' - -(guix-ui-list-define-interface package - :buffer-name "*Guix Package List*" - :format '((name guix-package-list-get-name 20 t) - (version nil 10 nil) - (outputs nil 13 t) - (installed guix-package-list-get-installed-outputs 13 t) - (synopsis guix-list-get-one-line 30 nil)) - :sort-key '(name) - :marks '((install . ?I) - (upgrade . ?U) - (delete . ?D))) - -(let ((map guix-package-list-mode-map)) - (define-key map (kbd "B") 'guix-package-list-latest-builds) - (define-key map (kbd "e") 'guix-package-list-edit) - (define-key map (kbd "x") 'guix-package-list-execute) - (define-key map (kbd "i") 'guix-package-list-mark-install) - (define-key map (kbd "d") 'guix-package-list-mark-delete) - (define-key map (kbd "U") 'guix-package-list-mark-upgrade) - (define-key map (kbd "^") 'guix-package-list-mark-upgrades)) - -(defface guix-package-list-installed - '((t :inherit guix-package-info-installed-outputs)) - "Face used if there are installed outputs for the current package." - :group 'guix-package-list-faces) - -(defface guix-package-list-obsolete - '((t :inherit guix-package-info-obsolete)) - "Face used if a package is obsolete." - :group 'guix-package-list-faces) - -(defcustom guix-package-list-generation-marking-enabled nil - "If non-nil, allow putting marks in a list with 'generation packages'. - -By default this is disabled, because it may be confusing. For -example, a package is installed in some generation, so a user can -mark it for deletion in the list of packages from this -generation, but the package may not be installed in the latest -generation, so actually it cannot be deleted. - -If you managed to understand the explanation above or if you -really know what you do or if you just don't care, you can set -this variable to t. It should not do much harm anyway (most -likely)." - :type 'boolean - :group 'guix-package-list) - -(defun guix-package-list-get-name (name entry) - "Return NAME of the package ENTRY. -Colorize it with `guix-package-list-installed' or -`guix-package-list-obsolete' if needed." - (guix-get-string name - (cond ((guix-entry-value entry 'obsolete) - 'guix-package-list-obsolete) - ((guix-entry-value entry 'installed) - 'guix-package-list-installed)))) - -(defun guix-package-list-get-installed-outputs (installed &optional _) - "Return string with outputs from INSTALLED entries." - (guix-get-string - (mapcar (lambda (entry) - (guix-entry-value entry 'output)) - installed))) - -(defun guix-package-list-marking-check () - "Signal an error if marking is disabled for the current buffer." - (when (and (not guix-package-list-generation-marking-enabled) - (or (derived-mode-p 'guix-package-list-mode) - (derived-mode-p 'guix-output-list-mode)) - (eq (guix-ui-current-search-type) 'generation)) - (error "Action marks are disabled for lists of 'generation packages'"))) - -(defun guix-package-list-mark-outputs (mark default - &optional prompt available) - "Mark the current package with MARK and move to the next line. -If PROMPT is non-nil, use it to ask a user for outputs from -AVAILABLE list, otherwise mark all DEFAULT outputs." - (let ((outputs (if prompt - (guix-completing-read-multiple - prompt available nil t) - default))) - (apply #'guix-list--mark mark t outputs))) - -(defun guix-package-list-mark-install (&optional arg) - "Mark the current package for installation and move to the next line. -With ARG, prompt for the outputs to install (several outputs may -be separated with \",\")." - (interactive "P") - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (all (guix-entry-value entry 'outputs)) - (installed (guix-package-installed-outputs entry)) - (available (cl-set-difference all installed :test #'string=))) - (or available - (user-error "This package is already installed")) - (guix-package-list-mark-outputs - 'install '("out") - (and arg "Output(s) to install: ") - available))) - -(defun guix-package-list-mark-delete (&optional arg) - "Mark the current package for deletion and move to the next line. -With ARG, prompt for the outputs to delete (several outputs may -be separated with \",\")." - (interactive "P") - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-package-installed-outputs entry))) - (or installed - (user-error "This package is not installed")) - (guix-package-list-mark-outputs - 'delete installed - (and arg "Output(s) to delete: ") - installed))) - -(defun guix-package-list-mark-upgrade (&optional arg) - "Mark the current package for upgrading and move to the next line. -With ARG, prompt for the outputs to upgrade (several outputs may -be separated with \",\")." - (interactive "P") - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-package-installed-outputs entry))) - (or installed - (user-error "This package is not installed")) - (when (or (guix-entry-value entry 'obsolete) - (y-or-n-p "This package is not obsolete. Try to upgrade it anyway? ")) - (guix-package-list-mark-outputs - 'upgrade installed - (and arg "Output(s) to upgrade: ") - installed)))) - -(defun guix-package-mark-upgrades (fun) - "Mark all obsolete packages for upgrading. -Use FUN to perform marking of the current line. FUN should -take an entry as argument." - (guix-package-list-marking-check) - (let ((obsolete (cl-remove-if-not - (lambda (entry) - (guix-entry-value entry 'obsolete)) - (guix-buffer-current-entries)))) - (guix-list-for-each-line - (lambda () - (let* ((id (guix-list-current-id)) - (entry (cl-find-if - (lambda (entry) - (equal id (guix-entry-id entry))) - obsolete))) - (when entry - (funcall fun entry))))))) - -(defun guix-package-list-mark-upgrades () - "Mark all obsolete packages for upgrading." - (interactive) - (guix-package-mark-upgrades - (lambda (entry) - (apply #'guix-list--mark - 'upgrade nil - (guix-package-installed-outputs entry))))) - -(defun guix-package-assert-non-system-profile () - "Verify that the current profile is not a system one. -The current profile is the one used by the current buffer." - (let ((profile (guix-ui-current-profile))) - (and profile - (guix-system-profile? profile) - (user-error "Packages cannot be installed or removed to/from \ -profile '%s'. -Use 'guix system reconfigure' shell command to modify a system profile." - profile)))) - -(defun guix-package-execute-actions (fun) - "Perform actions on the marked packages. -Use FUN to define actions suitable for `guix-process-package-actions'. -FUN should take action-type as argument." - (guix-package-assert-non-system-profile) - (let ((actions (delq nil - (mapcar fun '(install delete upgrade))))) - (if actions - (guix-process-package-actions (guix-ui-current-profile) - actions (current-buffer)) - (user-error "No operations specified")))) - -(defun guix-package-list-execute () - "Perform actions on the marked packages." - (interactive) - (guix-package-execute-actions #'guix-package-list-make-action)) - -(defun guix-package-list-make-action (action-type) - "Return action specification for the packages marked with ACTION-TYPE. -Return nil, if there are no packages marked with ACTION-TYPE. -The specification is suitable for `guix-process-package-actions'." - (let ((specs (guix-list-get-marked-args action-type))) - (and specs (cons action-type specs)))) - -(defun guix-package-list-edit (&optional directory) - "Go to the location of the current package. -See `guix-find-location' for the meaning of DIRECTORY." - (interactive (list (guix-read-directory))) - (guix-edit (guix-list-current-id) directory)) - -(defun guix-package-list-latest-builds (number &rest args) - "Display latest NUMBER of Hydra builds of the current package. -Interactively, prompt for NUMBER. With prefix argument, prompt -for all ARGS." - (interactive - (let ((entry (guix-list-current-entry))) - (guix-hydra-build-latest-prompt-args - :job (guix-hydra-job-name-specification - (guix-entry-value entry 'name) - (guix-entry-value entry 'version))))) - (apply #'guix-hydra-latest-builds number args)) - - -;;; Output 'info' - -(guix-ui-info-define-interface output - :buffer-name "*Guix Package Info*" - :format '((name format (format guix-package-info-name)) - (version format guix-output-info-insert-version) - (output format guix-output-info-insert-output) - (synopsis simple (indent guix-package-info-synopsis)) - guix-package-info-insert-misc - (source simple guix-package-info-insert-source) - (path simple (indent guix-file)) - (dependencies simple (indent guix-file)) - (location simple guix-package-info-insert-location) - (home-url format (format guix-url)) - (license format (format guix-package-license)) - (systems format guix-package-info-insert-systems) - (inputs format (format guix-package-input)) - (native-inputs format (format guix-package-native-input)) - (propagated-inputs format - (format guix-package-propagated-input)) - (description simple (indent guix-package-info-description))) - :titles guix-package-info-titles - :required '(id package-id installed non-unique)) - -(defun guix-output-info-insert-version (version entry) - "Insert output VERSION and obsolete text if needed at point." - (guix-info-insert-value-format version - 'guix-package-info-version) - (and (guix-entry-value entry 'obsolete) - (guix-package-info-insert-obsolete-text))) - -(defun guix-output-info-insert-output (output entry) - "Insert OUTPUT and action buttons at point." - (let* ((installed (guix-entry-value entry 'installed)) - (obsolete (guix-entry-value entry 'obsolete)) - (action-type (if installed 'delete 'install))) - (guix-info-insert-value-format - output - (if installed - 'guix-package-info-installed-outputs - 'guix-package-info-uninstalled-outputs)) - (guix-info-insert-indent) - (guix-package-info-insert-action-button action-type entry output) - (when obsolete - (guix-info-insert-indent) - (guix-package-info-insert-action-button 'upgrade entry output)))) - - -;;; Output 'list' - -(guix-ui-list-define-interface output - :buffer-name "*Guix Package List*" - :describe-function 'guix-output-list-describe - :format '((name guix-package-list-get-name 20 t) - (version nil 10 nil) - (output nil 9 t) - (installed nil 12 t) - (synopsis guix-list-get-one-line 30 nil)) - :required '(id package-id) - :sort-key '(name) - :marks '((install . ?I) - (upgrade . ?U) - (delete . ?D))) - -(let ((map guix-output-list-mode-map)) - (define-key map (kbd "B") 'guix-package-list-latest-builds) - (define-key map (kbd "e") 'guix-output-list-edit) - (define-key map (kbd "x") 'guix-output-list-execute) - (define-key map (kbd "i") 'guix-output-list-mark-install) - (define-key map (kbd "d") 'guix-output-list-mark-delete) - (define-key map (kbd "U") 'guix-output-list-mark-upgrade) - (define-key map (kbd "^") 'guix-output-list-mark-upgrades)) - -(defun guix-output-list-mark-install () - "Mark the current output for installation and move to the next line." - (interactive) - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-entry-value entry 'installed))) - (if installed - (user-error "This output is already installed") - (guix-list--mark 'install t)))) - -(defun guix-output-list-mark-delete () - "Mark the current output for deletion and move to the next line." - (interactive) - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-entry-value entry 'installed))) - (if installed - (guix-list--mark 'delete t) - (user-error "This output is not installed")))) - -(defun guix-output-list-mark-upgrade () - "Mark the current output for upgrading and move to the next line." - (interactive) - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-entry-value entry 'installed))) - (or installed - (user-error "This output is not installed")) - (when (or (guix-entry-value entry 'obsolete) - (y-or-n-p "This output is not obsolete. Try to upgrade it anyway? ")) - (guix-list--mark 'upgrade t)))) - -(defun guix-output-list-mark-upgrades () - "Mark all obsolete package outputs for upgrading." - (interactive) - (guix-package-mark-upgrades - (lambda (_) (guix-list--mark 'upgrade)))) - -(defun guix-output-list-execute () - "Perform actions on the marked outputs." - (interactive) - (guix-package-execute-actions #'guix-output-list-make-action)) - -(defun guix-output-list-make-action (action-type) - "Return action specification for the outputs marked with ACTION-TYPE. -Return nil, if there are no outputs marked with ACTION-TYPE. -The specification is suitable for `guix-process-output-actions'." - (let ((ids (guix-list-get-marked-id-list action-type))) - (and ids (cons action-type - (mapcar #'guix-package-id-and-output-by-output-id - ids))))) - -(defun guix-output-list-describe (ids) - "Describe outputs with IDS (list of output identifiers). -See `guix-package-info-type'." - (if (eq guix-package-info-type 'output) - (guix-buffer-get-display-entries - 'info 'output - (cl-list* (guix-ui-current-profile) 'id ids) - 'add) - (let ((pids (mapcar (lambda (oid) - (car (guix-package-id-and-output-by-output-id - oid))) - ids))) - (guix-buffer-get-display-entries - 'info 'package - (cl-list* (guix-ui-current-profile) - 'id (cl-remove-duplicates pids)) - 'add)))) - -(defun guix-output-list-edit (&optional directory) - "Go to the location of the current package. -See `guix-find-location' for the meaning of DIRECTORY." - (interactive (list (guix-read-directory))) - (guix-edit (guix-entry-value (guix-list-current-entry) - 'package-id) - directory)) - - -;;; Interactive commands - -(defvar guix-package-search-params '(name synopsis description) - "Default list of package parameters for searching by regexp.") - -(defvar guix-package-search-history nil - "A history of minibuffer prompts.") - -;;;###autoload -(defun guix-packages-by-name (name &optional profile) - "Display Guix packages with NAME. -NAME is a string with name specification. It may optionally contain -a version number. Examples: \"guile\", \"guile@2.0.11\". - -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (guix-read-package-name) - (guix-ui-read-profile))) - (guix-package-get-display profile 'name name)) - -;;;###autoload -(defun guix-packages-by-license (license &optional profile) - "Display Guix packages with LICENSE. -LICENSE is a license name string. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (guix-read-license-name) - (guix-ui-read-profile))) - (guix-package-get-display profile 'license license)) - -;;;###autoload -(defun guix-packages-by-location (location &optional profile) - "Display Guix packages placed in LOCATION file. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (guix-read-package-location) - (guix-ui-read-profile))) - (guix-package-get-display profile 'location location)) - -;;;###autoload -(defun guix-package-from-file (file &optional profile) - "Display Guix package that the code from FILE evaluates to. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (read-file-name "File with package: ") - (guix-ui-read-profile))) - (guix-buffer-get-display-entries - 'info 'package - (list (or profile guix-current-profile) 'from-file file) - 'add)) - -;;;###autoload -(defun guix-search-by-regexp (regexp &optional params profile) - "Search for Guix packages by REGEXP. -PARAMS are package parameters that should be searched. -If PARAMS are not specified, use `guix-package-search-params'. - -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (read-regexp "Regexp: " nil 'guix-package-search-history) - nil (guix-ui-read-profile))) - (guix-package-get-display profile 'regexp regexp - (or params guix-package-search-params))) - -;;;###autoload -(defun guix-search-by-name (regexp &optional profile) - "Search for Guix packages matching REGEXP in a package name. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (read-string "Package name by regexp: " - nil 'guix-package-search-history) - (guix-ui-read-profile))) - (guix-search-by-regexp regexp '(name) profile)) - -;;;###autoload -(defun guix-installed-packages (&optional profile) - "Display information about installed Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive (list (guix-ui-read-profile))) - (guix-package-get-display profile 'installed)) - -;;;###autoload -(defun guix-installed-user-packages () - "Display information about Guix packages installed in a user profile." - (interactive) - (guix-installed-packages guix-user-profile)) - -;;;###autoload -(defun guix-installed-system-packages () - "Display information about Guix packages installed in a system profile." - (interactive) - (guix-installed-packages - (guix-packages-profile guix-system-profile nil t))) - -;;;###autoload -(defun guix-obsolete-packages (&optional profile) - "Display information about obsolete Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive (list (guix-ui-read-profile))) - (guix-package-get-display profile 'obsolete)) - -;;;###autoload -(defun guix-all-available-packages (&optional profile) - "Display information about all available Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive (list (guix-ui-read-profile))) - (guix-package-get-display profile 'all-available)) - -;;;###autoload -(defun guix-newest-available-packages (&optional profile) - "Display information about the newest available Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive (list (guix-ui-read-profile))) - (guix-package-get-display profile 'newest-available)) - -(provide 'guix-ui-package) - -;;; guix-ui-package.el ends here diff --git a/emacs/guix-ui-system-generation.el b/emacs/guix-ui-system-generation.el deleted file mode 100644 index 7f4d76d489..0000000000 --- a/emacs/guix-ui-system-generation.el +++ /dev/null @@ -1,105 +0,0 @@ -;;; guix-ui-system-generation.el --- Interface for displaying system generations -*- lexical-binding: t -*- - -;; Copyright © 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides an interface for displaying system generations -;; in 'list' and 'info' buffers, and commands for working with them. - -;;; Code: - -(require 'cl-lib) -(require 'guix-list) -(require 'guix-ui) -(require 'guix-ui-generation) -(require 'guix-profiles) - -(guix-ui-define-entry-type system-generation) - -(defun guix-system-generation-get-display (search-type &rest search-values) - "Search for system generations and show results. -See `guix-ui-get-entries' for the meaning of SEARCH-TYPE and -SEARCH-VALUES." - (apply #'guix-list-get-display-entries - 'system-generation - guix-system-profile - search-type search-values)) - - -;;; System generation 'info' - -(guix-ui-info-define-interface system-generation - :buffer-name "*Guix Generation Info*" - :format '((number format guix-generation-info-insert-number) - (label format (format)) - (prev-number format (format)) - (current format guix-generation-info-insert-current) - (path format (format guix-file)) - (time format (time)) - (root-device format (format)) - (kernel format (format guix-file))) - :titles guix-generation-info-titles) - - -;;; System generation 'list' - -;; FIXME It is better to make `guix-generation-list-shared-map' with -;; common keys for both usual and system generations. -(defvar guix-system-generation-list-mode-map - (copy-keymap guix-generation-list-mode-map) - "Keymap for `guix-system-generation-list-mode' buffers.") - -(guix-ui-list-define-interface system-generation - :buffer-name "*Guix Generation List*" - :format '((number nil 5 guix-list-sort-numerically-0 :right-align t) - (current guix-generation-list-get-current 10 t) - (label nil 40 t) - (time guix-list-get-time 20 t) - (path guix-list-get-file-name 30 t)) - :titles guix-generation-list-titles - :sort-key '(number . t) - :marks '((delete . ?D))) - - -;;; Interactive commands - -;;;###autoload -(defun guix-system-generations () - "Display information about system generations." - (interactive) - (guix-system-generation-get-display 'all)) - -;;;###autoload -(defun guix-last-system-generations (number) - "Display information about last NUMBER of system generations." - (interactive "nThe number of last generations: ") - (guix-system-generation-get-display 'last number)) - -;;;###autoload -(defun guix-system-generations-by-time (from to) - "Display information about system generations created between FROM and TO." - (interactive - (list (guix-read-date "Find generations (from): ") - (guix-read-date "Find generations (to): "))) - (guix-system-generation-get-display - 'time (float-time from) (float-time to))) - -(provide 'guix-ui-system-generation) - -;;; guix-ui-system-generation.el ends here diff --git a/emacs/guix-ui.el b/emacs/guix-ui.el deleted file mode 100644 index 1b696314cd..0000000000 --- a/emacs/guix-ui.el +++ /dev/null @@ -1,323 +0,0 @@ -;;; guix-ui.el --- Common code for Guix package management interface -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015, 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides some general code for 'list'/'info' interfaces for -;; packages and generations. - -;;; Code: - -(require 'cl-lib) -(require 'guix-backend) -(require 'guix-buffer) -(require 'guix-guile) -(require 'guix-utils) -(require 'guix-messages) -(require 'guix-profiles) - -(guix-define-groups ui - :group-doc "\ -Settings for 'ui' (Guix package management) buffers. -This group includes settings for displaying packages, outputs and -generations in 'list' and 'info' buffers.") - -(defvar guix-ui-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "M") 'guix-apply-manifest) - (define-key map (kbd "C-c C-z") 'guix-switch-to-repl) - map) - "Parent keymap for Guix package/generation buffers.") - -(guix-buffer-define-current-args-accessors - "guix-ui-current" "profile" "search-type" "search-values") - -(defun guix-ui-read-profile () - "Return `guix-current-profile' or prompt for it. -This function is intended for using in `interactive' forms." - (if current-prefix-arg - (guix-profile-prompt) - guix-current-profile)) - -(defun guix-ui-get-entries (profile entry-type search-type search-values - &optional params) - "Receive ENTRY-TYPE entries for PROFILE. -Call an appropriate scheme procedure and return a list of entries. - -ENTRY-TYPE should be one of the following symbols: `package', -`output' or `generation'. - -SEARCH-TYPE may be one of the following symbols: - -- If ENTRY-TYPE is `package' or `output': `id', `name', `regexp', - `all-available', `newest-available', `installed', `obsolete', - `generation'. - -- If ENTRY-TYPE is `generation': `id', `last', `all', `time'. - -PARAMS is a list of parameters for receiving. If nil, get data -with all available parameters." - (guix-eval-read - (guix-make-guile-expression - 'entries - profile params entry-type search-type search-values))) - -(defun guix-ui-list-describe (ids) - "Describe 'ui' entries with IDS (list of identifiers)." - (guix-buffer-get-display-entries - 'info (guix-buffer-current-entry-type) - (cl-list* (guix-ui-current-profile) 'id ids) - 'add)) - - -;;; Buffers and auto updating - -(defcustom guix-ui-update-after-operation 'current - "Define what kind of data to update after executing an operation. - -After successful executing an operation in the Guix REPL (for -example after installing a package), the data in Guix buffers -will or will not be automatically updated depending on a value of -this variable. - -If nil, update nothing (do not revert any buffer). -If `current', update the buffer from which an operation was performed. -If `all', update all Guix buffers (not recommended)." - :type '(choice (const :tag "Do nothing" nil) - (const :tag "Update operation buffer" current) - (const :tag "Update all Guix buffers" all)) - :group 'guix-ui) - -(defcustom guix-ui-buffer-name-function - #'guix-ui-buffer-name-full - "Function used to define a name of a Guix buffer. -The function is called with 2 arguments: BASE-NAME and PROFILE." - :type '(choice (function-item guix-ui-buffer-name-full) - (function-item guix-ui-buffer-name-short) - (function-item guix-ui-buffer-name-simple) - (function :tag "Other function")) - :group 'guix-ui) - -(defun guix-ui-buffer-name-simple (base-name &rest _) - "Return BASE-NAME." - base-name) - -(defun guix-ui-buffer-name-short (base-name profile) - "Return buffer name by appending BASE-NAME and PROFILE's base file name." - (guix-compose-buffer-name base-name - (file-name-base (directory-file-name profile)))) - -(defun guix-ui-buffer-name-full (base-name profile) - "Return buffer name by appending BASE-NAME and PROFILE's full name." - (guix-compose-buffer-name base-name profile)) - -(defun guix-ui-buffer-name (base-name profile) - "Return Guix buffer name based on BASE-NAME and profile. -See `guix-ui-buffer-name-function' for details." - (funcall guix-ui-buffer-name-function - base-name profile)) - -(defun guix-ui-buffer? (&optional buffer modes) - "Return non-nil if BUFFER mode is derived from any of the MODES. -If BUFFER is nil, check current buffer. -If MODES is nil, use `guix-list-mode' and `guix-info-mode'." - (with-current-buffer (or buffer (current-buffer)) - (apply #'derived-mode-p - (or modes '(guix-list-mode guix-info-mode))))) - -(defun guix-ui-buffers (&optional modes) - "Return a list of all buffers with major modes derived from MODES. -If MODES is nil, return list of all Guix 'list' and 'info' buffers." - (cl-remove-if-not (lambda (buf) - (guix-ui-buffer? buf modes)) - (buffer-list))) - -(defun guix-ui-update-buffer (buffer) - "Update data in a 'list' or 'info' BUFFER." - (with-current-buffer buffer - (guix-buffer-revert nil t))) - -(defun guix-ui-update-buffers-after-operation () - "Update buffers after Guix operation if needed. -See `guix-ui-update-after-operation' for details." - (let ((to-update - (and guix-operation-buffer - (cl-case guix-ui-update-after-operation - (current (and (buffer-live-p guix-operation-buffer) - (guix-ui-buffer? guix-operation-buffer) - (list guix-operation-buffer))) - (all (guix-ui-buffers)))))) - (setq guix-operation-buffer nil) - (mapc #'guix-ui-update-buffer to-update))) - -(add-hook 'guix-after-repl-operation-hook - 'guix-ui-update-buffers-after-operation) - - -;;; Interface definers - -(defmacro guix-ui-define-entry-type (entry-type &rest args) - "Define general code for ENTRY-TYPE. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -The rest keyword arguments are passed to -`guix-define-entry-type' macro." - (declare (indent 1)) - `(guix-define-entry-type ,entry-type - :parent-group guix-ui - :parent-faces-group guix-ui-faces - ,@args)) - -(defmacro guix-ui-define-interface (buffer-type entry-type &rest args) - "Define BUFFER-TYPE interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... -In the following description TYPE means ENTRY-TYPE-BUFFER-TYPE. - -Required keywords: - - - `:buffer-name' - base part of a buffer name. It is used in a - generated `guix-TYPE-buffer-name' function; see - `guix-ui-buffer-name' for details. - -Optional keywords: - - - `:required' - default value of the generated - `guix-TYPE-required-params' variable. - -The rest keyword arguments are passed to -`guix-BUFFER-TYPE-define-interface' macro. - -Along with the mentioned definitions, this macro also defines: - - - `guix-TYPE-mode-map' - keymap based on `guix-ui-map' and - `guix-BUFFER-TYPE-mode-map'. - - - `guix-TYPE-get-entries' - a wrapper around `guix-ui-get-entries'. - - - `guix-TYPE-message' - a wrapper around `guix-result-message'." - (declare (indent 2)) - (let* ((entry-type-str (symbol-name entry-type)) - (buffer-type-str (symbol-name buffer-type)) - (prefix (concat "guix-" entry-type-str "-" - buffer-type-str)) - (mode-str (concat prefix "-mode")) - (mode-map (intern (concat mode-str "-map"))) - (parent-map (intern (format "guix-%s-mode-map" - buffer-type-str))) - (required-var (intern (concat prefix "-required-params"))) - (buffer-name-fun (intern (concat prefix "-buffer-name"))) - (get-fun (intern (concat prefix "-get-entries"))) - (message-fun (intern (concat prefix "-message"))) - (displayed-fun (intern (format "guix-%s-displayed-params" - buffer-type-str))) - (definer (intern (format "guix-%s-define-interface" - buffer-type-str)))) - (guix-keyword-args-let args - ((buffer-name-val :buffer-name) - (required-val :required ''(id))) - `(progn - (defvar ,mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent - map (make-composed-keymap ,parent-map guix-ui-map)) - map) - ,(format "Keymap for `%s' buffers." mode-str)) - - (defvar ,required-var ,required-val - ,(format "\ -List of the required '%s' parameters. -These parameters are received by `%S' -along with the displayed parameters. - -Do not remove `id' from this list as it is required for -identifying an entry." - entry-type-str get-fun)) - - (defun ,buffer-name-fun (profile &rest _) - ,(format "\ -Return a name of '%s' buffer for displaying '%s' entries. -See `guix-ui-buffer-name' for details." - buffer-type-str entry-type-str) - (guix-ui-buffer-name ,buffer-name-val profile)) - - (defun ,get-fun (profile search-type &rest search-values) - ,(format "\ -Receive '%s' entries for displaying them in '%s' buffer. -See `guix-ui-get-entries' for details." - entry-type-str buffer-type-str) - (guix-ui-get-entries - profile ',entry-type search-type search-values - (cl-union ,required-var - (,displayed-fun ',entry-type)))) - - (defun ,message-fun (entries profile search-type - &rest search-values) - ,(format "\ -Display a message after showing '%s' entries." - entry-type-str) - (guix-result-message - profile entries ',entry-type search-type search-values)) - - (,definer ,entry-type - :get-entries-function ',get-fun - :message-function ',message-fun - :buffer-name ',buffer-name-fun - ,@%foreign-args))))) - -(defmacro guix-ui-info-define-interface (entry-type &rest args) - "Define 'info' interface for displaying ENTRY-TYPE entries. -See `guix-ui-define-interface'." - (declare (indent 1)) - `(guix-ui-define-interface info ,entry-type - ,@args)) - -(defmacro guix-ui-list-define-interface (entry-type &rest args) - "Define 'list' interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Optional keywords: - - - `:describe-function' - default value of the generated - `guix-ENTRY-TYPE-list-describe-function' variable (if not - specified, use `guix-ui-list-describe'). - -The rest keyword arguments are passed to -`guix-ui-define-interface' macro." - (declare (indent 1)) - (guix-keyword-args-let args - ((describe-val :describe-function)) - `(guix-ui-define-interface list ,entry-type - :describe-function ,(or describe-val ''guix-ui-list-describe) - ,@args))) - - -(defvar guix-ui-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group (or "guix-ui-define-entry-type" - "guix-ui-define-interface" - "guix-ui-info-define-interface" - "guix-ui-list-define-interface")) - symbol-end) - . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-ui-font-lock-keywords) - -(provide 'guix-ui) - -;;; guix-ui.el ends here diff --git a/emacs/guix-utils.el b/emacs/guix-utils.el deleted file mode 100644 index 3e4ecc36ab..0000000000 --- a/emacs/guix-utils.el +++ /dev/null @@ -1,609 +0,0 @@ -;;; guix-utils.el --- General utility functions -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015, 2016 Alex Kost - -;; 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 this program. If not, see . - -;;; Commentary: - -;; This file provides auxiliary general functions for guix.el package. - -;;; Code: - -(require 'cl-lib) - -(defvar guix-true-string "Yes") -(defvar guix-false-string "–") -(defvar guix-list-separator ", ") - -(defvar guix-time-format "%F %T" - "String used to format time values. -For possible formats, see `format-time-string'.") - -(defun guix-get-string (val &optional face) - "Convert VAL into a string and return it. - -VAL can be an expression of any type. -If VAL is t/nil, it is replaced with -`guix-true-string'/`guix-false-string'. -If VAL is list, its elements are concatenated using -`guix-list-separator'. - -If FACE is non-nil, propertize returned string with this FACE." - (let ((str (cond - ((stringp val) val) - ((null val) guix-false-string) - ((eq t val) guix-true-string) - ((numberp val) (number-to-string val)) - ((listp val) (mapconcat #'guix-get-string - val guix-list-separator)) - (t (prin1-to-string val))))) - (if (and val face) - (propertize str 'font-lock-face face) - str))) - -(defun guix-get-time-string (seconds) - "Return formatted time string from SECONDS. -Use `guix-time-format'." - (format-time-string guix-time-format (seconds-to-time seconds))) - -(defun guix-get-one-line (str) - "Return one-line string from a multi-line STR." - (replace-regexp-in-string "\n" " " str)) - -(defmacro guix-with-indent (indent &rest body) - "Evaluate BODY and indent inserted text by INDENT number of spaces." - (declare (indent 1) (debug t)) - (let ((region-beg-var (make-symbol "region-beg")) - (indent-var (make-symbol "indent"))) - `(let ((,region-beg-var (point)) - (,indent-var ,indent)) - ,@body - (unless (zerop ,indent-var) - (indent-rigidly ,region-beg-var (point) ,indent-var))))) - -(defun guix-format-insert (val &optional face format) - "Convert VAL into a string and insert it at point. -If FACE is non-nil, propertize VAL with FACE. -If FORMAT is non-nil, format VAL with FORMAT." - (let ((str (guix-get-string val face))) - (insert (if format - (format format str) - str)))) - -(cl-defun guix-mapinsert (function sequence separator &key indent column) - "Like `mapconcat' but for inserting text. -Apply FUNCTION to each element of SEQUENCE, and insert SEPARATOR -at point between each FUNCTION call. - -If INDENT is non-nil, it should be a number of spaces used to -indent each line of the inserted text. - -If COLUMN is non-nil, it should be a column number which -shouldn't be exceeded by the inserted text." - (pcase sequence - (`(,first . ,rest) - (let* ((indent (or indent 0)) - (max-column (and column (- column indent)))) - (guix-with-indent indent - (funcall function first) - (dolist (element rest) - (let ((before-sep-pos (and column (point)))) - (insert separator) - (let ((after-sep-pos (and column (point)))) - (funcall function element) - (when (and column - (> (current-column) max-column)) - (save-excursion - (delete-region before-sep-pos after-sep-pos) - (goto-char before-sep-pos) - (insert "\n"))))))))))) - -(defun guix-insert-button (label &optional type &rest properties) - "Make button of TYPE with LABEL and insert it at point. -See `insert-text-button' for the meaning of PROPERTIES." - (if (null label) - (guix-format-insert nil) - (apply #'insert-text-button label - :type (or type 'button) - properties))) - -(defun guix-buttonize (value button-type separator &rest properties) - "Make BUTTON-TYPE button(s) from VALUE. -Return a string with button(s). - -VALUE should be a string or a list of strings. If it is a list -of strings, buttons are separated with SEPARATOR string. - -PROPERTIES are passed to `guix-insert-button'." - (with-temp-buffer - (let ((labels (if (listp value) value (list value)))) - (guix-mapinsert (lambda (label) - (apply #'guix-insert-button - label button-type properties)) - labels - separator)) - (buffer-substring (point-min) (point-max)))) - -(defun guix-button-type? (symbol) - "Return non-nil, if SYMBOL is a button type." - (and symbol - (get symbol 'button-category-symbol))) - -(defun guix-split-insert (val &optional face col separator) - "Convert VAL into a string, split it and insert at point. - -If FACE is non-nil, propertize returned string with this FACE. - -If COL is non-nil and result string is a one-line string longer -than COL, split it into several short lines. - -Separate inserted lines with SEPARATOR." - (if (null val) - (guix-format-insert nil) - (let ((strings (guix-split-string (guix-get-string val) col))) - (guix-mapinsert (lambda (str) (guix-format-insert str face)) - strings - (or separator ""))))) - -(defun guix-split-string (str &optional col) - "Split string STR by lines and return list of result strings. -If COL is non-nil, fill STR to this column." - (let ((str (if col - (guix-get-filled-string str col) - str))) - (split-string str "\n *" t))) - -(defun guix-get-filled-string (str col) - "Return string by filling STR to column COL." - (with-temp-buffer - (insert str) - (let ((fill-column col)) - (fill-region (point-min) (point-max))) - (buffer-string))) - -(defun guix-concat-strings (strings separator &optional location) - "Return new string by concatenating STRINGS with SEPARATOR. -If LOCATION is a symbol `head', add another SEPARATOR to the -beginning of the returned string; if `tail' - add SEPARATOR to -the end of the string; if nil, do not add SEPARATOR; otherwise -add both to the end and to the beginning." - (let ((str (mapconcat #'identity strings separator))) - (cond ((null location) - str) - ((eq location 'head) - (concat separator str)) - ((eq location 'tail) - (concat str separator)) - (t - (concat separator str separator))))) - -(defun guix-hexify (value) - "Convert VALUE to string and hexify it." - (url-hexify-string (guix-get-string value))) - -(defun guix-number->bool (number) - "Convert NUMBER to boolean value. -Return nil, if NUMBER is 0; return t otherwise." - (not (zerop number))) - -(defun guix-shell-quote-argument (argument) - "Quote shell command ARGUMENT. -This function is similar to `shell-quote-argument', but less strict." - (if (equal argument "") - "''" - (replace-regexp-in-string - "\n" "'\n'" - (replace-regexp-in-string - (rx (not (any alnum "-=,./\n"))) "\\\\\\&" argument)))) - -(defun guix-symbol-title (symbol) - "Return SYMBOL's name, a string. -This is like `symbol-name', but fancier." - (if (eq symbol 'id) - "ID" - (let ((str (replace-regexp-in-string "-" " " (symbol-name symbol)))) - (concat (capitalize (substring str 0 1)) - (substring str 1))))) - -(defun guix-command-symbol (&optional args) - "Return symbol by concatenating 'guix' and ARGS (strings)." - (intern (guix-concat-strings (cons "guix" args) "-"))) - -(defun guix-command-string (&optional args) - "Return 'guix ARGS ...' string with quoted shell arguments." - (let ((args (mapcar #'guix-shell-quote-argument args))) - (guix-concat-strings (cons "guix" args) " "))) - -(defun guix-copy-as-kill (string &optional no-message?) - "Put STRING into `kill-ring'. -If NO-MESSAGE? is non-nil, do not display a message about it." - (kill-new string) - (unless no-message? - (message "'%s' has been added to kill ring." string))) - -(defun guix-copy-command-as-kill (args &optional no-message?) - "Put 'guix ARGS ...' string into `kill-ring'. -See also `guix-copy-as-kill'." - (guix-copy-as-kill (guix-command-string args) no-message?)) - -(defun guix-compose-buffer-name (base-name postfix) - "Return buffer name by appending BASE-NAME and POSTFIX. - -In a simple case the result is: - - BASE-NAME: POSTFIX - -If BASE-NAME is wrapped by '*', then the result is: - - *BASE-NAME: POSTFIX*" - (let ((re (rx string-start - (group (? "*")) - (group (*? any)) - (group (? "*")) - string-end))) - (or (string-match re base-name) - (error "Unexpected error in defining buffer name")) - (let ((first* (match-string 1 base-name)) - (name-body (match-string 2 base-name)) - (last* (match-string 3 base-name))) - ;; Handle the case when buffer name is wrapped by '*'. - (if (and (string= "*" first*) - (string= "*" last*)) - (concat "*" name-body ": " postfix "*") - (concat base-name ": " postfix))))) - -(defun guix-completing-read (prompt table &optional predicate - require-match initial-input - hist def inherit-input-method) - "Same as `completing-read' but return nil instead of an empty string." - (let ((res (completing-read prompt table predicate - require-match initial-input - hist def inherit-input-method))) - (unless (string= "" res) res))) - -(defun guix-completing-read-multiple (prompt table &optional predicate - require-match initial-input - hist def inherit-input-method) - "Same as `completing-read-multiple' but remove duplicates in result." - (cl-remove-duplicates - (completing-read-multiple prompt table predicate - require-match initial-input - hist def inherit-input-method) - :test #'string=)) - -(declare-function org-read-date "org" t) - -(defun guix-read-date (prompt) - "Prompt for a date or time using `org-read-date'. -Return time value." - (require 'org) - (org-read-date nil t nil prompt)) - -(defun guix-read-file-name (prompt &optional dir default-filename - mustmatch initial predicate) - "Read file name. -This function is similar to `read-file-name' except it also -expands the file name." - (expand-file-name (read-file-name prompt dir default-filename - mustmatch initial predicate))) - -(defcustom guix-find-file-function #'find-file - "Function used to find a file. -The function is called by `guix-find-file' with a file name as a -single argument." - :type '(choice (function-item find-file) - (function-item org-open-file) - (function :tag "Other function")) - :group 'guix) - -(defun guix-find-file (file) - "Find FILE if it exists." - (if (file-exists-p file) - (funcall guix-find-file-function file) - (message "File '%s' does not exist." file))) - -(defvar url-handler-regexp) - -(defun guix-find-file-or-url (file-or-url) - "Find FILE-OR-URL." - (require 'url-handlers) - (let ((file-name-handler-alist - (cons (cons url-handler-regexp 'url-file-handler) - file-name-handler-alist))) - (find-file file-or-url))) - -(defmacro guix-while-search (regexp &rest body) - "Evaluate BODY after each search for REGEXP in the current buffer." - (declare (indent 1) (debug t)) - `(save-excursion - (goto-char (point-min)) - (while (re-search-forward ,regexp nil t) - ,@body))) - -(defmacro guix-while-null (&rest body) - "Evaluate BODY until its result becomes non-nil." - (declare (indent 0) (debug t)) - (let ((result-var (make-symbol "result"))) - `(let (,result-var) - (while (null ,result-var) - (setq ,result-var ,@body)) - ,result-var))) - -(defun guix-modify (object modifiers) - "Apply MODIFIERS to OBJECT. -OBJECT is passed as an argument to the first function from -MODIFIERS list, the returned result is passed to the second -function from the list and so on. Return result of the last -modifier call." - (if (null modifiers) - object - (guix-modify (funcall (car modifiers) object) - (cdr modifiers)))) - -(defmacro guix-keyword-args-let (args varlist &rest body) - "Parse ARGS, bind variables from VARLIST and eval BODY. - -Find keyword values in ARGS, bind them to variables according to -VARLIST, then evaluate BODY. - -ARGS is a keyword/value property list. - -Each element of VARLIST has a form: - - (SYMBOL KEYWORD [DEFAULT-VALUE]) - -SYMBOL is a varible name. KEYWORD is a symbol that will be -searched in ARGS for an according value. If the value of KEYWORD -does not exist, bind SYMBOL to DEFAULT-VALUE or nil. - -The rest arguments (that present in ARGS but not in VARLIST) will -be bound to `%foreign-args' variable. - -Example: - - (guix-keyword-args-let '(:two 8 :great ! :guix is) - ((one :one 1) - (two :two 2) - (foo :smth)) - (list one two foo %foreign-args)) - - => (1 8 nil (:guix is :great !))" - (declare (indent 2)) - (let ((args-var (make-symbol "args"))) - `(let (,@(mapcar (lambda (spec) - (pcase-let ((`(,name ,_ ,val) spec)) - (list name val))) - varlist) - (,args-var ,args) - %foreign-args) - (while ,args-var - (pcase ,args-var - (`(,key ,val . ,rest-args) - (cl-case key - ,@(mapcar (lambda (spec) - (pcase-let ((`(,name ,key ,_) spec)) - `(,key (setq ,name val)))) - varlist) - (t (setq %foreign-args - (cl-list* key val %foreign-args)))) - (setq ,args-var rest-args)))) - ,@body))) - - -;;; Alist procedures - -(defmacro guix-define-alist-accessor (name assoc-fun) - "Define NAME function to access alist values using ASSOC-FUN." - `(defun ,name (alist &rest keys) - ,(format "Return value from ALIST by KEYS using `%s'. -ALIST is alist of alists of alists ... which can be consecutively -accessed with KEYS." - assoc-fun) - (if (or (null alist) (null keys)) - alist - (apply #',name - (cdr (,assoc-fun (car keys) alist)) - (cdr keys))))) - -(guix-define-alist-accessor guix-assq-value assq) -(guix-define-alist-accessor guix-assoc-value assoc) - -(defun guix-alist-put (value alist &rest keys) - "Put (add or replace if exists) VALUE to ALIST using KEYS. -Return the new alist. - -ALIST is alist of alists of alists ... which can be consecutively -accessed with KEYS. - -Example: - - (guix-alist-put - 'foo - '((one (a . 1) (b . 2)) - (two (m . 7) (n . 8))) - 'one 'b) - - => ((one (a . 1) (b . foo)) - (two (m . 7) (n . 8)))" - (or keys (error "Keys should be specified")) - (guix-alist-put-1 value alist keys)) - -(defun guix-alist-put-1 (value alist keys) - "Subroutine of `guix-alist-put'." - (cond - ((null keys) - value) - ((null alist) - (list (cons (car keys) - (guix-alist-put-1 value nil (cdr keys))))) - ((eq (car keys) (caar alist)) - (cons (cons (car keys) - (guix-alist-put-1 value (cdar alist) (cdr keys))) - (cdr alist))) - (t - (cons (car alist) - (guix-alist-put-1 value (cdr alist) keys))))) - -(defun guix-alist-put! (value variable &rest keys) - "Modify alist VARIABLE (symbol) by putting VALUE using KEYS. -See `guix-alist-put' for details." - (set variable - (apply #'guix-alist-put value (symbol-value variable) keys))) - - -;;; Diff - -(defvar guix-diff-switches "-u" - "A string or list of strings specifying switches to be passed to diff.") - -(defun guix-diff (old new &optional switches no-async) - "Same as `diff', but use `guix-diff-switches' as default." - (diff old new (or switches guix-diff-switches) no-async)) - - -;;; Completing readers definers - -(defmacro guix-define-reader (name read-fun completions prompt) - "Define NAME function to read from minibuffer. -READ-FUN may be `completing-read', `completing-read-multiple' or -another function with the same arguments." - `(defun ,name (&optional prompt initial-contents) - (,read-fun ,(if prompt - `(or prompt ,prompt) - 'prompt) - ,completions nil nil initial-contents))) - -(defmacro guix-define-readers (&rest args) - "Define reader functions. - -ARGS should have a form [KEYWORD VALUE] ... The following -keywords are available: - - - `completions-var' - variable used to get completions. - - - `completions-getter' - function used to get completions. - - - `single-reader', `single-prompt' - name of a function to read - a single value, and a prompt for it. - - - `multiple-reader', `multiple-prompt' - name of a function to - read multiple values, and a prompt for it. - - - `multiple-separator' - if specified, another - `-string' function returning a string - of multiple values separated the specified separator will be - defined." - (guix-keyword-args-let args - ((completions-var :completions-var) - (completions-getter :completions-getter) - (single-reader :single-reader) - (single-prompt :single-prompt) - (multiple-reader :multiple-reader) - (multiple-prompt :multiple-prompt) - (multiple-separator :multiple-separator)) - (let ((completions - (cond ((and completions-var completions-getter) - `(or ,completions-var - (setq ,completions-var - (funcall ',completions-getter)))) - (completions-var - completions-var) - (completions-getter - `(funcall ',completions-getter))))) - `(progn - ,(when (and completions-var - (not (boundp completions-var))) - `(defvar ,completions-var nil)) - - ,(when single-reader - `(guix-define-reader ,single-reader guix-completing-read - ,completions ,single-prompt)) - - ,(when multiple-reader - `(guix-define-reader ,multiple-reader completing-read-multiple - ,completions ,multiple-prompt)) - - ,(when (and multiple-reader multiple-separator) - (let ((name (intern (concat (symbol-name multiple-reader) - "-string")))) - `(defun ,name (&optional prompt initial-contents) - (guix-concat-strings - (,multiple-reader prompt initial-contents) - ,multiple-separator)))))))) - - -;;; Memoizing - -(defun guix-memoize (function) - "Return a memoized version of FUNCTION." - (let ((cache (make-hash-table :test 'equal))) - (lambda (&rest args) - (let ((result (gethash args cache 'not-found))) - (if (eq result 'not-found) - (let ((result (apply function args))) - (puthash args result cache) - result) - result))))) - -(defmacro guix-memoized-defun (name arglist docstring &rest body) - "Define a memoized function NAME. -See `defun' for the meaning of arguments." - (declare (doc-string 3) (indent 2)) - `(defalias ',name - (guix-memoize (lambda ,arglist ,@body)) - ;; Add '(name args ...)' string with real arglist to the docstring, - ;; because *Help* will display '(name &rest ARGS)' for a defined - ;; function (since `guix-memoize' returns a lambda with '(&rest - ;; args)'). - ,(format "(%S %s)\n\n%s" - name - (mapconcat #'symbol-name arglist " ") - docstring))) - -(defmacro guix-memoized-defalias (symbol definition &optional docstring) - "Set SYMBOL's function definition to memoized version of DEFINITION." - (declare (doc-string 3) (indent 1)) - `(defalias ',symbol - (guix-memoize #',definition) - ,(or docstring - (format "Memoized version of `%S'." definition)))) - - -(defvar guix-utils-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group (or "guix-define-reader" - "guix-define-readers" - "guix-keyword-args-let" - "guix-while-null" - "guix-while-search" - "guix-with-indent")) - symbol-end) - . 1) - (,(rx "(" - (group "guix-memoized-" (or "defun" "defalias")) - symbol-end - (zero-or-more blank) - (zero-or-one - (group (one-or-more (or (syntax word) (syntax symbol)))))) - (1 font-lock-keyword-face) - (2 font-lock-function-name-face nil t))))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-utils-font-lock-keywords) - -(provide 'guix-utils) - -;;; guix-utils.el ends here diff --git a/emacs/local.mk b/emacs/local.mk deleted file mode 100644 index 959ec2dd34..0000000000 --- a/emacs/local.mk +++ /dev/null @@ -1,77 +0,0 @@ -# GNU Guix --- Functional package management for GNU -# Copyright © 2014, 2015, 2016 Alex Kost -# Copyright © 2016 Mathieu Lirzin -# -# 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 . - -AUTOLOADS = %D%/guix-autoloads.el - -ELFILES = \ - %D%/guix-about.el \ - %D%/guix-backend.el \ - %D%/guix-base.el \ - %D%/guix-build-log.el \ - %D%/guix-buffer.el \ - %D%/guix-command.el \ - %D%/guix-devel.el \ - %D%/guix-emacs.el \ - %D%/guix-entry.el \ - %D%/guix-external.el \ - %D%/guix-geiser.el \ - %D%/guix-guile.el \ - %D%/guix-help-vars.el \ - %D%/guix-history.el \ - %D%/guix-hydra.el \ - %D%/guix-hydra-build.el \ - %D%/guix-hydra-jobset.el \ - %D%/guix-info.el \ - %D%/guix-init.el \ - %D%/guix-license.el \ - %D%/guix-list.el \ - %D%/guix-location.el \ - %D%/guix-messages.el \ - %D%/guix-pcomplete.el \ - %D%/guix-popup.el \ - %D%/guix-prettify.el \ - %D%/guix-profiles.el \ - %D%/guix-read.el \ - %D%/guix-ui.el \ - %D%/guix-ui-license.el \ - %D%/guix-ui-location.el \ - %D%/guix-ui-package.el \ - %D%/guix-ui-generation.el \ - %D%/guix-ui-system-generation.el \ - %D%/guix-utils.el - -if HAVE_EMACS - -dist_lisp_DATA = $(ELFILES) - -nodist_lisp_DATA = \ - %D%/guix-config.el \ - $(AUTOLOADS) - -$(AUTOLOADS): $(ELFILES) - $(AM_V_EMACS)$(EMACS) --batch --eval \ - "(let ((backup-inhibited t) \ - (generated-autoload-file \ - (expand-file-name \"$(AUTOLOADS)\" \"$(builddir)\"))) \ - (update-directory-autoloads \ - (expand-file-name \"emacs\" \"$(srcdir)\")))" - -CLEANFILES += $(AUTOLOADS) - -endif HAVE_EMACS diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index 732dbc2ce3..1b9191cbcb 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -44,7 +44,6 @@ #:use-module (gnu packages curl) #:use-module (gnu packages web) #:use-module (gnu packages man) - #:use-module (gnu packages emacs) #:use-module (gnu packages bdw-gc) #:use-module (gnu packages python) #:use-module (gnu packages popt) @@ -162,7 +161,6 @@ #t)))))) (native-inputs `(("pkg-config" ,pkg-config) - ("emacs" ,emacs-minimal) ;for guix.el ;; XXX: Keep the development inputs here even though ;; they're unnecessary, just so that 'guix environment @@ -206,9 +204,7 @@ (propagated-inputs `(("gnutls" ,gnutls) ;for 'guix download' & co. ("guile-json" ,guile-json) - ("guile-ssh" ,guile-ssh) - ("geiser" ,geiser) ;for guix.el - ("emacs-magit-popup" ,emacs-magit-popup))) ;for "M-x guix" command + ("guile-ssh" ,guile-ssh))) (home-page "http://www.gnu.org/software/guix") (synopsis "Functional package manager for installed software packages and versions") -- cgit 1.4.1 From f11c444d440b68c3975c2dcaacb24fa3e0e09c7d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 31 Dec 2016 18:19:56 +0100 Subject: Add 'guix copy'. * guix/scripts/copy.scm: New file. * guix/scripts/archive.scm (options->derivations+files): Export. * doc/guix.texi (Invoking guix copy): New node. * Makefile.am (MODULES) [HAVE_GUILE_SSH]: Add guix/scripts/copy.scm. * po/guix/POTFILES.in: Likewise. --- Makefile.am | 3 +- doc/guix.texi | 77 +++++++++++++++++- guix/scripts/archive.scm | 3 +- guix/scripts/copy.scm | 207 +++++++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + 5 files changed, 285 insertions(+), 6 deletions(-) create mode 100644 guix/scripts/copy.scm (limited to 'doc/guix.texi') diff --git a/Makefile.am b/Makefile.am index 094d6e5108..fb08a004b6 100644 --- a/Makefile.am +++ b/Makefile.am @@ -173,7 +173,8 @@ endif if HAVE_GUILE_SSH MODULES += \ - guix/ssh.scm + guix/ssh.scm \ + guix/scripts/copy.scm endif HAVE_GUILE_SSH diff --git a/doc/guix.texi b/doc/guix.texi index 8756061a46..42fb439668 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -145,12 +145,13 @@ Utilities * Invoking guix environment:: Setting up development environments. * Invoking guix publish:: Sharing substitutes. * Invoking guix challenge:: Challenging substitute servers. +* Invoking guix copy:: Copying to and from a remote store. * Invoking guix container:: Process isolation. Invoking @command{guix build} * Common Build Options:: Build options for most commands. -* Package Transformation Options:: Creating variants of packages. +* Package Transformation Options:: Creating variants of packages. * Additional Build Options:: Options specific to 'guix build'. GNU Distribution @@ -199,12 +200,14 @@ Services * Log Rotation:: The rottlog service. * Networking Services:: Network setup, SSH daemon, etc. * X Window:: Graphical display. +* Printing Services:: Local and remote printer support. * Desktop Services:: D-Bus and desktop services. * Database Services:: SQL databases. * Mail Services:: IMAP, POP3, SMTP, and all that. * Kerberos Services:: Kerberos services. * Web Services:: Web servers. * Network File System:: NFS related services. +* Continuous Integration:: The Cuirass service. * Miscellaneous Services:: Other services. Defining Services @@ -551,7 +554,8 @@ interest primarily for developers and not for casual users. @item @c Note: We need at least 0.10.2 for 'channel-send-eof'. -Support for build offloading (@pxref{Daemon Offload Setup}) depends on +Support for build offloading (@pxref{Daemon Offload Setup}) and +@command{guix copy} (@pxref{Invoking guix copy}) depends on @uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH}, version 0.10.2 or later. @@ -2384,7 +2388,9 @@ However, note that, in both examples, all of @code{emacs} and the profile as well as all of their dependencies are transferred (due to @code{-r}), regardless of what is already available in the store on the target machine. The @code{--missing} option can help figure out which -items are missing from the target store. +items are missing from the target store. The @command{guix copy} +command simplifies and optimizes this whole process, so this is probably +what you should use in this case (@pxref{Invoking guix copy}). @cindex nar, archive format @cindex normalized archive (nar) @@ -4415,6 +4421,7 @@ the Scheme programming interface of Guix in a convenient way. * Invoking guix environment:: Setting up development environments. * Invoking guix publish:: Sharing substitutes. * Invoking guix challenge:: Challenging substitute servers. +* Invoking guix copy:: Copying to and from a remote store. * Invoking guix container:: Process isolation. @end menu @@ -4467,7 +4474,7 @@ described in the subsections below. @menu * Common Build Options:: Build options for most commands. -* Package Transformation Options:: Creating variants of packages. +* Package Transformation Options:: Creating variants of packages. * Additional Build Options:: Options specific to 'guix build'. @end menu @@ -6371,6 +6378,68 @@ URLs to compare to. @end table +@node Invoking guix copy +@section Invoking @command{guix copy} + +@cindex copy, of store items, over SSH +@cindex SSH, copy of store items +@cindex sharing store items across machines +@cindex transferring store items across machines +The @command{guix copy} command copies items from the store of one +machine to that of another machine over a secure shell (SSH) +connection@footnote{This command is available only when Guile-SSH was +found. @xref{Requirements}, for details.}. For example, the following +command copies the @code{coreutils} package, the user's profile, and all +their dependencies over to @var{host}, logged in as @var{user}: + +@example +guix copy --to=@var{user}@@@var{host} \ + coreutils `readlink -f ~/.guix-profile` +@end example + +If some of the items to be copied are already present on @var{host}, +they are not actually sent. + +The command below retrieves @code{libreoffice} and @code{gimp} from +@var{host}, assuming they are available there: + +@example +guix copy --from=@var{host} libreoffice gimp +@end example + +The SSH connection is established using the Guile-SSH client, which is +compatible with OpenSSH: it honors @file{~/.ssh/known_hosts} and +@file{~/.ssh/config}, and uses the SSH agent for authentication. + +The key used to sign items that are sent must be accepted by the remote +machine. Likewise, the key used by the remote machine to sign items you +are retrieving must be in @file{/etc/guix/acl} so it is accepted by your +own daemon. @xref{Invoking guix archive}, for more information about +store item authentication. + +The general syntax is: + +@example +guix copy [--to=@var{spec}|--from=@var{spec}] @var{items}@dots{} +@end example + +You must always specify one of the following options: + +@table @code +@item --to=@var{spec} +@itemx --from=@var{spec} +Specify the host to send to or receive from. @var{spec} must be an SSH +spec such as @code{example.org}, @code{charlie@@example.org}, or +@code{charlie@@example.org:2222}. +@end table + +The @var{items} can be either package names, such as @code{gimp}, or +store items, such as @file{/gnu/store/@dots{}-idutils-4.6}. + +When specifying the name of a package to send, it is first built if +needed, unless @option{--dry-run} was specified. Common build options +are supported (@pxref{Common Build Options}). + @node Invoking guix container @section Invoking @command{guix container} diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 400353247c..7e432351ed 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -41,7 +41,8 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 binary-ports) - #:export (guix-archive)) + #:export (guix-archive + options->derivations+files)) ;;; diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm new file mode 100644 index 0000000000..9ae204e6c6 --- /dev/null +++ b/guix/scripts/copy.scm @@ -0,0 +1,207 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts copy) + #:use-module (guix ui) + #:use-module (guix scripts) + #:use-module (guix ssh) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix scripts build) + #:use-module ((guix scripts archive) #:select (options->derivations+files)) + #:use-module (ssh session) + #:use-module (ssh auth) + #:use-module (ssh key) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-copy)) + + +;;; +;;; Exchanging store items over SSH. +;;; + +(define %compression + "zlib@openssh.com,zlib") + +(define* (open-ssh-session host #:key user port) + "Open an SSH session for HOST and return it. When USER and PORT are #f, use +default values or whatever '~/.ssh/config' specifies; otherwise use them. +Throw an error on failure." + (let ((session (make-session #:user user + #:host host + #:port port + #:timeout 10 ;seconds + ;; #:log-verbosity 'protocol + + ;; We need lightweight compression when + ;; exchanging full archives. + #:compression %compression + #:compression-level 3))) + + ;; Honor ~/.ssh/config. + (session-parse-config! session) + + (match (connect! session) + ('ok + ;; Let the SSH agent authenticate us to the server. + (match (userauth-agent! session) + ('success + session) + (x + (disconnect! session) + (leave (_ "SSH authentication failed for '~a': ~a~%") + host (get-error session))))) + (x + ;; Connection failed or timeout expired. + (leave (_ "SSH connection to '~a' failed: ~a~%") + host (get-error session)))))) + +(define (ssh-spec->user+host+port spec) + "Parse SPEC, a string like \"user@host:port\" or just \"host\", and return +three values: the user name (or #f), the host name, and the TCP port +number (or #f) corresponding to SPEC." + (define tokens + (char-set #\@ #\:)) + + (match (string-tokenize spec (char-set-complement tokens)) + ((host) + (values #f host #f)) + ((left right) + (if (string-index spec #\@) + (values left right #f) + (values #f left (string->number right)))) + ((user host port) + (match (string->number port) + ((? integer? port) + (values user host port)) + (x + (leave (_ "~a: invalid TCP port number~%") port)))) + (x + (leave (_ "~a: invalid SSH specification~%") spec)))) + +(define (send-to-remote-host target opts) + "Send ITEMS to TARGET. ITEMS is a list of store items or package names; for ; +package names, build the underlying packages before sending them." + (with-store local + (set-build-options-from-command-line local opts) + (let-values (((user host port) + (ssh-spec->user+host+port target)) + ((drv items) + (options->derivations+files local opts))) + (show-what-to-build local drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?)) + + (and (or (assoc-ref opts 'dry-run?) + (build-derivations local drv)) + (let* ((session (open-ssh-session host #:user user #:port port)) + (sent (send-files local items + (connect-to-remote-daemon session) + #:recursive? #t))) + (format #t "~{~a~%~}" sent) + sent))))) + +(define (retrieve-from-remote-host source opts) + "Retrieve ITEMS from SOURCE." + (with-store local + (let*-values (((user host port) + (ssh-spec->user+host+port source)) + ((session) + (open-ssh-session host #:user user #:port port)) + ((remote) + (connect-to-remote-daemon session))) + (set-build-options-from-command-line local opts) + ;; TODO: Here we could to compute and build the derivations on REMOTE + ;; rather than on LOCAL (one-off offloading) but that is currently too + ;; slow due to the many RPC round trips. So we just assume that REMOTE + ;; contains ITEMS. + (let*-values (((drv items) + (options->derivations+files local opts)) + ((retrieved) + (retrieve-files local items remote #:recursive? #t))) + (format #t "~{~a~%~}" retrieved) + retrieved)))) + + +;;; +;;; Options. +;;; + +(define (show-help) + (display (_ "Usage: guix copy [OPTION]... ITEMS... +Copy ITEMS to or from the specified host over SSH.\n")) + (display (_ " + --to=HOST send ITEMS to HOST")) + (display (_ " + --from=HOST receive ITEMS from HOST")) + (newline) + (show-build-options-help) + (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. + (cons* (option '("to") #t #f + (lambda (opt name arg result) + (alist-cons 'destination arg result))) + (option '("from") #t #f + (lambda (opt name arg result) + (alist-cons 'source arg result))) + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix copy"))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + %standard-build-options)) + +(define %default-options + `((system . ,(%current-system)) + (substitutes? . #t) + (graft? . #t) + (max-silent-time . 3600) + (verbosity . 0))) + + +;;; +;;; Entry point. +;;; + +(define (guix-copy . args) + (with-error-handling + (let* ((opts (parse-command-line args %options (list %default-options))) + (source (assoc-ref opts 'source)) + (target (assoc-ref opts 'destination))) + (cond (target (send-to-remote-host target opts)) + (source (retrieve-from-remote-host source opts)) + (else (leave (_ "use '--to' or '--from'~%"))))))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 27cc64929d..0a2eee8170 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -24,6 +24,7 @@ guix/scripts/edit.scm guix/scripts/size.scm guix/scripts/graph.scm guix/scripts/challenge.scm +guix/scripts/copy.scm guix/gnu-maintenance.scm guix/scripts/container.scm guix/scripts/container/exec.scm -- cgit 1.4.1 From 8de938d59aa48a43b71d9fa687d762c807f59136 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Jan 2017 22:52:35 +0100 Subject: services: cuirass: Allow for gexps in specifications. * gnu/services/cuirass.scm ()[specifications]: Change default value to #~'(). (cuirass-shepherd-service): Remove conditional for "--specifications". Use 'scheme-file' instead of 'plain-file'. Change file name to "cuirass-specs.scm". * doc/guix.texi (Continuous Integration): Change the example to use a gexp where #:file refers to a file within Cuirass. Adjust documentation. --- doc/guix.texi | 31 +++++++++++++++++++------------ gnu/services/cuirass.scm | 13 +++++-------- 2 files changed, 24 insertions(+), 20 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 42fb439668..45657ed2cf 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -13,7 +13,7 @@ @set OPENPGP-SIGNING-KEY-ID BCA689B636553801C3C62150197A5888235FACAC @copying -Copyright @copyright{} 2012, 2013, 2014, 2015, 2016 Ludovic Courtès@* +Copyright @copyright{} 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès@* Copyright @copyright{} 2013, 2014, 2016 Andreas Enge@* Copyright @copyright{} 2013 Nikita Karetnikov@* Copyright @copyright{} 2014, 2015, 2016 Alex Kost@* @@ -12028,16 +12028,22 @@ defining a build job based on a specification that can be found in Cuirass source tree. @example -(let ((spec `((#:name . "guix") - (#:url . "git://git.savannah.gnu.org/guix.git") - (#:load-path . ".") - ;; Adapt to a valid absolute file name. - (#:file . "/.../cuirass/tests/gnu-system.scm") - (#:proc . hydra-jobs) - (#:arguments (subset . "hello")) - (#:branch . "master")))) +(let ((spec #~((#:name . "guix") + (#:url . "git://git.savannah.gnu.org/guix.git") + (#:load-path . ".") + + ;; Here we must provide an absolute file name. + ;; We take jobs from one of the examples provided + ;; by Cuirass. + (#:file . #$(file-append + cuirass + "/tests/gnu-system.scm")) + + (#:proc . hydra-jobs) + (#:arguments (subset . "hello")) + (#:branch . "master")))) (cuirass-service #:config (cuirass-configuration - (specifications (list spec))))) + (specifications #~(list #$spec))))) @end example While information related to build jobs are located directly in the @@ -12068,8 +12074,9 @@ Cuirass jobs. Location of sqlite database which contains the build results and previously added specifications. -@item @code{specifications} (default: @code{'()}) -A list of specifications, where a specification is an association list +@item @code{specifications} (default: @code{#~'()}) +A gexp (@pxref{G-Expressions}) that evaluates to a list of specifications, +where a specification is an association list (@pxref{Associations Lists,,, guile, GNU Guile Reference Manual}) whose keys are keywords (@code{#:keyword-example}) as shown in the example above. diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index 67265e506e..4dc802fc8c 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Mathieu Lirzin -;;; Copyright © 2016 Ludovic Courtès +;;; Copyright © 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,8 +57,8 @@ (default 60)) (database cuirass-configuration-database ;string (file-name) (default "/var/run/cuirass/cuirass.db")) - (specifications cuirass-configuration-specifications ;specification-alist - (default '())) + (specifications cuirass-configuration-specifications + (default #~'())) ;gexp that evaluates to specification-alist (use-substitutes? cuirass-configuration-use-substitutes? ;boolean (default #f)) (one-shot? cuirass-configuration-one-shot? ;boolean @@ -85,11 +85,8 @@ (start #~(make-forkexec-constructor (list (string-append #$cuirass "/bin/cuirass") "--cache-directory" #$cache-directory - #$@(if (null? specs) - '() - (let ((str (format #f "'~S" specs))) - (list "--specifications" - (plain-file "specs.scm" str)))) + "--specifications" + #$(scheme-file "cuirass-specs.scm" specs) "--database" #$database "--interval" #$(number->string interval) #$@(if use-substitutes? '("--use-substitutes") '()) -- cgit 1.4.1 From 231eddc88ae1f459024f410c5fee48c0a2003bec Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Jan 2017 23:11:25 +0100 Subject: services: cuirass: Remove 'cuirass-service' procedure. * gnu/services/cuirass.scm ()[specifications]: Remove default value. (cuirass-service): Remove. * doc/guix.texi (Continuous Integration): Adjust accordingly. --- doc/guix.texi | 30 +++++++++++++----------------- gnu/services/cuirass.scm | 10 +++------- 2 files changed, 16 insertions(+), 24 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 45657ed2cf..8c65f44dac 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -12011,21 +12011,16 @@ providing substitutes to others (@pxref{Substitutes}). The @code{(gnu services cuirass)} module provides the following service. -@deffn {Scheme Procedure} cuirass-service @ - [#:config @code{(cuirass-configuration)}] -Return a service that runs @command{cuirass}. - -The @var{#:config} keyword argument specifies the configuration for -@command{cuirass}, which must be a @code{} -object, by default it doesn't provide any build job. If you want to -provide your own configuration you will most likely use the -@code{cuirass-configuration} special form which returns such objects. -@end deffn +@defvr {Scheme Procedure} cuirass-service-type +The type of the Cuirass service. Its value must be a +@code{cuirass-configuration} object, as described below. +@end defvr -In order to add build jobs you will have to set the -@code{specifications} field. Here is an example of a cuirass service -defining a build job based on a specification that can be found in -Cuirass source tree. +To add build jobs, you have to set the @code{specifications} field of +the configuration. Here is an example of a service defining a build job +based on a specification that can be found in Cuirass source tree. This +service polls the Guix repository and builds a subset of the Guix +packages, as prescribed in the @file{gnu-system.scm} example spec: @example (let ((spec #~((#:name . "guix") @@ -12042,11 +12037,12 @@ Cuirass source tree. (#:proc . hydra-jobs) (#:arguments (subset . "hello")) (#:branch . "master")))) - (cuirass-service #:config (cuirass-configuration - (specifications #~(list #$spec))))) + (service cuirass-service-type + (cuirass-configuration + (specifications #~(list #$spec))))) @end example -While information related to build jobs are located directly in the +While information related to build jobs is located directly in the specifications, global settings for the @command{cuirass} process are accessible in other @code{cuirass-configuration} fields. diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index 4dc802fc8c..c15a846bad 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -30,8 +30,7 @@ cuirass-configuration cuirass-configuration? - cuirass-service-type - cuirass-service)) + cuirass-service-type)) ;;;; Commentary: ;;; @@ -57,8 +56,8 @@ (default 60)) (database cuirass-configuration-database ;string (file-name) (default "/var/run/cuirass/cuirass.db")) - (specifications cuirass-configuration-specifications - (default #~'())) ;gexp that evaluates to specification-alist + (specifications cuirass-configuration-specifications) + ;gexp that evaluates to specification-alist (use-substitutes? cuirass-configuration-use-substitutes? ;boolean (default #f)) (one-shot? cuirass-configuration-one-shot? ;boolean @@ -140,6 +139,3 @@ (service-extension shepherd-root-service-type cuirass-shepherd-service) (service-extension account-service-type cuirass-account))))) -(define* (cuirass-service #:key (config (cuirass-configuration))) - "Return a service that runs cuirass according to CONFIG." - (service cuirass-service-type config)) -- cgit 1.4.1 From 3b9b12ef49d0b6d7a8887513acb9e9a1a8325148 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Tue, 13 Dec 2016 20:44:31 +0100 Subject: services: nginx: Rename "vhost" to "server". MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/web.scm (): Rename to... (): ... this. * doc/guix.texi (Web Services): Adjust accordingly. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 20 +++++++++--------- gnu/services/web.scm | 60 ++++++++++++++++++++++++++-------------------------- 2 files changed, 40 insertions(+), 40 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 8c65f44dac..fde9601e82 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11827,7 +11827,7 @@ The @code{(gnu services web)} module provides the following service: @deffn {Scheme Procedure} nginx-service [#:nginx nginx] @ [#:log-directory ``/var/log/nginx''] @ [#:run-directory ``/var/run/nginx''] @ - [#:vhost-list (list (nginx-vhost-configuration))] @ + [#:server-list (list (nginx-server-configuration))] @ [#:config-file] Return a service that runs @var{nginx}, the nginx web server. @@ -11838,32 +11838,32 @@ files are written to @var{run-directory}. For proper operation, these arguments should match what is in @var{config-file} to ensure that the directories are created when the service is activated. -As an alternative to using a @var{config-file}, @var{vhost-list} can be -used to specify the list of @dfn{virtual hosts} required on the host. For +As an alternative to using a @var{config-file}, @var{server-list} can be +used to specify the list of @dfn{server blocks} required on the host. For this to work, use the default value for @var{config-file}. @end deffn -@deftp {Data Type} nginx-vhost-configuration -Data type representing the configuration of an nginx virtual host. +@deftp {Data Type} nginx-server-configuration +Data type representing the configuration of an nginx server block. This type has the following parameters: @table @asis @item @code{http-port} (default: @code{80}) Nginx will listen for HTTP connection on this port. Set it at @code{#f} if nginx should not listen for HTTP (non secure) connection for this -@dfn{virtual host}. +@dfn{server block}. @item @code{https-port} (default: @code{443}) Nginx will listen for HTTPS connection on this port. Set it at @code{#f} if -nginx should not listen for HTTPS (secure) connection for this @dfn{virtual host}. +nginx should not listen for HTTPS (secure) connection for this @dfn{server block}. Note that nginx can listen for HTTP and HTTPS connections in the same -@dfn{virtual host}. +@dfn{server block}. @item @code{server-name} (default: @code{(list 'default)}) -A list of server names this vhost represents. @code{'default} represents the -default vhost for connections matching no other vhost. +A list of server names this server represents. @code{'default} represents the +default server for connections matching no other server. @item @code{root} (default: @code{"/srv/http"}) Root of the website nginx will serve. diff --git a/gnu/services/web.scm b/gnu/services/web.scm index 8f6e5bf6b7..12a146d8b0 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -30,8 +30,8 @@ #:use-module (ice-9 match) #:export (nginx-configuration nginx-configuration? - nginx-vhost-configuration - nginx-vhost-configuration? + nginx-server-configuration + nginx-server-configuration? nginx-service nginx-service-type)) @@ -41,24 +41,24 @@ ;;; ;;; Code: -(define-record-type* - nginx-vhost-configuration make-nginx-vhost-configuration - nginx-vhost-configuration? - (http-port nginx-vhost-configuration-http-port +(define-record-type* + nginx-server-configuration make-nginx-server-configuration + nginx-server-configuration? + (http-port nginx-server-configuration-http-port (default 80)) - (https-port nginx-vhost-configuration-https-port + (https-port nginx-server-configuration-https-port (default 443)) - (server-name nginx-vhost-configuration-server-name + (server-name nginx-server-configuration-server-name (default (list 'default))) - (root nginx-vhost-configuration-root + (root nginx-server-configuration-root (default "/srv/http")) - (index nginx-vhost-configuration-index + (index nginx-server-configuration-index (default (list "index.html"))) - (ssl-certificate nginx-vhost-configuration-ssl-certificate + (ssl-certificate nginx-server-configuration-ssl-certificate (default "/etc/nginx/cert.pem")) - (ssl-certificate-key nginx-vhost-configuration-ssl-certificate-key + (ssl-certificate-key nginx-server-configuration-ssl-certificate-key (default "/etc/nginx/key.pem")) - (server-tokens? nginx-vhost-configuration-server-tokens? + (server-tokens? nginx-server-configuration-server-tokens? (default #f))) (define-record-type* @@ -86,37 +86,37 @@ of index files." ((? string? str) str)) names))) -(define (default-nginx-vhost-config vhost) +(define (default-nginx-server-config server) (string-append " server {\n" - (if (nginx-vhost-configuration-http-port vhost) + (if (nginx-server-configuration-http-port server) (string-append " listen " - (number->string (nginx-vhost-configuration-http-port vhost)) + (number->string (nginx-server-configuration-http-port server)) ";\n") "") - (if (nginx-vhost-configuration-https-port vhost) + (if (nginx-server-configuration-https-port server) (string-append " listen " - (number->string (nginx-vhost-configuration-https-port vhost)) + (number->string (nginx-server-configuration-https-port server)) " ssl;\n") "") " server_name " (config-domain-strings - (nginx-vhost-configuration-server-name vhost)) + (nginx-server-configuration-server-name server)) ";\n" - (if (nginx-vhost-configuration-ssl-certificate vhost) + (if (nginx-server-configuration-ssl-certificate server) (string-append " ssl_certificate " - (nginx-vhost-configuration-ssl-certificate vhost) ";\n") + (nginx-server-configuration-ssl-certificate server) ";\n") "") - (if (nginx-vhost-configuration-ssl-certificate-key vhost) + (if (nginx-server-configuration-ssl-certificate-key server) (string-append " ssl_certificate_key " - (nginx-vhost-configuration-ssl-certificate-key vhost) ";\n") + (nginx-server-configuration-ssl-certificate-key server) ";\n") "") - " root " (nginx-vhost-configuration-root vhost) ";\n" - " index " (config-index-strings (nginx-vhost-configuration-index vhost)) ";\n" - " server_tokens " (if (nginx-vhost-configuration-server-tokens? vhost) + " root " (nginx-server-configuration-root server) ";\n" + " index " (config-index-strings (nginx-server-configuration-index server)) ";\n" + " server_tokens " (if (nginx-server-configuration-server-tokens? server) "on" "off") ";\n" " }\n")) -(define (default-nginx-config log-directory run-directory vhost-list) +(define (default-nginx-config log-directory run-directory server-list) (plain-file "nginx.conf" (string-append "user nginx nginx;\n" @@ -129,7 +129,7 @@ of index files." " uwsgi_temp_path " run-directory "/uwsgi_temp;\n" " scgi_temp_path " run-directory "/scgi_temp;\n" " access_log " log-directory "/access.log;\n" - (let ((http (map default-nginx-vhost-config vhost-list))) + (let ((http (map default-nginx-server-config server-list))) (do ((http http (cdr http)) (block "" (string-append (car http) "\n" block ))) ((null? http) block))) @@ -197,9 +197,9 @@ of index files." (define* (nginx-service #:key (nginx nginx) (log-directory "/var/log/nginx") (run-directory "/var/run/nginx") - (vhost-list (list (nginx-vhost-configuration))) + (server-list (list (nginx-server-configuration))) (config-file - (default-nginx-config log-directory run-directory vhost-list))) + (default-nginx-config log-directory run-directory server-list))) "Return a service that runs NGINX, the nginx web server. The nginx daemon loads its runtime configuration from CONFIG-FILE, stores log -- cgit 1.4.1 From d338237d8c2408e0cd13ecfeb303e327ff7e3d9b Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Tue, 13 Dec 2016 21:00:53 +0100 Subject: services: nginx: Make service extensible. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/web.scm ()[server-blocks]: New field. (nginx-activation): When CONFIG-FILE is #f, use 'default-nginx-config'. (nginx-shepherd-service): Likewise. (nginx-service-type): Add 'compose' and 'extend' fields. (nginx-service): Change default value of #:server-list to '(), and default value of #:config-file to #f. * doc/guix.texi (Web Services): Document it. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 18 ++++++++++++++++-- gnu/services/web.scm | 34 ++++++++++++++++++++++++++-------- 2 files changed, 42 insertions(+), 10 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index fde9601e82..74f1e77e28 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11827,8 +11827,8 @@ The @code{(gnu services web)} module provides the following service: @deffn {Scheme Procedure} nginx-service [#:nginx nginx] @ [#:log-directory ``/var/log/nginx''] @ [#:run-directory ``/var/run/nginx''] @ - [#:server-list (list (nginx-server-configuration))] @ - [#:config-file] + [#:server-list '()] @ + [#:config-file @code{#f}] Return a service that runs @var{nginx}, the nginx web server. @@ -11844,6 +11844,20 @@ this to work, use the default value for @var{config-file}. @end deffn +@deffn {Scheme Variable} nginx-service-type +This is type for the nginx web server. + +This service can be extended to add server blocks in addition to the +default one, as in this example: + +@example +(simple-service 'my-extra-server nginx-service-type + (list (nginx-server-configuration + (https-port #f) + (root "/srv/http/extra-website")))) +@end example +@end deffn + @deftp {Data Type} nginx-server-configuration Data type representing the configuration of an nginx server block. This type has the following parameters: diff --git a/gnu/services/web.scm b/gnu/services/web.scm index a36352225e..db895405a2 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -27,6 +27,7 @@ #:use-module (gnu packages web) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:export (nginx-configuration nginx-configuration? @@ -67,6 +68,7 @@ (nginx nginx-configuration-nginx) ; (log-directory nginx-configuration-log-directory) ;string (run-directory nginx-configuration-run-directory) ;string + (server-blocks nginx-configuration-server-blocks) ;list (file nginx-configuration-file)) ;string | file-like (define (config-domain-strings names) @@ -148,7 +150,8 @@ of index files." (define nginx-activation (match-lambda - (($ nginx log-directory run-directory config-file) + (($ nginx log-directory run-directory server-blocks + config-file) #~(begin (use-modules (guix build utils)) @@ -164,17 +167,25 @@ of index files." (mkdir-p (string-append #$run-directory "/scgi_temp")) ;; Check configuration file syntax. (system* (string-append #$nginx "/sbin/nginx") - "-c" #$config-file "-t"))))) + "-c" #$(or config-file + (default-nginx-config log-directory + run-directory server-blocks)) + "-t"))))) (define nginx-shepherd-service (match-lambda - (($ nginx log-directory run-directory config-file) + (($ nginx log-directory run-directory server-blocks + config-file) (let* ((nginx-binary (file-append nginx "/sbin/nginx")) (nginx-action (lambda args #~(lambda _ (zero? - (system* #$nginx-binary "-c" #$config-file #$@args)))))) + (system* #$nginx-binary "-c" + #$(or config-file + (default-nginx-config log-directory + run-directory server-blocks)) + #$@args)))))) ;; TODO: Add 'reload' action. (list (shepherd-service @@ -192,14 +203,20 @@ of index files." (service-extension activation-service-type nginx-activation) (service-extension account-service-type - (const %nginx-accounts)))))) + (const %nginx-accounts)))) + (compose concatenate) + (extend (lambda (config servers) + (nginx-configuration + (inherit config) + (server-blocks + (append (nginx-configuration-server-blocks config) + servers))))))) (define* (nginx-service #:key (nginx nginx) (log-directory "/var/log/nginx") (run-directory "/var/run/nginx") - (server-list (list (nginx-server-configuration))) - (config-file - (default-nginx-config log-directory run-directory server-list))) + (server-list '()) + (config-file #f)) "Return a service that runs NGINX, the nginx web server. The nginx daemon loads its runtime configuration from CONFIG-FILE, stores log @@ -209,4 +226,5 @@ files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY." (nginx nginx) (log-directory log-directory) (run-directory run-directory) + (server-blocks server-list) (file config-file)))) -- cgit 1.4.1 From 9b4ec5730a8739a55cce25adc8120b28035baebc Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 4 Jan 2017 11:42:31 +0100 Subject: doc: Change wording for "--with-graft". * doc/guix.texi (Package Transformation Options): Change wording for "--with-graft" documentation. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 74f1e77e28..3a9ebe8a63 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4685,7 +4685,7 @@ procedure (@pxref{Defining Packages, @code{package-input-rewriting}}). @item --with-graft=@var{package}=@var{replacement} This is similar to @code{--with-input} but with an important difference: -instead of rebuilding all the dependency chain, @var{replacement} is +instead of rebuilding the whole dependency chain, @var{replacement} is built and then @dfn{grafted} onto the binaries that were initially referring to @var{package}. @xref{Security Updates}, for more information on grafts. -- cgit 1.4.1 From b96a0640a3ca128c0b9bf9acaef7b3b7a8bb1455 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Jan 2017 16:16:17 +0100 Subject: graph: Add '%reverse-package-node-type'. * guix/scripts/graph.scm (%reverse-package-node-type): New variable. (%node-types): Add it. * tests/graph.scm ("reverse package DAG"): New test. * doc/guix.texi (Invoking guix refresh): Add cross-reference to "Invoking guix graph". (Invoking guix graph): Document 'reverse-package'. --- doc/guix.texi | 18 ++++++++++++++++++ guix/scripts/graph.scm | 21 +++++++++++++++++++++ tests/graph.scm | 14 +++++++++++++- 3 files changed, 52 insertions(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 3a9ebe8a63..adc7fefcae 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5445,6 +5445,10 @@ end, display the fraction of packages covered by all these updaters. List top-level dependent packages that would need to be rebuilt as a result of upgrading one or more packages. +@xref{Invoking guix graph, the @code{reverse-package} type of +@command{guix graph}}, for information on how to visualize the list of +dependents of a package. + @end table Be aware that the @code{--list-dependent} option only @@ -5746,6 +5750,20 @@ This is the default type used in the example above. It shows the DAG of package objects, excluding implicit dependencies. It is concise, but filters out many details. +@item reverse-package +This shows the @emph{reverse} DAG of packages. For example: + +@example +guix graph --type=reverse-package ocaml +@end example + +... yields the graph of packages that depend on OCaml. + +Note that for core packages this can yield huge graphs. If all you want +is to know the number of packages that depend on a given package, use +@command{guix refresh --list-dependent} (@pxref{Invoking guix refresh, +@option{--list-dependent}}). + @item bag-emerged This is the package DAG, @emph{including} implicit inputs. diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index d96df5fbaf..79ce503a2e 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -37,6 +37,7 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (%package-node-type + %reverse-package-node-type %bag-node-type %bag-with-origins-node-type %bag-emerged-node-type @@ -101,6 +102,25 @@ name." (label node-full-name) (edges (lift1 package-node-edges %store-monad)))) + +;;; +;;; Reverse package DAG. +;;; + +(define %reverse-package-node-type + ;; For this node type we first need to compute the list of packages and the + ;; list of back-edges. Since we want to do it only once, we use the + ;; promises below. + (let* ((packages (delay (fold-packages cons '()))) + (back-edges (delay (run-with-store #f ;store not actually needed + (node-back-edges %package-node-type + (force packages)))))) + (node-type + (inherit %package-node-type) + (name "reverse-package") + (description "the reverse DAG of packages") + (edges (lift1 (force back-edges) %store-monad))))) + ;;; ;;; Package DAG using bags. @@ -323,6 +343,7 @@ substitutes." (define %node-types ;; List of all the node types. (list %package-node-type + %reverse-package-node-type %bag-node-type %bag-with-origins-node-type %bag-emerged-node-type diff --git a/tests/graph.scm b/tests/graph.scm index bc4d62fe50..6431c482f7 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +32,7 @@ #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages guile) + #:use-module (gnu packages libunistring) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -92,6 +93,17 @@ edges." (list p3 p3 p2) (list p2 p1 p1)))))))) +(test-assert "reverse package DAG" + (let-values (((backend nodes+edges) (make-recording-backend))) + (run-with-store %store + (export-graph (list libunistring) 'port + #:node-type %reverse-package-node-type + #:backend backend)) + ;; We should see nothing more than these 3 packages. + (let-values (((nodes edges) (nodes+edges))) + (and (member (package->tuple guile-2.0) nodes) + (->bool (member (edge->tuple libunistring guile-2.0) edges)))))) + (test-assert "bag-emerged DAG" (let-values (((backend nodes+edges) (make-recording-backend))) (let* ((o (dummy-origin (method (lambda _ -- cgit 1.4.1 From 03476a23ff2d4175b7d3c808726178f764359bec Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 3 Jan 2017 16:20:15 +0100 Subject: guix: Add Docker image export. * guix/docker.scm: New file. * Makefile.am (MODULES): Register it. * guix/scripts/archive.scm (show-help, %options, guix-archive): Add support for "--format". * doc/guix.texi (Invoking guix archive): Document it. --- Makefile.am | 1 + doc/guix.texi | 18 ++++++- guix/docker.scm | 127 +++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/archive.scm | 17 ++++++- 4 files changed, 161 insertions(+), 2 deletions(-) create mode 100644 guix/docker.scm (limited to 'doc/guix.texi') diff --git a/Makefile.am b/Makefile.am index 1a66fff505..3e147df2e0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -160,6 +160,7 @@ MODULES = \ if HAVE_GUILE_JSON MODULES += \ + guix/docker.scm \ guix/import/github.scm \ guix/import/json.scm \ guix/import/crate.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index adc7fefcae..e52382e976 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2394,7 +2394,7 @@ what you should use in this case (@pxref{Invoking guix copy}). @cindex nar, archive format @cindex normalized archive (nar) -Archives are stored in the ``normalized archive'' or ``nar'' format, which is +By default archives are stored in the ``normalized archive'' or ``nar'' format, which is comparable in spirit to `tar', but with differences that make it more appropriate for our purposes. First, rather than recording all Unix metadata for each file, the nar format only mentions @@ -2410,6 +2410,9 @@ verifies the signature and rejects the import in case of an invalid signature or if the signing key is not authorized. @c FIXME: Add xref to daemon doc about signatures. +Optionally, archives can be exported as a Docker image in the tar +archive format using @code{--format=docker}. + The main options are: @table @code @@ -2438,6 +2441,19 @@ Read a list of store file names from the standard input, one per line, and write on the standard output the subset of these files missing from the store. +@item -f +@item --format=@var{FMT} +@cindex docker, export +@cindex export format +Specify the export format. Acceptable arguments are @code{nar} and +@code{docker}. The default is the nar format. When the format is +@code{docker}, recursively export the specified store directory as a +Docker image in tar archive format, as specified in +@uref{https://github.com/docker/docker/blob/master/image/spec/v1.2.md, +version 1.2.0 of the Docker Image Specification}. Using +@code{--format=docker} implies @code{--recursive}. The generated +archive can be loaded by Docker using @command{docker load}. + @item --generate-key[=@var{parameters}] @cindex signing, archives Generate a new key pair for the daemon. This is a prerequisite before diff --git a/guix/docker.scm b/guix/docker.scm new file mode 100644 index 0000000000..dbe1e5351c --- /dev/null +++ b/guix/docker.scm @@ -0,0 +1,127 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ricardo Wurmus +;;; +;;; 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 . + +(define-module (guix docker) + #:use-module (guix hash) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module ((guix build utils) + #:select (delete-file-recursively + with-directory-excursion)) + #:use-module (json) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:export (build-docker-image)) + +;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image +;; containing the closure at PATH. +(define docker-id + (compose bytevector->base16-string sha256 string->utf8)) + +(define (layer-diff-id layer) + "Generate a layer DiffID for the given LAYER archive." + (string-append "sha256:" (bytevector->base16-string (file-sha256 layer)))) + +;; This is the semantic version of the JSON metadata schema according to +;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md +;; It is NOT the version of the image specification. +(define schema-version "1.0") + +(define (image-description id time) + "Generate a simple image description." + `((id . ,id) + (created . ,time) + (container_config . #nil))) + +(define (generate-tag path) + "Generate an image tag for the given PATH." + (match (string-split (basename path) #\-) + ((hash name . rest) (string-append name ":" hash)))) + +(define (manifest path id) + "Generate a simple image manifest." + `(((Config . "config.json") + (RepoTags . (,(generate-tag path))) + (Layers . (,(string-append id "/layer.tar")))))) + +;; According to the specifications this is required for backwards +;; compatibility. It duplicates information provided by the manifest. +(define (repositories path id) + "Generate a repositories file referencing PATH and the image ID." + `((,(generate-tag path) . ((latest . ,id))))) + +;; See https://github.com/opencontainers/image-spec/blob/master/config.md +(define (config layer time arch) + "Generate a minimal image configuration for the given LAYER file." + ;; "architecture" must be values matching "platform.arch" in the + ;; runtime-spec at + ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform + `((architecture . ,arch) + (comment . "Generated by GNU Guix") + (created . ,time) + (config . #nil) + (container_config . #nil) + (os . "linux") + (rootfs . ((type . "layers") + (diff_ids . (,(layer-diff-id layer))))))) + +(define* (build-docker-image path #:key system) + "Generate a Docker image archive from the given store PATH. The image +contains the closure of the given store item." + (let ((id (docker-id path)) + (time (strftime "%FT%TZ" (localtime (current-time)))) + (name (string-append (getcwd) + "/docker-image-" (basename path) ".tar")) + (arch (match system + ("x86_64-linux" "amd64") + ("i686-linux" "386") + ("armhf-linux" "arm") + ("mips64el-linux" "mips64le")))) + (and (call-with-temporary-directory + (lambda (directory) + (with-directory-excursion directory + ;; Add symlink from /bin to /gnu/store/.../bin + (symlink (string-append path "/bin") "bin") + + (mkdir id) + (with-directory-excursion id + (with-output-to-file "VERSION" + (lambda () (display schema-version))) + (with-output-to-file "json" + (lambda () (scm->json (image-description id time)))) + + ;; Wrap it up + (let ((items (with-store store + (requisites store (list path))))) + (and (zero? (apply system* "tar" "-cf" "layer.tar" + (cons "../bin" items))) + (delete-file "../bin")))) + + (with-output-to-file "config.json" + (lambda () + (scm->json (config (string-append id "/layer.tar") + time arch)))) + (with-output-to-file "manifest.json" + (lambda () + (scm->json (manifest path id)))) + (with-output-to-file "repositories" + (lambda () + (scm->json (repositories path id))))) + (and (zero? (system* "tar" "-C" directory "-cf" name ".")) + (begin (delete-file-recursively directory) #t)))) + name))) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 7e432351ed..6eba9e0008 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +31,7 @@ #:use-module (guix ui) #:use-module (guix pki) #:use-module (guix pk-crypto) + #:use-module (guix docker) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu packages) @@ -62,6 +64,8 @@ Export/import one or more packages from/to the store.\n")) (display (_ " --export export the specified files/packages to stdout")) + (display (_ " + --format=FMT export files/packages in the specified format FMT")) (display (_ " -r, --recursive combined with '--export', include dependencies")) (display (_ " @@ -117,6 +121,9 @@ Export/import one or more packages from/to the store.\n")) (option '("export") #f #f (lambda (opt name arg result) (alist-cons 'export #t result))) + (option '(#\f "format") #t #f + (lambda (opt name arg result . rest) + (alist-cons 'format arg result))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'export-recursive? #t result))) @@ -331,7 +338,15 @@ the input port." (else (with-store store (cond ((assoc-ref opts 'export) - (export-from-store store opts)) + (cond ((equal? (assoc-ref opts 'format) "docker") + (match (car opts) + (('argument . (? store-path? item)) + (format #t "~a\n" + (build-docker-image + item + #:system (assoc-ref opts 'system)))) + (_ (leave (_ "argument must be a direct store path~%"))))) + (_ (export-from-store store opts)))) ((assoc-ref opts 'import) (import-paths store (current-input-port))) ((assoc-ref opts 'missing) -- cgit 1.4.1 From 78cef99b9812f1bb43708f84d316d286a1599bdf Mon Sep 17 00:00:00 2001 From: Clément Lassieur Date: Sun, 8 Jan 2017 20:08:14 +0100 Subject: gnu: Add Prosody service. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/messaging.scm: New file. * gnu/services/configuration.scm: New exported procedures. * gnu/local.mk (GNU_SYSTEM_MODULES): Add gnu/services/messaging.scm. * doc/guix.texi (Messaging Services): New section. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 393 +++++++++++++++++++++- gnu/local.mk | 1 + gnu/services/configuration.scm | 3 + gnu/services/messaging.scm | 726 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 1122 insertions(+), 1 deletion(-) create mode 100644 gnu/services/messaging.scm (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index e52382e976..d46a7743d0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -29,7 +29,8 @@ Copyright @copyright{} 2016 John Darrington@* Copyright @copyright{} 2016 ng0@* Copyright @copyright{} 2016 Jan Nieuwenhuizen@* Copyright @copyright{} 2016 Julien Lepiller@* -Copyright @copyright{} 2016 Alex ter Weele +Copyright @copyright{} 2016 Alex ter Weele@* +Copyright @copyright{} 2017 Clément Lassieur Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -204,6 +205,7 @@ Services * Desktop Services:: D-Bus and desktop services. * Database Services:: SQL databases. * Mail Services:: IMAP, POP3, SMTP, and all that. +* Messaging Services:: Messaging services. * Kerberos Services:: Kerberos services. * Web Services:: Web servers. * Network File System:: NFS related services. @@ -8110,6 +8112,7 @@ declaration. * Desktop Services:: D-Bus and desktop services. * Database Services:: SQL databases. * Mail Services:: IMAP, POP3, SMTP, and all that. +* Messaging Services:: Messaging services. * Kerberos Services:: Kerberos services. * Web Services:: Web servers. * Network File System:: NFS related services. @@ -11724,6 +11727,394 @@ remote servers. Run @command{man smtpd.conf} for more information. @end table @end deftp +@node Messaging Services +@subsubsection Messaging Services + +@cindex messaging +@cindex jabber +@cindex XMPP +The @code{(gnu services messaging)} module provides Guix service +definitions for messaging services: currently only Prosody is supported. + +@subsubheading Prosody Service + +@deffn {Scheme Variable} prosody-service-type +This is the type for the @uref{http://prosody.im, Prosody XMPP +communication server}. Its value must be a @code{prosody-configuration} +record as in this example: + +@example +(service prosody-service-type + (prosody-configuration + (modules-enabled (cons "groups" %default-modules-enabled)) + (int-components + (list + (int-component-configuration + (hostname "conference.example.net") + (plugin "muc") + (mod-muc (mod-muc-configuration))))) + (virtualhosts + (list + (virtualhost-configuration + (domain "example.net")))))) +@end example + +See below for details about @code{prosody-configuration}. + +@end deffn + +By default, Prosody does not need much configuration. Only one +@code{virtualhosts} field is needed: it specifies the domain you wish +Prosody to serve. + +Prosodyctl will help you generate X.509 certificates and keys: + +@example +prosodyctl cert request example.net +@end example + +The available configuration parameters follow. Each parameter +definition is preceded by its type; for example, @samp{string-list foo} +indicates that the @code{foo} parameter should be specified as a list of +strings. Types starting with @code{maybe-} denote parameters that won't +show up in @code{prosody.cfg.lua} when their value is @code{'disabled}. + +There is also a way to specify the configuration as a string, if you +have an old @code{prosody.cfg.lua} file that you want to port over from +some other system; see the end for more details. + +@c The following documentation was initially generated by +@c (generate-documentation) in (gnu services messaging). Manually maintained +@c documentation is better, so we shouldn't hesitate to edit below as +@c needed. However if the change you want to make to this documentation +@c can be done in an automated way, it's probably easier to change +@c (generate-documentation) than to make it below and have to deal with +@c the churn as Prosody updates. + +Available @code{prosody-configuration} fields are: + +@deftypevr {@code{prosody-configuration} parameter} package prosody +The Prosody package. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} file-name data-path +Location of the Prosody data storage directory. See +@url{http://prosody.im/doc/configure}. +Defaults to @samp{"/var/lib/prosody"}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} file-name-list plugin-paths +Additional plugin directories. They are searched in all the specified +paths in order. See @url{http://prosody.im/doc/plugins_directory}. +Defaults to @samp{()}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} string-list admins +This is a list of accounts that are admins for the server. Note that you +must create the accounts separately. See @url{http://prosody.im/doc/admins} and +@url{http://prosody.im/doc/creating_accounts}. +Example: @code{(admins '("user1@@example.com" "user2@@example.net"))} +Defaults to @samp{()}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} boolean use-libevent? +Enable use of libevent for better performance under high load. See +@url{http://prosody.im/doc/libevent}. +Defaults to @samp{#f}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} module-list modules-enabled +This is the list of modules Prosody will load on startup. It looks for +@code{mod_modulename.lua} in the plugins folder, so make sure that exists too. +Documentation on modules can be found at: @url{http://prosody.im/doc/modules}. +Defaults to @samp{%default-modules-enabled}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} string-list modules-disabled +@samp{"offline"}, @samp{"c2s"} and @samp{"s2s"} are auto-loaded, but +should you want to disable them then add them to this list. +Defaults to @samp{()}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} file-name groups-file +Path to a text file where the shared groups are defined. If this path is +empty then @samp{mod_groups} does nothing. See +@url{http://prosody.im/doc/modules/mod_groups}. +Defaults to @samp{"/var/lib/prosody/sharedgroups.txt"}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} boolean allow-registration? +Disable account creation by default, for security. See +@url{http://prosody.im/doc/creating_accounts}. +Defaults to @samp{#f}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} maybe-ssl-configuration ssl +These are the SSL/TLS-related settings. Most of them are disabled so to +use Prosody's defaults. If you do not completely understand these options, do +not add them to your config, it is easy to lower the security of your server +using them. See @url{http://prosody.im/doc/advanced_ssl_config}. + +Available @code{ssl-configuration} fields are: + +@deftypevr {@code{ssl-configuration} parameter} maybe-string protocol +This determines what handshake to use. +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} file-name key +Path to your private key file, relative to @code{/etc/prosody}. +Defaults to @samp{"/etc/prosody/certs/key.pem"}. +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} file-name certificate +Path to your certificate file, relative to @code{/etc/prosody}. +Defaults to @samp{"/etc/prosody/certs/cert.pem"}. +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} file-name capath +Path to directory containing root certificates that you wish Prosody to +trust when verifying the certificates of remote servers. +Defaults to @samp{"/etc/ssl/certs"}. +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} maybe-file-name cafile +Path to a file containing root certificates that you wish Prosody to trust. +Similar to @code{capath} but with all certificates concatenated together. +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} maybe-string-list verify +A list of verification options (these mostly map to OpenSSL's +@code{set_verify()} flags). +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} maybe-string-list options +A list of general options relating to SSL/TLS. These map to OpenSSL's +@code{set_options()}. For a full list of options available in LuaSec, see the +LuaSec source. +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} maybe-non-negative-integer depth +How long a chain of certificate authorities to check when looking for a +trusted root certificate. +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} maybe-string ciphers +An OpenSSL cipher string. This selects what ciphers Prosody will offer to +clients, and in what order. +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} maybe-file-name dhparam +A path to a file containing parameters for Diffie-Hellman key exchange. You +can create such a file with: +@code{openssl dhparam -out /etc/prosody/certs/dh-2048.pem 2048} +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} maybe-string curve +Curve for Elliptic curve Diffie-Hellman. Prosody's default is +@samp{"secp384r1"}. +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} maybe-string-list verifyext +A list of "extra" verification options. +@end deftypevr + +@deftypevr {@code{ssl-configuration} parameter} maybe-string password +Password for encrypted private keys. +@end deftypevr + +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} boolean c2s-require-encryption? +Whether to force all client-to-server connections to be encrypted or not. +See @url{http://prosody.im/doc/modules/mod_tls}. +Defaults to @samp{#f}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} boolean s2s-require-encryption? +Whether to force all server-to-server connections to be encrypted or not. +See @url{http://prosody.im/doc/modules/mod_tls}. +Defaults to @samp{#f}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} boolean s2s-secure-auth? +Whether to require encryption and certificate authentication. This +provides ideal security, but requires servers you communicate with to support +encryption AND present valid, trusted certificates. See +@url{http://prosody.im/doc/s2s#security}. +Defaults to @samp{#f}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} string-list s2s-insecure-domains +Many servers don't support encryption or have invalid or self-signed +certificates. You can list domains here that will not be required to +authenticate using certificates. They will be authenticated using DNS. See +@url{http://prosody.im/doc/s2s#security}. +Defaults to @samp{()}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} string-list s2s-secure-domains +Even if you leave @code{s2s-secure-auth?} disabled, you can still require +valid certificates for some domains by specifying a list here. See +@url{http://prosody.im/doc/s2s#security}. +Defaults to @samp{()}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} string authentication +Select the authentication backend to use. The default provider stores +passwords in plaintext and uses Prosody's configured data storage to store the +authentication data. If you do not trust your server please see +@url{http://prosody.im/doc/modules/mod_auth_internal_hashed} for information +about using the hashed backend. See also +@url{http://prosody.im/doc/authentication} +Defaults to @samp{"internal_plain"}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} maybe-string log +Set logging options. Advanced logging configuration is not yet supported +by the GuixSD Prosody Service. See @url{http://prosody.im/doc/logging}. +Defaults to @samp{"*syslog"}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} file-name pidfile +File to write pid in. See @url{http://prosody.im/doc/modules/mod_posix}. +Defaults to @samp{"/var/run/prosody/prosody.pid"}. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} virtualhost-configuration-list virtualhosts +A host in Prosody is a domain on which user accounts can be created. For +example if you want your users to have addresses like +@samp{"john.smith@@example.com"} then you need to add a host +@samp{"example.com"}. All options in this list will apply only to this host. + +Note: the name "virtual" host is used in configuration to avoid confusion with +the actual physical host that Prosody is installed on. A single Prosody +instance can serve many domains, each one defined as a VirtualHost entry in +Prosody's configuration. Conversely a server that hosts a single domain would +have just one VirtualHost entry. + +See @url{http://prosody.im/doc/configure#virtual_host_settings}. + +Available @code{virtualhost-configuration} fields are: + +all these @code{prosody-configuration} fields: @code{admins}, @code{use-libevent?}, @code{modules-enabled}, @code{modules-disabled}, @code{groups-file}, @code{allow-registration?}, @code{ssl}, @code{c2s-require-encryption?}, @code{s2s-require-encryption?}, @code{s2s-secure-auth?}, @code{s2s-insecure-domains}, @code{s2s-secure-domains}, @code{authentication}, @code{log}, plus: +@deftypevr {@code{virtualhost-configuration} parameter} string domain +Domain you wish Prosody to serve. +@end deftypevr + +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} int-component-configuration-list int-components +Components are extra services on a server which are available to clients, +usually on a subdomain of the main server (such as +@samp{"mycomponent.example.com"}). Example components might be chatroom +servers, user directories, or gateways to other protocols. + +Internal components are implemented with Prosody-specific plugins. To add an +internal component, you simply fill the hostname field, and the plugin you wish +to use for the component. + +See @url{http://prosody.im/doc/components}. +Defaults to @samp{()}. + +Available @code{int-component-configuration} fields are: + +all these @code{prosody-configuration} fields: @code{admins}, @code{use-libevent?}, @code{modules-enabled}, @code{modules-disabled}, @code{groups-file}, @code{allow-registration?}, @code{ssl}, @code{c2s-require-encryption?}, @code{s2s-require-encryption?}, @code{s2s-secure-auth?}, @code{s2s-insecure-domains}, @code{s2s-secure-domains}, @code{authentication}, @code{log}, plus: +@deftypevr {@code{int-component-configuration} parameter} string hostname +Hostname of the component. +@end deftypevr + +@deftypevr {@code{int-component-configuration} parameter} string plugin +Plugin you wish to use for the component. +@end deftypevr + +@deftypevr {@code{int-component-configuration} parameter} maybe-mod-muc-configuration mod-muc +Multi-user chat (MUC) is Prosody's module for allowing you to create +hosted chatrooms/conferences for XMPP users. + +General information on setting up and using multi-user chatrooms can be found +in the "Chatrooms" documentation (@url{http://prosody.im/doc/chatrooms}), +which you should read if you are new to XMPP chatrooms. + +See also @url{http://prosody.im/doc/modules/mod_muc}. + +Available @code{mod-muc-configuration} fields are: + +@deftypevr {@code{mod-muc-configuration} parameter} string name +The name to return in service discovery responses. +Defaults to @samp{"Prosody Chatrooms"}. +@end deftypevr + +@deftypevr {@code{mod-muc-configuration} parameter} string-or-boolean restrict-room-creation +If @samp{#t}, this will only allow admins to create new chatrooms. +Otherwise anyone can create a room. The value @samp{"local"} restricts room +creation to users on the service's parent domain. E.g. @samp{user@@example.com} +can create rooms on @samp{rooms.example.com}. The value @samp{"admin"} +restricts to service administrators only. +Defaults to @samp{#f}. +@end deftypevr + +@deftypevr {@code{mod-muc-configuration} parameter} non-negative-integer max-history-messages +Maximum number of history messages that will be sent to the member that has +just joined the room. +Defaults to @samp{20}. +@end deftypevr + +@end deftypevr + +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} ext-component-configuration-list ext-components +External components use XEP-0114, which most standalone components +support. To add an external component, you simply fill the hostname field. See +@url{http://prosody.im/doc/components}. +Defaults to @samp{()}. + +Available @code{ext-component-configuration} fields are: + +all these @code{prosody-configuration} fields: @code{admins}, @code{use-libevent?}, @code{modules-enabled}, @code{modules-disabled}, @code{groups-file}, @code{allow-registration?}, @code{ssl}, @code{c2s-require-encryption?}, @code{s2s-require-encryption?}, @code{s2s-secure-auth?}, @code{s2s-insecure-domains}, @code{s2s-secure-domains}, @code{authentication}, @code{log}, plus: +@deftypevr {@code{ext-component-configuration} parameter} string component-secret +Password which the component will use to log in. +@end deftypevr + +@deftypevr {@code{ext-component-configuration} parameter} string hostname +Hostname of the component. +@end deftypevr + +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} non-negative-integer-list component-ports +Port(s) Prosody listens on for component connections. +@end deftypevr + +@deftypevr {@code{prosody-configuration} parameter} string component-interface +Interface Prosody listens on for component connections. +Defaults to @samp{"127.0.0.1"}. +@end deftypevr + +It could be that you just want to get a @code{prosody.cfg.lua} +up and running. In that case, you can pass an +@code{opaque-prosody-configuration} record as the value of +@code{prosody-service-type}. As its name indicates, an opaque configuration +does not have easy reflective capabilities. +Available @code{opaque-prosody-configuration} fields are: + +@deftypevr {@code{opaque-prosody-configuration} parameter} package prosody +The prosody package. +@end deftypevr + +@deftypevr {@code{opaque-prosody-configuration} parameter} string prosody.cfg.lua +The contents of the @code{prosody.cfg.lua} to use. +@end deftypevr + +For example, if your @code{prosody.cfg.lua} is just the empty +string, you could instantiate a prosody service like this: + +@example +(service prosody-service-type + (opaque-prosody-configuration + (prosody.cfg.lua ""))) +@end example + @node Kerberos Services @subsubsection Kerberos Services @cindex Kerberos diff --git a/gnu/local.mk b/gnu/local.mk index 49d9554910..cc42a122de 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -414,6 +414,7 @@ GNU_SYSTEM_MODULES = \ %D%/services/lirc.scm \ %D%/services/mail.scm \ %D%/services/mcron.scm \ + %D%/services/messaging.scm \ %D%/services/networking.scm \ %D%/services/nfs.scm \ %D%/services/shepherd.scm \ diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index 94c5f21557..a98db64fa5 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -28,10 +28,13 @@ #:use-module (srfi srfi-35) #:export (configuration-field configuration-field-name + configuration-field-type configuration-missing-field configuration-field-error configuration-field-serializer configuration-field-getter + configuration-field-default-value-thunk + configuration-field-documentation serialize-configuration define-configuration validate-configuration diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm new file mode 100644 index 0000000000..0b5aa1fae8 --- /dev/null +++ b/gnu/services/messaging.scm @@ -0,0 +1,726 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Clément Lassieur +;;; +;;; 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 . + +(define-module (gnu services messaging) + #:use-module (gnu packages messaging) + #:use-module (gnu packages admin) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu services configuration) + #:use-module (gnu system shadow) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (guix packages) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-35) + #:use-module (ice-9 match) + #:export (prosody-service-type + prosody-configuration + opaque-prosody-configuration + + virtualhost-configuration + int-component-configuration + ext-component-configuration + + mod-muc-configuration + ssl-configuration + + %default-modules-enabled)) + +;;; Commentary: +;;; +;;; Messaging services. +;;; +;;; Code: + +(define (id ctx . parts) + (datum->syntax ctx (apply symbol-append (map syntax->datum parts)))) + +(define-syntax define-maybe + (lambda (x) + (syntax-case x () + ((_ stem) + (with-syntax + ((stem? (id #'stem #'stem #'?)) + (maybe-stem? (id #'stem #'maybe- #'stem #'?)) + (serialize-stem (id #'stem #'serialize- #'stem)) + (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem))) + #'(begin + (define (maybe-stem? val) + (or (eq? val 'disabled) (stem? val))) + (define (serialize-maybe-stem field-name val) + (when (stem? val) (serialize-stem field-name val))))))))) + +(define-syntax define-all-configurations + (lambda (stx) + (define (make-pred arg) + (lambda (field target) + (and (memq (syntax->datum target) `(common ,arg)) field))) + (syntax-case stx () + ((_ stem (field (field-type def) doc target) ...) + (with-syntax (((new-field-type ...) + (map (lambda (field-type target) + (if (and (eq? 'common (syntax->datum target)) + (not (string-prefix? + "maybe-" + (symbol->string + (syntax->datum field-type))))) + (id #'stem #'maybe- field-type) field-type)) + #'(field-type ...) #'(target ...))) + ((new-def ...) + (map (lambda (def target) + (if (eq? 'common (syntax->datum target)) + #''disabled def)) + #'(def ...) #'(target ...))) + ((new-doc ...) + (map (lambda (doc target) + (if (eq? 'common (syntax->datum target)) + "" doc)) + #'(doc ...) #'(target ...)))) + #`(begin + (define common-fields + '(#,@(filter-map (make-pred #f) #'(field ...) #'(target ...)))) + (define-configuration prosody-configuration + #,@(filter-map (make-pred 'global) + #'((field (field-type def) doc) ...) + #'(target ...))) + (define-configuration virtualhost-configuration + #,@(filter-map (make-pred 'virtualhost) + #'((field (new-field-type new-def) new-doc) ...) + #'(target ...))) + (define-configuration int-component-configuration + #,@(filter-map (make-pred 'int-component) + #'((field (new-field-type new-def) new-doc) ...) + #'(target ...))) + (define-configuration ext-component-configuration + #,@(filter-map (make-pred 'ext-component) + #'((field (new-field-type new-def) new-doc) ...) + #'(target ...))))))))) + +(define (uglify-field-name field-name) + (let ((str (symbol->string field-name))) + (string-join (string-split (if (string-suffix? "?" str) + (substring str 0 (1- (string-length str))) + str) + #\-) + "_"))) + +(define (serialize-field field-name val) + (format #t "~a = ~a;\n" (uglify-field-name field-name) val)) +(define (serialize-field-list field-name val) + (serialize-field field-name + (with-output-to-string + (lambda () + (format #t "{\n") + (for-each (lambda (x) + (format #t "~a;\n" x)) + val) + (format #t "}"))))) + +(define (serialize-boolean field-name val) + (serialize-field field-name (if val "true" "false"))) +(define-maybe boolean) + +(define (string-or-boolean? val) + (or (string? val) (boolean? val))) +(define (serialize-string-or-boolean field-name val) + (if (string? val) + (serialize-string field-name val) + (serialize-boolean field-name val))) + +(define (non-negative-integer? val) + (and (exact-integer? val) (not (negative? val)))) +(define (serialize-non-negative-integer field-name val) + (serialize-field field-name val)) +(define-maybe non-negative-integer) + +(define (non-negative-integer-list? val) + (and (list? val) (and-map non-negative-integer? val))) +(define (serialize-non-negative-integer-list field-name val) + (serialize-field-list field-name val)) +(define-maybe non-negative-integer-list) + +(define (enclose-quotes s) + (format #f "\"~a\"" s)) +(define (serialize-string field-name val) + (serialize-field field-name (enclose-quotes val))) +(define-maybe string) + +(define (string-list? val) + (and (list? val) + (and-map (lambda (x) + (and (string? x) (not (string-index x #\,)))) + val))) +(define (serialize-string-list field-name val) + (serialize-field-list field-name (map enclose-quotes val))) +(define-maybe string-list) + +(define (module-list? val) + (string-list? val)) +(define (serialize-module-list field-name val) + (serialize-string-list field-name (cons "posix" val))) +(define-maybe module-list) + +(define (file-name? val) + (and (string? val) + (string-prefix? "/" val))) +(define (serialize-file-name field-name val) + (serialize-string field-name val)) +(define-maybe file-name) + +(define (file-name-list? val) + (and (list? val) (and-map file-name? val))) +(define (serialize-file-name-list field-name val) + (serialize-string-list field-name val)) +(define-maybe file-name) + +(define-configuration mod-muc-configuration + (name + (string "Prosody Chatrooms") + "The name to return in service discovery responses.") + + (restrict-room-creation + (string-or-boolean #f) + "If @samp{#t}, this will only allow admins to create new chatrooms. +Otherwise anyone can create a room. The value @samp{\"local\"} restricts room +creation to users on the service's parent domain. E.g. @samp{user@@example.com} +can create rooms on @samp{rooms.example.com}. The value @samp{\"admin\"} +restricts to service administrators only.") + + (max-history-messages + (non-negative-integer 20) + "Maximum number of history messages that will be sent to the member that has +just joined the room.")) +(define (serialize-mod-muc-configuration field-name val) + (serialize-configuration val mod-muc-configuration-fields)) +(define-maybe mod-muc-configuration) + +(define-configuration ssl-configuration + (protocol + (maybe-string 'disabled) + "This determines what handshake to use.") + + (key + (file-name "/etc/prosody/certs/key.pem") + "Path to your private key file, relative to @code{/etc/prosody}.") + + (certificate + (file-name "/etc/prosody/certs/cert.pem") + "Path to your certificate file, relative to @code{/etc/prosody}.") + + (capath + (file-name "/etc/ssl/certs") + "Path to directory containing root certificates that you wish Prosody to +trust when verifying the certificates of remote servers.") + + (cafile + (maybe-file-name 'disabled) + "Path to a file containing root certificates that you wish Prosody to trust. +Similar to @code{capath} but with all certificates concatenated together.") + + (verify + (maybe-string-list 'disabled) + "A list of verification options (these mostly map to OpenSSL's +@code{set_verify()} flags).") + + (options + (maybe-string-list 'disabled) + "A list of general options relating to SSL/TLS. These map to OpenSSL's +@code{set_options()}. For a full list of options available in LuaSec, see the +LuaSec source.") + + (depth + (maybe-non-negative-integer 'disabled) + "How long a chain of certificate authorities to check when looking for a +trusted root certificate.") + + (ciphers + (maybe-string 'disabled) + "An OpenSSL cipher string. This selects what ciphers Prosody will offer to +clients, and in what order.") + + (dhparam + (maybe-file-name 'disabled) + "A path to a file containing parameters for Diffie-Hellman key exchange. You +can create such a file with: +@code{openssl dhparam -out /etc/prosody/certs/dh-2048.pem 2048}") + + (curve + (maybe-string 'disabled) + "Curve for Elliptic curve Diffie-Hellman. Prosody's default is +@samp{\"secp384r1\"}.") + + (verifyext + (maybe-string-list 'disabled) + "A list of \"extra\" verification options.") + + (password + (maybe-string 'disabled) + "Password for encrypted private keys.")) +(define (serialize-ssl-configuration field-name val) + (format #t "ssl = {\n") + (serialize-configuration val ssl-configuration-fields) + (format #t "};\n")) +(define-maybe ssl-configuration) + +(define %default-modules-enabled + '("roster" + "saslauth" + "tls" + "dialback" + "disco" + "private" + "vcard" + "version" + "uptime" + "time" + "ping" + "pep" + "register" + "admin_adhoc")) + +;; Guile bug. Use begin wrapper, because otherwise virtualhost-configuration +;; is assumed to be a function. See +;; https://www.gnu.org/software/guile/manual/html_node/R6RS-Incompatibilities.html +(begin + (define (virtualhost-configuration-list? val) + (and (list? val) (and-map virtualhost-configuration? val))) + (define (serialize-virtualhost-configuration-list l) + (for-each + (lambda (val) (serialize-virtualhost-configuration val)) l)) + + (define (int-component-configuration-list? val) + (and (list? val) (and-map int-component-configuration? val))) + (define (serialize-int-component-configuration-list l) + (for-each + (lambda (val) (serialize-int-component-configuration val)) l)) + + (define (ext-component-configuration-list? val) + (and (list? val) (and-map ext-component-configuration? val))) + (define (serialize-ext-component-configuration-list l) + (for-each + (lambda (val) (serialize-ext-component-configuration val)) l)) + + (define-all-configurations prosody-configuration + (prosody + (package prosody) + "The Prosody package." + global) + + (data-path + (file-name "/var/lib/prosody") + "Location of the Prosody data storage directory. See +@url{http://prosody.im/doc/configure}." + global) + + (plugin-paths + (file-name-list '()) + "Additional plugin directories. They are searched in all the specified +paths in order. See @url{http://prosody.im/doc/plugins_directory}." + global) + + (admins + (string-list '()) + "This is a list of accounts that are admins for the server. Note that you +must create the accounts separately. See @url{http://prosody.im/doc/admins} and +@url{http://prosody.im/doc/creating_accounts}. +Example: @code{(admins '(\"user1@@example.com\" \"user2@@example.net\"))}" + common) + + (use-libevent? + (boolean #f) + "Enable use of libevent for better performance under high load. See +@url{http://prosody.im/doc/libevent}." + common) + + (modules-enabled + (module-list %default-modules-enabled) + "This is the list of modules Prosody will load on startup. It looks for +@code{mod_modulename.lua} in the plugins folder, so make sure that exists too. +Documentation on modules can be found at: @url{http://prosody.im/doc/modules}. +Defaults to @samp{%default-modules-enabled}." + common) + + (modules-disabled + (string-list '()) + "@samp{\"offline\"}, @samp{\"c2s\"} and @samp{\"s2s\"} are auto-loaded, but +should you want to disable them then add them to this list." + common) + + (groups-file + (file-name "/var/lib/prosody/sharedgroups.txt") + "Path to a text file where the shared groups are defined. If this path is +empty then @samp{mod_groups} does nothing. See +@url{http://prosody.im/doc/modules/mod_groups}." + common) + + (allow-registration? + (boolean #f) + "Disable account creation by default, for security. See +@url{http://prosody.im/doc/creating_accounts}." + common) + + (ssl + (maybe-ssl-configuration (ssl-configuration)) + "These are the SSL/TLS-related settings. Most of them are disabled so to +use Prosody's defaults. If you do not completely understand these options, do +not add them to your config, it is easy to lower the security of your server +using them. See @url{http://prosody.im/doc/advanced_ssl_config}." + common) + + (c2s-require-encryption? + (boolean #f) + "Whether to force all client-to-server connections to be encrypted or not. +See @url{http://prosody.im/doc/modules/mod_tls}." + common) + + (s2s-require-encryption? + (boolean #f) + "Whether to force all server-to-server connections to be encrypted or not. +See @url{http://prosody.im/doc/modules/mod_tls}." + common) + + (s2s-secure-auth? + (boolean #f) + "Whether to require encryption and certificate authentication. This +provides ideal security, but requires servers you communicate with to support +encryption AND present valid, trusted certificates. See +@url{http://prosody.im/doc/s2s#security}." + common) + + (s2s-insecure-domains + (string-list '()) + "Many servers don't support encryption or have invalid or self-signed +certificates. You can list domains here that will not be required to +authenticate using certificates. They will be authenticated using DNS. See +@url{http://prosody.im/doc/s2s#security}." + common) + + (s2s-secure-domains + (string-list '()) + "Even if you leave @code{s2s-secure-auth?} disabled, you can still require +valid certificates for some domains by specifying a list here. See +@url{http://prosody.im/doc/s2s#security}." + common) + + (authentication + (string "internal_plain") + "Select the authentication backend to use. The default provider stores +passwords in plaintext and uses Prosody's configured data storage to store the +authentication data. If you do not trust your server please see +@url{http://prosody.im/doc/modules/mod_auth_internal_hashed} for information +about using the hashed backend. See also +@url{http://prosody.im/doc/authentication}" + common) + + ;; TODO: Handle more complicated log structures. + (log + (maybe-string "*syslog") + "Set logging options. Advanced logging configuration is not yet supported +by the GuixSD Prosody Service. See @url{http://prosody.im/doc/logging}." + common) + + (pidfile + (file-name "/var/run/prosody/prosody.pid") + "File to write pid in. See @url{http://prosody.im/doc/modules/mod_posix}." + global) + + (virtualhosts + (virtualhost-configuration-list + (list (virtualhost-configuration + (domain "localhost")))) + "A host in Prosody is a domain on which user accounts can be created. For +example if you want your users to have addresses like +@samp{\"john.smith@@example.com\"} then you need to add a host +@samp{\"example.com\"}. All options in this list will apply only to this host. + +Note: the name \"virtual\" host is used in configuration to avoid confusion with +the actual physical host that Prosody is installed on. A single Prosody +instance can serve many domains, each one defined as a VirtualHost entry in +Prosody's configuration. Conversely a server that hosts a single domain would +have just one VirtualHost entry. + +See @url{http://prosody.im/doc/configure#virtual_host_settings}." + global) + + (int-components + (int-component-configuration-list '()) + "Components are extra services on a server which are available to clients, +usually on a subdomain of the main server (such as +@samp{\"mycomponent.example.com\"}). Example components might be chatroom +servers, user directories, or gateways to other protocols. + +Internal components are implemented with Prosody-specific plugins. To add an +internal component, you simply fill the hostname field, and the plugin you wish +to use for the component. + +See @url{http://prosody.im/doc/components}." + global) + + (ext-components + (ext-component-configuration-list '()) + "External components use XEP-0114, which most standalone components +support. To add an external component, you simply fill the hostname field. See +@url{http://prosody.im/doc/components}." + global) + + (component-secret + (string (configuration-missing-field 'ext-component 'component-secret)) + "Password which the component will use to log in." + ext-component) + + (component-ports + (non-negative-integer-list '(5347)) + "Port(s) Prosody listens on for component connections." + global) + + (component-interface + (string "127.0.0.1") + "Interface Prosody listens on for component connections." + global) + + (domain + (string (configuration-missing-field 'virtualhost 'domain)) + "Domain you wish Prosody to serve." + virtualhost) + + (hostname + (string (configuration-missing-field 'int-component 'hostname)) + "Hostname of the component." + int-component) + + (plugin + (string (configuration-missing-field 'int-component 'plugin)) + "Plugin you wish to use for the component." + int-component) + + (mod-muc + (maybe-mod-muc-configuration 'disabled) + "Multi-user chat (MUC) is Prosody's module for allowing you to create +hosted chatrooms/conferences for XMPP users. + +General information on setting up and using multi-user chatrooms can be found +in the \"Chatrooms\" documentation (@url{http://prosody.im/doc/chatrooms}), +which you should read if you are new to XMPP chatrooms. + +See also @url{http://prosody.im/doc/modules/mod_muc}." + int-component) + + (hostname + (string (configuration-missing-field 'ext-component 'hostname)) + "Hostname of the component." + ext-component))) + +;; Serialize Virtualhost line first. +(define (serialize-virtualhost-configuration config) + (define (rest? field) + (not (memq (configuration-field-name field) + '(domain)))) + (let ((domain (virtualhost-configuration-domain config)) + (rest (filter rest? virtualhost-configuration-fields))) + (format #t "VirtualHost \"~a\"\n" domain) + (serialize-configuration config rest))) + +;; Serialize Component line first. +(define (serialize-int-component-configuration config) + (define (rest? field) + (not (memq (configuration-field-name field) + '(hostname plugin)))) + (let ((hostname (int-component-configuration-hostname config)) + (plugin (int-component-configuration-plugin config)) + (rest (filter rest? int-component-configuration-fields))) + (format #t "Component \"~a\" \"~a\"\n" hostname plugin) + (serialize-configuration config rest))) + +;; Serialize Component line first. +(define (serialize-ext-component-configuration config) + (define (rest? field) + (not (memq (configuration-field-name field) + '(hostname)))) + (let ((hostname (ext-component-configuration-hostname config)) + (rest (filter rest? ext-component-configuration-fields))) + (format #t "Component \"~a\"\n" hostname) + (serialize-configuration config rest))) + +;; Serialize virtualhosts and components last. +(define (serialize-prosody-configuration config) + (define (rest? field) + (not (memq (configuration-field-name field) + '(virtualhosts int-components ext-components)))) + (let ((rest (filter rest? prosody-configuration-fields))) + (serialize-configuration config rest)) + (serialize-virtualhost-configuration-list + (prosody-configuration-virtualhosts config)) + (serialize-int-component-configuration-list + (prosody-configuration-int-components config)) + (serialize-ext-component-configuration-list + (prosody-configuration-ext-components config))) + +(define-configuration opaque-prosody-configuration + (prosody + (package prosody) + "The prosody package.") + + (prosody.cfg.lua + (string (configuration-missing-field 'opaque-prosody-configuration + 'prosody.cfg.lua)) + "The contents of the @code{prosody.cfg.lua} to use.")) + +(define (prosody-shepherd-service config) + "Return a for Prosody with CONFIG." + (let* ((prosody (if (opaque-prosody-configuration? config) + (opaque-prosody-configuration-prosody config) + (prosody-configuration-prosody config))) + (prosodyctl-bin (file-append prosody "/bin/prosodyctl")) + (prosodyctl-action (lambda args + #~(lambda _ + (zero? (system* #$prosodyctl-bin #$@args)))))) + (list (shepherd-service + (documentation "Run the Prosody XMPP server") + (provision '(prosody)) + (requirement '(networking syslogd user-processes)) + (start (prosodyctl-action "start")) + (stop (prosodyctl-action "stop")))))) + +(define %prosody-accounts + (list (user-group (name "prosody") (system? #t)) + (user-account + (name "prosody") + (group "prosody") + (system? #t) + (comment "Prosody daemon user") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))) + +(define (prosody-activation config) + "Return the activation gexp for CONFIG." + (let* ((config-dir "/etc/prosody") + (default-certs-dir "/etc/prosody/certs") + (data-path (prosody-configuration-data-path config)) + (pidfile-dir (dirname (prosody-configuration-pidfile config))) + (config-str + (if (opaque-prosody-configuration? config) + (opaque-prosody-configuration-prosody.cfg.lua config) + (with-output-to-string + (lambda () + (serialize-prosody-configuration config))))) + (config-file (plain-file "prosody.cfg.lua" config-str))) + #~(begin + (define %user (getpw "prosody")) + + (mkdir-p #$config-dir) + (chown #$config-dir (passwd:uid %user) (passwd:gid %user)) + (copy-file #$config-file (string-append #$config-dir + "/prosody.cfg.lua")) + + (mkdir-p #$default-certs-dir) + (chown #$default-certs-dir (passwd:uid %user) (passwd:gid %user)) + (chmod #$default-certs-dir #o750) + + (mkdir-p #$data-path) + (chown #$data-path (passwd:uid %user) (passwd:gid %user)) + (chmod #$data-path #o750) + + (mkdir-p #$pidfile-dir) + (chown #$pidfile-dir (passwd:uid %user) (passwd:gid %user))))) + +(define prosody-service-type + (service-type (name 'prosody) + (extensions + (list (service-extension shepherd-root-service-type + prosody-shepherd-service) + (service-extension account-service-type + (const %prosody-accounts)) + (service-extension activation-service-type + prosody-activation))))) + +;; A little helper to make it easier to document all those fields. +(define (generate-documentation) + (define documentation + `((prosody-configuration + ,prosody-configuration-fields + (ssl ssl-configuration) + (virtualhosts virtualhost-configuration) + (int-components int-component-configuration) + (ext-components ext-component-configuration)) + (ssl-configuration ,ssl-configuration-fields) + (int-component-configuration ,int-component-configuration-fields + (mod-muc mod-muc-configuration)) + (ext-component-configuration ,ext-component-configuration-fields) + (mod-muc-configuration ,mod-muc-configuration-fields) + (virtualhost-configuration ,virtualhost-configuration-fields) + (opaque-prosody-configuration ,opaque-prosody-configuration-fields))) + (define (generate configuration-name) + (match (assq-ref documentation configuration-name) + ((fields . sub-documentation) + (format #t "\nAvailable @code{~a} fields are:\n\n" configuration-name) + (when (memq configuration-name + '(virtualhost-configuration + int-component-configuration + ext-component-configuration)) + (format #t "all these @code{prosody-configuration} fields: ~a, plus:\n" + (string-join (map (lambda (s) + (format #f "@code{~a}" s)) common-fields) + ", "))) + (for-each + (lambda (f) + (let ((field-name (configuration-field-name f)) + (field-type (configuration-field-type f)) + (field-docs (string-trim-both + (configuration-field-documentation f))) + (default (catch #t + (configuration-field-default-value-thunk f) + (lambda _ 'nope)))) + (define (escape-chars str chars escape) + (with-output-to-string + (lambda () + (string-for-each (lambda (c) + (when (char-set-contains? chars c) + (display escape)) + (display c)) + str)))) + (define (show-default? val) + (or (string? default) (number? default) (boolean? default) + (and (list? val) (and-map show-default? val)))) + (format #t "@deftypevr {@code{~a} parameter} ~a ~a\n~a\n" + configuration-name field-type field-name field-docs) + (when (show-default? default) + (format #t "Defaults to @samp{~a}.\n" + (escape-chars (format #f "~s" default) + (char-set #\@ #\{ #\}) + #\@))) + (for-each generate (or (assq-ref sub-documentation field-name) '())) + (format #t "@end deftypevr\n\n"))) + (filter (lambda (f) + (not (string=? "" (configuration-field-documentation f)))) + fields))))) + (generate 'prosody-configuration) + (format #t "It could be that you just want to get a @code{prosody.cfg.lua} +up and running. In that case, you can pass an +@code{opaque-prosody-configuration} record as the value of +@code{prosody-service-type}. As its name indicates, an opaque configuration +does not have easy reflective capabilities.") + (generate 'opaque-prosody-configuration) + (format #t "For example, if your @code{prosody.cfg.lua} is just the empty +string, you could instantiate a prosody service like this: + +@example +(service prosody-service-type + (opaque-prosody-configuration + (prosody.cfg.lua \"\"))) +@end example")) -- cgit 1.4.1 From b1a505baf61cc771197eb44af9173f31d2bace46 Mon Sep 17 00:00:00 2001 From: David Craven Date: Wed, 30 Nov 2016 19:30:12 +0100 Subject: system: Add btrfs file system support. * gnu/build/file-systems.scm (%btrfs-endianness, btrfs-superblock?, read-btrfs-superblock, btrfs-superblock-uuid, btrfs-superblock-volume-name, check-btrfs-file-system): New variables. (%paritition-label-readers, %partition-uuid-readers): Add btrfs readers. * gnu/system/linux-initrd.scm (linux-modules): Add btrfs modules when a btrfs file-system is used. * gnu/tests/install.scm (%btrfs-root-os %btrfs-root-os-source, %btrfs-root-installation-script, %test-btrfs-root-os): New system test. * doc/guix.texi: Adjust accordingly. Fixes . --- doc/guix.texi | 6 ++-- gnu/build/file-systems.scm | 46 +++++++++++++++++++++++++-- gnu/system/linux-initrd.scm | 6 ++++ gnu/tests/install.scm | 77 ++++++++++++++++++++++++++++++++++++++++++++- 4 files changed, 129 insertions(+), 6 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index d46a7743d0..086895996f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6919,9 +6919,9 @@ cfdisk Once you are done partitioning the target hard disk drive, you have to create a file system on the relevant partition(s)@footnote{Currently -GuixSD pretty much assumes an ext4 file system. In particular, code -that reads partition UUIDs and labels only works with ext4. This will -be fixed in the future.}. +GuixSD only supports ext4 and btrfs file systems. In particular, code +that reads partition UUIDs and labels only works for these file system +types.}. Preferably, assign partitions a label so that you can easily and reliably refer to them in @code{file-system} declarations (@pxref{File diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index e76854490c..6e5c6aaf15 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -144,6 +144,43 @@ if DEVICE does not contain an ext2 file system." (2 'reboot-required) (_ 'fatal-error))) + +;;; +;;; Btrfs file systems. +;;; + +;; . + +(define-syntax %btrfs-endianness + ;; Endianness of btrfs file systems. + (identifier-syntax (endianness little))) + +(define (btrfs-superblock? sblock) + "Return #t when SBLOCK is a btrfs superblock." + (bytevector=? (sub-bytevector sblock 64 8) + (string->utf8 "_BHRfS_M"))) + +(define (read-btrfs-superblock device) + "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f +if DEVICE does not contain a btrfs file system." + (read-superblock device 65536 4096 btrfs-superblock?)) + +(define (btrfs-superblock-uuid sblock) + "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector." + (sub-bytevector sblock 32 16)) + +(define (btrfs-superblock-volume-name sblock) + "Return the volume name of SBLOCK as a string of at most 256 characters, or +#f if SBLOCK has no volume name." + (null-terminated-latin1->string (sub-bytevector sblock 299 256))) + +(define (check-btrfs-file-system device) + "Return the health of a btrfs file system on DEVICE." + (match (status:exit-val + (system* "btrfs" "device" "scan")) + (0 'pass) + (_ 'fatal-error))) + ;;; ;;; LUKS encrypted devices. @@ -257,11 +294,15 @@ partition field reader that returned a value." (define %partition-label-readers (list (partition-field-reader read-ext2-superblock - ext2-superblock-volume-name))) + ext2-superblock-volume-name) + (partition-field-reader read-btrfs-superblock + btrfs-superblock-volume-name))) (define %partition-uuid-readers (list (partition-field-reader read-ext2-superblock - ext2-superblock-uuid))) + ext2-superblock-uuid) + (partition-field-reader read-btrfs-superblock + btrfs-superblock-uuid))) (define read-partition-label (cut read-partition-field <> %partition-label-readers)) @@ -428,6 +469,7 @@ the following: (define check-procedure (cond ((string-prefix? "ext" type) check-ext2-file-system) + ((string-prefix? "btrfs" type) check-btrfs-file-system) (else #f))) (if check-procedure diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index a787072ba7..4a753cdadb 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -197,6 +197,9 @@ loaded at boot time in the order in which they appear." ,@(if (find (file-system-type-predicate "vfat") file-systems) '("nls_iso8859-1") '()) + ,@(if (find (file-system-type-predicate "btrfs") file-systems) + '("btrfs") + '()) ,@(if volatile-root? '("fuse") '()) @@ -214,6 +217,9 @@ loaded at boot time in the order in which they appear." file-systems) (list fatfsck/static) '()) + ,@(if (find (file-system-type-predicate "btrfs") file-systems) + (list btrfs-progs/static) + '()) ,@(if volatile-root? (list unionfs-fuse/static) '()))) diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 4779b80e94..ae54154c5c 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -36,7 +36,8 @@ #:export (%test-installed-os %test-separate-store-os %test-raid-root-os - %test-encrypted-os)) + %test-encrypted-os + %test-btrfs-root-os)) ;;; Commentary: ;;; @@ -518,4 +519,78 @@ build (current-guix) and then store a couple of full system images.") (run-basic-test %encrypted-root-os command "encrypted-root-os" #:initialization enter-luks-passphrase))))) + +;;; +;;; Btrfs root file system. +;;; + +(define-os-with-source (%btrfs-root-os %btrfs-root-os-source) + ;; The OS we want to install. + (use-modules (gnu) (gnu tests) (srfi srfi-1)) + + (operating-system + (host-name "liberigilo") + (timezone "Europe/Paris") + (locale "en_US.UTF-8") + + (bootloader (grub-configuration (device "/dev/vdb"))) + (kernel-arguments '("console=ttyS0")) + (file-systems (cons (file-system + (device "my-root") + (title 'label) + (mount-point "/") + (type "btrfs")) + %base-file-systems)) + (users (cons (user-account + (name "charlie") + (group "users") + (home-directory "/home/charlie") + (supplementary-groups '("wheel" "audio" "video"))) + %base-user-accounts)) + (services (cons (service marionette-service-type + (marionette-configuration + (imported-modules '((gnu services herd) + (guix combinators))))) + %base-services)))) + +(define %btrfs-root-installation-script + ;; Shell script of a simple installation. + "\ +. /etc/profile +set -e -x +guix --version + +export GUIX_BUILD_OPTIONS=--no-grafts +ls -l /run/current-system/gc-roots +parted --script /dev/vdb mklabel gpt \\ + mkpart primary ext2 1M 3M \\ + mkpart primary ext2 3M 1G \\ + set 1 boot on \\ + set 1 bios_grub on +mkfs.btrfs -L my-root /dev/vdb2 +mount /dev/vdb2 /mnt +btrfs subvolume create /mnt/home +herd start cow-store /mnt +mkdir /mnt/etc +cp /etc/target-config.scm /mnt/etc/config.scm +guix system build /mnt/etc/config.scm +guix system init /mnt/etc/config.scm /mnt --no-substitutes +sync +reboot\n") + +(define %test-btrfs-root-os + (system-test + (name "btrfs-root-os") + (description + "Test basic functionality of an OS installed like one would do by hand. +This test is expensive in terms of CPU and storage usage since we need to +build (current-guix) and then store a couple of full system images.") + (value + (mlet* %store-monad ((image (run-install %btrfs-root-os + %btrfs-root-os-source + #:script + %btrfs-root-installation-script)) + (command (qemu-command/writable-image image))) + (run-basic-test %btrfs-root-os command "btrfs-root-os"))))) + ;;; install.scm ends here -- cgit 1.4.1 From 67cadaca4746f847fbbea5ef69f6cc65d1eb3acc Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 10 Jan 2017 07:24:01 +0000 Subject: services: Add 'redis-service-type'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/database.scm (): New record type. (%redis-accounts, redis-service-type): New variables. (default-redis.conf, redis-activation, redis-shepherd-service): New procedures. * doc/guix.texi (Database Services): Document the new redis service. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 24 ++++++++++++++ gnu/services/databases.scm | 81 +++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 104 insertions(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 086895996f..c495e39f42 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10331,6 +10331,30 @@ TCP port on which the database server listens for incoming connections. @end table @end deftp +@defvr {Scheme Variable} redis-service-type +This is the service type for the @uref{https://redis.io/, Redis} +key/value store, whose value is a @code{redis-configuration} object. +@end defvr + +@deftp {Data Type} redis-configuration +Data type representing the configuration of redis. + +@table @asis +@item @code{redis} (default: @code{redis}) +The Redis package to use. + +@item @code{bind} (default: @code{"127.0.0.1"}) +Network interface on which to listen. + +@item @code{port} (default: @code{6379}) +Port on which to accept connections on, a value of 0 will disable +listining on a TCP socket. + +@item @code{working-directory} (default: @code{"/var/lib/redis"}) +Directory in which to store the database and related files. +@end table +@end deftp + @node Mail Services @subsubsection Mail Services diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index d88c839f7d..3ecc8aff78 100644 --- a/gnu/services/databases.scm +++ b/gnu/services/databases.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2015 David Thompson ;;; Copyright © 2015, 2016 Ludovic Courtès ;;; Copyright © 2016 Leo Famulari +;;; Copyright © 2017 Christopher Baines ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,7 +36,11 @@ mysql-service mysql-service-type mysql-configuration - mysql-configuration?)) + mysql-configuration? + + redis-configuration + redis-configuration? + redis-service-type)) ;;; Commentary: ;;; @@ -287,3 +292,77 @@ database server. The optional @var{config} argument specifies the configuration for @command{mysqld}, which should be a @code{} object." (service mysql-service-type config)) + + +;;; +;;; Redis +;;; + +(define-record-type* + redis-configuration make-redis-configuration + redis-configuration? + (redis redis-configuration-redis ; + (default redis)) + (bind redis-configuration-bind + (default "127.0.0.1")) + (port redis-configuration-port + (default 6379)) + (working-directory redis-configuration-working-directory + (default "/var/lib/redis")) + (config-file redis-configuration-config-file + (default #f))) + +(define (default-redis.conf bind port working-directory) + (mixed-text-file "redis.conf" + "bind " bind "\n" + "port " (number->string port) "\n" + "dir " working-directory "\n" + "daemonize no\n")) + +(define %redis-accounts + (list (user-group (name "redis") (system? #t)) + (user-account + (name "redis") + (group "redis") + (system? #t) + (comment "Redis server user") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))) + +(define redis-activation + (match-lambda + (($ redis bind port working-directory config-file) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (let ((user (getpwnam "redis"))) + (mkdir-p #$working-directory) + (chown #$working-directory (passwd:uid user) (passwd:gid user))))))) + +(define redis-shepherd-service + (match-lambda + (($ redis bind port working-directory config-file) + (let ((config-file + (or config-file + (default-redis.conf bind port working-directory)))) + (list (shepherd-service + (provision '(redis)) + (documentation "Run the Redis daemon.") + (requirement '(user-processes syslogd)) + (start #~(make-forkexec-constructor + '(#$(file-append redis "/bin/redis-server") + #$config-file) + #:user "redis" + #:group "redis")) + (stop #~(make-kill-destructor)))))))) + +(define redis-service-type + (service-type (name 'redis) + (extensions + (list (service-extension shepherd-root-service-type + redis-shepherd-service) + (service-extension activation-service-type + redis-activation) + (service-extension account-service-type + (const %redis-accounts)))))) -- cgit 1.4.1