diff options
| author | Efraim Flashner <efraim@flashner.co.il> | 2017-10-01 19:59:55 +0300 |
|---|---|---|
| committer | Efraim Flashner <efraim@flashner.co.il> | 2017-10-01 22:16:22 +0300 |
| commit | 64df08f0cfac8f7a329002afa3461fd62a4b229c (patch) | |
| tree | 019909423138ceb49cdd86f1af48d366503db68f /guix | |
| parent | b83ad3ace56c65a367e8f58c7b78323cf251b94b (diff) | |
| parent | 0ef1c223071869488c35b72b7407234c11425589 (diff) | |
| download | guix-patches-64df08f0cfac8f7a329002afa3461fd62a4b229c.tar guix-patches-64df08f0cfac8f7a329002afa3461fd62a4b229c.tar.gz | |
Merge remote-tracking branch 'origin/master' into core-updates
Diffstat (limited to 'guix')
32 files changed, 1475 insertions, 292 deletions
diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm new file mode 100644 index 0000000000..d7754e460a --- /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/emacs-build-system.scm b/guix/build/emacs-build-system.scm index bda699ddf4..2404dbddb4 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -110,22 +110,41 @@ store in '.el' files." (define source (getcwd)) - (define (install-file? file stat) - (let ((stripped-file (string-trim (string-drop file (string-length source)) #\/))) - (and (any (cut string-match <> stripped-file) include) - (not (any (cut string-match <> stripped-file) exclude))))) + (define* (install-file? file stat #:key verbose?) + (let* ((stripped-file (string-trim + (string-drop file (string-length source)) #\/))) + (define (match-stripped-file action regex) + (let ((result (string-match regex stripped-file))) + (when (and result verbose?) + (format #t "info: ~A ~A as it matches \"~A\"\n" + stripped-file action regex)) + result)) + + (when verbose? + (format #t "info: considering installing ~A\n" stripped-file)) + + (and (any (cut match-stripped-file "included" <>) include) + (not (any (cut match-stripped-file "excluded" <>) exclude))))) (let* ((out (assoc-ref outputs "out")) (elpa-name-ver (store-directory->elpa-name-version out)) - (target-directory (string-append out %install-suffix "/" elpa-name-ver))) - (for-each - (lambda (file) - (let* ((stripped-file (string-drop file (string-length source))) - (target-file (string-append target-directory stripped-file))) - (format #t "`~a' -> `~a'~%" file target-file) - (install-file file (dirname target-file)))) - (find-files source install-file?))) - #t) + (target-directory (string-append out %install-suffix "/" elpa-name-ver)) + (files-to-install (find-files source install-file?))) + (cond + ((not (null? files-to-install)) + (for-each + (lambda (file) + (let* ((stripped-file (string-drop file (string-length source))) + (target-file (string-append target-directory stripped-file))) + (format #t "`~a' -> `~a'~%" file target-file) + (install-file file (dirname target-file)))) + files-to-install) + #t) + (else + (format #t "error: No files found to install.\n") + (find-files source (lambda (file stat) + (install-file? file stat #:verbose? #t))) + #f)))) (define* (move-doc #:key outputs #:allow-other-keys) "Move info files from the ELPA package directory to the info directory." 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 1dde2919a7..a1560de1a1 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -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 07e6909641..0de36f2f71 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (rnrs io ports) #:use-module (system foreign) #:use-module (guix http-client) #:use-module (guix ftp-client) @@ -34,6 +35,7 @@ #:use-module (guix records) #:use-module (guix upstream) #:use-module (guix packages) + #:use-module (guix zlib) #:export (gnu-package-name gnu-package-mundane-name gnu-package-copyright-holder @@ -58,7 +60,7 @@ gnu-package-name->name+version %gnu-updater - %gnome-updater + %gnu-ftp-updater %kde-updater %xorg-updater %kernel.org-updater)) @@ -433,6 +435,70 @@ hosted on ftp.gnu.org, or not under that name (this is the case for #:server server #:directory directory)))) +(define %gnu-file-list-uri + ;; URI of the file list for ftp.gnu.org. + (string->uri "https://ftp.gnu.org/find.txt.gz")) + +(define ftp.gnu.org-files + (mlambda () + "Return the list of files available at ftp.gnu.org." + + ;; XXX: Memoize the whole procedure to work around the fact that + ;; 'http-fetch/cached' caches the gzipped version. + + (define (trim-leading-components str) + ;; Trim the leading ".", if any, in "./gnu/foo". + (string-trim str (char-set #\.))) + + (define (string->lines str) + (string-tokenize str (char-set-complement (char-set #\newline)))) + + ;; 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)))))) + +(define (latest-gnu-release package) + "Return the latest release of PACKAGE, a GNU package available via +ftp.gnu.org. + +This method does not rely on FTP access at all; instead, it browses the file +list available from %GNU-FILE-LIST-URI over HTTP(S)." + (let-values (((server directory) + (ftp-server/directory package)) + ((name) + (package-upstream-name package))) + (let* ((files (ftp.gnu.org-files)) + (relevant (filter (lambda (file) + (and (string-prefix? "/gnu" file) + (string-contains file directory) + (release-file? name (basename file)))) + files))) + (match (sort relevant (lambda (file1 file2) + (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))))) + (define %package-name-rx ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed. @@ -445,6 +511,9 @@ hosted on ftp.gnu.org, or not under that name (this is the case for (values name+version #f) (values (match:substring match 1) (match:substring match 2))))) +(define gnome-package? + (url-prefix-predicate "mirror://gnome/")) + (define (pure-gnu-package? package) "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This excludes AucTeX, for instance, whose releases are now uploaded to @@ -455,70 +524,9 @@ releases are on gnu.org." (not (gnome-package? package)) (gnu-package? package))) -(define (url-prefix-predicate prefix) - "Return a predicate that returns true when passed a package where one of its -source URLs starts with PREFIX." - (lambda (package) - (define matching-uri? - (match-lambda - ((? string? uri) - (string-prefix? prefix uri)) - (_ - #f))) - - (match (package-source package) - ((? origin? origin) - (match (origin-uri origin) - ((? matching-uri?) #t) - (_ #f))) - (_ #f)))) - (define gnu-hosted? (url-prefix-predicate "mirror://gnu/")) -(define gnome-package? - (url-prefix-predicate "mirror://gnome/")) - -(define (latest-gnome-release package) - "Return the latest release of PACKAGE, the name of a GNOME package." - (define %not-dot - (char-set-complement (char-set #\.))) - - (define (even-minor-version? version) - (match (string-tokenize version %not-dot) - (((= string->number major) (= string->number minor) . rest) - (and minor (even? minor))) - (_ - #t))) ;cross fingers - - (define (even-numbered? file) - ;; Return true if FILE somehow denotes an even-numbered file name. The - ;; trick here is that we want this to match both directories such as - ;; "3.18.6" and actual file names such as "gtk+-3.18.6.tar.bz2". - (let-values (((name version) (package-name->name+version file))) - (even-minor-version? (or version name)))) - - (define upstream-name - ;; Some packages like "NetworkManager" have camel-case names. - (package-upstream-name package)) - - (false-if-ftp-error - (latest-ftp-release upstream-name - #:server "ftp.gnome.org" - #:directory (string-append "/pub/gnome/sources/" - upstream-name) - - - ;; <https://www.gnome.org/gnome-3/source/> explains - ;; that odd minor version numbers represent development - ;; releases, which we are usually not interested in. - #:keep-file? even-numbered? - - ;; ftp.gnome.org provides no signatures, only - ;; checksums. - #:file->signature (const #f)))) - - (define (latest-kde-release package) "Return the latest release of PACKAGE, the name of an KDE.org package." (let ((uri (string->uri (origin-uri (package-source package))))) @@ -557,18 +565,23 @@ source URLs starts with PREFIX." ".sign")))))) (define %gnu-updater + ;; This is for everything at ftp.gnu.org. (upstream-updater (name 'gnu) (description "Updater for GNU packages") - (pred pure-gnu-package?) - (latest latest-release*))) + (pred gnu-hosted?) + (latest latest-gnu-release))) -(define %gnome-updater +(define %gnu-ftp-updater + ;; This is for GNU packages taken from alternate locations, such as + ;; alpha.gnu.org, ftp.gnupg.org, etc. It is obsolescent. (upstream-updater - (name 'gnome) - (description "Updater for GNOME packages") - (pred gnome-package?) - (latest latest-gnome-release))) + (name 'gnu-ftp) + (description "Updater for GNU packages only available via FTP") + (pred (lambda (package) + (and (not (gnu-hosted? package)) + (pure-gnu-package? package)))) + (latest latest-release*))) (define %kde-updater (upstream-updater diff --git a/guix/http-client.scm b/guix/http-client.scm index 3c5441c38c..59788c1f38 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,34 @@ 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" + (begin + (utime file) ;update FILE's mtime + 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 +345,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/import/gnome.scm b/guix/import/gnome.scm new file mode 100644 index 0000000000..1ade63e1af --- /dev/null +++ b/guix/import/gnome.scm @@ -0,0 +1,112 @@ +;;; 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 import gnome) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix http-client) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-34) + #:use-module (web uri) + #:use-module (ice-9 match) + #:export (%gnome-updater)) + +;;; Commentary: +;;; +;;; This package provides not an actual importer but simply an updater for +;;; GNOME packages. It grabs package meta-data from 'cache.json' files +;;; available on ftp.gnome.org. +;;; +;;; Code: + +(define (jsonish->upstream-source name jsonish) + "Return an <upstream-source> object for package NAME, using JSONISH as the +source for metadata." + (match jsonish + ((version . dictionary) + (upstream-source + (package name) + (version version) + (urls (filter-map (lambda (extension) + (match (hash-ref dictionary extension) + (#f + #f) + ((? string? relative-url) + (string-append "mirror://gnome/sources/" + name "/" relative-url)))) + '("tar.lz" "tar.xz" "tar.bz2" "tar.gz"))))))) + +(define (latest-gnome-release package) + "Return the latest release of PACKAGE, a GNOME package, or #f if it could +not be determined." + (define %not-dot + (char-set-complement (char-set #\.))) + + (define (even-minor-version? version) + (match (string-tokenize version %not-dot) + (((= string->number major) (= string->number minor) . rest) + (and minor (even? minor))) + (_ + #t))) ;cross fingers + + (define upstream-name + ;; Some packages like "NetworkManager" have camel-case names. + (package-upstream-name package)) + + (guard (c ((http-get-error? c) + (if (= 404 (http-get-error-code c)) + #f + (raise c)))) + (let* ((port (http-fetch/cached + (string->uri (string-append + "https://ftp.gnome.org/pub/gnome/sources/" + upstream-name "/cache.json")) + + ;; ftp.gnome.org supports 'if-Modified-Since', so the local + ;; cache can expire early. + #:ttl (* 60 10))) + (json (json->scm port))) + (close-port port) + (match json + ((4 (? hash-table? releases) _ ...) + (let* ((releases (hash-ref releases upstream-name)) + (latest (hash-fold (lambda (key value result) + (cond ((even-minor-version? key) + (match result + (#f + (cons key value)) + ((newest . _) + (if (version>? key newest) + (cons key value) + result)))) + (else + result))) + #f + releases))) + (and latest + (jsonish->upstream-source upstream-name latest)))))))) + +(define %gnome-updater + (upstream-updater + (name 'gnome) + (description "Updater for GNOME packages") + (pred (url-prefix-predicate "mirror://gnome/")) + (latest latest-gnome-release))) diff --git a/guix/import/print.scm b/guix/import/print.scm new file mode 100644 index 0000000000..0bec32c8dc --- /dev/null +++ b/guix/import/print.scm @@ -0,0 +1,164 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 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 import print) + #:use-module (guix base32) + #:use-module (guix utils) + #:use-module (guix licenses) + #:use-module (guix packages) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (gnu packages) + #:use-module (srfi srfi-1) + #:use-module (guix import utils) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:export (package->code)) + +;; FIXME: the quasiquoted arguments field may contain embedded package +;; objects, e.g. in #:disallowed-references; they will just be printed with +;; their usual #<package ...> representation, not as variable names. +(define (package->code package) + "Return an S-expression representing the source code that produces PACKAGE +when evaluated." + ;; The module in which the package PKG is defined + (define (package-module-name pkg) + (map string->symbol + (string-split (string-drop-right + (location-file (package-location pkg)) 4) + #\/))) + + ;; Return the first candidate variable name that is bound to VAL. + (define (variable-name val mod) + (match (let/ec return + (module-for-each (lambda (sym var) + (if (eq? val (variable-ref var)) + (return sym) + #f)) + (resolve-interface mod))) + ((? symbol? sym) sym) + (_ #f))) + + ;; Print either license variable name or the code for a license object + (define (license->code lic) + (let ((var (variable-name lic '(guix licenses)))) + (or var + `(license + (name ,(license-name lic)) + (uri ,(license-uri lic)) + (comment ,(license-comment lic)))))) + + (define (search-path-specification->code spec) + `(search-path-specification + (variable ,(search-path-specification-variable spec)) + (files (list ,@(search-path-specification-files spec))) + (separator ,(search-path-specification-separator spec)) + (file-type (quote ,(search-path-specification-file-type spec))) + (file-pattern ,(search-path-specification-file-pattern spec)))) + + (define (source->code source version) + (let ((uri (origin-uri source)) + (method (origin-method source)) + (sha256 (origin-sha256 source)) + (file-name (origin-file-name source)) + (patches (origin-patches source))) + `(origin + (method ,(procedure-name method)) + (uri (string-append ,@(factorize-uri uri version))) + (sha256 + (base32 + ,(format #f "~a" (bytevector->nix-base32-string sha256)))) + ;; FIXME: in order to be able to throw away the directory prefix, + ;; we just assume that the patch files can be found with + ;; "search-patches". + ,@(if (null? patches) '() + `((patches (search-patches ,@(map basename patches)))))))) + + (define (package-lists->code lsts) + (list 'quasiquote + (map (match-lambda + ((label pkg . out) + (let ((mod (package-module-name pkg))) + (list label + ;; FIXME: using '@ certainly isn't pretty, but it + ;; avoids having to import the individual package + ;; modules. + (list 'unquote + (list '@ mod (variable-name pkg mod))))))) + lsts))) + + (let ((name (package-name package)) + (version (package-version package)) + (source (package-source package)) + (build-system (package-build-system package)) + (arguments (package-arguments package)) + (inputs (package-inputs package)) + (propagated-inputs (package-propagated-inputs package)) + (native-inputs (package-native-inputs package)) + (outputs (package-outputs package)) + (native-search-paths (package-native-search-paths package)) + (search-paths (package-search-paths package)) + (replacement (package-replacement package)) + (synopsis (package-synopsis package)) + (description (package-description package)) + (license (package-license package)) + (home-page (package-home-page package)) + (supported-systems (package-supported-systems package)) + (properties (package-properties package))) + `(package + (name ,name) + (version ,version) + (source ,(source->code source version)) + ,@(match properties + (() '()) + (_ `((properties ,properties)))) + ,@(if replacement + `((replacement ,replacement)) + '()) + (build-system ,(symbol-append (build-system-name build-system) + '-build-system)) + ,@(match arguments + (() '()) + (args `((arguments ,(list 'quasiquote args))))) + ,@(match outputs + (("out") '()) + (outs `((outputs (list ,@outs))))) + ,@(match native-inputs + (() '()) + (pkgs `((native-inputs ,(package-lists->code pkgs))))) + ,@(match inputs + (() '()) + (pkgs `((inputs ,(package-lists->code pkgs))))) + ,@(match propagated-inputs + (() '()) + (pkgs `((propagated-inputs ,(package-lists->code pkgs))))) + ,@(if (lset= string=? supported-systems %supported-systems) + '() + `((supported-systems (list ,@supported-systems)))) + ,@(match (map search-path-specification->code native-search-paths) + (() '()) + (paths `((native-search-paths (list ,@paths))))) + ,@(match (map search-path-specification->code search-paths) + (() '()) + (paths `((search-paths (list ,@paths))))) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,description) + (license ,(if (list? license) + `(list ,@(map license->code license)) + (license->code license)))))) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index be1980d08f..1e2f0c809d 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,9 +26,17 @@ #:use-module (guix http-client) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix discovery) + #:use-module (guix build-system) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix download) + #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:export (factorize-uri hash-table->alist @@ -45,7 +54,9 @@ license->symbol snake-case - beautify-description)) + beautify-description + + alist->package)) (define (factorize-uri uri version) "Factorize URI, a package tarball URI as a string, such that any occurrences @@ -241,3 +252,80 @@ package definition." (('package ('name (? string? name)) _ ...) `(define-public ,(string->symbol name) ,guix-package)))) + +(define (build-system-modules) + (all-modules (map (lambda (entry) + `(,entry . "guix/build-system")) + %load-path))) + +(define (lookup-build-system-by-name name) + "Return a <build-system> value for the symbol NAME, representing the name of +the build system." + (fold-module-public-variables (lambda (obj result) + (if (and (build-system? obj) + (eq? name (build-system-name obj))) + obj result)) + #f + (build-system-modules))) + +(define (specs->package-lists specs) + "Convert each string in the SPECS list to a list of a package label and a +package value." + (map (lambda (spec) + (let-values (((pkg out) (specification->package+output spec))) + (match out + (("out") (list (package-name pkg) pkg)) + (_ (list (package-name pkg) pkg out))))) + specs)) + +(define (source-spec->object source) + "Generate an <origin> object from a SOURCE specification. The SOURCE can +either be a simple URL string, #F, or an alist containing entries for each of +the expected fields of an <origin> object." + (match source + ((? string? source-url) + (let ((tarball (with-store store (download-to-store store source-url)))) + (origin + (method url-fetch) + (uri source-url) + (sha256 (base32 (guix-hash-url tarball)))))) + (#f #f) + (orig (let ((sha (match (assoc-ref orig "sha256") + ((("base32" . value)) + (base32 value)) + (_ #f)))) + (origin + (method (match (assoc-ref orig "method") + ("url-fetch" (@ (guix download) url-fetch)) + ("git-fetch" (@ (guix git-download) git-fetch)) + ("svn-fetch" (@ (guix svn-download) svn-fetch)) + ("hg-fetch" (@ (guix hg-download) hg-fetch)) + (_ #f))) + (uri (assoc-ref orig "uri")) + (sha256 sha)))))) + +(define (alist->package meta) + (package + (name (assoc-ref meta "name")) + (version (assoc-ref meta "version")) + (source (source-spec->object (assoc-ref meta "source"))) + (build-system + (lookup-build-system-by-name + (string->symbol (assoc-ref meta "build-system")))) + (native-inputs + (specs->package-lists (or (assoc-ref meta "native-inputs") '()))) + (inputs + (specs->package-lists (or (assoc-ref meta "inputs") '()))) + (propagated-inputs + (specs->package-lists (or (assoc-ref meta "propagated-inputs") '()))) + (home-page + (assoc-ref meta "home-page")) + (synopsis + (assoc-ref meta "synopsis")) + (description + (assoc-ref meta "description")) + (license + (let ((l (assoc-ref meta "license"))) + (or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:) + (spdx-string->license l)) + (license:fsdg-compatible l)))))) diff --git a/guix/licenses.scm b/guix/licenses.scm index b7dadd9750..6de611da2b 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -41,6 +41,7 @@ cc0 cc-by2.0 cc-by3.0 cc-by4.0 cc-by-sa2.0 cc-by-sa3.0 cc-by-sa4.0 + cc-sampling-plus-1.0 cddl1.0 cecill cecill-b cecill-c artistic2.0 clarified-artistic @@ -206,6 +207,11 @@ at URI, which may be a file:// URI pointing the package's tree." "http://creativecommons.org/licenses/by/2.0/" "Creative Commons Attribution 2.0 Generic")) +(define cc-sampling-plus-1.0 + (license "CC-Sampling+ 1.0" + "https://creativecommons.org/licenses/sampling+/1.0" + "Creative Commons Sampling Plus 1.0")) + (define cddl1.0 (license "CDDL 1.0" "http://directory.fsf.org/wiki/License:CDDLv1.0" diff --git a/guix/memoization.scm b/guix/memoization.scm index 5cae283610..bf3b73d806 100644 --- a/guix/memoization.scm +++ b/guix/memoization.scm @@ -76,10 +76,11 @@ the result is returned via (apply values results)." exactly one value." ((_ cached () body ...) ;; The zero-argument case is equivalent to a promise. - (let ((result #f) (cached? #f)) + (let ((result #f) (cached? #f) + (compute (lambda () body ...))) (lambda () (unless cached? - (set! result (begin body ...)) + (set! result (compute)) (set! cached? #t)) result))) 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)))))) 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/upstream.scm b/guix/upstream.scm index 5083e6b805..6ad52ac960 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -45,6 +45,7 @@ upstream-source-signature-urls upstream-source-archive-types + url-prefix-predicate coalesce-sources upstream-updater @@ -81,6 +82,24 @@ (signature-urls upstream-source-signature-urls ;#f | list of strings (default #f))) +(define (url-prefix-predicate prefix) + "Return a predicate that returns true when passed a package where one of its +source URLs starts with PREFIX." + (lambda (package) + (define matching-uri? + (match-lambda + ((? string? uri) + (string-prefix? prefix uri)) + (_ + #f))) + + (match (package-source package) + ((? origin? origin) + (match (origin-uri origin) + ((? matching-uri?) #t) + (_ #f))) + (_ #f)))) + (define (upstream-source-archive-types release) "Return the available types of archives for RELEASE---a list of strings such as \"gz\" or \"xz\"." 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: |