From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:37884) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fI8p0-0005TB-Ew for guix-patches@gnu.org; Mon, 14 May 2018 04:27:08 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1fI8oy-0003WX-Ed for guix-patches@gnu.org; Mon, 14 May 2018 04:27:06 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:53530) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1fI8oy-0003WL-Ak for guix-patches@gnu.org; Mon, 14 May 2018 04:27:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1fI8oy-0007c5-4p for guix-patches@gnu.org; Mon, 14 May 2018 04:27:04 -0400 Subject: [bug#31442] [PATCH 5/5] DRAFT Add 'guix health'. Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Mon, 14 May 2018 10:25:50 +0200 Message-Id: <20180514082550.1131-5-ludo@gnu.org> In-Reply-To: <20180514082550.1131-1-ludo@gnu.org> References: <20180514082550.1131-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 31442@debbugs.gnu.org DRAFT: Needs doc and tests, plus the FIXME noted inside. * guix/scripts/health.scm: New file. * Makefile.am (MODULES): Add it. * po/guix/POTFILES.in: Add it. --- Makefile.am | 1 + guix/scripts/health.scm | 158 ++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + 3 files changed, 160 insertions(+) create mode 100644 guix/scripts/health.scm diff --git a/Makefile.am b/Makefile.am index 38bd54cf4..870ff6a89 100644 --- a/Makefile.am +++ b/Makefile.am @@ -194,6 +194,7 @@ MODULES = \ guix/scripts/package.scm \ guix/scripts/gc.scm \ guix/scripts/hash.scm \ + guix/scripts/health.scm \ guix/scripts/pack.scm \ guix/scripts/pull.scm \ guix/scripts/substitute.scm \ diff --git a/guix/scripts/health.scm b/guix/scripts/health.scm new file mode 100644 index 000000000..a991fcbe3 --- /dev/null +++ b/guix/scripts/health.scm @@ -0,0 +1,158 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts health) + #:use-module (guix ui) + #:use-module (guix scripts) + #:use-module (guix profiles) + #:use-module (guix packages) + #:use-module (guix cve) + #:use-module (guix utils) + #:use-module (gnu packages) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (guix-health)) + + +;;; +;;; Reporting CVEs. +;;; + +(define (same-package-entries? entry1 entry2) + "Return true if ENTRY1 and ENTRY2 refer to the same package and version." + (and (string=? (manifest-entry-name entry1) + (manifest-entry-name entry2)) + (string=? (manifest-entry-version entry1) + (manifest-entry-version entry2)))) + +(define (manifest-entry-vulnerabilities entry lookup-vulnerabilities) + "Return the list of vulnerabilities for ENTRY. Call LOOKUP-VULNERABILITIES +to determine the list of vulnerabilities for a package/version." + (let* ((name (manifest-entry-name entry)) + (cpe-name (or (assoc-ref (manifest-entry-properties entry) + 'cpe-name) + name)) + (version (manifest-entry-version entry)) + (cpe-version (or (assoc-ref (manifest-entry-properties entry) + 'cpe-version) + version)) + (fixed (or (assoc-ref (manifest-entry-properties entry) + 'fixed-vulnerabilities) + '()))) + (remove (lambda (vuln) + (member (vulnerability-id vuln) fixed)) + (lookup-vulnerabilities cpe-name cpe-version)))) + +(define (check-profile-cve profile) + "Check and report the CVEs of packages in PROFILE." + (define lookup-vulnerabilities + (vulnerabilities->lookup-proc (current-vulnerabilities))) + + (define (report-entry-vulnerabilities entry) + (let ((name (manifest-entry-name entry)) + (version (manifest-entry-version entry))) + (match (manifest-entry-vulnerabilities entry lookup-vulnerabilities) + (() + #t) + ((vulns ...) + (warning (G_ "~a@~a may be vulnerable to~{ ~a~}~%") + name version (map vulnerability-id vulns)) + (match (find-best-packages-by-name name #f) + ((package . _) + (let ((vulns* (lookup-vulnerabilities name + (package-version package)))) + (match (lset-difference string=? + (map vulnerability-id vulns) + (map vulnerability-id vulns*)) + (() + (warning (G_ "~a@~a is available but does not \ +fix any of these~%") + name (package-version package)) + (display-hint (format #f (G_ "Run @command{guix pull} and +then re-run @command{guix health} to see if fixes are available. If none are +available, please consider submitting a patch for the package definition of +'~a'.") name))) + (fixed + (warning (G_ "~a@~a is available and fixes~{ ~a~}, \ +consider ugprading~%") + name (package-version package) fixed))))) + (() + (warning (G_ "'~a' is unavailable and thus \ +cannot be upgraded~%") + name))))))) + + (let* ((manifest (profile-manifest profile)) + (entries (manifest-transitive-entries manifest))) + ;; FIXME: We don't report vulnerabilities in dependencies of the entries. + ;; We could check the references and infer the package name/version for + ;; each of them, but then we wouldn't know their CPE name nor whether they + ;; already contain patches fixing known vulnerabilities. + (for-each report-entry-vulnerabilities + (delete-duplicates entries same-package-entries?)))) + + +;;; +;;; Command-line options. +;;; + +(define (show-help) + (display (G_ "Usage: guix health [OPTIONS] +Report on the vulnerabilities of packages in a profile.\n")) + (display (G_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + (newline) + (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 + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix package"))) + + (option '(#\p "profile") #t #f + (lambda (opt name arg result) + (values (alist-cons 'profile (canonicalize-profile arg) + result) + #f))))) + +(define %default-options + ;; Alist of default option values. + '()) + + +;;; +;;; Entry point. +;;; + +(define (guix-health . args) + (with-error-handling + (let* ((opts (parse-command-line args %options (list %default-options) + #:build-options? #f)) + (profile (or (and=> (assoc-ref opts 'profile) + user-friendly-profile) + %user-profile-directory))) + (check-profile-cve profile)))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index d11f408d4..76fdbe13b 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -31,6 +31,7 @@ guix/scripts/challenge.scm guix/scripts/copy.scm guix/scripts/pack.scm guix/scripts/weather.scm +guix/scripts/health.scm guix/gnu-maintenance.scm guix/scripts/container.scm guix/scripts/container/exec.scm -- 2.17.0