| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> |
| 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) |
| 24 | #:use-module (gnu services shepherd) |
| 25 | #:use-module (srfi srfi-1) |
| 26 | #:use-module (srfi srfi-11) |
| 27 | #:use-module (srfi srfi-26) |
| 28 | #:use-module (srfi srfi-34) |
| 29 | #:use-module (ice-9 format) |
| 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 | |
| 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." |
| 64 | (append-map shepherd-service-provision |
| 65 | (service-type-default-shepherd-services type))) |
| 66 | |
| 67 | (define* (service-type->recutils type port |
| 68 | #:optional (width (%text-width)) |
| 69 | #:key |
| 70 | (extra-fields '()) |
| 71 | (hyperlinks? (supports-hyperlinks? port))) |
| 72 | "Write to PORT a recutils record of TYPE, arranging to fit within WIDTH |
| 73 | columns. When HYPERLINKS? is true, emit hyperlink escape sequences when |
| 74 | appropriate." |
| 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~%" |
| 91 | (or (and=> (service-type-location type) |
| 92 | (if hyperlinks? location->hyperlink location->string)) |
| 93 | (G_ "unknown"))) |
| 94 | |
| 95 | (format port "extends: ~a~%" |
| 96 | (extensions->recutils (service-type-extensions type))) |
| 97 | |
| 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 | |
| 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) |
| 147 | "Return a list of service type/score pairs: service types whose name or |
| 148 | description matches REGEXPS sorted by relevance, and their score." |
| 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 |
| 156 | (cons (cons type score) result)))) |
| 157 | '()))) |
| 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)))))))))) |
| 168 | |
| 169 | \f |
| 170 | (define (guix-system-search . args) |
| 171 | (with-error-handling |
| 172 | (let* ((regexps (map (cut make-regexp* <> regexp/icase) args)) |
| 173 | (matches (find-service-types regexps))) |
| 174 | (leave-on-EPIPE |
| 175 | (display-search-results matches (current-output-port) |
| 176 | #:print service-type->recutils |
| 177 | #:command "guix system search"))))) |