Commit | Line | Data |
---|---|---|
0649321d | 1 | ;;; GNU Guix --- Functional package management for GNU |
6ac8b735 | 2 | ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> |
0649321d LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix scripts system search) | |
20 | #:use-module (guix ui) | |
21 | #:use-module (guix utils) | |
22 | #:use-module (gnu services) | |
6ac8b735 | 23 | #:use-module (gnu services shepherd) |
0649321d LC |
24 | #:use-module (srfi srfi-1) |
25 | #:use-module (srfi srfi-11) | |
26 | #:use-module (srfi srfi-26) | |
6ac8b735 | 27 | #:use-module (srfi srfi-34) |
0649321d LC |
28 | #:use-module (ice-9 regex) |
29 | #:use-module (ice-9 match) | |
30 | #:export (service-type->recutils | |
31 | find-service-types | |
32 | guix-system-search)) | |
33 | ||
34 | ;;; Commentary: | |
35 | ;;; | |
36 | ;;; Implement the 'guix system search' command, which searches among the | |
37 | ;;; available service types. | |
38 | ;;; | |
39 | ;;; Code: | |
40 | ||
41 | (define service-type-name* | |
42 | (compose symbol->string service-type-name)) | |
43 | ||
6ac8b735 LC |
44 | (define (service-type-default-shepherd-services type) |
45 | "Return the list of Shepherd services created by default instances of TYPE, | |
46 | provided TYPE has a default value." | |
47 | (match (guard (c ((service-error? c) #f)) | |
48 | (service type)) | |
49 | (#f '()) | |
50 | ((? service? service) | |
51 | (let* ((extension (find (lambda (extension) | |
52 | (eq? (service-extension-target extension) | |
53 | shepherd-root-service-type)) | |
54 | (service-type-extensions type))) | |
55 | (compute (and extension (service-extension-compute extension)))) | |
56 | (if compute | |
57 | (compute (service-value service)) | |
58 | '()))))) | |
59 | ||
60 | (define (service-type-shepherd-names type) | |
61 | "Return the default names of Shepherd services created for TYPE." | |
62 | (match (map shepherd-service-provision | |
63 | (service-type-default-shepherd-services type)) | |
64 | (((names . _) ...) | |
65 | names))) | |
66 | ||
0649321d LC |
67 | (define* (service-type->recutils type port |
68 | #:optional (width (%text-width)) | |
69 | #:key (extra-fields '())) | |
70 | "Write to PORT a recutils record of TYPE, arranging to fit within WIDTH | |
71 | columns." | |
72 | (define width* | |
73 | ;; The available number of columns once we've taken into account space for | |
74 | ;; the initial "+ " prefix. | |
75 | (if (> width 2) (- width 2) width)) | |
76 | ||
77 | (define (extensions->recutils extensions) | |
78 | (let ((list (string-join (map (compose service-type-name* | |
79 | service-extension-target) | |
80 | extensions)))) | |
81 | (string->recutils | |
82 | (fill-paragraph list width* | |
83 | (string-length "extends: "))))) | |
84 | ||
85 | ;; Note: Don't i18n field names so that people can post-process it. | |
86 | (format port "name: ~a~%" (service-type-name type)) | |
87 | (format port "location: ~a~%" | |
88 | (or (and=> (service-type-location type) location->string) | |
89 | (G_ "unknown"))) | |
90 | ||
91 | (format port "extends: ~a~%" | |
92 | (extensions->recutils (service-type-extensions type))) | |
93 | ||
6ac8b735 LC |
94 | ;; If possible, display the list of *default* Shepherd service names. Note |
95 | ;; that we may not always be able to do this (e.g., if the service type | |
96 | ;; lacks a default value); furthermore, it could be that the service | |
97 | ;; generates Shepherd services with different names if we give it different | |
98 | ;; parameters (this is the case, for instance, for | |
99 | ;; 'console-font-service-type'.) | |
100 | (match (service-type-shepherd-names type) | |
101 | (() #f) | |
102 | (names (format port "shepherdnames:~{ ~a~}~%" names))) | |
103 | ||
0649321d LC |
104 | (when (service-type-description type) |
105 | (format port "~a~%" | |
106 | (string->recutils | |
107 | (string-trim-right | |
108 | (parameterize ((%text-width width*)) | |
109 | (texi->plain-text | |
110 | (string-append "description: " | |
111 | (or (and=> (service-type-description type) P_) | |
112 | "")))) | |
113 | #\newline)))) | |
114 | ||
115 | (for-each (match-lambda | |
116 | ((field . value) | |
117 | (let ((field (symbol->string field))) | |
118 | (format port "~a: ~a~%" | |
119 | field | |
120 | (fill-paragraph (object->string value) width* | |
121 | (string-length field)))))) | |
122 | extra-fields) | |
123 | (newline port)) | |
124 | ||
125 | (define (service-type-description-string type) | |
126 | "Return the rendered and localised description of TYPE, a service type." | |
127 | (and=> (service-type-description type) | |
128 | (compose texi->plain-text P_))) | |
129 | ||
130 | (define %service-type-metrics | |
131 | ;; Metrics used to estimate the relevance of a search result. | |
132 | `((,service-type-name* . 3) | |
133 | (,service-type-description-string . 2) | |
134 | (,(lambda (type) | |
135 | (match (and=> (service-type-location type) location-file) | |
136 | ((? string? file) | |
137 | (basename file ".scm")) | |
138 | (#f | |
139 | ""))) | |
140 | . 1))) | |
141 | ||
142 | (define (find-service-types regexps) | |
143 | "Return two values: the list of service types whose name or description | |
144 | matches at least one of REGEXPS sorted by relevance, and the list of relevance | |
145 | scores." | |
146 | (let ((matches (fold-service-types | |
147 | (lambda (type result) | |
148 | (match (relevance type regexps | |
149 | %service-type-metrics) | |
150 | ((? zero?) | |
151 | result) | |
152 | (score | |
153 | (cons (list type score) result)))) | |
154 | '()))) | |
155 | (unzip2 (sort matches | |
156 | (lambda (m1 m2) | |
157 | (match m1 | |
158 | ((type1 score1) | |
159 | (match m2 | |
160 | ((type2 score2) | |
161 | (if (= score1 score2) | |
162 | (string>? (service-type-name* type1) | |
163 | (service-type-name* type2)) | |
164 | (> score1 score2))))))))))) | |
165 | ||
166 | \f | |
167 | (define (guix-system-search . args) | |
168 | (with-error-handling | |
169 | (let ((regexps (map (cut make-regexp* <> regexp/icase) args))) | |
170 | (leave-on-EPIPE | |
171 | (let-values (((services scores) | |
172 | (find-service-types regexps))) | |
173 | (for-each (lambda (service score) | |
174 | (service-type->recutils service | |
175 | (current-output-port) | |
176 | #:extra-fields | |
177 | `((relevance . ,score)))) | |
178 | services | |
179 | scores)))))) |