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

@@ -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)"

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
+(define (insert-packages conn inf packages)
-                                                            packages
-                                                            inferior-data-4-tuples)
   (let* ((package-license-set-ids
           (log-time "fetching inferior package license metadata"
                     (lambda ()
@@ -344,44 +441,82 @@ WHERE job_id = $1"
           (log-time "fetching inferior package metadata"
                     (lambda ()
                       (inferior-packages->package-metadata-ids
-                       conn packages package-license-set-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
+(define (insert-lint-warnings conn inferior-package-id->package-database-id
-     #t "debug: finished loading information from inferior\n")
+                              lint-warnings-data)
-    (close-inferior inf)
+  (let ((lint-checker-ids
+         (lint-checkers->lint-checker-ids
+          conn
+          (map car lint-warnings-data))))
 
-    (let* ((derivation-ids
+    (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
+               ((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)))
-           (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
          (map
           (match-lambda
             ((inferior-package-id system target derivation-file-name)
-                (list (hashq-ref inferior-package-id->package-id-hash-table
+             (list (inferior-package-id->package-database-id
                     inferior-package-id)
                    system
                    target)))
-             inferior-data-4-tuples))
+          inferior-data-4-tuples)))
-           (package-derivation-ids
+
+
     (insert-package-derivations conn
                                 flat-package-ids-systems-and-targets
                                 derivation-ids)))
 
-      package-derivation-ids)))
-
 (define (inferior-package-transitive-supported-systems package)
   ((@@ (guix inferior) inferior-package-field)
    package
@@ -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,11 +726,39 @@ WHERE job_id = $1"
             (obtain-advisory-transaction-lock conn
                                               'load-new-guix-revision-inserts)
 
-            (let* ((package-derivation-ids
+            (let* ((package-ids
-                    (packages-and-inferior-data->package-derivation-ids
+                    (insert-packages conn inf packages))
-                     conn inf packages inferior-data-4-tuples))
+                   (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 "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 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
@@ -598,14 +766,17 @@ WHERE job_id = $1"
 
                 (simple-format
                  #t "Successfully loaded ~A package/derivation pairs\n"
-               (length package-derivation-ids))))
+                 (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)

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))

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)))))

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)
+     ", "))))

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;

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;

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

sqitch/verify/lint_warnings.sql

@@ -0,0 +1,7 @@
+-- Verify guix-data-service:lint_warnings on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;

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)

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)