.dir-locals.el

@@ -7,7 +7,6 @@
  (scheme-mode
   (indent-tabs-mode)
   (eval put 'with-time-logging 'scheme-indent-function 1)
-  (eval put 'with-delay-logging 'scheme-indent-function 1)
   (eval put 'make-parameter 'scheme-indent-function 1)
   (eval put 'fibers-let 'scheme-indent-function 1)
   (eval put 'call-with-resource-from-pool 'scheme-indent-function 1)

Makefile.am

@@ -98,6 +98,8 @@ 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-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					\
@@ -146,9 +148,16 @@ TESTS =					\
   tests/branch-updated-emails.scm		\
   tests/forgejo.scm				\
   tests/jobs-load-new-guix-revision.scm	\
+  tests/model-derivation.scm			\
   tests/model-git-branch.scm			\
   tests/model-git-commit.scm			\
-  tests/model-git-repository.scm
+  tests/model-git-repository.scm		\
+  tests/model-license-set.scm			\
+  tests/model-license.scm			\
+  tests/model-lint-checker.scm			\
+  tests/model-lint-warning-message.scm		\
+  tests/model-package.scm			\
+  tests/model-package-metadata.scm
 
 AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)"
 

guix-data-service/database.scm

@@ -16,7 +16,6 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (guix-data-service database)
-  #:use-module (srfi srfi-1)
   #:use-module (system foreign)
   #:use-module (ice-9 match)
   #:use-module (ice-9 threads)
@@ -37,8 +36,6 @@
             %postgresql-in-transaction?
             with-postgresql-transaction
 
-            postgresql-duplicate-key-error?
-
             check-test-database!
 
             lock-advisory-session-lock
@@ -253,16 +250,6 @@
             result))))
     #:unwind? #t))
 
-(define (postgresql-duplicate-key-error? exn)
-  (let ((args (exception-args exn)))
-    (if (and args
-             (>= (length args) 3))
-        (let ((third-arg (third args)))
-          (and (string? third-arg)
-               (string-prefix?
-                "ERROR:  duplicate key value violates unique constraint"
-                third-arg))))))
-
 (define (check-test-database! conn)
   (match (exec-query conn "SELECT current_database()")
     (((name))

guix-data-service/model/channel-news.scm

@@ -24,7 +24,9 @@
   #:use-module (guix channels)
   #:use-module (guix-data-service database)
   #:use-module (guix-data-service model utils)
-  #:export (select-channel-news-entries-contained-in-guix-revision))
+  #:export (select-channel-news-entries-contained-in-guix-revision
+
+            insert-channel-news-entries-for-guix-revision))
 
 (define (select-channel-news-entries-contained-in-guix-revision conn commit)
   (define query
@@ -68,3 +70,82 @@ SELECT channel_news_entries.commit,
                      (vector->list
                       (json-string->scm body_text))))))
        (exec-query-with-null-handling conn query (list commit))))
