diff options
| -rw-r--r-- | Makefile.am | 8 | ||||
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 271 | ||||
| -rw-r--r-- | guix-data-service/model/lint-checker.scm | 15 | ||||
| -rw-r--r-- | guix-data-service/model/lint-warning-message.scm | 57 | ||||
| -rw-r--r-- | guix-data-service/model/lint-warning.scm | 36 | ||||
| -rw-r--r-- | sqitch/deploy/lint_warnings.sql | 41 | ||||
| -rw-r--r-- | sqitch/revert/lint_warnings.sql | 11 | ||||
| -rw-r--r-- | sqitch/sqitch.plan | 1 | ||||
| -rw-r--r-- | sqitch/verify/lint_warnings.sql | 7 | ||||
| -rw-r--r-- | tests/model-lint-checker.scm | 37 | ||||
| -rw-r--r-- | tests/model-lint-warning-message.scm | 57 |
11 files changed, 490 insertions, 51 deletions
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) + (($ <location> 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" (string<? a-name b-name))))))) -(define (packages-and-inferior-data->package-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 <mail@cbaines.net> # Fix duplicated licenses, and add constraints change_git_branches_primary_key 2019-08-05T18:57:41Z Christopher Baines <mail@cbaines.net> # 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 <mail@cbaines.net> # Remove duplicate load_new_guix_revision_jobs +lint_warnings 2019-08-18T17:10:12Z Christopher Baines <mail@cbaines.net> # 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) |