aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-09-13 16:07:30 +0200
committerLudovic Courtès <ludo@gnu.org>2017-09-16 17:47:46 +0200
commit0649321d91406bb5c19419fac931c202867d7416 (patch)
treed791205cb7ba9f021ad76c2fe3e18827749a9b6c
parent0c0c1b21d959a9761a247309428c64a92c599fb3 (diff)
downloadguix-0649321d91406bb5c19419fac931c202867d7416.tar
guix-0649321d91406bb5c19419fac931c202867d7416.tar.gz
guix system: Add 'search' command.
* guix/scripts/system.scm (resolve-subcommand): New procedure. (process-command): Handle 'search'. (guix-system): Likewise. (show-help): Augment. * guix/scripts/system/search.scm: New file. * po/guix/POTFILES.in: Add it. * Makefile.am (MODULES): Add it. * guix/ui.scm (%text-width): Export. * doc/guix.texi (Invoking guix system): Document it. (Service Types and Services): Mention 'guix system search'. * tests/guix-system.sh: Test it.
-rw-r--r--Makefile.am1
-rw-r--r--doc/guix.texi40
-rw-r--r--guix/scripts/system.scm13
-rw-r--r--guix/scripts/system/search.scm144
-rw-r--r--guix/ui.scm1
-rw-r--r--po/guix/POTFILES.in1
-rw-r--r--tests/guix-system.sh6
7 files changed, 202 insertions, 4 deletions
diff --git a/Makefile.am b/Makefile.am
index aca18526f7..a2fb313916 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -164,6 +164,7 @@ MODULES = \
guix/scripts/authenticate.scm \
guix/scripts/refresh.scm \
guix/scripts/system.scm \
+ guix/scripts/system/search.scm \
guix/scripts/lint.scm \
guix/scripts/challenge.scm \
guix/scripts/import/cran.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index b2eed51bd0..ebeef50709 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -17391,6 +17391,42 @@ operating system is instantiated. Currently the following values are
supported:
@table @code
+@item search
+Display available service type definitions that match the given regular
+expressions, sorted by relevance:
+
+@example
+$ guix system search console font
+name: console-fonts
+location: gnu/services/base.scm:729:2
+extends: shepherd-root
+description: Install the given fonts on the specified ttys (fonts are
++ per virtual console on GNU/Linux). The value of this service is a list
++ of tty/font pairs like:
++
++ '(("tty1" . "LatGrkCyr-8x16"))
+relevance: 20
+
+name: mingetty
+location: gnu/services/base.scm:1048:2
+extends: shepherd-root
+description: Provide console login using the `mingetty' program.
+relevance: 2
+
+name: login
+location: gnu/services/base.scm:775:2
+extends: pam
+description: Provide a console log-in service as specified by its
++ configuration value, a `login-configuration' object.
+relevance: 2
+
+@dots{}
+@end example
+
+As for @command{guix package --search}, the result is written in
+@code{recutils} format, which makes it easy to filter the output
+(@pxref{Top, GNU recutils databases,, recutils, GNU recutils manual}).
+
@item reconfigure
Build the operating system described in @var{file}, activate it, and
switch to it@footnote{This action (and the related actions
@@ -18023,7 +18059,9 @@ list of contributed rules.
@item description
This is a string giving an overview of the service type. The string can
-contain Texinfo markup (@pxref{Overview,,, texinfo, GNU Texinfo}).
+contain Texinfo markup (@pxref{Overview,,, texinfo, GNU Texinfo}). The
+@command{guix system search} command searches these strings and displays
+them (@pxref{Invoking guix system}).
@end table
There can be only one instance of an extensible service type such as
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index ea35fcdbc9..567d8bb643 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -73,7 +73,6 @@
"Read the operating-system declaration from FILE and return it."
(load* file %user-module))
-
;;;
;;; Installation.
@@ -752,6 +751,8 @@ Some ACTIONS support additional ARGS.\n"))
(display (G_ "The valid values for ACTION are:\n"))
(newline)
(display (G_ "\
+ search search for existing service types\n"))
+ (display (G_ "\
reconfigure switch to a new operating system configuration\n"))
(display (G_ "\
roll-back switch to the previous operating system configuration\n"))
@@ -937,6 +938,12 @@ resulting from command-line parsing."
#:gc-root (assoc-ref opts 'gc-root)))))
#:system system))))
+(define (resolve-subcommand name)
+ (let ((module (resolve-interface
+ `(guix scripts system ,(string->symbol name))))
+ (proc (string->symbol (string-append "guix-system-" name))))
+ (module-ref module proc)))
+
(define (process-command command args opts)
"Process COMMAND, one of the 'guix system' sub-commands. ARGS is its
argument list and OPTS is the option alist."
@@ -949,6 +956,8 @@ argument list and OPTS is the option alist."
((pattern) pattern)
(x (leave (G_ "wrong number of arguments~%"))))))
(list-generations pattern)))
+ ((search)
+ (apply (resolve-subcommand "search") args))
;; The following commands need to use the store, but they do not need an
;; operating system configuration file.
((switch-generation)
@@ -978,7 +987,7 @@ argument list and OPTS is the option alist."
(case action
((build container vm vm-image disk-image reconfigure init
extension-graph shepherd-graph list-generations roll-back
- switch-generation)
+ switch-generation search)
(alist-cons 'action action result))
(else (leave (G_ "~a: unknown action~%") action))))))
diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm
new file mode 100644
index 0000000000..b4f790c9bf
--- /dev/null
+++ b/guix/scripts/system/search.scm
@@ -0,0 +1,144 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts system search)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (gnu services)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 match)
+ #:export (service-type->recutils
+ find-service-types
+ guix-system-search))
+
+;;; Commentary:
+;;;
+;;; Implement the 'guix system search' command, which searches among the
+;;; available service types.
+;;;
+;;; Code:
+
+(define service-type-name*
+ (compose symbol->string service-type-name))
+
+(define* (service-type->recutils type port
+ #:optional (width (%text-width))
+ #:key (extra-fields '()))
+ "Write to PORT a recutils record of TYPE, arranging to fit within WIDTH
+columns."
+ (define width*
+ ;; The available number of columns once we've taken into account space for
+ ;; the initial "+ " prefix.
+ (if (> width 2) (- width 2) width))
+
+ (define (extensions->recutils extensions)
+ (let ((list (string-join (map (compose service-type-name*
+ service-extension-target)
+ extensions))))
+ (string->recutils
+ (fill-paragraph list width*
+ (string-length "extends: ")))))
+
+ ;; Note: Don't i18n field names so that people can post-process it.
+ (format port "name: ~a~%" (service-type-name type))
+ (format port "location: ~a~%"
+ (or (and=> (service-type-location type) location->string)
+ (G_ "unknown")))
+
+ (format port "extends: ~a~%"
+ (extensions->recutils (service-type-extensions type)))
+
+ (when (service-type-description type)
+ (format port "~a~%"
+ (string->recutils
+ (string-trim-right
+ (parameterize ((%text-width width*))
+ (texi->plain-text
+ (string-append "description: "
+ (or (and=> (service-type-description type) P_)
+ ""))))
+ #\newline))))
+
+ (for-each (match-lambda
+ ((field . value)
+ (let ((field (symbol->string field)))
+ (format port "~a: ~a~%"
+ field
+ (fill-paragraph (object->string value) width*
+ (string-length field))))))
+ extra-fields)
+ (newline port))
+
+(define (service-type-description-string type)
+ "Return the rendered and localised description of TYPE, a service type."
+ (and=> (service-type-description type)
+ (compose texi->plain-text P_)))
+
+(define %service-type-metrics
+ ;; Metrics used to estimate the relevance of a search result.
+ `((,service-type-name* . 3)
+ (,service-type-description-string . 2)
+ (,(lambda (type)
+ (match (and=> (service-type-location type) location-file)
+ ((? string? file)
+ (basename file ".scm"))
+ (#f
+ "")))
+ . 1)))
+
+(define (find-service-types regexps)
+ "Return two values: the list of service types whose name or description
+matches at least one of REGEXPS sorted by relevance, and the list of relevance
+scores."
+ (let ((matches (fold-service-types
+ (lambda (type result)
+ (match (relevance type regexps
+ %service-type-metrics)
+ ((? zero?)
+ result)
+ (score
+ (cons (list type score) result))))
+ '())))
+ (unzip2 (sort matches
+ (lambda (m1 m2)
+ (match m1
+ ((type1 score1)
+ (match m2
+ ((type2 score2)
+ (if (= score1 score2)
+ (string>? (service-type-name* type1)
+ (service-type-name* type2))
+ (> score1 score2)))))))))))
+
+
+(define (guix-system-search . args)
+ (with-error-handling
+ (let ((regexps (map (cut make-regexp* <> regexp/icase) args)))
+ (leave-on-EPIPE
+ (let-values (((services scores)
+ (find-service-types regexps)))
+ (for-each (lambda (service score)
+ (service-type->recutils service
+ (current-output-port)
+ #:extra-fields
+ `((relevance . ,score))))
+ services
+ scores))))))
diff --git a/guix/ui.scm b/guix/ui.scm
index a51877c04d..6dfc8c7a5b 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -79,6 +79,7 @@
read/eval-package-expression
location->string
fill-paragraph
+ %text-width
texi->plain-text
package-description-string
package-synopsis-string
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index b8e0aca877..e3f767cc67 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -19,6 +19,7 @@ guix/scripts/pull.scm
guix/scripts/substitute.scm
guix/scripts/authenticate.scm
guix/scripts/system.scm
+guix/scripts/system/search.scm
guix/scripts/lint.scm
guix/scripts/publish.scm
guix/scripts/edit.scm
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index de6db0928c..d575795ea0 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@@ -215,3 +215,7 @@ EOF
# In both cases 'my-torrc' should be properly resolved.
guix system build "$tmpdir/config.scm" -n
(cd "$tmpdir"; guix system build "config.scm" -n)
+
+# Searching.
+guix system search tor | grep "^name: tor"
+guix system search anonym network | grep "^name: tor"