+
+(define (insert-channel-news-entry-text conn text)
+  (insert-missing-data-and-return-all-ids
+   conn
+   "channel_news_entry_text"
+   '(lang text)
+   (list->vector
+    (map (match-lambda
+           ((lang . text)
+            (list lang text)))
+         text))))
+
+(define (insert-channel-news-entry conn commit tag)
+  (insert-and-return-id
+   conn
+   "channel_news_entries"
+   '(commit tag)
+   (list (or commit NULL)
+         (or tag NULL))))
+
+(define (insert-channel-news-entries conn channel-news-entries)
+  (map
+   (lambda (entry)
+     (let ((commit (channel-news-entry-commit entry))
+           (tag (channel-news-entry-tag entry))
+           (title-ids
+            (sort (insert-channel-news-entry-text
+                   conn (channel-news-entry-title entry))
+                  <))
+           (body-ids
+            (sort (insert-channel-news-entry-text
+                   conn
+                   (channel-news-entry-body entry))
+                  <)))
+       (let ((channel-news-entry-id
+              (insert-channel-news-entry conn commit tag)))
+         (for-each
+          (lambda (table ids)
+            (exec-query
+             conn
+             (string-append
+              "INSERT INTO " table
+              " VALUES "
+              (string-join
+               (map (lambda (id)
+                      (simple-format #f "(~A, ~A)"
+                                     channel-news-entry-id
+                                     id))
+                    (vector->list ids))
+               ", ")
+              " ON CONFLICT DO NOTHING")))
+          '("channel_news_entry_titles"
+            "channel_news_entry_bodies")
+          (list title-ids
+                body-ids))
+
+         channel-news-entry-id)))
+   channel-news-entries))
+
+(define (insert-channel-news-entries-for-guix-revision
+         conn
+         guix-revision-id
+         channel-news-entries)
+  (unless (null? channel-news-entries)
+    (let ((channel-news-entry-ids
+           (insert-channel-news-entries conn channel-news-entries)))
+      (exec-query
+       conn
+       (string-append
+        "INSERT INTO guix_revision_channel_news_entries "
+        "(guix_revision_id, channel_news_entry_id, index) VALUES "
+        (string-join
+         (map (lambda (id index)
+                (simple-format #f "(~A,~A,~A)" guix-revision-id id index))
+              channel-news-entry-ids
+              (iota (length channel-news-entries)))
+         ", ")
+        " ON CONFLICT DO NOTHING"))))
+  #t)

guix-data-service/model/license-set.scm

@@ -0,0 +1,38 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program 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
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-data-service model license-set)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-43)
+  #:use-module (ice-9 vlist)
+  #:use-module (squee)
+  #:use-module (guix-data-service utils)
+  #:use-module (guix-data-service model utils)
+  #:use-module (guix-data-service model license)
+  #:export (inferior-packages->license-set-ids))
+
+(define (inferior-packages->license-set-ids conn license-id-lists)
+  (insert-missing-data-and-return-all-ids
+   conn
+   "license_sets"
+   '(license_ids)
+   (vector-map
+    (lambda (_ license-ids)
+      (if (= 0 (vector-length license-ids))
+          (list (cons "integer[]" license-ids))
+          (list (sort license-ids <))))
+    license-id-lists)))

guix-data-service/model/license.scm

@@ -0,0 +1,91 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program 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
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-data-service model license)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-43)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+  #:use-module (squee)
+  #:use-module (guix inferior)
+  #:use-module (guix-data-service database)
+  #:use-module (guix-data-service model utils)
+  #:export (inferior-packages->license-id-lists
+            inferior-packages->license-data))
+
+(define inferior-package-id
+  (@@ (guix inferior) inferior-package-id))
+
+(define (inferior-packages->license-data inf)
+  (define proc
+    `(vector-map
+      (lambda (_ package)
+        (match (package-license package)
+          ((? license? license)
+           (list
+            (list (license-name license)
+                  (license-uri license)
+                  (license-comment license))))
+          ((values ...)
+           (map (match-lambda
+                  ((? license? license)
+                   (list (license-name license)
+                         (license-uri license)
+                         (license-comment license)))
+                  (x
+                   (simple-format
+                    (current-error-port)
+                    "error: unknown license value ~A for package ~A"
+                    x package)
+                   #f))
+                values))
+          (x
+           (simple-format
+            (current-error-port)
+            "error: unknown license value ~A for package ~A"
+            x package)
+           '())))
+      gds-inferior-packages))
+
+  (inferior-eval '(use-modules (guix licenses)) inf)
+  (inferior-eval proc inf))
+
+(define (inferior-packages->license-id-lists conn license-data)
+  (define (string-or-null v)
+    (if (string? v)
+        v
+        ;; save non string values as NULL
+        NULL))
+
+  (vector-map
+   (lambda (_ license-tuples)
+     (if (null? license-tuples)
+         #()
+         (insert-missing-data-and-return-all-ids
+          conn
+          "licenses"
+          `(name uri comment)
+          (list->vector
+           (filter-map
+            (match-lambda
+              ((name uri comment)
+               (list name
+                     (string-or-null uri)
+                     (string-or-null comment)))
+              (#f #f))
+            license-tuples)))))
+   license-data))

guix-data-service/model/lint-checker.scm

@@ -21,10 +21,43 @@
   #:use-module (ice-9 match)
   #:use-module (squee)
   #:use-module (guix-data-service model utils)
-  #:export (lint-warning-count-by-lint-checker-for-revision
+  #:export (lint-checkers->lint-checker-ids
+            lint-warning-count-by-lint-checker-for-revision
+            insert-guix-revision-lint-checkers
             lint-checkers-for-revision
             lint-checker-description-data->lint-checker-description-set-id))
 
