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