diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/copy.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import/json.scm | 102 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 24 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/size.scm | 2 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 207 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 20 | ||||
| -rw-r--r-- | guix/scripts/system/search.scm | 144 |
14 files changed, 402 insertions, 113 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 5ea19784dc..a569848ae3 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -54,7 +54,6 @@ `((system . ,(%current-system)) (substitutes? . #t) (graft? . #t) - (max-silent-time . 3600) (verbosity . 0))) (define (show-help) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 32438b99d9..9ffffe8ccd 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -151,7 +151,6 @@ Copy ITEMS to or from the specified host over SSH.\n")) `((system . ,(%current-system)) (substitutes? . #t) (graft? . #t) - (max-silent-time . 3600) (verbosity . 0))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index f40213be33..8225f82bb9 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -49,7 +49,7 @@ ((or 'file #f) (copy-file (uri-path uri) file)) (_ - (url-fetch url file))) + (url-fetch url file #:mirrors %mirrors))) file)) (define* (download-to-store* url #:key (verify-certificate? #t)) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 95ba199d97..0d69218338 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -179,7 +179,6 @@ COMMAND or an interactive shell in that environment.\n")) `((system . ,(%current-system)) (substitutes? . #t) (graft? . #t) - (max-silent-time . 3600) (verbosity . 0))) (define (tag-package-arg opts arg) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 9bba074e8c..67bc7a7553 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -74,7 +74,7 @@ rather than \\n." ;;; (define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem" - "cran" "crate" "texlive")) + "cran" "crate" "texlive" "json")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/json.scm b/guix/scripts/import/json.scm new file mode 100644 index 0000000000..8771e7b0eb --- /dev/null +++ b/guix/scripts/import/json.scm @@ -0,0 +1,102 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; 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 import json) + #:use-module (json) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import utils) + #:use-module (guix import print) + #:use-module (guix scripts import) + #:use-module (guix packages) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 format) + #:export (guix-import-json)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import json PACKAGE-FILE +Import and convert the JSON package definition in PACKAGE-FILE.\n")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import json"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-json . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((file-name) + (catch 'json-invalid + (lambda () + (let ((json (json-string->scm + (with-input-from-file file-name read-string)))) + ;; TODO: also print define-module boilerplate + (package->code (alist->package (hash-table->alist json))))) + (lambda _ + (leave (G_ "invalid JSON in file '~a'~%") file-name)))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index aceafc674d..57bbeec465 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> +;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -411,7 +412,11 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (close-connection port)))) (case (response-code response) - ((301 302 307) + ((301 ; moved permanently + 302 ; found (redirection) + 303 ; see other + 307 ; temporary redirection + 308) ; permanent redirection (let ((location (response-location response))) (if (or (not location) (member location visited)) (values 'http-response response) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index c269a1fefc..21fea446a6 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -263,7 +263,6 @@ the image." (system . ,(%current-system)) (substitutes? . #t) (graft? . #t) - (max-silent-time . 3600) (verbosity . 0) (symlinks . ()) (compressor . ,(first %compressors)))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index fa45bd48a6..4adc705220 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -246,27 +246,8 @@ specified in MANIFEST, a manifest object." "Return two values: the list of packages whose name, synopsis, or description matches at least one of REGEXPS sorted by relevance, and the list of relevance scores." - (define (score str) - (let ((counts (filter-map (lambda (regexp) - (match (regexp-exec regexp str) - (#f #f) - (m (match:count m)))) - regexps))) - ;; Compute a score that's proportional to the number of regexps matched - ;; and to the number of matches for each regexp. - (* (length counts) (reduce + 0 counts)))) - - (define (package-score package) - (+ (* 3 (score (package-name package))) - (* 2 (match (package-synopsis package) - ((? string? str) (score (P_ str))) - (#f 0))) - (match (package-description package) - ((? string? str) (score (P_ str))) - (#f 0)))) - (let ((matches (fold-packages (lambda (package result) - (match (package-score package) + (match (package-relevance package regexps) ((? zero?) result) (score @@ -377,8 +358,7 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (define %default-options ;; Alist of default option values. - `((max-silent-time . 3600) - (verbosity . 0) + `((verbosity . 0) (graft? . #t) (substitutes? . #t))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index a1deec8040..b1c87c870e 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -96,7 +96,6 @@ Install it by running: (system . ,(%current-system)) (substitutes? . #t) (graft? . #t) - (max-silent-time . 3600) (verbosity . 0))) (define (show-help) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 1e54d3f218..eade184e67 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -282,7 +282,7 @@ Report the size of PACKAGE and its dependencies.\n")) (define %default-options `((system . ,(%current-system)) - (profile<? . ,profile-closure<?))) + (profile<? . ,profile-self<?))) ;;; diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 0d36997bc4..3dcf42d0d1 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -34,7 +34,8 @@ #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select (current-terminal-columns - progress-proc uri-abbreviation nar-uri-abbreviation + progress-reporter/file + uri-abbreviation nar-uri-abbreviation (open-connection-for-uri . guix:open-connection-for-uri) close-connection @@ -78,12 +79,13 @@ narinfo-signature narinfo-hash->sha256 - assert-valid-narinfo lookup-narinfos lookup-narinfos/diverse read-narinfo write-narinfo + + substitute-urls guix-substitute)) ;;; Comment: @@ -405,38 +407,41 @@ No authentication and authorization checks are performed here!" (let ((above-signature (string-take contents index))) (sha256 (string->utf8 above-signature))))))) -(define* (assert-valid-narinfo narinfo - #:optional (acl (current-acl)) - #:key verbose?) - "Raise an exception if NARINFO lacks a signature, has an invalid signature, -or is signed by an unauthorized key." - (let ((hash (narinfo-sha256 narinfo))) - (if (not hash) - (if %allow-unauthenticated-substitutes? - narinfo - (leave (G_ "substitute at '~a' lacks a signature~%") - (uri->string (narinfo-uri narinfo)))) - (let ((signature (narinfo-signature narinfo))) - (unless %allow-unauthenticated-substitutes? - (assert-valid-signature narinfo signature hash acl) - (when verbose? - (format (current-error-port) - (G_ "Found valid signature for ~a~%") - (narinfo-path narinfo)) - (format (current-error-port) - (G_ "From ~a~%") - (uri->string (narinfo-uri narinfo))))) - narinfo)))) - -(define* (valid-narinfo? narinfo #:optional (acl (current-acl))) +(define* (valid-narinfo? narinfo #:optional (acl (current-acl)) + #:key verbose?) "Return #t if NARINFO's signature is not valid." (or %allow-unauthenticated-substitutes? (let ((hash (narinfo-sha256 narinfo)) - (signature (narinfo-signature narinfo))) + (signature (narinfo-signature narinfo)) + (uri (uri->string (narinfo-uri narinfo)))) (and hash signature (signature-case (signature hash acl) (valid-signature #t) - (else #f)))))) + (invalid-signature + (when verbose? + (format (current-error-port) + "invalid signature for substitute at '~a'~%" + uri)) + #f) + (hash-mismatch + (when verbose? + (format (current-error-port) + "hash mismatch for substitute at '~a'~%" + uri)) + #f) + (unauthorized-key + (when verbose? + (format (current-error-port) + "substitute at '~a' is signed by an \ +unauthorized party~%" + uri)) + #f) + (corrupt-signature + (when verbose? + (format (current-error-port) + "corrupt signature for substitute at '~a'~%" + uri)) + #f)))))) (define (write-narinfo narinfo port) "Write NARINFO to PORT." @@ -706,30 +711,68 @@ information is available locally." (let ((missing (fetch-narinfos cache missing))) (append cached (or missing '())))))) -(define (lookup-narinfos/diverse caches paths) +(define (equivalent-narinfo? narinfo1 narinfo2) + "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe +the same store item. This ignores unnecessary metadata such as the Nar URL." + (and (string=? (narinfo-hash narinfo1) + (narinfo-hash narinfo2)) + + ;; The following is not needed if all we want is to download a valid + ;; nar, but it's necessary if we want valid narinfo. + (string=? (narinfo-path narinfo1) + (narinfo-path narinfo2)) + (equal? (narinfo-references narinfo1) + (narinfo-references narinfo2)) + + (= (narinfo-size narinfo1) + (narinfo-size narinfo2)))) + +(define (lookup-narinfos/diverse caches paths authorized?) "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order. -That is, when a cache lacks a narinfo, look it up in the next cache, and so -on. Return a list of narinfos for PATHS or a subset thereof." +That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next +cache, and so on. + +Return a list of narinfos for PATHS or a subset thereof. The returned +narinfos are either AUTHORIZED?, or they claim a hash that matches an +AUTHORIZED? narinfo." + (define (select-hit result) + (lambda (path) + (match (vhash-fold* cons '() path result) + ((one) + one) + ((several ..1) + (let ((authorized (find authorized? (reverse several)))) + (and authorized + (find (cut equivalent-narinfo? <> authorized) + several))))))) + (let loop ((caches caches) (paths paths) - (result '())) + (result vlist-null) ;path->narinfo vhash + (hits '())) ;paths (match paths (() ;we're done - result) + ;; Now iterate on all the HITS, and return exactly one match for each + ;; hit: the first narinfo that is authorized, or that has the same hash + ;; as an authorized narinfo, in the order of CACHES. + (filter-map (select-hit result) hits)) (_ (match caches ((cache rest ...) (let* ((narinfos (lookup-narinfos cache paths)) - (hits (map narinfo-path narinfos)) - (missing (lset-difference string=? paths hits))) ;XXX: perf - (loop rest missing (append narinfos result)))) + (definite (map narinfo-path (filter authorized? narinfos))) + (missing (lset-difference string=? paths definite))) ;XXX: perf + (loop rest missing + (fold vhash-cons result + (map narinfo-path narinfos) narinfos) + (append definite hits)))) (() ;that's it - result)))))) + (filter-map (select-hit result) hits))))))) -(define (lookup-narinfo caches path) +(define (lookup-narinfo caches path authorized?) "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH was found." - (match (lookup-narinfos/diverse caches (list path)) + (match (lookup-narinfos/diverse caches (list path) authorized?) ((answer) answer) (_ #f))) @@ -772,23 +815,25 @@ was found." (= (string-length file) 32))))) (narinfo-cache-directories directory))) -(define (progress-report-port report-progress port) - "Return a port that calls REPORT-PROGRESS every time something is read from -PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by -`progress-proc'." - (define total 0) - (define (read! bv start count) - (let ((n (match (get-bytevector-n! port bv start count) - ((? eof-object?) 0) - (x x)))) - (set! total (+ total n)) - (report-progress total (const n)) - ;; XXX: We're not in control, so we always return anyway. - n)) - - (make-custom-binary-input-port "progress-port-proc" - read! #f #f - (cut close-connection port))) +(define (progress-report-port reporter port) + "Return a port that continuously reports the bytes read from PORT using +REPORTER, which should be a <progress-reporter> object." + (match reporter + (($ <progress-reporter> start report stop) + (let* ((total 0) + (read! (lambda (bv start count) + (let ((n (match (get-bytevector-n! port bv start count) + ((? eof-object?) 0) + (x x)))) + (set! total (+ total n)) + (report total) + n)))) + (start) + (make-custom-binary-input-port "progress-port-proc" + read! #f #f + (lambda () + (close-connection port) + (stop))))))) (define-syntax with-networking (syntax-rules () @@ -866,15 +911,15 @@ authorized substitutes." (match (string-tokenize command) (("have" paths ..1) ;; Return the subset of PATHS available in CACHE-URLS. - (let ((substitutable (lookup-narinfos/diverse cache-urls paths))) + (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?))) (for-each (lambda (narinfo) (format #t "~a~%" (narinfo-path narinfo))) - (filter valid? substitutable)) + substitutable) (newline))) (("info" paths ..1) ;; Reply info about PATHS if it's in CACHE-URLS. - (let ((substitutable (lookup-narinfos/diverse cache-urls paths))) - (for-each display-narinfo-data (filter valid? substitutable)) + (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?))) + (for-each display-narinfo-data substitutable) (newline))) (wtf (error "unknown `--query' command" wtf)))) @@ -883,10 +928,12 @@ authorized substitutes." #:key cache-urls acl) "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to DESTINATION as a nar file. Verify the substitute against ACL." - (let* ((narinfo (lookup-narinfo cache-urls store-item)) - (uri (narinfo-uri narinfo))) - ;; Make sure it is signed and everything. - (assert-valid-narinfo narinfo acl) + (let* ((narinfo (lookup-narinfo cache-urls store-item + (cut valid-narinfo? <> acl))) + (uri (and=> narinfo narinfo-uri))) + (unless uri + (leave (G_ "no valid substitute for '~a'~%") + store-item)) ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) @@ -903,21 +950,21 @@ DESTINATION as a nar file. Verify the substitute against ACL." (dl-size (or download-size (and (equal? comp "none") (narinfo-size narinfo)))) - (progress (progress-proc (uri->string uri) - dl-size - (current-error-port) - #:abbreviation - nar-uri-abbreviation))) - (progress-report-port progress raw))) + (reporter (progress-reporter/file + (uri->string uri) dl-size + (current-error-port) + #:abbreviation nar-uri-abbreviation))) + (progress-report-port reporter raw))) ((input pids) (decompressed-port (and=> (narinfo-compression narinfo) string->symbol) progress))) ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) + (close-port input) - ;; Skip a line after what 'progress-proc' printed, and another one to - ;; visually separate substitutions. + ;; Skip a line after what 'progress-reporter/file' printed, and another + ;; one to visually separate substitutions. (display "\n\n" (current-error-port)) (every (compose zero? cdr waitpid) pids)))) @@ -971,7 +1018,7 @@ substitutes may be unavailable\n"))))) found." (assoc-ref (daemon-options) option)) -(define %cache-urls +(define %default-substitute-urls (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client (find-daemon-option "substitute-urls")) ;admin string-tokenize) @@ -982,6 +1029,10 @@ found." ;; daemon. '("http://hydra.gnu.org")))) +(define substitute-urls + ;; List of substitute URLs. + (make-parameter %default-substitute-urls)) + (define (client-terminal-columns) "Return the number of columns in the client's terminal, if it is known, or a default value." @@ -1010,15 +1061,15 @@ default value." ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly ;; when we know we cannot substitute, but we must emit a newline on stdout ;; when everything is alright. - (when (null? %cache-urls) + (when (null? (substitute-urls)) (exit 0)) ;; Say hello (see above.) (newline) (force-output (current-output-port)) - ;; Sanity-check %CACHE-URLS so we can provide a meaningful error message. - (for-each validate-uri %cache-urls) + ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error message. + (for-each validate-uri (substitute-urls)) ;; Attempt to install the client's locale, mostly so that messages are ;; suitably translated. @@ -1038,7 +1089,7 @@ default value." (or (eof-object? command) (begin (process-query command - #:cache-urls %cache-urls + #:cache-urls (substitute-urls) #:acl acl) (loop (read-line))))))) (("--substitute" store-path destination) @@ -1047,7 +1098,7 @@ default value." ;; report displays nicely. (parameterize ((current-terminal-columns (client-terminal-columns))) (process-substitution store-path destination - #:cache-urls %cache-urls + #:cache-urls (substitute-urls) #:acl (current-acl)))) (("--version") (show-version-and-exit "guix substitute")) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 8793c40925..567d8bb643 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -41,6 +41,7 @@ #:use-module (gnu bootloader) #:use-module (gnu system file-systems) #:use-module (gnu system linux-container) + #:use-module (gnu system uuid) #:use-module (gnu system vm) #:use-module (gnu services) #:use-module (gnu services shepherd) @@ -72,7 +73,6 @@ "Read the operating-system declaration from FILE and return it." (load* file %user-module)) - ;;; ;;; Installation. @@ -530,7 +530,10 @@ list of services." ;; TRANSLATORS: Please preserve the two-space indentation. (format #t (G_ " label: ~a~%") label) (format #t (G_ " bootloader: ~a~%") bootloader-name) - (format #t (G_ " root device: ~a~%") root-device) + (format #t (G_ " root device: ~a~%") + (if (uuid? root-device) + (uuid->string root-device) + root-device)) (format #t (G_ " kernel: ~a~%") kernel)))) (define* (list-generations pattern #:optional (profile %system-profile)) @@ -748,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")) @@ -864,7 +869,6 @@ Some ACTIONS support additional ARGS.\n")) (substitutes? . #t) (graft? . #t) (build-hook? . #t) - (max-silent-time . 3600) (verbosity . 0) (file-system-type . "ext4") (image-size . guess) @@ -934,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." @@ -946,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) @@ -975,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)))))) |