aboutsummaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/meson.scm178
-rw-r--r--guix/build/download.scm179
-rw-r--r--guix/build/meson-build-system.scm150
-rw-r--r--guix/cve.scm17
-rw-r--r--guix/download.scm4
-rw-r--r--guix/gnu-maintenance.scm36
-rw-r--r--guix/http-client.scm44
-rw-r--r--guix/import/cpan.scm2
-rw-r--r--guix/scripts/download.scm2
-rw-r--r--guix/scripts/lint.scm7
-rw-r--r--guix/scripts/package.scm21
-rw-r--r--guix/scripts/size.scm2
-rwxr-xr-xguix/scripts/substitute.scm207
-rw-r--r--guix/scripts/system.scm19
-rw-r--r--guix/scripts/system/search.scm144
-rw-r--r--guix/store.scm6
-rw-r--r--guix/ui.scm44
-rw-r--r--guix/utils.scm36
18 files changed, 888 insertions, 210 deletions
diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm
new file mode 100644
index 0000000000..d66ec760a4
--- /dev/null
+++ b/guix/build-system/meson.scm
@@ -0,0 +1,178 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com>
+;;;
+;;; 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 build-system meson)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix derivations)
+ #:use-module (guix search-paths)
+ #:use-module (guix build-system)
+ #:use-module (guix build-system gnu)
+ #:use-module (guix build-system glib-or-gtk)
+ #:use-module (guix packages)
+ #:use-module (ice-9 match)
+ #:export (%meson-build-system-modules
+ meson-build-system))
+
+;; Commentary:
+;;
+;; Standard build procedure for packages using Meson. This is implemented as an
+;; extension of `gnu-build-system', with the option to turn on the glib/gtk
+;; phases from `glib-or-gtk-build-system'.
+;;
+;; Code:
+
+(define %meson-build-system-modules
+ ;; Build-side modules imported by default.
+ `((guix build meson-build-system)
+ (guix build rpath)
+ ;; The modules from glib-or-gtk contains the modules from gnu-build-system,
+ ;; so there is no need to import that too.
+ ,@%glib-or-gtk-build-system-modules))
+
+(define (default-ninja)
+ "Return the default ninja package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((module (resolve-interface '(gnu packages ninja))))
+ (module-ref module 'ninja)))
+
+(define (default-meson)
+ "Return the default meson package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((module (resolve-interface '(gnu packages build-tools))))
+ (module-ref module 'meson-for-build)))
+
+(define (default-patchelf)
+ "Return the default patchelf package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((module (resolve-interface '(gnu packages elf))))
+ (module-ref module 'patchelf)))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ (meson (default-meson))
+ (ninja (default-ninja))
+ (glib-or-gtk #f)
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+ (define private-keywords
+ `(#:source #:meson #:ninja #:inputs #:native-inputs #:outputs #:target))
+
+ (and (not target) ;; TODO: add support for cross-compilation.
+ (bag
+ (name name)
+ (system system)
+ (build-inputs `(("meson" ,meson)
+ ("ninja" ,ninja)
+ ;; Add patchelf for (guix build rpath) to work.
+ ("patchelf" ,(default-patchelf))
+ ,@native-inputs))
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (outputs outputs)
+ (build meson-build)
+ (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (meson-build store name inputs
+ #:key (guile #f)
+ (outputs '("out"))
+ (configure-flags ''())
+ (search-paths '())
+ (build-type "plain")
+ (tests? #t)
+ (test-target "test")
+ (glib-or-gtk? #f)
+ (parallel-build? #t)
+ (parallel-tests? #f)
+ (validate-runpath? #t)
+ (patch-shebangs? #t)
+ (strip-binaries? #t)
+ (strip-flags ''("--strip-debug"))
+ (strip-directories ''("lib" "lib64" "libexec"
+ "bin" "sbin"))
+ (elf-directories ''("lib" "lib64" "libexec"
+ "bin" "sbin"))
+ (phases '(@ (guix build meson-build-system)
+ %standard-phases))
+ (system (%current-system))
+ (imported-modules %meson-build-system-modules)
+ (modules '((guix build meson-build-system)
+ (guix build utils))))
+ "Build SOURCE using MESON, and with INPUTS, assuming that SOURCE
+has a 'meson.build' file."
+ (define builder
+ `(let ((build-phases (if ,glib-or-gtk?
+ ,phases
+ (modify-phases ,phases
+ (delete 'glib-or-gtk-compile-schemas)
+ (delete 'glib-or-gtk-wrap)))))
+ (use-modules ,@modules)
+ (meson-build #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:outputs %outputs
+ #:inputs %build-inputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:phases build-phases
+ #:configure-flags ,configure-flags
+ #:build-type ,build-type
+ #:tests? ,tests?
+ #:test-target ,test-target
+ #:parallel-build? ,parallel-build?
+ #:parallel-tests? ,parallel-tests?
+ #:validate-runpath? ,validate-runpath?
+ #:patch-shebangs? ,patch-shebangs?
+ #:strip-binaries? ,strip-binaries?
+ #:strip-flags ,strip-flags
+ #:strip-directories ,strip-directories
+ #:elf-directories ,elf-directories)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f ; the default
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:system system
+ #:inputs inputs
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build))
+
+(define meson-build-system
+ (build-system
+ (name 'meson)
+ (description "The standard Meson build system")
+ (lower lower)))
+
+;;; meson.scm ends here
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 6ef6233346..9490f48055 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
+;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -26,6 +27,7 @@
#:use-module (guix base64)
#:use-module (guix ftp-client)
#:use-module (guix build utils)
+ #:use-module (guix utils)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
@@ -44,7 +46,7 @@
url-fetch
byte-count->string
current-terminal-columns
- progress-proc
+ progress-reporter/file
uri-abbreviation
nar-uri-abbreviation
store-path-abbreviation))
@@ -147,65 +149,97 @@ Otherwise return STORE-PATH."
(define time-monotonic time-tai))
(else #t))
-(define* (progress-proc file size
- #:optional (log-port (current-output-port))
- #:key (abbreviation basename))
- "Return a procedure to show the progress of FILE's download, which is SIZE
-bytes long. The returned procedure is suitable for use as an argument to
-`dump-port'. The progress report is written to LOG-PORT, with ABBREVIATION
-used to shorten FILE for display."
- ;; XXX: Because of <http://bugs.gnu.org/19939> this procedure is often not
- ;; called as frequently as we'd like too; this is especially bad with Nginx
- ;; on hydra.gnu.org, which returns whole nars as a single chunk.
- (let ((start-time #f))
- (let-syntax ((with-elapsed-time
- (syntax-rules ()
- ((_ elapsed body ...)
- (let* ((now (current-time time-monotonic))
- (elapsed (and start-time
- (duration->seconds
- (time-difference now
- start-time)))))
- (unless start-time
- (set! start-time now))
- body ...)))))
+
+;; TODO: replace '(@ (guix build utils) dump-port))'.
+(define* (dump-port* in out
+ #:key (buffer-size 16384)
+ (reporter (make-progress-reporter noop noop noop)))
+ "Read as much data as possible from IN and write it to OUT, using chunks of
+BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or
+less, report the total number of bytes transferred to the REPORTER, which
+should be a <progress-reporter> object."
+ (define buffer
+ (make-bytevector buffer-size))
+
+ (call-with-progress-reporter reporter
+ (lambda (report)
+ (let loop ((total 0)
+ (bytes (get-bytevector-n! in buffer 0 buffer-size)))
+ (or (eof-object? bytes)
+ (let ((total (+ total bytes)))
+ (put-bytevector out buffer 0 bytes)
+ (report total)
+ (loop total (get-bytevector-n! in buffer 0 buffer-size))))))))
+
+(define (rate-limited proc interval)
+ "Return a procedure that will forward the invocation to PROC when the time
+elapsed since the previous forwarded invocation is greater or equal to
+INTERVAL (a time-duration object), otherwise does nothing and returns #f."
+ (let ((previous-at #f))
+ (lambda args
+ (let* ((now (current-time time-monotonic))
+ (forward-invocation (lambda ()
+ (set! previous-at now)
+ (apply proc args))))
+ (if previous-at
+ (let ((elapsed (time-difference now previous-at)))
+ (if (time>=? elapsed interval)
+ (forward-invocation)
+ #f))
+ (forward-invocation))))))
+
+(define* (progress-reporter/file file size
+ #:optional (log-port (current-output-port))
+ #:key (abbreviation basename))
+ "Return a <progress-reporter> object to show the progress of FILE's download,
+which is SIZE bytes long. The progress report is written to LOG-PORT, with
+ABBREVIATION used to shorten FILE for display."
+ (let ((start-time (current-time time-monotonic))
+ (transferred 0))
+ (define (render)
+ "Write the progress report to LOG-PORT."
+ (define elapsed
+ (duration->seconds
+ (time-difference (current-time time-monotonic) start-time)))
(if (number? size)
- (lambda (transferred cont)
- (with-elapsed-time elapsed
- (let* ((% (* 100.0 (/ transferred size)))
- (throughput (if elapsed
- (/ transferred elapsed)
- 0))
- (left (format #f " ~a ~a"
- (abbreviation file)
- (byte-count->string size)))
- (right (format #f "~a/s ~a ~a~6,1f%"
- (byte-count->string throughput)
- (seconds->string elapsed)
- (progress-bar %) %)))
- (display "\r\x1b[K" log-port)
- (display (string-pad-middle left right
- (current-terminal-columns))
- log-port)
- (flush-output-port log-port)
- (cont))))
- (lambda (transferred cont)
- (with-elapsed-time elapsed
- (let* ((throughput (if elapsed
- (/ transferred elapsed)
- 0))
- (left (format #f " ~a"
- (abbreviation file)))
- (right (format #f "~a/s ~a | ~a transferred"
- (byte-count->string throughput)
- (seconds->string elapsed)
- (byte-count->string transferred))))
- (display "\r\x1b[K" log-port)
- (display (string-pad-middle left right
- (current-terminal-columns))
- log-port)
- (flush-output-port log-port)
- (cont))))))))
+ (let* ((% (* 100.0 (/ transferred size)))
+ (throughput (/ transferred elapsed))
+ (left (format #f " ~a ~a"
+ (abbreviation file)
+ (byte-count->string size)))
+ (right (format #f "~a/s ~a ~a~6,1f%"
+ (byte-count->string throughput)
+ (seconds->string elapsed)
+ (progress-bar %) %)))
+ (display "\r\x1b[K" log-port)
+ (display (string-pad-middle left right
+ (current-terminal-columns))
+ log-port)
+ (flush-output-port log-port))
+ (let* ((throughput (/ transferred elapsed))
+ (left (format #f " ~a"
+ (abbreviation file)))
+ (right (format #f "~a/s ~a | ~a transferred"
+ (byte-count->string throughput)
+ (seconds->string elapsed)
+ (byte-count->string transferred))))
+ (display "\r\x1b[K" log-port)
+ (display (string-pad-middle left right
+ (current-terminal-columns))
+ log-port)
+ (flush-output-port log-port))))
+
+ (progress-reporter
+ (start render)
+ ;; Report the progress every 300ms or longer.
+ (report
+ (let ((rate-limited-render
+ (rate-limited render (make-time time-monotonic 300000000 0))))
+ (lambda (value)
+ (set! transferred value)
+ (rate-limited-render))))
+ ;; Don't miss the last report.
+ (stop render))))
(define* (uri-abbreviation uri #:optional (max-length 42))
"If URI's string representation is larger than MAX-LENGTH, return an
@@ -263,9 +297,10 @@ out if the connection could not be established in less than TIMEOUT seconds."
(dirname (uri-path uri)))))
(call-with-output-file file
(lambda (out)
- (dump-port in out
- #:buffer-size %http-receive-buffer-size
- #:progress (progress-proc (uri-abbreviation uri) size))))
+ (dump-port* in out
+ #:buffer-size %http-receive-buffer-size
+ #:reporter (progress-reporter/file
+ (uri-abbreviation uri) size))))
(ftp-close conn))
(newline)
@@ -754,16 +789,18 @@ certificates; otherwise simply ignore them."
(lambda (p)
(if (port? bv-or-port)
(begin
- (dump-port bv-or-port p
- #:buffer-size %http-receive-buffer-size
- #:progress (progress-proc (uri-abbreviation uri)
- size))
+ (dump-port* bv-or-port p
+ #:buffer-size %http-receive-buffer-size
+ #:reporter (progress-reporter/file
+ (uri-abbreviation uri) size))
(newline))
(put-bytevector p bv-or-port))))
file))
((301 ; moved permanently
302 ; found (redirection)
- 307) ; temporary redirection
+ 303 ; see other
+ 307 ; temporary redirection
+ 308) ; permanent redirection
(let ((uri (resolve-uri-reference (response-location resp) uri)))
(format #t "following redirection to `~a'...~%"
(uri->string uri))
@@ -860,8 +897,8 @@ otherwise simply ignore them."
hashes))
content-addressed-mirrors))
- ;; Make this unbuffered so 'progress-proc' works as expected. _IOLBF means
- ;; '\n', not '\r', so it's not appropriate here.
+ ;; Make this unbuffered so 'progress-report/file' works as expected. _IOLBF
+ ;; means '\n', not '\r', so it's not appropriate here.
(setvbuf (current-output-port) _IONBF)
(setvbuf (current-error-port) _IOLBF)
@@ -876,8 +913,4 @@ otherwise simply ignore them."
file url)
#f))))
-;;; Local Variables:
-;;; eval: (put 'with-elapsed-time 'scheme-indent-function 1)
-;;; End:
-
;;; download.scm ends here
diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm
new file mode 100644
index 0000000000..2b92240c52
--- /dev/null
+++ b/guix/build/meson-build-system.scm
@@ -0,0 +1,150 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com>
+;;;
+;;; 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 build meson-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module ((guix build glib-or-gtk-build-system) #:prefix glib-or-gtk:)
+ #:use-module (guix build utils)
+ #:use-module (guix build rpath)
+ #:use-module (guix build gremlin)
+ #:use-module (guix elf)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:export (%standard-phases
+ meson-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard meson build procedure.
+;;
+;; Code:
+
+(define* (configure #:key outputs configure-flags build-type
+ #:allow-other-keys)
+ "Configure the given package."
+ (let* ((out (assoc-ref outputs "out"))
+ (source-dir (getcwd))
+ (build-dir "../build")
+ (prefix (assoc-ref outputs "out"))
+ (args `(,(string-append "--prefix=" prefix)
+ ,(string-append "--buildtype=" build-type)
+ ,@configure-flags
+ ,source-dir)))
+ (mkdir build-dir)
+ (chdir build-dir)
+ (zero? (apply system* "meson" args))))
+
+(define* (build #:key parallel-build?
+ #:allow-other-keys)
+ "Build a given meson package."
+ (zero? (apply system* "ninja"
+ (if parallel-build?
+ `("-j" ,(number->string (parallel-job-count)))
+ '("-j" "1")))))
+
+(define* (check #:key test-target parallel-tests? tests?
+ #:allow-other-keys)
+ (setenv "MESON_TESTTHREADS"
+ (if parallel-tests?
+ (number->string (parallel-job-count))
+ "1"))
+ (if tests?
+ (zero? (system* "ninja" test-target))
+ (begin
+ (format #t "test suite not run~%")
+ #t)))
+
+(define* (install #:rest args)
+ (zero? (system* "ninja" "install")))
+
+(define* (fix-runpath #:key (elf-directories '("lib" "lib64" "libexec"
+ "bin" "sbin"))
+ outputs #:allow-other-keys)
+ "Try to make sure all ELF files in ELF-DIRECTORIES are able to find their
+local dependencies in their RUNPATH, by searching for the needed libraries in
+the directories of the package, and adding them to the RUNPATH if needed.
+Also shrink the RUNPATH to what is needed,
+since a lot of directories are left over from the build phase of meson,
+for example libraries only needed for the tests."
+
+ ;; Find the directories (if any) that contains DEP-NAME. The directories
+ ;; searched are the ones that ELF-FILES are in.
+ (define (find-deps dep-name elf-files)
+ (map dirname (filter (lambda (file)
+ (string=? dep-name (basename file)))
+ elf-files)))
+
+ ;; Return a list of libraries that FILE needs.
+ (define (file-needed file)
+ (let* ((elf (call-with-input-file file
+ (compose parse-elf get-bytevector-all)))
+ (dyninfo (elf-dynamic-info elf)))
+ (if dyninfo
+ (elf-dynamic-info-needed dyninfo)
+ '())))
+
+
+ ;; If FILE needs any libs that are part of ELF-FILES, the RUNPATH
+ ;; is modified accordingly.
+ (define (handle-file file elf-files)
+ (let* ((dep-dirs (concatenate (map (lambda (dep-name)
+ (find-deps dep-name elf-files))
+ (file-needed file)))))
+ (unless (null? dep-dirs)
+ (augment-rpath file (string-join dep-dirs ":")))))
+
+ (define handle-output
+ (match-lambda
+ ((output . directory)
+ (let* ((elf-dirnames (map (lambda (subdir)
+ (string-append directory "/" subdir))
+ elf-directories))
+ (existing-elf-dirs (filter (lambda (dir)
+ (and (file-exists? dir)
+ (file-is-directory? dir)))
+ elf-dirnames))
+ (elf-pred (lambda (name stat)
+ (elf-file? name)))
+ (elf-list (concatenate (map (lambda (dir)
+ (find-files dir elf-pred))
+ existing-elf-dirs))))
+ (for-each (lambda (elf-file)
+ (system* "patchelf" "--shrink-rpath" elf-file)
+ (handle-file elf-file elf-list))
+ elf-list)))))
+ (for-each handle-output outputs)
+ #t)
+
+(define %standard-phases
+ ;; The standard-phases of glib-or-gtk contains a superset of the phases
+ ;; from the gnu-build-system. If the glib-or-gtk? key is #f (the default)
+ ;; then the extra phases will be removed again in (guix build-system meson).
+ (modify-phases glib-or-gtk:%standard-phases
+ (replace 'configure configure)
+ (replace 'build build)
+ (replace 'check check)
+ (replace 'install install)
+ (add-after 'strip 'fix-runpath fix-runpath)))
+
+(define* (meson-build #:key inputs phases
+ #:allow-other-keys #:rest args)
+ "Build the given package, applying all of PHASES in order."
+ (apply gnu:gnu-build #:inputs inputs #:phases phases args))
+
+;;; meson-build-system.scm ends here
diff --git a/guix/cve.scm b/guix/cve.scm
index 088e39837a..38e59944c8 100644
--- a/guix/cve.scm
+++ b/guix/cve.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -229,11 +229,24 @@ the given TTL (fetch from the NIST web site when TTL has expired)."
(now (current-time time-utc)))
(< (+ (stat:mtime s) ttl) (time-second now))))
+ (define (read* port)
+ ;; Disable read options to avoid populating the source property weak
+ ;; table, which speeds things up, saves memory, and works around
+ ;; <https://lists.gnu.org/archive/html/guile-devel/2017-09/msg00031.html>.
+ (let ((options (read-options)))
+ (dynamic-wind
+ (lambda ()
+ (read-disable 'positions))
+ (lambda ()
+ (read port))
+ (lambda ()
+ (read-options options)))))
+
(catch 'system-error
(lambda ()
(if (old? cache)
(update-cache)
- (match (call-with-input-file cache read)
+ (match (call-with-input-file cache read*)
(('vulnerabilities 1 vulns)
(map sexp->vulnerability vulns))
(x
diff --git a/guix/download.scm b/guix/download.scm
index ae381ee7ab..e090a72306 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
@@ -50,7 +50,7 @@
(let* ((gnu-mirrors
'(;; This one redirects to a (supposedly) nearby and (supposedly)
;; up-to-date mirror.
- "http://ftpmirror.gnu.org/"
+ "https://ftpmirror.gnu.org/gnu/"
"ftp://ftp.cs.tu-berlin.de/pub/gnu/"
"ftp://ftp.funet.fi/pub/mirrors/ftp.gnu.org/gnu/"
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 7c7ca65d7b..796c2d6569 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -454,7 +454,9 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
(define (string->lines str)
(string-tokenize str (char-set-complement (char-set #\newline))))
- (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 60 60))))
+ ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded
+ ;; TTL can be relatively short.
+ (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60))))
(map trim-leading-components
(call-with-gzip-input-port port
(compose string->lines get-string-all))))))
@@ -471,18 +473,30 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)."
(package-upstream-name package)))
(let* ((files (ftp.gnu.org-files))
(relevant (filter (lambda (file)
- (and (string-contains file directory)
- (release-file? name (basename file))
- ))
+ (and (string-prefix? "/gnu" file)
+ (string-contains file directory)
+ (release-file? name (basename file))))
files)))
(match (sort relevant (lambda (file1 file2)
- (version>? (basename file1) (basename file2))))
- ((tarball _ ...)
- (upstream-source
- (package name)
- (version (tarball->version tarball))
- (urls (list (string-append "mirror://gnu/" tarball)))
- (signature-urls (map (cut string-append <> ".sig") urls))))
+ (version>? (sans-extension (basename file1))
+ (sans-extension (basename file2)))))
+ ((and tarballs (reference _ ...))
+ (let* ((version (tarball->version reference))
+ (tarballs (filter (lambda (file)
+ (string=? (sans-extension
+ (basename file))
+ (sans-extension
+ (basename reference))))
+ tarballs)))
+ (upstream-source
+ (package name)
+ (version version)
+ (urls (map (lambda (file)
+ (string-append "mirror://gnu/"
+ (string-drop file
+ (string-length "/gnu/"))))
+ tarballs))
+ (signature-urls (map (cut string-append <> ".sig") urls)))))
(()
#f)))))
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 3c5441c38c..853bba4fe3 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
+;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -259,7 +260,10 @@ Raise an '&http-get-error' condition if downloading fails."
((200)
(values data (response-content-length resp)))
((301 ; moved permanently
- 302) ; found (redirection)
+ 302 ; found (redirection)
+ 303 ; see other
+ 307 ; temporary redirection
+ 308) ; permanent redirection
(let ((uri (resolve-uri-reference (response-location resp) uri)))
(close-port port)
(format #t (G_ "following redirection to `~a'...~%")
@@ -302,14 +306,32 @@ Raise an '&http-get-error' condition if downloading fails."
"Like 'http-fetch', return an input port, but cache its contents in
~/.cache/guix. The cache remains valid for TTL seconds."
(let ((file (cache-file-for-uri uri)))
- (define (update-cache)
+ (define (update-cache cache-port)
+ (define cache-time
+ (and cache-port
+ (stat:mtime (stat cache-port))))
+
+ (define headers
+ `((user-agent . "GNU Guile")
+ ,@(if cache-time
+ `((if-modified-since
+ . ,(time-utc->date (make-time time-utc 0 cache-time))))
+ '())))
+
;; Update the cache and return an input port.
- (let ((port (http-fetch uri #:text? text?)))
- (mkdir-p (dirname file))
- (with-atomic-file-output file
- (cut dump-port port <>))
- (close-port port)
- (open-input-file file)))
+ (guard (c ((http-get-error? c)
+ (if (= 304 (http-get-error-code c)) ;"Not Modified"
+ cache-port
+ (raise c))))
+ (let ((port (http-fetch uri #:text? text?
+ #:headers headers)))
+ (mkdir-p (dirname file))
+ (when cache-port
+ (close-port cache-port))
+ (with-atomic-file-output file
+ (cut dump-port port <>))
+ (close-port port)
+ (open-input-file file))))
(define (old? port)
;; Return true if PORT has passed TTL.
@@ -321,13 +343,11 @@ Raise an '&http-get-error' condition if downloading fails."
(lambda ()
(let ((port (open-input-file file)))
(if (old? port)
- (begin
- (close-port port)
- (update-cache))
+ (update-cache port)
port)))
(lambda args
(if (= ENOENT (system-error-errno args))
- (update-cache)
+ (update-cache #f)
(apply throw args))))))
;;; http-client.scm ends here
diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index 9ee69e5296..01acc6f36e 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -71,7 +71,7 @@
;; mozilla_1_0
("mozilla_1_1" 'mpl1.1)
("openssl" 'openssl)
- ("perl_5" '(package-license perl)) ;GPL1+ and Artistic 1
+ ("perl_5" 'perl-license) ;GPL1+ and Artistic 1
("qpl_1_0" 'qpl)
;; ssleay
;; sun
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/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/package.scm b/guix/scripts/package.scm
index 9ec6950c4b..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
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 7737793189..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"))
@@ -933,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."
@@ -945,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)
@@ -974,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/store.scm b/guix/store.scm
index 2563d26fa0..d571122021 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -40,6 +40,7 @@
#:use-module (ice-9 regex)
#:use-module (ice-9 vlist)
#:use-module (ice-9 popen)
+ #:use-module (ice-9 threads)
#:use-module (web uri)
#:export (%daemon-socket-uri
%gc-roots-directory
@@ -1428,7 +1429,8 @@ where FILE is the entry's absolute file name and STAT is the result of
(define* (run-with-store store mval
#:key
(guile-for-build (%guile-for-build))
- (system (%current-system)))
+ (system (%current-system))
+ (target #f))
"Run MVAL, a monadic value in the store monad, in STORE, an open store
connection, and return the result."
;; Initialize the dynamic bindings here to avoid bad surprises. The
@@ -1436,7 +1438,7 @@ connection, and return the result."
;; bind-time and not at call time, which can be disconcerting.
(parameterize ((%guile-for-build guile-for-build)
(%current-system system)
- (%current-target-system #f))
+ (%current-target-system target))
(call-with-values (lambda ()
(run-with-state mval store))
(lambda (result store)
diff --git a/guix/ui.scm b/guix/ui.scm
index b0108d0705..6dfc8c7a5b 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -79,12 +79,15 @@
read/eval-package-expression
location->string
fill-paragraph
+ %text-width
texi->plain-text
package-description-string
package-synopsis-string
string->recutils
package->recutils
package-specification->name+version+output
+ relevance
+ package-relevance
string->generations
string->duration
matching-generations
@@ -1024,6 +1027,47 @@ WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit."
extra-fields)
(newline port))
+(define (relevance obj regexps metrics)
+ "Compute a \"relevance score\" for OBJ as a function of its number of
+matches of REGEXPS and accordingly to METRICS. METRICS is list of
+field/weight pairs, where FIELD is a procedure that returns a string
+describing OBJ, and WEIGHT is a positive integer denoting the weight of this
+field in the final score.
+
+A score of zero means that OBJ does not match any of REGEXPS. The higher the
+score, the more relevant OBJ is to REGEXPS."
+ (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))))
+
+ (fold (lambda (metric relevance)
+ (match metric
+ ((field . weight)
+ (match (field obj)
+ (#f relevance)
+ (str (+ relevance
+ (* (score str) weight)))))))
+ 0
+ metrics))
+
+(define %package-metrics
+ ;; Metrics used to compute the "relevance score" of a package against a set
+ ;; of regexps.
+ `((,package-name . 3)
+ (,package-synopsis-string . 2)
+ (,package-description-string . 1)))
+
+(define (package-relevance package regexps)
+ "Return a score denoting the relevance of PACKAGE for REGEXPS. A score of
+zero means that PACKAGE does not match any of REGEXPS."
+ (relevance package regexps %package-metrics))
+
(define (string->generations str)
"Return the list of generations matching a pattern in STR. This function
accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"."
diff --git a/guix/utils.scm b/guix/utils.scm
index ab43ed4008..de4aa65319 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -33,6 +33,7 @@
#:autoload (rnrs io ports) (make-custom-binary-input-port)
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
#:use-module (guix memoization)
+ #:use-module (guix records)
#:use-module ((guix build utils) #:select (dump-port mkdir-p))
#:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
#:use-module (ice-9 format)
@@ -94,7 +95,13 @@
call-with-decompressed-port
compressed-output-port
call-with-compressed-output-port
- canonical-newline-port))
+ canonical-newline-port
+
+ <progress-reporter>
+ progress-reporter
+ make-progress-reporter
+ progress-reporter?
+ call-with-progress-reporter))
;;;
@@ -700,7 +707,7 @@ failure."
be determined."
(syntax-case s ()
((_)
- (match (assq 'filename (syntax-source s))
+ (match (assq 'filename (or (syntax-source s) '()))
(('filename . (? string? file-name))
;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME
;; can be relative. In that case, we try to find out at run time
@@ -713,7 +720,7 @@ be determined."
(dirname file-name))
(else
#`(absolute-dirname #,file-name))))
- (_
+ (#f
#f))))))
;; A source location.
@@ -747,3 +754,26 @@ a location object."
`((line . ,(and=> (location-line loc) 1-))
(column . ,(location-column loc))
(filename . ,(location-file loc))))
+
+
+;;;
+;;; Progress reporter.
+;;;
+
+(define-record-type* <progress-reporter>
+ progress-reporter make-progress-reporter progress-reporter?
+ (start progress-reporter-start) ; thunk
+ (report progress-reporter-report) ; procedure
+ (stop progress-reporter-stop)) ; thunk
+
+(define (call-with-progress-reporter reporter proc)
+ "Start REPORTER for progress reporting, and call @code{(@var{proc} report)}
+with the resulting report procedure. When @var{proc} returns, the REPORTER is
+stopped."
+ (match reporter
+ (($ <progress-reporter> start report stop)
+ (dynamic-wind start (lambda () (proc report)) stop))))
+
+;;; Local Variables:
+;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
+;;; End:
generated by cgit v1.2.3 (git 2.45.0) at 2025-01-23 17:45:48 +0000