Rework how data is inserted

This is the big change needed to allow for parallel revision
processing. Previously, a lock was used to prevent this since the parallel
transactions could deadlock if each inserted data that the other then went to
insert.

By defining the order in which inserts happen, both in terms of the order of
tables, and the order of rows within the table, this change should guarantee
that there won't be deadlocks.

I'm also hoping this change will address whatever issue was causing some
derivation data to be missing from the database.

.dir-locals.el

@@ -7,6 +7,7 @@
  (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,8 +98,6 @@ 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					\
@@ -148,16 +146,9 @@ 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,6 +16,7 @@
 ;;; <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)
@@ -36,6 +37,8 @@
             %postgresql-in-transaction?
             with-postgresql-transaction
 
+            postgresql-duplicate-key-error?
+
             check-test-database!
 
             lock-advisory-session-lock
@@ -250,6 +253,16 @@
             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,9 +24,7 @@
   #: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
@@ -70,82 +68,3 @@ 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

@@ -1,38 +0,0 @@
-;;; 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

@@ -1,91 +0,0 @@
-;;; 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,43 +21,10 @@
   #:use-module (ice-9 match)
   #:use-module (squee)
   #:use-module (guix-data-service model utils)
-  #:export (lint-checkers->lint-checker-ids
+  #:export (lint-warning-count-by-lint-checker-for-revision
-            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
     "
@@ -85,24 +52,6 @@ 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,34 +21,7 @@
   #: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
+  #:export (lint-warning-message-locales-for-revision))
-            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,43 +20,11 @@
   #:use-module (srfi srfi-1)
   #:use-module (squee)
   #:use-module (guix-data-service model utils)
-  #:export (lint-warnings-data->lint-warning-ids
+  #:export (lint-warnings-for-guix-revision
-            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,39 +23,7 @@
   #:use-module (squee)
   #:use-module (guix-data-service model utils)
   #:use-module (guix-data-service model system)
-  #:export (insert-package-derivations
+  #:export (count-packages-derivations-in-revision))
-            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,6 +25,7 @@
   #: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)
@@ -275,92 +276,6 @@ 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
@@ -480,7 +395,7 @@ INNER JOIN (
        OR translated_package_descriptions.locale = 'en_US.UTF-8')
 WHERE package_metadata.id IN ("
          (string-join
-          (map number->string (vector->list package-metadata-ids))
+          (map number->string package-metadata-ids)
           ", ") ")"
 "
 ORDER BY package_metadata.id, locale,

guix-data-service/model/package.scm

@@ -27,7 +27,6 @@
             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
@@ -250,13 +249,6 @@ 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,56 +23,9 @@
   #:use-module (guix utils)
   #:use-module (guix-data-service model utils)
   #:use-module (guix-data-service model location)
-  #:export (insert-system-tests-for-guix-revision
+  #:export (select-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,11 +37,23 @@
   #: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!
@@ -70,9 +82,103 @@
   "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
@@ -86,45 +192,26 @@
      (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")))
 
-    (unless (= 0 (first list-lengths))
+  (let loop ((lsts lsts))
-      (do-one-iteration 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)))))
 
-  #t)
+  *unspecified*)
 
 (define* (delete-duplicates/sort! unsorted-lst less #:optional (equal? equal?))
   (if (null? unsorted-lst)

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

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

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

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

tests/model-derivation.scm

@@ -1,17 +0,0 @@
-(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

@@ -1,47 +0,0 @@
-(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

@@ -1,44 +0,0 @@
-(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

@@ -1,38 +0,0 @@
-(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

@@ -1,59 +0,0 @@
-(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

@@ -1,98 +0,0 @@
-(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

@@ -1,125 +0,0 @@
-(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)