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.

3 files changed, 156 insertions, 2 deletions

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