+(define (lint-checkers->lint-checker-ids conn lint-checkers-data)
+  (insert-missing-data-and-return-all-ids
+   conn
+   "lint_checkers"
+   '(name network_dependent lint_checker_description_set_id)
+   lint-checkers-data))
+
+(define (lint-checker-description-data->lint-checker-description-ids
+         conn descriptions-by-locale)
+  (insert-missing-data-and-return-all-ids
+   conn
+   "lint_checker_descriptions"
+   '(locale description)
+   (list->vector
+    (map (match-lambda
+           ((locale . description)
+            (list locale description)))
+         descriptions-by-locale))))
+
+(define (lint-checker-description-data->lint-checker-description-set-id
+         conn
+         descriptions-by-locale)
+  (insert-and-return-id
+   conn
+   "lint_checker_description_sets"
+   '(description_ids)
+   (list
+    (lint-checker-description-data->lint-checker-description-ids
+     conn
+     descriptions-by-locale))))
+
 (define (lint-warning-count-by-lint-checker-for-revision conn commit-hash)
   (define query
     "
@@ -52,6 +85,24 @@ ORDER BY count DESC")
 
   (exec-query conn query (list commit-hash)))
 
+(define (insert-guix-revision-lint-checkers conn
+                                            guix-revision-id
+                                            lint-checker-ids)
+  (exec-query
+   conn
+   (string-append
+    "INSERT INTO guix_revision_lint_checkers (lint_checker_id, guix_revision_id) "
+    "VALUES "
+    (string-join
+     (map (lambda (lint-checker-id)
+            (simple-format
+             #f
+             "(~A, ~A)"
+             lint-checker-id
+             guix-revision-id))
+          (vector->list lint-checker-ids))
+     ", "))))
+
 (define (lint-checkers-for-revision conn commit-hash)
   (exec-query
    conn

guix-data-service/model/lint-warning-message.scm

@@ -21,7 +21,34 @@
   #:use-module (squee)
   #:use-module (guix-data-service database)
   #:use-module (guix-data-service model utils)
-  #:export (lint-warning-message-locales-for-revision))
+  #:export (lint-warning-message-data->lint-warning-message-ids
+            lint-warning-message-locales-for-revision
+            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 message)
+   (let ((v (list->vector messages-by-locale)))
+     (vector-map! (lambda (_ data)
+                    (match data
+                      ((locale . message)
+                       (list locale message))))
+                  v)
+     v)))
+
+(define (lint-warning-message-data->lint-warning-message-set-id
+         conn
+         messages-by-locale)
+  (insert-and-return-id
+   conn
+   "lint_warning_message_sets"
+   '(message_ids)
+   (list (lint-warning-message-data->lint-warning-message-ids
+          conn
+          messages-by-locale))))
 
 (define (lint-warning-message-locales-for-revision conn commit-hash)
   (exec-query

guix-data-service/model/lint-warning.scm

@@ -20,11 +20,43 @@
   #:use-module (srfi srfi-1)
   #:use-module (squee)
   #:use-module (guix-data-service model utils)
-  #:export (lint-warnings-for-guix-revision
+  #:export (lint-warnings-data->lint-warning-ids
+            insert-guix-revision-lint-warnings
+            lint-warnings-for-guix-revision
             select-lint-warnings-by-revision-package-name-and-version
 
             any-translated-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 package_id location_id lint_warning_message_set_id)
+   lint-warnings-data))
+
+(define (insert-guix-revision-lint-warnings conn
+                                            guix-revision-id
+                                            lint-warning-ids)
+  (unless (= 0 (vector-length 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))
+            (vector->list lint-warning-ids))
+       ", ")
+      " ON CONFLICT DO NOTHING"))))
+
 (define* (lint-warnings-for-guix-revision conn commit-hash
                                           #:key
                                           locale

guix-data-service/model/package-derivation.scm

@@ -23,7 +23,39 @@
   #:use-module (squee)
   #:use-module (guix-data-service model utils)
   #:use-module (guix-data-service model system)
-  #:export (count-packages-derivations-in-revision))
+  #:export (insert-package-derivations
+            count-packages-derivations-in-revision))
+
+(define (insert-package-derivations conn
+                                    system
+                                    target
+                                    package-ids
+                                    derivation-ids)
+  (define system-id
+    (system->system-id conn system))
+
+  (define data-4-tuples
+    (vector-fold
+     (lambda (_ result package-id derivation-id)
+       (if derivation-id
+           (cons (list package-id
+                       derivation-id
+                       system-id
+                       target)
+                 result)
+           result))
+     '()
+     package-ids
+     derivation-ids))
+
+  (if (null? data-4-tuples)
+      #()
+      (insert-missing-data-and-return-all-ids
+       conn
+       "package_derivations"
+       '(package_id derivation_id system_id target)
+       (list->vector
+        data-4-tuples))))
 
 (define (count-packages-derivations-in-revision conn commit-hash)
   (define query

guix-data-service/model/package-metadata.scm

@@ -25,7 +25,6 @@
   #:use-module (json)
   #:use-module (gcrypt hash)
   #:use-module (rnrs bytevectors)
-  #:use-module (guix utils)
   #:use-module (guix base16)
   #:use-module (guix packages)
   #:use-module (guix i18n)
@@ -276,6 +275,92 @@ WHERE packages.id IN (
 
 (prevent-inlining-for-tests inferior-packages->translated-package-descriptions-and-synopsis)
 
+(define (inferior-packages->package-metadata-ids conn
+                                                 package-metadata
+                                                 license-set-ids)
+  (define (vector-zip . vecs)
+    (let ((result (make-vector (vector-length (first vecs)))))
+      (apply vector-map!
+             (lambda (i . vals)
+               (cdr vals))
+             (cons result vecs))
+      result))
+
+  (insert-missing-data-and-return-all-ids
+   conn
+   "package_metadata"
+   '(home_page
+     location_id
+     license_set_id
+     package_description_set_id
+     package_synopsis_set_id)
+
+   (vector-zip
+    (vector-map (match-lambda*
+                  ((_ (home-page rest ...))
+                   (if (string? home-page)
+                       home-page
+                       NULL)))
+                package-metadata)
+    (with-time-logging "preparing location ids"
+      (vector-map (match-lambda*
+                    ((_ (_ location rest ...))
+                     (if location
+                         (location->location-id
+                          conn
+                          location)
+                         NULL)))
+                  package-metadata))
+    license-set-ids
+    (with-time-logging "preparing package description set ids"
+      (vector-map (match-lambda*
+                    ((_ (_ _ package-description-data _))
+                     (let ((package-description-ids
+                            (insert-missing-data-and-return-all-ids
+                             conn
+                             "package_descriptions"
+                             '(locale description)
+                             (let ((vec (list->vector package-description-data)))
+                               (vector-map!
+                                (match-lambda*
+                                  ((_ (locale . description))
+                                   (list locale
+                                         ;; \u0000 has appeared in package
+                                         ;; descriptions (#71968), so strip it
+                                         ;; out here to avoid PostgreSQL throwing
+                                         ;; an error
+                                         (string-delete-null description))))
+                                vec)
+                               vec))))
+                       (insert-and-return-id
+                        conn
+                        "package_description_sets"
+                        '(description_ids)
+                        (list (sort! package-description-ids <))))))
+                  package-metadata))
+    (with-time-logging "preparing package synopsis set ids"
+      (vector-map (match-lambda*
+                    ((_ (_ _ _ package-synopsis-data))
+                     (let ((package-synopsis-ids
+                            (insert-missing-data-and-return-all-ids
+                             conn
+                             "package_synopsis"
+                             '(locale synopsis)
+                             (let ((vec
+                                    (list->vector package-synopsis-data)))
+                               (vector-map!
+                                (match-lambda*
+                                  ((_ (locale . synopsis))
+                                   (list locale synopsis)))
+                                vec)
+                               vec))))
+                       (insert-and-return-id
+                        conn
+                        "package_synopsis_sets"
+                        '(synopsis_ids)
+                        (list (sort! package-synopsis-ids <))))))
+                  package-metadata)))))
+
 (define (package-description-and-synopsis-locale-options-guix-revision conn
                                                                        revision-id)
   ;; TODO This no longer uses the revision-id, as that's too expensive. Maybe
@@ -395,7 +480,7 @@ INNER JOIN (
        OR translated_package_descriptions.locale = 'en_US.UTF-8')
 WHERE package_metadata.id IN ("
          (string-join
-          (map number->string package-metadata-ids)
+          (map number->string (vector->list package-metadata-ids))
           ", ") ")"
 "
 ORDER BY package_metadata.id, locale,

guix-data-service/model/package.scm

@@ -27,6 +27,7 @@
             select-packages-in-revision
             search-packages-in-revision
             count-packages-in-revision
+            inferior-packages->package-ids
 
             select-package-versions-for-revision
             package-versions-for-branch
@@ -249,6 +250,13 @@ WHERE packages.id IN (
 
   (exec-query conn query (list commit-hash)))
 
+(define (inferior-packages->package-ids conn package-entries)
+  (insert-missing-data-and-return-all-ids
+   conn
+   "packages"
+   '(name version package_metadata_id replacement_package_id)
+   package-entries))
+
 (define (select-package-versions-for-revision conn
                                               commit
                                               package-name)

guix-data-service/model/system-test.scm

@@ -23,9 +23,56 @@
   #:use-module (guix utils)
   #:use-module (guix-data-service model utils)
   #:use-module (guix-data-service model location)
-  #:export (select-system-tests-for-guix-revision
+  #:export (insert-system-tests-for-guix-revision
+
+            select-system-tests-for-guix-revision
             system-test-derivations-for-branch))
 
+(define (insert-system-tests-for-guix-revision conn
+                                               guix-revision-id
+                                               system-test-data)
+  (unless (null? system-test-data)
+    (let* ((system-test-ids
+            (insert-missing-data-and-return-all-ids
+             conn
+             "system_tests"
+             '(name description location_id)
+             (list->vector
+              (map (match-lambda
+                     ((name description derivation-ids-by-system location-data)
+                      (list name
+                            description
+                            (location->location-id
+                             conn
+                             (apply location location-data)))))
+                   system-test-data))))
+           (data
+            (append-map
+             (lambda (system-test-id derivation-ids-by-system)
+               (map (lambda (system-and-derivation-id)
+                      (list guix-revision-id
+                            system-test-id
+                            (cdr system-and-derivation-id)
+                            (car system-and-derivation-id)))
+                    derivation-ids-by-system))
+             (vector->list system-test-ids)
+             (map third system-test-data))))
+
+      (exec-query
+       conn
+       (string-append
+        "
+INSERT INTO guix_revision_system_test_derivations
+  (guix_revision_id, system_test_id, derivation_id, system)
+VALUES "
+        (string-join
+         (map (lambda (vals)
+                (apply simple-format #f "(~A, ~A, ~A, '~A')"
+                       vals))
+              data)
+         ", ")))))
+  #t)
+
 (define (select-system-tests-for-guix-revision conn
                                                system
                                                commit-hash)

guix-data-service/utils.scm

@@ -37,23 +37,11 @@
   #:use-module (fibers conditions)
   #:use-module (fibers scheduler)
   #:use-module (knots timeout)
-  #:use-module (knots promise)
-  #:use-module (knots parallelism)
   #:use-module (prometheus)
   #:export (call-with-time-logging
             with-time-logging
-
-            %delay-threshold
-            call-with-delay-logging
-            with-delay-logging
-
             prevent-inlining-for-tests
 
-            fibers-delay/eager
-            fibers-sort!
-
-            try-split-at!
-
             chunk
             chunk!
             chunk-for-each!
@@ -82,103 +70,9 @@
   "Log under NAME the time taken to evaluate EXP."
   (call-with-time-logging action (lambda () exp ...)))
 
-(define %delay-threshold
-  (make-parameter 4))
-
-(define (call-with-delay-logging action thunk)
-  (let ((start-time (current-time)))
-    (let-values
-        ((result (thunk)))
-      (let ((time-taken (- (current-time) start-time)))
-        (when (and=> (%delay-threshold)
-                     (lambda (threshold)
-                       (>= time-taken threshold)))
-          (simple-format #t "delay detected in ~A, took ~A seconds\n"
-                         action time-taken)))
-      (apply values result))))
-
-(define-syntax-rule (with-delay-logging action exp ...)
-  "Log under NAME the time taken to evaluate EXP."
-  (call-with-delay-logging action (lambda () exp ...)))
-
 (define-syntax-rule (prevent-inlining-for-tests var)
   (set! var var))
 
-(define (fibers-delay/eager thunk)
-  (let ((promise (fibers-delay thunk)))
-    (spawn-fiber
-     (lambda ()
-       (with-exception-handler
-           (lambda _
-             ;; Silently handle this exception
-             #f)
-         (lambda ()
-           (fibers-force promise))
-         #:unwind? #t)))
-    promise))
-
-(define (try-split-at! lst i)
-  (cond ((< i 0)
-         (error "negitive split size"))
-        ((= i 0)
-         (values '() lst))
-        (else
-         (let lp ((l lst) (n (- i 1)))
-           (if (<= n 0)
-               (let ((tmp (cdr l)))
-                 (unless (null? tmp)
-                   (set-cdr! l '()))
-                 (values lst tmp))
-               (if (or (null? l)
-                       (null? (cdr l)))
-                   (values lst '())
-                   (lp (cdr l) (- n 1))))))))
-
-(define (chunk! lst max-length)
-  (let loop ((chunks '())
-             (lst lst))
-    (let ((chunk
-           rest
-           (try-split-at! lst max-length)))
-      (if (null? rest)
-          (reverse! (cons chunk chunks))
-          (loop (cons chunk chunks)
-                rest)))))
-
-(define* (fibers-sort! items less #:key parallelism)
-  (define requested-chunk-count
-    (or parallelism
-        (+ 1 (length (scheduler-remote-peers (current-scheduler))))))
-
-  (define items-length (length items))
-
-  (if (= 0 items-length)
-      items
-      (let* ((chunk-length (ceiling (/ items-length
-                                       requested-chunk-count)))
-             (chunks (chunk! items chunk-length)))
-        (let loop ((sorted-chunk-promises
-                    (map
-                     (lambda (chunk)
-                       (fibers-delay/eager
-                        (lambda ()
-                          (sort! chunk less))))
-                     chunks)))
-          (if (null? (cdr sorted-chunk-promises))
-              (fibers-force
-               (first sorted-chunk-promises))
-              (loop
-               (map
-                (match-lambda
-                  ((items) items)
-                  ((a b)
-                   (fibers-delay/eager
-                    (lambda ()
-                      (merge! (fibers-force a)
-                              (fibers-force b)
-                              less)))))
-                (chunk! sorted-chunk-promises 2))))))))
-
 (define (chunk lst max-length)
   (let ((len (length lst)))
     (cond
@@ -192,26 +86,45 @@
      (else
       (list lst)))))
 
+(define (chunk! lst max-length)
+  (let ((len (length lst)))
+    (cond
+     ((= 0 len) '())
+     ((> (length lst) max-length)
+      (call-with-values (lambda ()
+                          (split-at! lst max-length))
+        (lambda (first-lst rest)
+          (cons first-lst
+                (chunk! rest max-length)))))
+     (else
+      (list lst)))))
+
 (define* (chunk-for-each! proc chunk-size #:rest lsts)
+  (define (do-one-iteration lsts)
+    (if (> (length (car lsts))
+           chunk-size)
+        (let ((chunks-and-rest
+               (map (lambda (lst)
+                      (call-with-values (lambda ()
+                                          (split-at! lst chunk-size))
+                        (lambda (first-lst rest)
+                          (cons first-lst
+                                rest))))
+                    lsts)))
+          (apply proc
+                 (map car chunks-and-rest))
+          (do-one-iteration
+           (map cdr chunks-and-rest)))
+        (apply proc lsts)))
+
   (let ((list-lengths (map length lsts)))
     (unless (= 1 (length (delete-duplicates list-lengths)))
-      (error "lists not equal length")))
+      (error "lists not equal length"))
 
-  (let loop ((lsts lsts))
-    (let ((chunks-and-rest
-           (map (lambda (lst)
-                  (call-with-values (lambda ()
-                                      (try-split-at! lst chunk-size))
-                    (lambda (first-lst rest)
-                      (cons first-lst
-                            rest))))
-                lsts)))
-      (apply proc
-             (map car chunks-and-rest))
-      (unless (null? (cdr (first chunks-and-rest)))
-        (loop (map cdr chunks-and-rest)))))
+    (unless (= 0 (first list-lengths))
+      (do-one-iteration lsts)))
 
-  *unspecified*)
+  #t)
 
 (define* (delete-duplicates/sort! unsorted-lst less #:optional (equal? equal?))
   (if (null? unsorted-lst)

scripts/guix-data-service-process-job.in

@@ -129,4 +129,6 @@
              #:parallelism (assq-ref opts 'parallelism)))
           #:unwind? #t))
       #:hz 0
-      #:parallelism (assq-ref opts 'parallelism)))))
+      #:parallelism 1
+      ;; Drain to make sure there are no bugs with the use of fibers
+      #:drain? #t))))

tests/jobs-load-new-guix-revision.scm

@@ -3,13 +3,11 @@
   #:use-module (ice-9 match)
   #:use-module (squee)
   #:use-module (fibers)
-  #:use-module (knots)
   #:use-module (guix utils)
   #:use-module (guix store)
   #:use-module (guix tests)
   #:use-module (guix-data-service database)
   #:use-module (guix-data-service model git-repository)
-  #:use-module (guix-data-service model guix-revision)
   #:use-module (guix-data-service jobs load-new-guix-revision))
 
 (test-begin "jobs-load-new-guix-revision")
@@ -67,16 +65,13 @@
           ((guix-data-service jobs load-new-guix-revision)
            extract-information-from
            (lambda _
-             '()))
+             #t))
 
           (mock
-           ((guix-data-service jobs load-new-guix-revision)
-            load-channel-instances
-            (lambda (call-with-utility-thread
-                     read-derivations/serialised
-                     git-repository-id commit
-                     channel-derivations-by-system)
-              (insert-guix-revision conn git-repository-id commit)))
+           ((guix-data-service model channel-instance)
+            insert-channel-instances
+            (lambda (conn guix-revision-id derivations-by-system)
+              #t))
 
            (mock
             ((guix channels)
@@ -86,7 +81,7 @@
 
            (mock
             ((guix-data-service jobs load-new-guix-revision)
-             insert-derivations-with-table-managers
+             derivation-file-names->derivation-ids
              (lambda _
                #(1)))
 
@@ -108,13 +103,8 @@
                 ((id)
                  (run-fibers
                   (lambda ()
-                    (with-exception-handler
-                        (lambda (exn)
-                          (print-backtrace-and-exception/knots exn)
-                          (raise-exception exn))
-                      (lambda ()
-                        (process-load-new-guix-revision-job
-                         id #:parallelism 1))))
+                    (process-load-new-guix-revision-job
+                     id #:parallelism 1))
                   #:hz 0
                   #:parallelism 1
                   #:drain? #t))))))))))))))

tests/model-derivation.scm

@@ -0,0 +1,17 @@
+(define-module (test-model-derivation)
+  #:use-module (srfi srfi-64)
+  #:use-module (guix-data-service database)
+  #:use-module (guix-data-service model derivation))
+
+(test-begin "test-model-derivation")
+
+(with-postgresql-connection
+ "test-model-derivation"
+ (lambda (conn)
+   (check-test-database! conn)
+
+   (test-equal "count-derivations"
+     '("0")
+     (count-derivations conn))))
+
+(test-end)

tests/model-license-set.scm

@@ -0,0 +1,47 @@
+(define-module (tests model-license-set)
+  #:use-module (srfi srfi-64)
+  #:use-module (guix utils)
+  #:use-module (guix tests)
+  #:use-module (guix-data-service database)
+  #:use-module (guix-data-service model license)
+  #:use-module (guix-data-service model license-set))
+
+(test-begin "test-model-license-set")
+
+(define license-data
+  '#((("License 1"
+       "https://gnu.org/licenses/test-1.html"
+       "https://example.com/why-license-1"))
+     (("License 1"
+       "https://gnu.org/licenses/test-1.html"
+       #f)
+      ("License 2"
+       #f
+       #f))
+     ()))
+
+(with-postgresql-connection
+ "test-model-license-set"
+ (lambda (conn)
+   (check-test-database! conn)
+
+   (with-postgresql-transaction
+    conn
+    (lambda (conn)
+      (test-assert "works"
+        (inferior-packages->license-set-ids
+         conn
+         (inferior-packages->license-id-lists conn license-data))))
+    #:always-rollback? #t)
+
+   (with-postgresql-transaction
+    conn
+    (lambda (conn)
+      (let ((license-id-lists
+             (inferior-packages->license-id-lists conn license-data)))
+        (test-equal "works repeatedly"
+          (inferior-packages->license-set-ids conn license-id-lists)
+          (inferior-packages->license-set-ids conn license-id-lists))))
+    #:always-rollback? #t)))
+
+(test-end)

tests/model-license.scm

@@ -0,0 +1,44 @@
+(define-module (tests model-license)
+  #:use-module (srfi srfi-64)
+  #:use-module (guix utils)
+  #:use-module (guix tests)
+  #:use-module (guix-data-service database)
+  #:use-module (guix-data-service model license))
+
+(test-begin "test-model-license")
+
+(define license-data
+  '#((("License 1"
+       "https://gnu.org/licenses/test-1.html"
+       "https://example.com/why-license-1"))
+     (("License 1"
+       "https://gnu.org/licenses/test-1.html"
+       #f)
+      ("License 2"
+       "https://gnu.org/licenses/test-2.html"
+       #f)
+      ("License 3"
+       #f
+       #f))))
+
+(with-postgresql-connection
+ "test-model-license"
+ (lambda (conn)
+   (check-test-database! conn)
+
+   (with-postgresql-transaction
+    conn
+    (lambda (conn)
+      (test-assert "works"
+        (inferior-packages->license-id-lists conn license-data)))
+    #:always-rollback? #t)
+
+   (with-postgresql-transaction
+    conn
+    (lambda (conn)
+      (test-equal "works repeatedly"
+        (inferior-packages->license-id-lists conn license-data)
+        (inferior-packages->license-id-lists conn license-data)))
+    #:always-rollback? #t)))
+
+(test-end)

tests/model-lint-checker.scm

@@ -0,0 +1,38 @@
+(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")
+
+(with-postgresql-connection
+ "test-model-lint-checker"
+ (lambda (conn)
+   (check-test-database! conn)
+
+   (test-assert "single insert"
+     (with-postgresql-transaction
+      conn
+      (lambda (conn)
+        (define data
+          `#((name-1
+              #t
+              ,(lint-checker-description-data->lint-checker-description-set-id
+                conn
+                '(("en_US" . "foo"))))
+             (name-2
+              #f
+              ,(lint-checker-description-data->lint-checker-description-set-id
+                conn
+                '(("en_US" . "bar"))))))
+
+        (match (lint-checkers->lint-checker-ids conn data)
+          (#((? number? id1) (? number? id2))
+           (match (lint-checkers->lint-checker-ids conn data)
+             (#((? number? second-id1) (? number? second-id2))
+              (and (= id1 second-id1)
+                   (= id2 second-id2)))))))
+      #:always-rollback? #t))))
+
+(test-end)

tests/model-lint-warning-message.scm

@@ -0,0 +1,59 @@
+(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)
+   (check-test-database! conn)
+
+   (test-assert "single insert"
+     (with-postgresql-transaction
+      conn
+      (lambda (conn)
+        (match (lint-warning-message-data->lint-warning-message-ids conn data)
+          (#((? number? id1) (? number? 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)
+          (#((? number? id1) (? number? id2))
+           (match (lint-warning-message-data->lint-warning-message-ids conn data)
+             (#((? number? second-id1) (? number? second-id2))
+              (and (= id1 second-id1)
+                   (= 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)
+          ((? number? 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)
+          ((? number? id)
+           (match (lint-warning-message-data->lint-warning-message-set-id conn data)
+             ((? number? second-id)
+              (= id second-id))))))
+      #:always-rollback? #t))))
+
+(test-end)

tests/model-package-metadata.scm

@@ -0,0 +1,98 @@
+(define-module (test-model-package-metadata)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-64)
+  #:use-module (guix utils)
+  #:use-module (guix tests)
+  #:use-module (tests mock-inferior)
+  #:use-module (guix-data-service model license)
+  #:use-module (guix-data-service model license-set)
+  #:use-module (guix-data-service model package-metadata)
+  #:use-module (guix-data-service database))
+
+(test-begin "test-model-package-metadata")
+
+(define mock-inferior-package-foo
+  (mock-inferior-package
+   (name "foo")
+   (version "2")
+   (synopsis "Foo")
+   (description "Foo description")
+   (home-page "https://example.com")
+   (location (location "file.scm" 5 0))))
+
+(define mock-inferior-package-foo-2
+  (mock-inferior-package
+   (name "foo")
+   (version "2")
+   (synopsis "Foo")
+   (description "Foo description")
+   (home-page #f)
+   (location #f)))
+
+(define mock-inferior-packages
+  (list mock-inferior-package-foo
+        mock-inferior-package-foo-2))
+
+(define mock-package-metadata
+  (list->vector
+   (map (lambda (mock-inf-pkg)
+          (list
+           (mock-inferior-package-home-page mock-inf-pkg)
+           (mock-inferior-package-location mock-inf-pkg)
+           `(("en_US.UTF-8" . "Fake synopsis"))
+           `(("en_US.UTF-8" . "Fake description"))))
+        mock-inferior-packages)))
+
+(define (test-license-set-ids conn)
+  (let ((license-id-lists
+         (inferior-packages->license-id-lists
+          conn
+          '#((("License 1"
+               "https://gnu.org/licenses/test-1.html"
+               "https://example.com/why-license-1"))
+             (("License 1"
+               "https://gnu.org/licenses/test-1.html"
+               "https://example.com/why-license-1"))))))
+
+    (inferior-packages->license-set-ids conn license-id-lists)))
+
+(with-mock-inferior-packages
+ (lambda ()
+   (use-modules (guix-data-service model package)
+                (guix-data-service model git-repository)
+                (guix-data-service model guix-revision)
+                (guix-data-service model package-metadata))
+
+   (with-postgresql-connection
+    "test-model-package-metadata"
+    (lambda (conn)
+      (check-test-database! conn)
+
+      (test-assert "inferior-packages->package-metadata-ids"
+        (with-postgresql-transaction
+         conn
+         (lambda (conn)
+           (match
+               (inferior-packages->package-metadata-ids
+                conn
+                mock-package-metadata
+                (test-license-set-ids conn))
+             (#(x y) (and (number? x)
+                          (number? y)))))
+         #:always-rollback? #t))
+
+      (with-postgresql-transaction
+       conn
+       (lambda (conn)
+         (test-equal "inferior-packages->package-metadata-ids"
+           (inferior-packages->package-metadata-ids
+            conn
+            mock-package-metadata
+            (test-license-set-ids conn))
+           (inferior-packages->package-metadata-ids
+            conn
+            mock-package-metadata
+            (test-license-set-ids conn)))
+         #:always-rollback? #t))))))
+
+(test-end)

tests/model-package.scm

@@ -0,0 +1,125 @@
+(define-module (test-model-package)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-64)
+  #:use-module (guix utils)
+  #:use-module (guix tests)
+  #:use-module (tests mock-inferior)
+  #:use-module (guix-data-service model utils)
+  #:use-module (guix-data-service model license)
+  #:use-module (guix-data-service model license-set)
+  #:use-module (guix-data-service model package)
+  #:use-module (guix-data-service model package-metadata)
+  #:use-module (guix-data-service database))
+
+(test-begin "test-model-package")
+
+(define mock-inferior-package-foo
+  (mock-inferior-package
+   (name "foo")
+   (version "2")
+   (synopsis "Foo")
+   (description "Foo description")
+   (home-page "https://example.com")
+   (location (location "file.scm" 5 0))))
+
+(define mock-inferior-package-foo-2
+  (mock-inferior-package
+   (name "foo")
+   (version "2")
+   (synopsis "Foo")
+   (description "Foo description")
+   (home-page #f)
+   (location #f)))
+
+(define (test-license-set-ids conn)
+  (let ((license-id-lists
+         (inferior-packages->license-id-lists
+          conn
+          '#((("License 1"
+               "https://gnu.org/licenses/test-1.html"
+               "https://example.com/why-license-1"))
+             (("License 1"
+               "https://gnu.org/licenses/test-1.html"
+               "https://example.com/why-license-1"))))))
+
+    (inferior-packages->license-set-ids conn license-id-lists)))
+
+(define mock-inferior-packages
+  (list mock-inferior-package-foo
+        mock-inferior-package-foo-2))
+
+(define mock-package-metadata
+  (list->vector
+   (map (lambda (mock-inf-pkg)
+          (list
+           (mock-inferior-package-home-page mock-inf-pkg)
+           (mock-inferior-package-location mock-inf-pkg)
+           `(("en_US.UTF-8" . "Fake synopsis"))
+           `(("en_US.UTF-8" . "Fake description"))))
+        mock-inferior-packages)))
+
+(with-mock-inferior-packages
+ (lambda ()
+   (use-modules (guix-data-service model package)
+                (guix-data-service model git-repository)
+                (guix-data-service model guix-revision)
+                (guix-data-service model package-metadata))
+
+   (with-postgresql-connection
+    "test-model-package"
+    (lambda (conn)
+      (check-test-database! conn)
+
+      (with-postgresql-transaction
+       conn
+       (lambda (conn)
+         (test-assert "inferior-packages->package-ids works once"
+           (let ((package-metadata-ids
+                  (inferior-packages->package-metadata-ids
+                   conn
+                   mock-package-metadata
+                   (test-license-set-ids conn)))
+                 (package-replacement-package-ids
+                  (make-list (length mock-inferior-packages)
+                             (cons "integer" NULL))))
+             (match (inferior-packages->package-ids
+                     conn
+                     (list->vector
+                      (zip (map mock-inferior-package-name mock-inferior-packages)
+                           (map mock-inferior-package-version mock-inferior-packages)
+                           (vector->list package-metadata-ids)
+                           package-replacement-package-ids)))
+               (#(x y) (and (number? x)
+                            (number? y)))))))
+       #:always-rollback? #t)
+
+      (with-postgresql-transaction
+       conn
+       (lambda (conn)
+         (let ((package-metadata-ids
+                (inferior-packages->package-metadata-ids
+                 conn
+                 mock-package-metadata
+                 (test-license-set-ids conn)))
+               (package-replacement-package-ids
+                (make-list (length mock-inferior-packages)
+                           (cons "integer" NULL))))
+           (test-equal "inferior-packages->package-ids is idempotent"
+             (inferior-packages->package-ids
+              conn
+              (list->vector
+               (zip (map mock-inferior-package-name mock-inferior-packages)
+                    (map mock-inferior-package-version mock-inferior-packages)
+                    (vector->list package-metadata-ids)
+                    package-replacement-package-ids)))
+             (inferior-packages->package-ids
+              conn
+              (list->vector
+               (zip (map mock-inferior-package-name mock-inferior-packages)
+                    (map mock-inferior-package-version mock-inferior-packages)
+                    (vector->list package-metadata-ids)
+                    package-replacement-package-ids))))))
+       #:always-rollback? #t)))))
+
+(test-end)