From 6b9977f62eef54678c7a53844ad5d26d8efeecb0 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 31 Aug 2019 12:11:58 +0100 Subject: Store lint warnings in the database This commit adds the relevant tables and code to store lint warnings in the database. Currently, only lint checkers which don't require access to the network will be run, as this allows the processing to happen without network access. Also, this functionality won't work in older versions of Guix which don't expose the lint warnings in a compatible way. --- Makefile.am | 8 +- guix-data-service/jobs/load-new-guix-revision.scm | 271 ++++++++++++++++++---- guix-data-service/model/lint-checker.scm | 15 ++ guix-data-service/model/lint-warning-message.scm | 57 +++++ guix-data-service/model/lint-warning.scm | 36 +++ sqitch/deploy/lint_warnings.sql | 41 ++++ sqitch/revert/lint_warnings.sql | 11 + sqitch/sqitch.plan | 1 + sqitch/verify/lint_warnings.sql | 7 + tests/model-lint-checker.scm | 37 +++ tests/model-lint-warning-message.scm | 57 +++++ 11 files changed, 490 insertions(+), 51 deletions(-) create mode 100644 guix-data-service/model/lint-checker.scm create mode 100644 guix-data-service/model/lint-warning-message.scm create mode 100644 guix-data-service/model/lint-warning.scm create mode 100644 sqitch/deploy/lint_warnings.sql create mode 100644 sqitch/revert/lint_warnings.sql create mode 100644 sqitch/verify/lint_warnings.sql create mode 100644 tests/model-lint-checker.scm create mode 100644 tests/model-lint-warning-message.scm diff --git a/Makefile.am b/Makefile.am index e923ec1..8046df9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -57,8 +57,11 @@ SOURCES = \ guix-data-service/model/git-repository.scm \ guix-data-service/model/guix-revision-package-derivation.scm \ guix-data-service/model/guix-revision.scm \ - guix-data-service/model/license.scm \ guix-data-service/model/license-set.scm \ + guix-data-service/model/license.scm \ + guix-data-service/model/lint-checker.scm \ + guix-data-service/model/lint-warning-message.scm \ + guix-data-service/model/lint-warning.scm \ guix-data-service/model/location.scm \ guix-data-service/model/package-derivation.scm \ guix-data-service/model/package-metadata.scm \ @@ -84,6 +87,9 @@ TESTS = \ tests/model-git-repository.scm \ tests/model-license-set.scm \ tests/model-license.scm \ + tests/model-lint-checker.scm \ + tests/model-lint-warning.scm \ + tests/model-lint-warning-message.scm \ tests/model-package-metadata.scm AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)" diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index 8b1ea84..a138b12 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -9,6 +9,7 @@ #:use-module (guix channels) #:use-module (guix inferior) #:use-module (guix profiles) + #:use-module (guix utils) #:use-module (guix progress) #:use-module (guix packages) #:use-module (guix derivations) @@ -21,6 +22,10 @@ #:use-module (guix-data-service model package-derivation) #:use-module (guix-data-service model guix-revision-package-derivation) #:use-module (guix-data-service model license-set) + #:use-module (guix-data-service model lint-checker) + #:use-module (guix-data-service model lint-warning) + #:use-module (guix-data-service model lint-warning-message) + #:use-module (guix-data-service model location) #:use-module (guix-data-service model package-metadata) #:use-module (guix-data-service model derivation) #:export (log-for-job @@ -193,6 +198,100 @@ WHERE job_id = $1" (simple-format #t "debug: Finished ~A, took ~A seconds\n" action time-taken))))) +(define (all-inferior-lint-warnings inf store) + (define checkers + (inferior-eval + '(begin + (use-modules (guix lint)) + (map (lambda (checker) + (list (lint-checker-name checker) + (lint-checker-description checker) + (if (memq checker %network-dependent-checkers) + #t + #f))) + %all-checkers)) + inf)) + + (define locales + '("cs_CZ.utf8" + "da_DK.utf8" + "de_DE.utf8" + "eo_EO.utf8" + "es_ES.utf8" + "fr_FR.utf8" + "hu_HU.utf8" + "pl_PL.utf8" + "pt_BR.utf8" + ;;"sr_SR.utf8" + "sv_SE.utf8" + "vi_VN.utf8" + "zh_CN.utf8")) + + (define (lint-warnings-for-checker checker-name) + `(lambda (store) + (let* ((checker (find (lambda (checker) + (eq? (lint-checker-name checker) + ',checker-name)) + %local-checkers)) + (check (lint-checker-check checker))) + (filter + (match-lambda + ((package-id . warnings) + (not (null? warnings)))) + (hash-map->list + (lambda (package-id package) + (cons + package-id + (map + (lambda (lint-warning) + (list + (match (lint-warning-location lint-warning) + (($ file line column) + (list (if (string-prefix? "/gnu/store/" file) + ;; Convert a string like + ;; /gnu/store/53xh0mpigin2rffg31s52x5dc08y0qmr-guix-module-union/share/guile/site/2.2/gnu/packages/xdisorg.scm + ;; + ;; This happens when the checker uses + ;; package-field-location. + (string-join (drop (string-split file #\/) 8) "/") + file) + line + column))) + (let* ((source-locale "en_US.utf8") + (source-message + (begin + (setlocale LC_MESSAGES source-locale) + (lint-warning-message lint-warning))) + (messages-by-locale + (filter-map + (lambda (locale) + (setlocale LC_MESSAGES locale) + (let ((message + (lint-warning-message lint-warning))) + (if (string=? message source-message) + #f + (cons locale message)))) + (list ,@locales)))) + (setlocale LC_MESSAGES "") + (cons (cons source-locale source-message) + messages-by-locale)))) + (check package)))) + %package-table))))) + + (map + (match-lambda + ((name description network-dependent?) + (cons + (list name description network-dependent?) + (if network-dependent? + '() + (log-time + (simple-format #f "getting ~A lint warnings" name) + (lambda () + (inferior-eval-with-store inf store (lint-warnings-for-checker + name)))))))) + checkers)) + (define (all-inferior-package-derivations store inf packages) (define inferior-%supported-systems (inferior-eval '(@ (guix packages) %supported-systems) inf)) @@ -332,9 +431,7 @@ WHERE job_id = $1" (stringpackage-derivation-ids conn inf - packages - inferior-data-4-tuples) +(define (insert-packages conn inf packages) (let* ((package-license-set-ids (log-time "fetching inferior package license metadata" (lambda () @@ -344,43 +441,81 @@ WHERE job_id = $1" (log-time "fetching inferior package metadata" (lambda () (inferior-packages->package-metadata-ids - conn packages package-license-set-ids)))) - (package-ids - (log-time "getting package-ids" - (lambda () - (inferior-packages->package-ids - conn packages packages-metadata-ids))))) - - (simple-format - #t "debug: finished loading information from inferior\n") - (close-inferior inf) - - (let* ((derivation-ids - (derivation-file-names->derivation-ids - conn - (map fourth inferior-data-4-tuples))) - (inferior-package-id->package-id-hash-table - (alist->hashq-table - (map (lambda (package package-id) - (cons (inferior-package-id package) - package-id)) - packages - package-ids))) - (flat-package-ids-systems-and-targets + conn packages package-license-set-ids))))) + + (log-time "getting package-ids" + (lambda () + (inferior-packages->package-ids + conn packages packages-metadata-ids))))) + +(define (insert-lint-warnings conn inferior-package-id->package-database-id + lint-warnings-data) + (let ((lint-checker-ids + (lint-checkers->lint-checker-ids + conn + (map car lint-warnings-data)))) + + (lint-warnings-data->lint-warning-ids + conn + (append-map + (lambda (lint-checker-id warnings-by-package-id) + (append-map + (match-lambda + ((package-id . warnings) (map (match-lambda - ((inferior-package-id system target derivation-file-name) - (list (hashq-ref inferior-package-id->package-id-hash-table - inferior-package-id) - system - target))) - inferior-data-4-tuples)) - (package-derivation-ids - (insert-package-derivations conn - flat-package-ids-systems-and-targets - derivation-ids))) - - package-derivation-ids))) + ((location-data messages-by-locale) + (let ((location-id + (location->location-id + conn + (apply location location-data))) + (lint-warning-message-set-id + (lint-warning-message-data->lint-warning-message-set-id + conn + messages-by-locale))) + (list lint-checker-id + (inferior-package-id->package-database-id package-id) + location-id + lint-warning-message-set-id)))) + (fold (lambda (location-and-messages result) + (if (member location-and-messages result) + (begin + (apply + simple-format + (current-error-port) + "warning: skipping duplicate lint warning ~A ~A" + location-and-messages) + result) + (append result + (list location-and-messages)))) + '() + warnings)))) + warnings-by-package-id)) + lint-checker-ids + (map cdr lint-warnings-data))))) + +(define (inferior-data->package-derivation-ids + conn inf + inferior-package-id->package-database-id + inferior-data-4-tuples) + (let ((derivation-ids + (derivation-file-names->derivation-ids + conn + (map fourth inferior-data-4-tuples))) + (flat-package-ids-systems-and-targets + (map + (match-lambda + ((inferior-package-id system target derivation-file-name) + (list (inferior-package-id->package-database-id + inferior-package-id) + system + target))) + inferior-data-4-tuples))) + + + (insert-package-derivations conn + flat-package-ids-systems-and-targets + derivation-ids))) (define (inferior-package-transitive-supported-systems package) ((@@ (guix inferior) inferior-package-field) @@ -575,6 +710,11 @@ WHERE job_id = $1" (lambda () (deduplicate-inferior-packages (inferior-packages inf))))) + (inferior-lint-warnings + (log-time + "fetching inferior lint warnings" + (lambda () + (all-inferior-lint-warnings inf store)))) (inferior-data-4-tuples (log-time "getting inferior derivations" @@ -586,26 +726,57 @@ WHERE job_id = $1" (obtain-advisory-transaction-lock conn 'load-new-guix-revision-inserts) - (let* ((package-derivation-ids - (packages-and-inferior-data->package-derivation-ids - conn inf packages inferior-data-4-tuples)) - (guix-revision-id - (insert-guix-revision conn git-repository-id commit store-path))) - - (insert-guix-revision-package-derivations conn - guix-revision-id - package-derivation-ids) + (let* ((package-ids + (insert-packages conn inf packages)) + (inferior-package-id->package-database-id + (let ((lookup-table + (alist->hashq-table + (map (lambda (package package-id) + (cons (inferior-package-id package) + package-id)) + packages + package-ids)))) + (lambda (inferior-id) + (hashq-ref lookup-table inferior-id))))) (simple-format - #t "Successfully loaded ~A package/derivation pairs\n" - (length package-derivation-ids)))) + #t "debug: finished loading information from inferior\n") + (close-inferior inf) + + (let* ((lint-warning-ids + (insert-lint-warnings + conn + inferior-package-id->package-database-id + inferior-lint-warnings)) + (package-derivation-ids + (inferior-data->package-derivation-ids + conn inf inferior-package-id->package-database-id + inferior-data-4-tuples)) + (guix-revision-id + (insert-guix-revision conn git-repository-id + commit store-path))) + + (insert-guix-revision-lint-warnings conn + guix-revision-id + lint-warning-ids) + + (insert-guix-revision-package-derivations conn + guix-revision-id + package-derivation-ids) + + (simple-format + #t "Successfully loaded ~A package/derivation pairs\n" + (length package-derivation-ids))))) #t) (lambda (key . args) (simple-format (current-error-port) "Failed extracting information from commit: ~A\n\n" commit) (simple-format (current-error-port) " ~A ~A\n\n" key args) - #f))))) + #f) + (lambda (key . args) + (display-backtrace (make-stack #t) (current-error-port))))))) + (define (store-item-for-git-repository-id-and-commit conn git-repository-id commit) diff --git a/guix-data-service/model/lint-checker.scm b/guix-data-service/model/lint-checker.scm new file mode 100644 index 0000000..6193966 --- /dev/null +++ b/guix-data-service/model/lint-checker.scm @@ -0,0 +1,15 @@ +(define-module (guix-data-service model lint-checker) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (guix-data-service model utils) + #:export (lint-checkers->lint-checker-ids)) + +(define (lint-checkers->lint-checker-ids conn lint-checkers-data) + (insert-missing-data-and-return-all-ids + conn + "lint_checkers" + `((name . ,(lambda (value) + (quote-string (symbol->string value)))) + (description . ,quote-string) + (network_dependent . ,value->sql-boolean)) + lint-checkers-data)) diff --git a/guix-data-service/model/lint-warning-message.scm b/guix-data-service/model/lint-warning-message.scm new file mode 100644 index 0000000..70851d9 --- /dev/null +++ b/guix-data-service/model/lint-warning-message.scm @@ -0,0 +1,57 @@ +(define-module (guix-data-service model lint-warning-message) + #:use-module (ice-9 match) + #:use-module (squee) + #:use-module (guix-data-service database) + #:use-module (guix-data-service model utils) + #:export (lint-warning-message-data->lint-warning-message-ids + + lint-warning-message-data->lint-warning-message-set-id)) + +(define (lint-warning-message-data->lint-warning-message-ids conn + messages-by-locale) + (insert-missing-data-and-return-all-ids + conn + "lint_warning_messages" + `((locale . ,quote-string) + (message . ,quote-string)) + (map (match-lambda + ((locale . message) + (list locale message))) + messages-by-locale))) + +(define (insert-lint-warning-message-set conn lint-message-ids) + (let ((query + (string-append + "INSERT INTO lint_warning_message_sets (message_ids) VALUES " + (string-append + "('{" + (string-join + (map number->string + (sort (map string->number lint-message-ids) <)) + ", ") + "}')") + " RETURNING id"))) + + (match (exec-query conn query) + (((id)) id)))) + +(define (lint-warning-message-data->lint-warning-message-set-id + conn + messages-by-locale) + + (let* ((lint-warning-message-ids + (lint-warning-message-data->lint-warning-message-ids + conn messages-by-locale)) + (lint-message-set-id + (exec-query + conn + (string-append + "SELECT id FROM lint_warning_message_sets " + "WHERE message_ids = ARRAY[" + (string-join lint-warning-message-ids ", ") + "]")))) + + (match lint-message-set-id + (((id)) id) + (() + (insert-lint-warning-message-set conn lint-warning-message-ids))))) diff --git a/guix-data-service/model/lint-warning.scm b/guix-data-service/model/lint-warning.scm new file mode 100644 index 0000000..e516618 --- /dev/null +++ b/guix-data-service/model/lint-warning.scm @@ -0,0 +1,36 @@ +(define-module (guix-data-service model lint-warning) + #:use-module (squee) + #:use-module (guix-data-service model utils) + #:export (lint-warnings-data->lint-warning-ids + insert-guix-revision-lint-warnings)) + +(define (lint-warnings-data->lint-warning-ids + conn + ;; (lint-checker-id package-id location-id lint-warning-message-set-id) + lint-warnings-data) + (insert-missing-data-and-return-all-ids + conn + "lint_warnings" + `((lint_checker_id . ,identity) + (package_id . ,identity) + (location_id . ,identity) + (lint_warning_message_set_id . ,identity)) + lint-warnings-data)) + +(define (insert-guix-revision-lint-warnings conn + guix-revision-id + lint-warning-ids) + (exec-query + conn + (string-append + "INSERT INTO guix_revision_lint_warnings (lint_warning_id, guix_revision_id) " + "VALUES " + (string-join + (map (lambda (lint-warning-id) + (simple-format + #f + "(~A, ~A)" + lint-warning-id + guix-revision-id)) + lint-warning-ids) + ", ")))) diff --git a/sqitch/deploy/lint_warnings.sql b/sqitch/deploy/lint_warnings.sql new file mode 100644 index 0000000..1051b74 --- /dev/null +++ b/sqitch/deploy/lint_warnings.sql @@ -0,0 +1,41 @@ +-- Deploy guix-data-service:lint_warnings to pg + +BEGIN; + +CREATE TABLE lint_checkers ( + id integer PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + name varchar NOT NULL, + description varchar NOT NULL, + network_dependent boolean NOT NULL, + UNIQUE (name, description, network_dependent) +); + +CREATE TABLE lint_warning_messages ( + id integer PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + locale varchar NOT NULL, + message varchar NOT NULL, + UNIQUE (locale, message) +); + +CREATE TABLE lint_warning_message_sets ( + id integer NOT NULL PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + message_ids integer[] NOT NULL, + UNIQUE (message_ids) +); + +CREATE TABLE lint_warnings ( + id integer PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + lint_checker_id integer NOT NULL, + package_id integer NOT NULL REFERENCES packages (id), + location_id integer NOT NULL REFERENCES locations (id), + lint_warning_message_set_id integer NOT NULL REFERENCES lint_warning_message_sets (id), + UNIQUE (lint_checker_id, package_id, location_id, lint_warning_message_set_id) +); + +CREATE TABLE guix_revision_lint_warnings ( + lint_warning_id integer NOT NULL REFERENCES lint_warnings (id), + guix_revision_id integer NOT NULL REFERENCES guix_revisions (id), + PRIMARY KEY (lint_warning_id, guix_revision_id) +); + +COMMIT; diff --git a/sqitch/revert/lint_warnings.sql b/sqitch/revert/lint_warnings.sql new file mode 100644 index 0000000..ea36d37 --- /dev/null +++ b/sqitch/revert/lint_warnings.sql @@ -0,0 +1,11 @@ +-- Revert guix-data-service:lint_warnings from pg + +BEGIN; + +DROP TABLE guix_revision_lint_warnings; +DROP TABLE lint_warnings; +DROP TABLE lint_warning_message_sets; +DROP TABLE lint_warning_messages; +DROP TABLE lint_checkers; + +COMMIT; diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan index 541074c..fb234ae 100644 --- a/sqitch/sqitch.plan +++ b/sqitch/sqitch.plan @@ -18,3 +18,4 @@ change_load_new_guix_revision_job_logs_contents_to_be_nullable 2019-07-07T20:10: fix_duplicated_licenses 2019-07-30T05:48:17Z Christopher Baines # Fix duplicated licenses, and add constraints change_git_branches_primary_key 2019-08-05T18:57:41Z Christopher Baines # Change the git_branches primary key to include the git_repository_id,\nas this will allow having the same branch in different repositories. remove_duplicate_load_new_guix_revision_jobs 2019-08-05T19:06:36Z Christopher Baines # Remove duplicate load_new_guix_revision_jobs +lint_warnings 2019-08-18T17:10:12Z Christopher Baines # Store lint warnings diff --git a/sqitch/verify/lint_warnings.sql b/sqitch/verify/lint_warnings.sql new file mode 100644 index 0000000..5af9a76 --- /dev/null +++ b/sqitch/verify/lint_warnings.sql @@ -0,0 +1,7 @@ +-- Verify guix-data-service:lint_warnings on pg + +BEGIN; + +-- XXX Add verifications here. + +ROLLBACK; diff --git a/tests/model-lint-checker.scm b/tests/model-lint-checker.scm new file mode 100644 index 0000000..64088e5 --- /dev/null +++ b/tests/model-lint-checker.scm @@ -0,0 +1,37 @@ +(define-module (tests model-lint-checker) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match) + #:use-module (guix-data-service database) + #:use-module (guix-data-service model lint-checker)) + +(test-begin "test-model-lint-checker") + +(define data + '((name-1 "description-1" #t) + (name-2 "description-2" #f))) + +(with-postgresql-connection + "test-model-lint-checker" + (lambda (conn) + (test-assert "single insert" + (with-postgresql-transaction + conn + (lambda (conn) + (match (lint-checkers->lint-checker-ids conn data) + (((? string? id1) (? string? id2)) + #t))) + #:always-rollback? #t)) + + (test-assert "double insert" + (with-postgresql-transaction + conn + (lambda (conn) + (match (lint-checkers->lint-checker-ids conn data) + (((? string? id1) (? string? id2)) + (match (lint-checkers->lint-checker-ids conn data) + (((? string? second-id1) (? string? second-id2)) + (and (string=? id1 second-id1) + (string=? id2 second-id2))))))) + #:always-rollback? #t)))) + +(test-end) diff --git a/tests/model-lint-warning-message.scm b/tests/model-lint-warning-message.scm new file mode 100644 index 0000000..c6fad55 --- /dev/null +++ b/tests/model-lint-warning-message.scm @@ -0,0 +1,57 @@ +(define-module (tests model-lint-warning-message) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match) + #:use-module (guix-data-service database) + #:use-module (guix-data-service model lint-warning-message)) + +(test-begin "test-model-lint-warning-message") + +(define data + '(("en" . "Test message") + ("es" . "Test message in Spanish"))) + +(with-postgresql-connection + "test-model-lint-checker" + (lambda (conn) + (test-assert "single insert" + (with-postgresql-transaction + conn + (lambda (conn) + (match (lint-warning-message-data->lint-warning-message-ids conn data) + (((? string? id1) (? string? id2)) + #t))) + #:always-rollback? #t)) + + (test-assert "double insert" + (with-postgresql-transaction + conn + (lambda (conn) + (match (lint-warning-message-data->lint-warning-message-ids conn data) + (((? string? id1) (? string? id2)) + (match (lint-warning-message-data->lint-warning-message-ids conn data) + (((? string? second-id1) (? string? second-id2)) + (and (string=? id1 second-id1) + (string=? id2 second-id2))))))) + #:always-rollback? #t)) + + (test-assert "single set insert" + (with-postgresql-transaction + conn + (lambda (conn) + (match (lint-warning-message-data->lint-warning-message-set-id conn data) + ((? string? id1) + #t))) + #:always-rollback? #t)) + + (test-assert "double set insert" + (with-postgresql-transaction + conn + (lambda (conn) + (match (lint-warning-message-data->lint-warning-message-set-id conn data) + ((? string? id) + (match (lint-warning-message-data->lint-warning-message-set-id conn data) + ((? string? second-id) + (string=? id second-id)))))) + #:always-rollback? #t)))) + +(test-end) -- cgit v1.2.3