diff --git a/.dir-locals.el b/.dir-locals.el
index d0ffe3f..cd6ada2 100644
--- a/.dir-locals.el
+++ b/.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)
diff --git a/Makefile.am b/Makefile.am
index 14106d8..1875e97 100644
--- a/Makefile.am
+++ b/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)"
diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm
index 7b266e4..f048c0d 100644
--- a/guix-data-service/database.scm
+++ b/guix-data-service/database.scm
@@ -16,7 +16,6 @@
;;; .
(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))
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index 3e9cfe4..a41599f 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -47,7 +47,6 @@
#:use-module (knots parallelism)
#:use-module (knots resource-pool)
#:use-module (guix monads)
- #:use-module (guix base16)
#:use-module (guix base32)
#:use-module (guix store)
#:use-module (guix channels)
@@ -77,6 +76,8 @@
#:use-module (guix-data-service model guix-revision)
#:use-module (guix-data-service model package-derivation)
#:use-module (guix-data-service model guix-revision-package-derivation)
+ #:use-module (guix-data-service model license)
+ #:use-module (guix-data-service model license-set)
#:use-module (guix-data-service model lint-checker)
#:use-module (guix-data-service model lint-warning)
#:use-module (guix-data-service model lint-warning-message)
@@ -179,357 +180,6 @@
inf)))
string file line column)
- (vector file
- line
- column)))))
+ (list file
+ line
+ column)))))
(all-system-tests)))))
(catch
@@ -665,18 +315,17 @@
(setlocale LC_MESSAGES source-locale)
(if (string=? description source-description)
#f
- (vector locale description))))
+ (cons locale description))))
(list ,@locales))))
- (list->vector
- (cons (vector source-locale source-description)
- descriptions-by-locale))))
+ (cons (cons source-locale source-description)
+ descriptions-by-locale)))
(map (lambda (checker)
(list (lint-checker-name checker)
+ (lint-descriptions-by-locale checker)
(if (memq checker %network-dependent-checkers)
#t
- #f)
- (lint-descriptions-by-locale checker)))
+ #f)))
%all-checkers))
inf)))
@@ -698,16 +347,16 @@
(list
(match (lint-warning-location lint-warning)
(($ file line column)
- (vector (if (string-prefix? "/gnu/store/" file)
- ;; Convert a string like
- ;; /gnu/store/53xh0mpigin2rffg31s52x5dc08y0qmr-guix-module-union/share/guile/site/2.2/gnu/packages/xdisorg.scm
- ;;
- ;; This happens when the checker uses
- ;; package-field-location.
- (string-join (drop (string-split file #\/) 8) "/")
- file)
- line
- column)))
+ (list (if (string-prefix? "/gnu/store/" file)
+ ;; Convert a string like
+ ;; /gnu/store/53xh0mpigin2rffg31s52x5dc08y0qmr-guix-module-union/share/guile/site/2.2/gnu/packages/xdisorg.scm
+ ;;
+ ;; This happens when the checker uses
+ ;; package-field-location.
+ (string-join (drop (string-split file #\/) 8) "/")
+ file)
+ line
+ column)))
(let* ((source-locale "en_US.UTF-8")
(source-message
(begin
@@ -730,30 +379,28 @@
(setlocale LC_MESSAGES source-locale)
(if (string=? message source-message)
#f
- (vector locale message))))
+ (cons locale message))))
(list ,@locales))))
- (list->vector
- (cons (vector source-locale source-message)
- messages-by-locale)))))
+ (cons (cons source-locale source-message)
+ messages-by-locale))))
(vector-map
(lambda (_ package)
- (list->vector
- (map process-lint-warning
- (with-exception-handler
- (lambda (exn)
- (simple-format (current-error-port)
- "exception checking ~A with ~A checker: ~A\n"
- package checker-name exn)
- ;; TODO Record and report this exception
- '())
- (lambda ()
- (if (and lint-checker-requires-store?-defined?
- (lint-checker-requires-store? checker))
+ (map process-lint-warning
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format (current-error-port)
+ "exception checking ~A with ~A checker: ~A\n"
+ package checker-name exn)
+ ;; TODO Record and report this exception
+ '())
+ (lambda ()
+ (if (and lint-checker-requires-store?-defined?
+ (lint-checker-requires-store? checker))
- (check package #:store store)
- (check package)))
- #:unwind? #t))))
+ (check package #:store store)
+ (check package)))
+ #:unwind? #t)))
gds-inferior-packages))))
(ensure-gds-inferior-packages-defined! inf)
@@ -1210,41 +857,6 @@
(with-time-logging "ensuring gds-inferior-packages is defined in inferior"
(inferior-packages-plus-replacements inf))))
-(define (inferior-packages->license-data inf)
- (define proc
- `(vector-map
- (lambda (_ package)
- (match (package-license package)
- ((? license? license)
- (vector
- (vector (license-name license)
- (license-uri license)
- (license-comment license))))
- ((values ...)
- (list->vector
- (map (match-lambda
- ((? license? license)
- (vector (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* (all-inferior-packages-data inf packages pkg-to-replacement-hash-table)
(define inferior-package-id->packages-index-hash-table
(let ((hash-table (make-hash-table)))
@@ -1305,235 +917,133 @@
(metadata . ,package-metadata)
(replacements . ,package-replacement-data))))
-(define (inferior-packages->package-metadata-ids table-manager-coordinator
- package-metadata
- license-set-ids)
- (define (vector-zip . vecs)
- (let ((result (make-vector (vector-length (first vecs)))))
- (apply vector-map!
- (lambda (i . vals)
- (list->vector (cdr vals)))
- (cons result vecs))
- result))
-
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "package_metadata")
- (vector-zip
- (vector-map (match-lambda*
- ((_ (home-page rest ...))
- (if (string? home-page)
- home-page
- NULL)))
- package-metadata)
- (with-time-logging "preparing location ids"
- (let* ((locations-vector
- (vector-map
- (match-lambda*
- ((_ (_ location rest ...))
- (match location
- (#f #f)
- (($ file line column)
- (vector file line column)))))
- package-metadata))
- (result
- (call-with-false-hidden-in-vector
- locations-vector
- (lambda (locations-vector)
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "locations")
- locations-vector)))))
- (vector-map!
- (lambda (_ val)
- (or val NULL))
- result)
- result))
- license-set-ids
- (with-time-logging "preparing package description set ids"
- (let* ((package-description-counts
- (make-vector (vector-length package-metadata)))
- (all-package-descriptions
- (list->vector
- (vector-fold-right
- (lambda (index result metadata)
- (match metadata
- ((_ _ package-description-data _)
- (vector-set! package-description-counts
- index
- (length package-description-data))
- (fold
- (lambda (locale-and-description result)
- (match locale-and-description
- ((locale . description)
- (cons
- (vector locale
- ;; \u0000 has appeared in package
- ;; descriptions (#71968), so strip it
- ;; out here to avoid PostgreSQL throwing
- ;; an error
- (string-delete-null description))
- result))))
- result
- package-description-data))))
- '()
- package-metadata)))
- (package-descriptions-ids
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "package_descriptions")
- all-package-descriptions)))
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "package_description_sets")
- (group-ids-by-counts-vector
- package-descriptions-ids
- package-description-counts))))
- (with-time-logging "preparing package synopsis set ids"
- (let* ((package-synopsis-counts
- (make-vector (vector-length package-metadata)))
- (all-package-synopsis
- (list->vector
- (vector-fold-right
- (lambda (index result metadata)
- (match metadata
- ((_ _ _ package-synopsis-data)
- (vector-set! package-synopsis-counts
- index
- (length package-synopsis-data))
- (fold
- (lambda (locale-and-synopsis result)
- (match locale-and-synopsis
- ((locale . synopsis)
- (cons
- (vector locale
- (string-delete-null synopsis))
- result))))
- result
- package-synopsis-data))))
- '()
- package-metadata)))
- (package-synopsis-ids
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "package_synopsis")
- all-package-synopsis)))
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "package_synopsis_sets")
- (group-ids-by-counts-vector
- package-synopsis-ids
- package-synopsis-counts)))))))
-
-(define (insert-packages postgresql-connection-pool
- table-manager-coordinator
- inferior-packages-data)
+(define (insert-packages conn inferior-packages-data)
(let* ((names (assq-ref inferior-packages-data 'names))
(versions (assq-ref inferior-packages-data 'versions))
(package-license-set-ids
(with-time-logging "inserting package license sets"
- (let* ((license-sets-counts
- (make-vector
- (vector-length
- (assq-ref inferior-packages-data 'license-data))))
- (license-set-ids
- ;; TODO Deduplicate
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "licenses")
- (list->vector
- (vector-fold-right
- (lambda (index result license-details-vector)
- (vector-set! license-sets-counts
- index
- (vector-length license-details-vector))
- (vector-fold-right
- (lambda (_ result details)
- (match details
- (#(name uri comment)
- (cons
- (vector name
- (or uri NULL)
- (or comment NULL))
- result))))
- result
- license-details-vector))
- '()
- (assq-ref inferior-packages-data 'license-data)))))
- (license-set-ids
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "license_sets")
- (group-ids-by-counts-vector
- license-set-ids
- license-sets-counts))))
- (close-table-manager table-manager-coordinator
- "licenses")
- (close-table-manager table-manager-coordinator
- "license_sets")
-
- license-set-ids)))
+ (inferior-packages->license-set-ids
+ conn
+ (inferior-packages->license-id-lists
+ conn
+ (assq-ref inferior-packages-data 'license-data)))))
(all-package-metadata-ids
new-package-metadata-ids
(with-time-logging "inserting package metadata entries"
(inferior-packages->package-metadata-ids
- table-manager-coordinator
+ conn
(assq-ref inferior-packages-data 'metadata)
package-license-set-ids)))
(replacement-package-ids
(vector-map
(lambda (_ package-index-or-false)
(if package-index-or-false
- (table-manager-add-row
- (fetch-table-manager table-manager-coordinator
- "packages")
- (vector
- (vector-ref names package-index-or-false)
- (vector-ref versions package-index-or-false)
- (vector-ref all-package-metadata-ids
- package-index-or-false)
- NULL))
- NULL))
+ (vector-ref
+ (inferior-packages->package-ids
+ conn
+ (vector
+ (list (vector-ref names package-index-or-false)
+ (vector-ref versions package-index-or-false)
+ (vector-ref all-package-metadata-ids
+ package-index-or-false)
+ (cons "integer" NULL))))
+ 0)
+ (cons "integer" NULL)))
(assq-ref inferior-packages-data 'replacements))))
- (close-table-manager table-manager-coordinator
- "package_descriptions")
- (close-table-manager table-manager-coordinator
- "package_description_sets")
- (close-table-manager table-manager-coordinator
- "package_synopsis")
- (close-table-manager table-manager-coordinator
- "package_synopsis_sets")
- (close-table-manager table-manager-coordinator
- "package_metadata")
+ (unless (= 0 (vector-length new-package-metadata-ids))
+ (with-time-logging "inserting package metadata tsvector entries"
+ (insert-package-metadata-tsvector-entries
+ conn new-package-metadata-ids)))
- (let ((new-package-metadata-ids-list
- (vector-fold-right
- (lambda (_ result id new?)
- (if new?
- (cons id result)
- result))
- '()
- all-package-metadata-ids
- new-package-metadata-ids))
- (package-ids
- (with-time-logging "getting package-ids (without replacements)"
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "packages")
- (vector-map (lambda (index . vals)
- (list->vector vals))
- names
- versions
- all-package-metadata-ids
- replacement-package-ids)))))
+ (with-time-logging "getting package-ids (without replacements)"
+ (inferior-packages->package-ids
+ conn
+ ;; Similar to zip, but generating a vector of lists
+ (vector-map (lambda (index . vals) vals)
+ names
+ versions
+ all-package-metadata-ids
+ replacement-package-ids)))))
- (close-table-manager table-manager-coordinator
- "packages")
+(define (insert-lint-warnings conn
+ package-ids
+ lint-checker-ids
+ lint-warnings-data)
+ (vector-fold
+ (lambda (_ result lint-checker-id warnings-per-package)
+ (if warnings-per-package
+ (vector-fold
+ (lambda (_ result package-id warnings)
+ (if (null? warnings)
+ result
+ (cons
+ (lint-warnings-data->lint-warning-ids
+ conn
+ (list->vector
+ (map
+ (match-lambda
+ ((location-data messages-by-locale)
+ (let ((location-id
+ (location->location-id
+ conn
+ (apply location location-data)))
+ (lint-warning-message-set-id
+ (lint-warning-message-data->lint-warning-message-set-id
+ conn
+ messages-by-locale)))
+ (list lint-checker-id
+ package-id
+ location-id
+ lint-warning-message-set-id))))
+ warnings)))
+ result)))
+ result
+ package-ids
+ warnings-per-package)
+ result))
+ '()
+ lint-checker-ids
+ lint-warnings-data))
- (values
- package-ids
- new-package-metadata-ids-list))))
+(define (update-derivation-ids-hash-table! conn
+ derivation-ids-hash-table
+ derivations-or-file-names)
+ (define derivations-count (vector-length derivations-or-file-names))
+
+ (let ((missing-file-names
+ (vector-fold
+ (lambda (_ result file-name-or-drv)
+ (if file-name-or-drv
+ (let ((file-name
+ (if (string? file-name-or-drv)
+ file-name-or-drv
+ (derivation-file-name file-name-or-drv))))
+ (if (hash-ref derivation-ids-hash-table
+ file-name)
+ result
+ (cons file-name
+ result)))
+ result))
+ '()
+ derivations-or-file-names)))
+
+ (simple-format
+ #t "debug: update-derivation-ids-hash-table!: lookup ~A file-names, ~A not cached\n"
+ derivations-count (length missing-file-names))
+
+ (unless (null? missing-file-names)
+ (chunk-for-each!
+ (lambda (chunk)
+ (for-each
+ (match-lambda
+ ((id file-name)
+ (hash-set! derivation-ids-hash-table
+ file-name
+ (string->number id))))
+ (exec-query conn (select-existing-derivations chunk))))
+ 1000
+ missing-file-names))))
(define (compute-and-update-derivation-source-file-nar
postgresql-connection-pool
@@ -1577,6 +1087,247 @@
compressed-nar-bytevector
uncompressed-size)))))
+(define* (derivations-insert-sources postgresql-connection-pool
+ call-with-utility-thread
+ derivations
+ derivation-ids
+ #:key (log-tag "unspecified"))
+ (with-time-logging
+ (string-append "insert-missing-derivations: inserting sources for "
+ (number->string (vector-length derivations))
+ " derivations (" log-tag ")")
+ (let ((sources-ids-vector
+ (with-resource-from-pool postgresql-connection-pool conn
+ (with-time-logging
+ (string-append
+ "insert-missing-derivations: inserting "
+ (number->string (vector-length derivations))
+ " derivation_source_files and derivation_sources"
+ " (" log-tag ")")
+ (vector-map
+ (lambda (_ derivation-id derivation)
+ (let ((sources (derivation-sources derivation)))
+ (if (null? sources)
+ #()
+ (insert-derivation-sources conn
+ derivation-id
+ sources))))
+ derivation-ids
+ derivations)))))
+ (with-time-logging
+ (string-append
+ "insert-missing-derivations: inserting "
+ (number->string (vector-length derivations))
+ " derivation_source_file_nars"
+ " (" log-tag ")")
+ (fibers-for-each
+ (lambda (derivation source-ids)
+ (for-each
+ (lambda (id source-file)
+ (when
+ (with-resource-from-pool postgresql-connection-pool conn
+ (match
+ (exec-query
+ conn
+ "
+SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
+ (list (number->string id)))
+ (()
+ ;; Insert a placeholder to avoid other fibers
+ ;; working on this source file
+ (insert-placeholder-derivation-source-file-nar
+ conn
+ id)
+ #t)
+ (_ #f)))
+ ;; Use a utility thread to control concurrency here, to
+ ;; avoid using too much memory
+ (call-with-utility-thread
+ (lambda ()
+ (compute-and-update-derivation-source-file-nar
+ postgresql-connection-pool
+ id
+ source-file)))))
+ (vector->list source-ids)
+ (derivation-sources derivation)))
+ derivations
+ sources-ids-vector)))))
+
+(define* (insert-missing-derivations postgresql-connection-pool
+ call-with-utility-thread
+ derivation-ids-hash-table
+ unfiltered-derivations
+ #:key (log-tag "unspecified"))
+
+ (define (insert-into-derivations conn drvs)
+ (insert-missing-data-and-return-all-ids
+ conn
+ "derivations"
+ '(file_name builder args env_vars system_id)
+ (vector-map (match-lambda*
+ ((_ ($ outputs inputs sources
+ system builder args env-vars file-name))
+ (list file-name
+ builder
+ (cons "varchar[]"
+ (list->vector args))
+ (cons "varchar[][]"
+ (list->vector
+ (map (match-lambda
+ ((key . value)
+ (vector key value)))
+ env-vars)))
+ (system->system-id conn system))))
+ drvs)))
+
+ (define (insert-derivations)
+ (with-resource-from-pool postgresql-connection-pool conn
+ (update-derivation-ids-hash-table!
+ conn
+ derivation-ids-hash-table
+ (list->vector unfiltered-derivations))
+
+ (let ((derivations
+ ;; Do this while holding the PostgreSQL connection to
+ ;; avoid conflicts with other fibers
+ (list->vector
+ (delete-duplicates
+ (filter-map (lambda (derivation)
+ (if (hash-ref derivation-ids-hash-table
+ (derivation-file-name
+ derivation))
+ #f
+ derivation))
+ unfiltered-derivations)))))
+ (if (= 0 (vector-length derivations))
+ (values #() #())
+ (begin
+ (simple-format
+ (current-error-port)
+ "insert-missing-derivations: inserting ~A derivations (~A)\n"
+ (vector-length derivations)
+ log-tag)
+ (let ((derivation-ids
+ (insert-into-derivations conn derivations)))
+
+ ;; Do this while holding the connection so that other
+ ;; fibers don't also try inserting the same derivations
+ (with-time-logging
+ (string-append "insert-missing-derivations: updating hash table (" log-tag ")")
+ (vector-for-each (lambda (_ derivation derivation-id)
+ (hash-set! derivation-ids-hash-table
+ (derivation-file-name derivation)
+ derivation-id))
+ derivations
+ derivation-ids))
+
+ (simple-format
+ (current-error-port)
+ "insert-missing-derivations: finished inserting ~A derivations (~A)\n"
+ (vector-length derivations)
+ log-tag)
+
+ (values derivations
+ derivation-ids)))))))
+
+ (define (insert-input-derivations derivations)
+ (with-time-logging
+ (string-append
+ "insert-missing-derivations: ensure-input-derivations-exist ("
+ log-tag ")")
+ (let ((input-derivations
+ (vector-fold
+ (lambda (_ result drv)
+ (append! (map derivation-input-derivation
+ (derivation-inputs drv))
+ result))
+ '()
+ derivations)))
+ (unless (null? input-derivations)
+ (let loop ((chunk '())
+ (count 0)
+ (rest input-derivations))
+ (if (null? rest)
+ (unless (null? chunk)
+ (insert-missing-derivations
+ postgresql-connection-pool
+ call-with-utility-thread
+ derivation-ids-hash-table
+ chunk
+ #:log-tag log-tag))
+ (if (= count 1000)
+ (begin
+ (simple-format #t "debug: inserting ~A input derivations\n"
+ count)
+ (insert-missing-derivations
+ postgresql-connection-pool
+ call-with-utility-thread
+ derivation-ids-hash-table
+ chunk
+ #:log-tag log-tag)
+ (loop '()
+ 0
+ rest))
+ (let ((drv (car rest)))
+ (if (hash-ref derivation-ids-hash-table
+ (derivation-file-name
+ drv))
+ (loop chunk
+ count
+ (cdr rest))
+ (loop (cons drv chunk)
+ (+ 1 count)
+ (cdr rest)))))))))))
+
+ (let ((derivations
+ derivation-ids
+ (insert-derivations)))
+
+ (unless (= 0 (vector-length derivations))
+ (fibers-parallel
+ (derivations-insert-sources postgresql-connection-pool
+ call-with-utility-thread
+ derivations
+ derivation-ids
+ #:log-tag log-tag)
+ (with-time-logging
+ (string-append "insert-missing-derivations: inserting outputs ("
+ log-tag ")")
+ (with-resource-from-pool postgresql-connection-pool conn
+ (vector-for-each
+ (lambda (_ derivation-id derivation)
+ (insert-derivation-outputs conn
+ derivation-id
+ (derivation-outputs derivation)))
+ derivation-ids
+ derivations)))
+ (insert-input-derivations derivations))
+
+ (simple-format
+ (current-error-port)
+ "debug: insert-missing-derivations: done parallel (~A)\n" log-tag)
+ (retry-on-missing-derivation-output
+ (lambda ()
+ (with-resource-from-pool postgresql-connection-pool conn
+ (with-time-logging
+ (simple-format
+ #f "insert-missing-derivations: inserting inputs for ~A derivations (~A)"
+ (vector-length derivations)
+ log-tag)
+ (insert-derivation-inputs conn
+ derivation-ids
+ derivations))))
+ #:on-exception
+ (lambda ()
+ ;; If this has happened because derivations have been removed, it
+ ;; might be necessary to insert them in the database where they
+ ;; previously existed. Clear the hash table while having the
+ ;; PostgreSQL connection to avoid issues with it being used at the
+ ;; same time.
+ (with-resource-from-pool postgresql-connection-pool conn
+ (hash-clear! derivation-ids-hash-table))
+ (insert-input-derivations derivations))))))
+
(define (fix-derivation file-name)
(define (derivation-missing-inputs? conn drv-id)
(let ((inputs (select-derivation-inputs-by-derivation-id
@@ -1620,23 +1371,37 @@
(match (select-derivation-by-file-name conn (derivation-file-name drv))
((drv-id rest ...)
- (when (or (and (derivation-missing-sources? conn drv-id)
- (not (null? (derivation-sources drv))))
- (and (derivation-missing-inputs? conn drv-id)
- (not (null? (derivation-inputs drv)))))
+ (when (and (derivation-missing-sources? conn drv-id)
+ (not (null? (derivation-sources drv))))
(with-postgresql-transaction
conn
(lambda (conn)
- (let ((table-manager-coordinator
- (get-table-manager-coordinator
- postgresql-connection-pool)))
- (insert-derivations-with-table-managers
- table-manager-coordinator
- call-with-utility-thread
- (vector drv)
- #:repair? #t)
- (destroy-table-manager-coordinator
- table-manager-coordinator)))))))
+ (derivations-insert-sources postgresql-connection-pool
+ call-with-utility-thread
+ (vector drv)
+ (vector drv-id)))))
+
+ (when (and (derivation-missing-inputs? conn drv-id)
+ (not (null? (derivation-inputs drv))))
+ (with-postgresql-transaction
+ conn
+ (lambda (conn)
+ (let ((input-derivations
+ (map derivation-input-derivation
+ (derivation-inputs drv))))
+ (unless (null? input-derivations)
+ ;; Ensure all the input derivations exist
+ (chunk-for-each!
+ (lambda (chunk)
+ (insert-missing-derivations
+ postgresql-connection-pool
+ call-with-utility-thread
+ derivation-ids-hash-table
+ chunk))
+ 1000
+ input-derivations)))))
+
+ (fix-derivation-inputs conn drv))))
(destroy-resource-pool postgresql-connection-pool)))))))
#:unwind? #t))
@@ -2017,378 +1782,116 @@ WHERE builder != 'builtin:download'
(for-each fix-derivation
broken-derivations))))
-(define (flatten-derivation-graph table-manager-coordinator
- derivations)
+(define (flatten-derivation-graph derivations
+ derivation-ids-hash-table)
(define seen-hash-table
(make-hash-table))
- (define derivations-table-manager
- (fetch-table-manager table-manager-coordinator "derivations"))
-
- (define derivation-outputs-table-manager
- (fetch-table-manager table-manager-coordinator "derivation_outputs"))
-
- (define (add-inputs-recursively result derivation)
+ (define (flatten-inputs derivation result)
(fold
(lambda (input result)
(let ((drv (derivation-input-derivation input)))
- (if (or (hash-ref seen-hash-table drv)
- (let ((derivation-id
- (table-manager-id-for-key
- derivations-table-manager
- (derivation-file-name drv))))
- (and derivation-id
- (every
- (lambda (name)
- (table-manager-id-for-key
- derivation-outputs-table-manager
- (vector derivation-id
- name)))
- (derivation-input-sub-derivations input)))))
+ (if (or (hash-ref derivation-ids-hash-table
+ (derivation-file-name drv))
+ (hash-ref seen-hash-table
+ drv))
result
(begin
(hash-set! seen-hash-table drv #t)
(cons drv
- (add-inputs-recursively result drv))))))
+ (flatten-inputs drv result))))))
result
(derivation-inputs derivation)))
(reverse!
- (vector-fold
- (lambda (_ result derivation)
- (if derivation
- (cons derivation
- (add-inputs-recursively result derivation))
- result))
+ (fold
+ (lambda (derivation result)
+ (let ((flat-inputs
+ (flatten-inputs derivation
+ result)))
+ (cons derivation
+ flat-inputs)))
'()
derivations)))
-(define* (insert-derivations-with-table-managers table-manager-coordinator
- call-with-utility-thread
- derivations
- #:key repair?
- store-items-promise)
- (define (extract-vector-columns vecs)
- (let ((result (make-vector (vector-length (first vecs)))))
- (apply vector-map!
- (lambda (i . vals)
- (list->vector (cdr vals)))
- (cons result vecs))
- (apply values (vector->list result))))
+(define* (derivation-file-names->derivation-ids postgresql-connection-pool
+ call-with-utility-thread
+ read-derivations/serialised
+ derivation-ids-hash-table
+ derivation-file-names
+ #:key (log-tag "unspecified"))
+ (define derivations-count
+ (vector-length derivation-file-names))
- (define (vector-zip . vecs)
- (let ((result (make-vector (vector-length (first vecs)))))
- (apply vector-map!
- (lambda (i . vals)
- (list->vector (cdr vals)))
- (cons result vecs))
- result))
+ (if (= 0 derivations-count)
+ #()
+ (begin
+ (with-resource-from-pool postgresql-connection-pool conn
+ (update-derivation-ids-hash-table!
+ conn
+ derivation-ids-hash-table
+ derivation-file-names))
- (define (insert-derivation-outputs derivations derivation-ids)
- (let* ((derivation-output-details-counts
- (make-vector
- (vector-length derivations)))
- (derivations-output-details-derivation-ids
- derivations-output-details-names
- derivations-output-details
- (with-delay-logging "prepare derivations vectors"
- (extract-vector-columns
- (vector-fold-right
- (lambda (index result derivation derivation-id)
- (vector-set! derivation-output-details-counts
- index
- (length (derivation-outputs derivation)))
- (fold
- (lambda (name-and-output result)
- (match name-and-output
- ((name . ($ path hash-algo
- hash recursive?))
- (cons
- (vector
- derivation-id
- name
- (vector path
- (or (and=> hash-algo symbol->string)
- NULL)
- (or (and=> hash bytevector->base16-string)
- NULL)
- recursive?))
- result))))
- result
- (derivation-outputs derivation)))
- '()
- derivations
- derivation-ids))))
- (derivation-output-details-ids
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "derivation_output_details")
- derivations-output-details)))
+ (let ((missing-derivation-filenames
+ (deduplicate-strings
+ (vector-fold
+ (lambda (_ result derivation-file-name)
+ (if (not derivation-file-name)
+ result
+ (if (hash-ref derivation-ids-hash-table
+ derivation-file-name)
+ result
+ (cons derivation-file-name result))))
+ '()
+ derivation-file-names))))
+ (simple-format
+ #t "debug: derivation-file-names->derivation-ids: processing ~A missing derivations (~A)\n"
+ (length missing-derivation-filenames)
+ log-tag)
- (fibers-parallel
- (let ((derivation-output-detail-sets-ids
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "derivation_output_details_sets")
- (with-delay-logging "prepare grouped derivation outputs vectors"
- (group-ids-by-counts-vector
- derivation-output-details-ids
- derivation-output-details-counts)))))
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "derivations_by_output_details_set")
- (vector-map
- (lambda (_ derivation-id derivation-output-detail-set-id)
- (vector derivation-id
- derivation-output-detail-set-id))
- derivation-ids
- derivation-output-detail-sets-ids)))
+ (let ((chunk-counter 0))
+ (chunk-for-each!
+ (lambda (missing-derivation-file-names-chunk)
+ (simple-format
+ #t "debug: derivation-file-names->derivation-ids: processing chunk ~A (~A)\n"
+ chunk-counter
+ log-tag)
+ (let* ((missing-derivations-chunk
+ (read-derivations/serialised
+ missing-derivation-file-names-chunk))
+ (flat-missing-derivations
+ (with-time-logging "flattening missing derivations"
+ (flatten-derivation-graph
+ missing-derivations-chunk
+ derivation-ids-hash-table))))
+ (simple-format
+ #t "debug: derivation-file-names->derivation-ids: processing ~A flat missing derivations (~A)\n"
+ (length flat-missing-derivations)
+ log-tag)
+ (set! chunk-counter (+ 1 chunk-counter))
+ (insert-missing-derivations postgresql-connection-pool
+ call-with-utility-thread
+ derivation-ids-hash-table
+ missing-derivations-chunk
+ #:log-tag log-tag)))
+ 1000
+ missing-derivation-filenames))
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "derivation_outputs")
- (with-delay-logging "prepare zipped derivations vectors"
- (vector-zip derivations-output-details-derivation-ids
- derivations-output-details-names
- derivation-output-details-ids)))))
+ (let ((all-ids
+ (vector-map
+ (lambda (_ derivation-file-name)
+ (if derivation-file-name
+ (or (hash-ref derivation-ids-hash-table
+ derivation-file-name)
+ (error
+ (simple-format #f "missing derivation id (~A)"
+ derivation-file-name)))
+ #f))
+ derivation-file-names)))
- *unspecified*)
+ all-ids)))))
- (define (insert-derivation-inputs derivations derivation-ids)
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "derivation_inputs")
- (with-delay-logging "prepare derivation-inputs vectors"
- (list->vector
- (vector-fold
- (lambda (_ result derivation derivation-id)
- (fold
- (lambda (input result)
- (let* ((input-derivation
- (derivation-input-derivation input))
- (input-derivation-filename
- (derivation-file-name
- input-derivation))
- (input-derivation-id
- (table-manager-lookup-id-or-placeholder
- (fetch-table-manager table-manager-coordinator
- "derivations")
- input-derivation-filename)))
- (fold
- (lambda (name result)
- (let ((derivation-output-id
- (table-manager-lookup-id-or-placeholder
- (fetch-table-manager table-manager-coordinator
- "derivation_outputs")
- (vector input-derivation-id
- name))))
- (cons (vector derivation-id
- derivation-output-id)
- result)))
- result
- (derivation-input-sub-derivations input))))
- result
- (derivation-inputs derivation)))
- '()
- derivations
- derivation-ids)))))
-
- (define (get-source-file-details source)
- (define (read-source)
- (call-with-values
- (lambda ()
- (open-bytevector-output-port))
- (lambda (port get-bytevector)
- (unless (file-exists? source)
- (raise-exception
- (make-missing-store-item-error
- source)))
- (write-file source port)
- (let ((res (get-bytevector)))
- (close-port port) ; maybe reduces memory?
- res))))
-
- (let* ((nar-bytevector
- (if store-items-promise
- (retry-on-missing-store-item
- read-source
- #:on-exception
- (lambda ()
- (simple-format #t "debug: missing store item ~A, retrying\n"
- source)
- (fibers-promise-reset store-items-promise)
- (fibers-force store-items-promise)))
- (read-source)))
- (compressed-nar-bytevector
- (call-with-values
- (lambda ()
- (open-bytevector-output-port))
- (lambda (port get-bytevector)
- (call-with-lzip-output-port port
- (lambda (port)
- (put-bytevector port nar-bytevector))
- #:level 9)
- (let ((res (get-bytevector)))
- (close-port port) ; maybe reduces memory?
- res))))
- (hash
- (bytevector->nix-base32-string
- (sha256 nar-bytevector)))
- (uncompressed-size
- (bytevector-length nar-bytevector)))
- `((hash . ,hash)
- (uncompressed-size . ,uncompressed-size)
- (data
- . ,(string-append
- "\\x"
- (bytevector->base16-string
- compressed-nar-bytevector))))))
-
- (define (insert-derivation-sources derivations derivation-ids)
- (let* ((derivations-index-and-source
- (list->vector
- (vector-fold
- (lambda (index result derivation derivation-id)
- (fold
- (lambda (source result)
- (cons (cons index source)
- result))
- result
- (derivation-sources derivation)))
- '()
- derivations
- derivation-ids)))
- (derivation-source-file-ids
- new-derivation-source-files?-vector
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "derivation_source_files")
- (vector-map
- (lambda (_ pair)
- (vector (cdr pair)))
- derivations-index-and-source))))
-
- (fibers-parallel
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "derivation_sources")
- (vector-map
- (lambda (_ index-and-source derivation-source-file-id)
- (vector (vector-ref derivation-ids
- (car index-and-source))
- derivation-source-file-id))
- derivations-index-and-source
- derivation-source-file-ids))
-
- (let ((new-derivations-index-and-source
- new-derivation-source-file-ids
- (if repair?
- (values derivations-index-and-source
- derivation-source-file-ids)
- (filter-vectors-only-new
- new-derivation-source-files?-vector
- derivations-index-and-source
- derivation-source-file-ids))))
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "derivation_source_file_nars")
- (vector-map
- (lambda (_ index-and-source derivation-source-file-id)
- (define source
- (cdr index-and-source))
-
- (define promise
- (fibers-delay
- (lambda ()
- (call-with-utility-thread
- (lambda ()
- (get-source-file-details source))))))
-
- (vector derivation-source-file-id
- "lzip"
- "sha256"
- (make-table-manager-thunk-placeholder
- (lambda ()
- (assq-ref (fibers-force promise)
- 'hash)))
- (make-table-manager-thunk-placeholder
- (lambda ()
- (assq-ref (fibers-force promise)
- 'uncompressed-size)))
- (make-table-manager-thunk-placeholder
- (lambda ()
- (assq-ref (fibers-force promise)
- 'data)))))
- new-derivations-index-and-source
- new-derivation-source-file-ids))))))
-
- (define (add-derivations-rows derivations)
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "derivations")
- (vector-map
- (lambda (_ derivation)
- (match derivation
- (($ outputs inputs sources
- system builder args env-vars file-name)
- (vector file-name
- builder
- (cons "varchar[]"
- (list->vector args))
- (cons "varchar[][]"
- (list->vector
- (map (match-lambda
- ((key . value)
- (vector key value)))
- env-vars)))
- (table-manager-add-row
- (fetch-table-manager table-manager-coordinator
- "systems")
- (vector system))))))
- derivations)))
-
- (let ((flat-derivations
- (with-delay-logging "flatten derivation graph"
- (list->vector
- (flatten-derivation-graph table-manager-coordinator
- derivations)))))
- (unless (= 0 (vector-length flat-derivations))
- (let* ((flat-derivations-ids
- flat-derivations-new?-vector
- (add-derivations-rows flat-derivations))
-
- (new-derivations
- new-derivation-ids
- (if repair?
- (values flat-derivations
- flat-derivations-ids)
- (filter-vectors-only-new
- flat-derivations-new?-vector
- flat-derivations
- flat-derivations-ids))))
-
- (unless (= 0 (vector-length new-derivations))
- (fibers-parallel
- (insert-derivation-sources new-derivations
- new-derivation-ids)
- (begin
- ;; Outputs then inputs, so that all outputs for this chunk are
- ;; available when inserting inputs. Insert outputs for all
- ;; derivations, not just new ones, since that'll ensure all
- ;; output information is available when inserting inputs.
- (insert-derivation-outputs flat-derivations
- flat-derivations-ids)
- (insert-derivation-inputs new-derivations
- new-derivation-ids)))))))
-
- (vector-map
- (lambda (_ derivation)
- (if derivation
- (table-manager-lookup-id-or-placeholder
- (fetch-table-manager table-manager-coordinator "derivations")
- (derivation-file-name derivation))
- #f))
- derivations))
+(prevent-inlining-for-tests derivation-file-names->derivation-ids)
(define guix-store-path
(let ((store-path #f))
@@ -2755,9 +2258,6 @@ WHERE builder != 'builtin:download'
(prevent-inlining-for-tests channel-derivations-by-system->guix-store-item)
(define (glibc-locales-for-guix-store-path store store-path)
- (unless (valid-path? store store-path)
- (raise-exception
- (make-missing-store-item-error store-path)))
(let ((inf (if (defined?
'open-inferior/container
(resolve-module '(guix inferior)))
@@ -2987,14 +2487,10 @@ WHERE builder != 'builtin:download'
*unspecified*)
-(define* (extract-information-from postgresql-connection-pool
- inf-and-store-pool
- table-manager-coordinator
- guix-revision-id-promise
+(define* (extract-information-from db-conn guix-revision-id-promise
commit
guix-source store-item
guix-derivation
- channel-for-commit
call-with-utility-thread
read-derivations/serialised
#:key skip-system-tests?
@@ -3003,8 +2499,83 @@ WHERE builder != 'builtin:download'
ignore-systems ignore-targets
inferior-memory-limit)
+ (define guix-locpath
+ ;; Augment the GUIX_LOCPATH to include glibc-locales from
+ ;; the Guix at store-path, this should mean that the
+ ;; inferior Guix works, even if it's build using a different
+ ;; glibc version
+ (string-append
+ (with-store-connection
+ (lambda (store)
+ (glibc-locales-for-guix-store-path store store-item)))
+ "/lib/locale"
+ ":" (getenv "GUIX_LOCPATH")))
+
+ (define inf-and-store-pool
+ (make-resource-pool
+ (lambda ()
+ (let* ((inferior-store (open-store-connection)))
+ (unless (valid-path? inferior-store store-item)
+ (simple-format #t "warning: store item missing (~A)\n"
+ store-item)
+ (unless (valid-path? inferior-store guix-derivation)
+ (simple-format #t "warning: attempting to substitute guix derivation (~A)\n"
+ guix-derivation)
+ ;; Wait until the derivations are in the database
+ (fibers-force guix-revision-id-promise)
+ (ensure-path inferior-store guix-derivation))
+ (simple-format #t "warning: building (~A)\n"
+ guix-derivation)
+ (build-derivations inferior-store
+ (list (read-derivation-from-file
+ guix-derivation))))
+ ;; Use this more to keep the store-path alive so long as there's a
+ ;; inferior operating
+ (add-temp-root inferior-store store-item)
+
+ (let ((inferior (start-inferior-for-data-extration
+ inferior-store
+ store-item
+ guix-locpath
+ extra-inferior-environment-variables)))
+ (ensure-non-blocking-store-connection inferior-store)
+ (make-inferior-non-blocking! inferior)
+ (simple-format #t "debug: started new inferior and store connection\n")
+
+ (cons inferior inferior-store))))
+ parallelism
+ #:min-size 0
+ #:idle-seconds 20
+ #:name "inferior"
+ #:destructor
+ (match-lambda
+ ((inferior . store)
+ (simple-format
+ #t "debug: closing inferior and associated store connection\n")
+
+ (close-connection store)
+ (close-inferior inferior)))))
+
+ (define postgresql-connection-pool
+ (make-resource-pool
+ (lambda ()
+ (with-time-logging
+ "waiting for guix-revision-id"
+ ;; This uses the transaction lock, so wait until the transaction has
+ ;; committed
+ (fibers-force guix-revision-id-promise))
+ (with-time-logging
+ "extract information, acquiring advisory transaction lock: load-new-guix-revision-inserts"
+ ;; Wait until this is the only transaction inserting data, to
+ ;; avoid any concurrency issues
+ (obtain-advisory-transaction-lock db-conn
+ 'load-new-guix-revision-inserts))
+ db-conn)
+ 1
+ #:name "postgres"))
+
(define package-ids-promise
- (fibers-delay/eager
+ (fibers-delay
(lambda ()
(let ((packages-data
(call-with-inferior
@@ -3021,9 +2592,8 @@ WHERE builder != 'builtin:download'
packages
pkg-to-replacement-hash-table))))
#:memory-limit inferior-memory-limit)))
- (insert-packages postgresql-connection-pool
- table-manager-coordinator
- packages-data)))))
+ (with-resource-from-pool postgresql-connection-pool conn
+ (insert-packages conn packages-data))))))
(define (extract-and-store-lint-checkers-and-warnings)
(define inferior-lint-checkers-data
@@ -3036,156 +2606,60 @@ WHERE builder != 'builtin:download'
(when inferior-lint-checkers-data
(fibers-let ((lint-checker-ids
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "lint_checkers")
- (vector-map
- (lambda (_ lint-checker-details)
- (match lint-checker-details
- ((name network-dependent descriptions-by-locale)
- (vector
- (symbol->string name)
- network-dependent
- (table-manager-add-row
- (fetch-table-manager table-manager-coordinator
- "lint_checker_description_sets")
- (vector
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "lint_checker_descriptions")
- descriptions-by-locale)))))))
- inferior-lint-checkers-data)))
- (lint-warnings-data
- (fibers-batch-map
- (match-lambda
- ((checker-name network-dependent? _)
- (and (and (not network-dependent?)
- ;; Running the derivation linter is
- ;; currently infeasible
- (not (eq? checker-name 'derivation)))
- (begin
- (call-with-inferior
- inf-and-store-pool
- (lambda (inferior inferior-store)
- (inferior-lint-warnings inferior
- inferior-store
- checker-name))
- #:memory-limit inferior-memory-limit)))))
- 20 ; TODO
- inferior-lint-checkers-data)))
+ (with-resource-from-pool postgresql-connection-pool conn
+ (lint-checkers->lint-checker-ids
+ conn
+ (vector-map
+ (match-lambda*
+ ((_ (name descriptions-by-locale network-dependent))
+ (list
+ name
+ network-dependent
+ (lint-checker-description-data->lint-checker-description-set-id
+ conn
+ descriptions-by-locale))))
+ inferior-lint-checkers-data))))
+ (lint-warnings-data
+ (fibers-batch-map
+ (match-lambda
+ ((checker-name _ network-dependent?)
+ (and (and (not network-dependent?)
+ ;; Running the derivation linter is
+ ;; currently infeasible
+ (not (eq? checker-name 'derivation)))
+ (begin
+ (call-with-inferior
+ inf-and-store-pool
+ (lambda (inferior inferior-store)
+ (inferior-lint-warnings inferior
+ inferior-store
+ checker-name))
+ #:memory-limit inferior-memory-limit)))))
+ 20 ; TODO
+ inferior-lint-checkers-data)))
- (close-table-manager table-manager-coordinator
- "lint_checker_descriptions")
- (close-table-manager table-manager-coordinator
- "lint_checker_description_sets")
- (close-table-manager table-manager-coordinator
- "lint_checkers")
+ (let ((package-ids (fibers-force package-ids-promise)))
+ (with-resource-from-pool postgresql-connection-pool conn
+ (insert-guix-revision-lint-checkers
+ conn
+ (fibers-force guix-revision-id-promise)
+ lint-checker-ids)
- (let ((guix-revision-id
- (fibers-force guix-revision-id-promise)))
-
- (table-manager-add-raw-rows
- (fetch-table-manager table-manager-coordinator
- "guix_revision_lint_checkers")
- (vector-map
- (lambda (_ lint-checker-id)
- (vector lint-checker-id
- guix-revision-id))
- lint-checker-ids)))
-
- (let* ((package-ids (fibers-force package-ids-promise))
- (lint-warning-ids
- (with-time-logging "inserting lint warnings"
- (vector-fold
- (lambda (_ result lint-checker-id warnings-per-package)
- (if warnings-per-package
- (vector-fold
- (lambda (_ result package-id warnings)
- (if (= 0 (vector-length warnings))
- result
- (let* ((lint-warning-ids-list
- (vector->list
- (table-manager-add-rows
- (fetch-table-manager
- table-manager-coordinator
- "lint_warnings")
- (vector-map
- (lambda (_ data)
- (match data
- ((location-data messages-by-locale)
- (vector
- lint-checker-id
- package-id
- (table-manager-add-row
- (fetch-table-manager
- table-manager-coordinator
- "locations")
- location-data)
- (table-manager-add-row
- (fetch-table-manager table-manager-coordinator
- "lint_warning_message_sets")
- (vector
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "lint_warning_messages")
- messages-by-locale)))))))
- warnings))))
- (deduplicated-new-lint-warning-ids
- (pair-fold
- (lambda (pair result)
- (if (null? (cdr pair))
- (cons (first pair) result)
- (let ((a (first pair))
- (b (second pair)))
- (if (eq? a b)
- (begin
- (simple-format #t "duplicate lint warning ~A\n"
- a)
- result)
- (cons a result)))))
- '()
- (filter table-manager-placeholder?
- lint-warning-ids-list))))
- (append!
- ;; TODO Sort properly so pair-fold above
- ;; works as intended
- (delete-duplicates
- deduplicated-new-lint-warning-ids
- eq?)
- (delete-duplicates/sort!
- (filter integer? lint-warning-ids-list)
- <
- =)
- result))))
- result
- package-ids
- warnings-per-package)
- result))
- '()
- lint-checker-ids
- lint-warnings-data))))
-
- (close-table-manager table-manager-coordinator
- "lint_warnings")
- (close-table-manager table-manager-coordinator
- "lint_warning_messages")
- (close-table-manager table-manager-coordinator
- "lint_warning_message_sets")
-
- (let ((guix-revision-id
- (fibers-force guix-revision-id-promise)))
-
- (table-manager-add-raw-rows
- (fetch-table-manager table-manager-coordinator "guix_revision_lint_warnings")
- (list->vector
- (map
- (lambda (lint-warning-id)
- (vector lint-warning-id
- guix-revision-id))
- lint-warning-ids))))))
-
- (close-table-manager table-manager-coordinator
- "guix_revision_lint_warnings")))
+ (let ((lint-warning-id-vectors
+ (with-time-logging "inserting lint warnings"
+ (insert-lint-warnings
+ conn
+ package-ids
+ lint-checker-ids
+ lint-warnings-data))))
+ (with-time-logging "inserting guix revision lint warnings"
+ (for-each
+ (lambda (lint-warning-ids)
+ (insert-guix-revision-lint-warnings
+ conn
+ (fibers-force guix-revision-id-promise)
+ lint-warning-ids))
+ lint-warning-id-vectors))))))))
(define (extract-and-store-package-derivations)
(define packages-count
@@ -3197,162 +2671,95 @@ WHERE builder != 'builtin:download'
(inferior-eval '(vector-length gds-inferior-packages) inferior))
#:memory-limit inferior-memory-limit))
- (define chunk-size 200)
+ (define chunk-size 1000)
(define get-derivations/parallelism-limiter
(make-parallelism-limiter parallelism))
- (define insert-derivations/parallelism-limiter
- (make-parallelism-limiter parallelism))
(define (get-derivations system target)
- (define (make-chunk-promise chunk-promises
- index chunk-count
- chunk
- store-items-promise)
- (fibers-delay/eager
- (lambda ()
- (with-parallelism-limiter
- insert-derivations/parallelism-limiter
- (let ((chunk-derivations
- (with-time-logging
- (simple-format
- #f "read-derivations/serialised (~A ~A, chunk ~A/~A)"
- system target index chunk-count)
- (read-derivations/serialised chunk))))
-
- (with-time-logging
- (simple-format
- #f "insert-derivations-with-table-managers (~A ~A, chunk ~A/~A)"
- system target index chunk-count)
- (insert-derivations-with-table-managers
- table-manager-coordinator
- call-with-utility-thread
- chunk-derivations
- #:store-items-promise
- store-items-promise)))))))
-
- (define (get-chunk-promises)
- (define indexes-and-counts
- (append
- (map
- (lambda (start-index)
- (cons start-index chunk-size))
- (iota (quotient packages-count chunk-size)
- 0
- chunk-size))
- (let ((last-chunk-size
- (modulo packages-count chunk-size)))
- (if (= 0 last-chunk-size)
- '()
- (list (cons (* (quotient packages-count chunk-size)
- chunk-size)
- last-chunk-size))))))
-
- (define chunk-count
- (length indexes-and-counts))
-
- (define (get-chunk start-index count)
- (call-with-inferior
- inf-and-store-pool
- (lambda (inferior inferior-store)
- (ensure-gds-inferior-packages-defined! inferior)
-
- (let ((result
- (inferior-package-derivations
- inferior-store
- inferior
- system
- target
- start-index
- count)))
-
- ;; When last chunk?
- (when (< count chunk-size)
- (inferior-cleanup inferior))
-
- result))
- #:memory-limit inferior-memory-limit))
-
- (let loop ((indexes-and-counts indexes-and-counts)
- (chunk-promises '()))
- (if (null? indexes-and-counts)
- (reverse chunk-promises)
- (match (car indexes-and-counts)
- ((start-index . count)
- (let* ((chunk
- (get-chunk start-index count))
- (chunk-promise
- (make-chunk-promise
- chunk-promises
- (/ start-index chunk-size)
- chunk-count
- chunk
- (fibers-delay
- (lambda ()
- (get-chunk start-index count))))))
- (loop (cdr indexes-and-counts)
- (cons chunk-promise
- chunk-promises))))))))
-
- ;; Limit concurrency here to keep focused on specific systems
- ;; until they've been fully processed
+ ;; Limit concurrency here to keep focused on specific systems until
+ ;; they've been fully processed
(with-parallelism-limiter
get-derivations/parallelism-limiter
- (let ((chunk-promises
- (with-time-logging
- (simple-format #f "getting derivations for ~A"
- (cons system target))
- (get-chunk-promises)))
- (derivations-vector (make-vector packages-count)))
- (for-each
- (lambda (index chunk-promise)
- (vector-copy! derivations-vector
- (* index chunk-size)
- (fibers-force chunk-promise)))
- (iota (length chunk-promises))
- chunk-promises)
+ (let ((derivations-vector (make-vector packages-count)))
+ (with-time-logging
+ (simple-format #f "getting derivations for ~A"
+ (cons system target))
+ (let loop ((start-index 0))
+ (let* ((last-chunk?
+ (>= (+ start-index chunk-size) packages-count))
+ (count
+ (if last-chunk?
+ (- packages-count start-index)
+ chunk-size))
+ (chunk
+ (call-with-inferior
+ inf-and-store-pool
+ (lambda (inferior inferior-store)
+ (ensure-gds-inferior-packages-defined! inferior)
+
+ (let ((result
+ (inferior-package-derivations
+ inferior-store
+ inferior
+ system
+ target
+ start-index
+ count)))
+
+ (when last-chunk?
+ (inferior-cleanup inferior))
+
+ result))
+ #:memory-limit inferior-memory-limit)))
+ (vector-copy! derivations-vector
+ start-index
+ chunk)
+ (unless last-chunk?
+ (loop (+ start-index chunk-size))))))
derivations-vector)))
+ (define derivation-file-names->derivation-ids/parallelism-limiter
+ (make-parallelism-limiter 2))
(define (process-system-and-target system target)
(with-time-logging
(simple-format #f "processing derivations for ~A" (cons system target))
- (let* ((derivation-ids
- (get-derivations system target))
+ (let* ((derivations-vector (get-derivations system target))
+ (derivation-ids
+ (with-parallelism-limiter
+ derivation-file-names->derivation-ids/parallelism-limiter
+ (with-time-logging
+ (simple-format #f "derivation-file-names->derivation-ids (~A ~A)"
+ system target)
+ (derivation-file-names->derivation-ids
+ postgresql-connection-pool
+ call-with-utility-thread
+ read-derivations/serialised
+ (make-hash-table)
+ derivations-vector
+ #:log-tag (simple-format #f "~A:~A" system target)))))
(guix-revision-id
(fibers-force guix-revision-id-promise))
- (package-ids
- (fibers-force package-ids-promise))
- (system-id
- (table-manager-add-row
- (fetch-table-manager table-manager-coordinator "systems")
- (vector system)))
+ (package-ids (fibers-force package-ids-promise))
(package-derivation-ids
- (with-time-logging
- (simple-format #f "insert-package-derivations (~A ~A)"
- system target)
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator "package_derivations")
- (list->vector
- (vector-fold-right
- (lambda (_ result package-id derivation-id)
- (if derivation-id
- (cons
- (vector package-id
- derivation-id
- (or target "")
- system-id)
- result)
- result))
- '()
- package-ids
- derivation-ids))))))
-
- (table-manager-add-raw-rows
- (fetch-table-manager table-manager-coordinator "guix_revision_package_derivations")
- (vector-map
- (lambda (_ package-derivation-id)
- (vector guix-revision-id
- package-derivation-id))
- package-derivation-ids))))
+ (with-resource-from-pool postgresql-connection-pool conn
+ (with-time-logging
+ (simple-format #f "insert-package-derivations (~A ~A)"
+ system target)
+ (insert-package-derivations conn
+ system
+ (or target "")
+ package-ids
+ derivation-ids)))))
+ (chunk-for-each!
+ (lambda (package-derivation-ids-chunk)
+ (with-resource-from-pool postgresql-connection-pool conn
+ (insert-guix-revision-package-derivations
+ conn
+ guix-revision-id
+ package-derivation-ids-chunk)))
+ 2000
+ ;; TODO Chunk more efficiently
+ (vector->list package-derivation-ids))))
'finished)
@@ -3360,14 +2767,9 @@ WHERE builder != 'builtin:download'
(fibers-map-with-progress
(match-lambda
((system . target)
- (with-exception-handler
- (lambda (exn)
- (print-backtrace-and-exception/knots exn)
- (raise-exception exn))
- (lambda ()
- (retry-on-missing-store-item
- (lambda ()
- (process-system-and-target system target)))))))
+ (retry-on-missing-store-item
+ (lambda ()
+ (process-system-and-target system target)))))
(list
(let ((all-system-target-pairs
(call-with-inferior
@@ -3399,8 +2801,6 @@ WHERE builder != 'builtin:download'
data)))
(destroy-parallelism-limiter
get-derivations/parallelism-limiter)
- (destroy-parallelism-limiter
- insert-derivations/parallelism-limiter)
#t))
(define (extract-and-store-system-tests)
@@ -3420,90 +2820,49 @@ WHERE builder != 'builtin:download'
guix-source
commit
#:ignore-systems ignore-systems)))
- #:memory-limit inferior-memory-limit))
- (guix-revision-id
- (fibers-force guix-revision-id-promise)))
+ #:memory-limit inferior-memory-limit)))
(when data-with-derivation-file-names
- (let ((system-test-ids
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator "system_tests")
- (vector-map
- (lambda (_ details)
- (match details
- ((name
- description
- _
- location-data)
-
- (vector name
- description
- (table-manager-add-row
- (fetch-table-manager table-manager-coordinator "locations")
- location-data)))))
- data-with-derivation-file-names))))
-
- (vector-for-each
- (lambda (_ system-test-id details)
- (let* ((derivation-file-names-by-system
- (vector-ref details 2))
- (systems
- (list->vector
- (map car derivation-file-names-by-system)))
- (derivation-ids
- (insert-derivations-with-table-managers
- table-manager-coordinator
- call-with-utility-thread
- (read-derivations/serialised
- (list->vector
- (map cdr derivation-file-names-by-system))))))
- (table-manager-add-raw-rows
- (fetch-table-manager table-manager-coordinator
- "guix_revision_system_test_derivations")
- (vector-map
- (lambda (_ derivation-id system)
- (vector guix-revision-id
- system-test-id
- derivation-id
- system))
- derivation-ids
- systems))))
- system-test-ids
- data-with-derivation-file-names)))))))
-
- (define (extract-and-store-channel-news)
- (if (defined? 'channel-news-for-commit
- (resolve-module '(guix channels)))
- (with-time-logging "inserting channel news entries"
- (insert-channel-news-entries-for-guix-revision
- table-manager-coordinator
- (fibers-force guix-revision-id-promise)
- (channel-news-for-commit channel-for-commit commit)))
- (simple-format
- #t "debug: importing channel news not supported\n")))
+ (let ((data-with-derivation-ids
+ (map (match-lambda
+ ((name description derivation-file-names-by-system location-data)
+ (list name
+ description
+ (let ((systems
+ (map car derivation-file-names-by-system))
+ (derivation-ids
+ (vector->list
+ (derivation-file-names->derivation-ids
+ postgresql-connection-pool
+ call-with-utility-thread
+ read-derivations/serialised
+ (make-hash-table)
+ (list->vector
+ (map cdr derivation-file-names-by-system))
+ #:log-tag "channel-instances"))))
+ (map cons systems derivation-ids))
+ location-data)))
+ data-with-derivation-file-names)))
+ (with-resource-from-pool postgresql-connection-pool conn
+ (insert-system-tests-for-guix-revision
+ conn
+ (fibers-force guix-revision-id-promise)
+ data-with-derivation-ids))))))))
(with-time-logging
(simple-format #f "extract-information-from: ~A\n" store-item)
(fibers-parallel
- (extract-and-store-channel-news)
+ (begin
+ (fibers-force package-ids-promise)
+ #f)
(extract-and-store-package-derivations)
(retry-on-missing-store-item extract-and-store-system-tests)
(with-time-logging "extract-and-store-lint-checkers-and-warnings"
(extract-and-store-lint-checkers-and-warnings))))
- (close-table-manager table-manager-coordinator
- "systems")
- (close-table-manager table-manager-coordinator
- "derivations")
+ (destroy-resource-pool inf-and-store-pool)
+ (destroy-resource-pool postgresql-connection-pool)
- (let ((_
- new-package-metadata-ids
- (fibers-force package-ids-promise)))
- (close-table-manager table-manager-coordinator
- "derivation_source_files")
- (close-table-manager table-manager-coordinator
- "derivation_source_file_nars")
-
- new-package-metadata-ids))
+ *unspecified*)
(prevent-inlining-for-tests extract-information-from)
@@ -3519,20 +2878,28 @@ WHERE builder != 'builtin:download'
(with-postgresql-transaction
channel-instances-conn
(lambda (channel-instances-conn)
- (let* ((postgresql-connection-pool
+
+ (with-time-logging
+ "channel instances, acquiring advisory transaction lock: load-new-guix-revision-inserts"
+ ;; Wait until this is the only transaction inserting data, to avoid
+ ;; any concurrency issues
+ (obtain-advisory-transaction-lock channel-instances-conn
+ 'load-new-guix-revision-inserts))
+
+ (let* ((existing-guix-revision-id
+ (git-repository-id-and-commit->revision-id channel-instances-conn
+ git-repository-id
+ commit))
+ (guix-revision-id
+ (or existing-guix-revision-id
+ (insert-guix-revision channel-instances-conn
+ git-repository-id commit)))
+ (postgresql-connection-pool
(make-fixed-size-resource-pool
(list channel-instances-conn)
- #:name "postgres"))
- (table-manager-coordinator
- (get-table-manager-coordinator postgresql-connection-pool))
- (guix-revision-id
- new-guix-revision-id?
- (table-manager-add-row
- (fetch-table-manager table-manager-coordinator "guix_revisions")
- (vector commit
- (string->number git-repository-id)))))
+ #:name "postgres")))
- (when new-guix-revision-id?
+ (unless existing-guix-revision-id
(let* ((derivations-by-system
(filter-map
(match-lambda
@@ -3543,98 +2910,33 @@ WHERE builder != 'builtin:download'
(lambda (drv)
(cons system drv)))))
channel-derivations-by-system))
- (derivation-ids-vector
- (insert-derivations-with-table-managers
- table-manager-coordinator
- call-with-utility-thread
- (read-derivations/serialised
- (list->vector (map cdr derivations-by-system))))))
+ (derivation-ids-by-system
+ (fibers-batch-map
+ (match-lambda
+ ((system . drv)
+ (cons system
+ (vector-ref
+ (derivation-file-names->derivation-ids
+ postgresql-connection-pool
+ call-with-utility-thread
+ read-derivations/serialised
+ (make-hash-table)
+ (vector drv))
+ 0))))
+ 20 ; TODO
+ derivations-by-system)))
- (for-each
- (match-lambda*
- ((system derivation-id)
- (table-manager-add-row
- (fetch-table-manager table-manager-coordinator
- "channel_instances")
- (vector guix-revision-id
- system
- derivation-id))))
- (map car derivations-by-system)
- (vector->list derivation-ids-vector))))
+ (insert-channel-instances channel-instances-conn
+ guix-revision-id
+ derivation-ids-by-system))
+ (simple-format
+ (current-error-port)
+ "guix-data-service: saved the channel instance derivations to the database\n"))
- (with-time-logging
- "load-channel-instances destroy-table-manager-coordinator"
- (destroy-table-manager-coordinator table-manager-coordinator))
- (destroy-resource-pool postgresql-connection-pool)
-
- (simple-format
- (current-error-port)
- "guix-data-service: saved the channel instance derivations to the database\n")
-
- (resolve-table-manager-placeholder guix-revision-id)))))))
+ guix-revision-id))))))
(prevent-inlining-for-tests load-channel-instances)
-(define (insert-channel-news-entries-for-guix-revision table-manager-coordinator
- guix-revision-id
- channel-news-entries)
- (let ((channel-news-entry-ids
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator "channel_news_entries")
- (list->vector
- (map (lambda (entry)
- (vector (or (channel-news-entry-commit entry)
- NULL)
- (or (channel-news-entry-tag entry)
- NULL)))
- channel-news-entries)))))
-
- (table-manager-add-raw-rows
- (fetch-table-manager table-manager-coordinator "guix_revision_channel_news_entries")
- (vector-map
- (lambda (index channel-news-entry-id)
- (vector guix-revision-id
- channel-news-entry-id
- index))
- channel-news-entry-ids))
-
- (vector-for-each
- (lambda (_ entry channel-news-entry-id)
- (let ((text-ids
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator "channel_news_entry_text")
- (list->vector
- (map (match-lambda
- ((lang . text)
- (vector lang text)))
- (channel-news-entry-title entry))))))
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator "channel_news_entry_titles")
- (vector-map
- (lambda (_ text-id)
- (vector channel-news-entry-id
- text-id))
- text-ids)))
-
- (let ((text-ids
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator "channel_news_entry_text")
- (list->vector
- (map (match-lambda
- ((lang . text)
- (vector lang text)))
- (channel-news-entry-body entry))))))
- (table-manager-add-rows
- (fetch-table-manager table-manager-coordinator
- "channel_news_entry_bodies")
- (vector-map
- (lambda (_ text-id)
- (vector channel-news-entry-id
- text-id))
- text-ids))))
- (list->vector channel-news-entries)
- channel-news-entry-ids)))
-
(define* (load-new-guix-revision conn git-repository-id commit
#:key skip-system-tests? parallelism
extra-inferior-environment-variables
@@ -3643,26 +2945,30 @@ WHERE builder != 'builtin:download'
(define utility-thread-pool
;; Use a thread pool rather than a fixed size thread pool, since this
;; takes care of queuing waiters
- (make-thread-pool parallelism
- #:name "utility"))
+ (make-thread-pool parallelism))
(define call-with-utility-thread
(lambda (thunk)
(call-with-thread
utility-thread-pool
thunk)))
- (define (read-derivations/serialised filenames)
+ (define (read-derivations filenames)
(call-with-utility-thread
(lambda ()
- (vector-map (lambda (_ filename)
- (if (eq? #f filename)
- #f
- (if (file-exists? filename)
- (read-derivation-from-file filename)
- (raise-exception
- (make-missing-store-item-error
- filename)))))
- filenames))))
+ (map (lambda (filename)
+ (if (file-exists? filename)
+ (read-derivation-from-file filename)
+ (raise-exception
+ (make-missing-store-item-error
+ filename))))
+ filenames))))
+
+ (define read-derivations/parallelism-limiter
+ (make-parallelism-limiter 1))
+ (define (read-derivations/serialised . args)
+ (with-parallelism-limiter
+ read-derivations/parallelism-limiter
+ (apply read-derivations args)))
(let* ((git-repository-fields
(select-git-repository conn git-repository-id))
@@ -3689,7 +2995,7 @@ WHERE builder != 'builtin:download'
#:ignore-systems ignore-systems))))))
(define guix-revision-id-promise
- (fibers-delay/eager
+ (fibers-delay
(lambda ()
(parameterize
((%postgresql-in-transaction? #f))
@@ -3706,133 +3012,57 @@ WHERE builder != 'builtin:download'
(lambda ()
(fibers-promise-reset channel-derivations-by-system-promise)))))))
+ ;; Prompt getting the guix-revision-id as soon as possible
+ (spawn-fiber
+ (lambda ()
+ (with-exception-handler
+ (lambda _
+ ;; Silently handle this exception
+ #f)
+ (lambda ()
+ (fibers-force guix-revision-id-promise))
+ #:unwind? #t)))
+
(let* ((guix-source
channel-derivations-by-system
(fibers-force channel-derivations-by-system-promise))
(store-item
guix-derivation
(channel-derivations-by-system->guix-store-item
- channel-derivations-by-system))
- (postgresql-connection-pool
- (make-fixed-size-resource-pool
- (list conn)
- #:name "postgres"))
- (table-manager-coordinator
- (get-table-manager-coordinator postgresql-connection-pool))
- (glibc-locales-promise
- (fibers-delay
- (lambda ()
- (with-store-connection
- (lambda (store)
- (glibc-locales-for-guix-store-path store store-item))))))
- (inf-and-store-pool
- (make-resource-pool
- (lambda ()
- (define inferior-store (open-store-connection))
+ channel-derivations-by-system)))
- (define (ensure-store-item)
- (simple-format #t "warning: store item missing (~A)\n"
- store-item)
- (unless (valid-path? inferior-store guix-derivation)
- (simple-format #t "warning: attempting to substitute guix derivation (~A)\n"
- guix-derivation)
- ;; Wait until the derivations are in the database
- (fibers-force guix-revision-id-promise)
- (ensure-path inferior-store guix-derivation))
- (simple-format #t "warning: building (~A)\n"
- guix-derivation)
- (build-derivations inferior-store
- (list (read-derivation-from-file
- guix-derivation))))
-
- (unless (valid-path? inferior-store store-item)
- (ensure-store-item))
-
- ;; Use this more to keep the store-path alive so long as
- ;; there's a inferior operating
- (add-temp-root inferior-store store-item)
-
- (let* ((glibc-locales
- (retry-on-missing-store-item
- (lambda ()
- (let ((output
- (fibers-force glibc-locales-promise)))
- (unless (file-exists? output)
- (raise-exception
- (make-missing-store-item-error
- output)))
- output))
- #:on-exception
- (lambda ()
- (ensure-store-item)
- (fibers-promise-reset glibc-locales-promise))))
- (guix-locpath
- ;; Augment the GUIX_LOCPATH to include glibc-locales
- ;; from the Guix at store-path, this should mean that
- ;; the inferior Guix works, even if it's build using
- ;; a different glibc version
- (string-append
- glibc-locales
- "/lib/locale"
- ":" (getenv "GUIX_LOCPATH")))
- (inferior (start-inferior-for-data-extration
- inferior-store
- store-item
- guix-locpath
- extra-inferior-environment-variables)))
- (ensure-non-blocking-store-connection inferior-store)
- (make-inferior-non-blocking! inferior)
- (simple-format #t "debug: started new inferior and store connection\n")
-
- (cons inferior inferior-store)))
- parallelism
- #:min-size 0
- #:idle-seconds 20
- #:name "inferior"
- #:destructor
- (match-lambda
- ((inferior . store)
- (simple-format
- #t "debug: closing inferior and associated store connection\n")
-
- (close-connection store)
- (close-inferior inferior)))))
- (new-package-metadata-ids-list
- (extract-information-from
- postgresql-connection-pool
- inf-and-store-pool
- table-manager-coordinator
- guix-revision-id-promise
- commit guix-source store-item
- guix-derivation
- channel-for-commit
- call-with-utility-thread
- read-derivations/serialised
- #:skip-system-tests?
- skip-system-tests?
- #:extra-inferior-environment-variables
- extra-inferior-environment-variables
- #:ignore-systems ignore-systems
- #:ignore-targets ignore-targets
- #:parallelism parallelism
- #:inferior-memory-limit
- inferior-memory-limit)))
-
- (destroy-table-manager-coordinator table-manager-coordinator)
- (destroy-resource-pool inf-and-store-pool)
-
- (unless (null? new-package-metadata-ids-list)
- (with-resource-from-pool postgresql-connection-pool conn
- (with-time-logging "inserting package metadata tsvector entries"
- (insert-package-metadata-tsvector-entries
- conn
- (map resolve-table-manager-placeholder
- new-package-metadata-ids-list)))))
+ (extract-information-from conn
+ guix-revision-id-promise
+ commit guix-source store-item
+ guix-derivation
+ call-with-utility-thread
+ read-derivations/serialised
+ #:skip-system-tests?
+ skip-system-tests?
+ #:extra-inferior-environment-variables
+ extra-inferior-environment-variables
+ #:ignore-systems ignore-systems
+ #:ignore-targets ignore-targets
+ #:parallelism parallelism
+ #:inferior-memory-limit
+ inferior-memory-limit)
(let ((guix-revision-id
(fibers-force guix-revision-id-promise)))
+ (destroy-parallelism-limiter
+ read-derivations/parallelism-limiter)
+ (destroy-thread-pool
+ utility-thread-pool)
- (destroy-thread-pool utility-thread-pool)
+ (if (defined? 'channel-news-for-commit
+ (resolve-module '(guix channels)))
+ (with-time-logging "inserting channel news entries"
+ (insert-channel-news-entries-for-guix-revision
+ conn
+ guix-revision-id
+ (channel-news-for-commit channel-for-commit commit)))
+ (simple-format
+ #t "debug: importing channel news not supported\n"))
(with-time-logging "updating builds.derivation_output_details_set_id"
(update-builds-derivation-output-details-set-id
@@ -3845,8 +3075,6 @@ WHERE builder != 'builtin:download'
guix-revision-id
commit)
- (destroy-resource-pool postgresql-connection-pool)
-
(let ((stats (gc-stats)))
(format (current-error-port)
"gc-stats: time taken: ~3fs, times: ~d~%"
@@ -4305,8 +3533,7 @@ SKIP LOCKED")
(with-postgresql-connection
(simple-format #f "load-new-guix-revision ~A record failure" id)
(lambda (conn)
- (record-job-event conn id "failure")))
- (primitive-exit 1))
+ (record-job-event conn id "failure"))))
#f)
(lambda ()
(with-exception-handler
diff --git a/guix-data-service/model/channel-news.scm b/guix-data-service/model/channel-news.scm
index 5dcecd1..4bb5625 100644
--- a/guix-data-service/model/channel-news.scm
+++ b/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)
diff --git a/guix-data-service/model/license-set.scm b/guix-data-service/model/license-set.scm
new file mode 100644
index 0000000..8436875
--- /dev/null
+++ b/guix-data-service/model/license-set.scm
@@ -0,0 +1,38 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines
+;;;
+;;; 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
+;;; .
+
+(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)))
diff --git a/guix-data-service/model/license.scm b/guix-data-service/model/license.scm
new file mode 100644
index 0000000..f16634d
--- /dev/null
+++ b/guix-data-service/model/license.scm
@@ -0,0 +1,91 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines
+;;;
+;;; 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
+;;; .
+
+(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))
diff --git a/guix-data-service/model/lint-checker.scm b/guix-data-service/model/lint-checker.scm
index 0ef1ce2..4ee6521 100644
--- a/guix-data-service/model/lint-checker.scm
+++ b/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
diff --git a/guix-data-service/model/lint-warning-message.scm b/guix-data-service/model/lint-warning-message.scm
index d94bc9d..c44ba8a 100644
--- a/guix-data-service/model/lint-warning-message.scm
+++ b/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
diff --git a/guix-data-service/model/lint-warning.scm b/guix-data-service/model/lint-warning.scm
index 63b8f89..4efa186 100644
--- a/guix-data-service/model/lint-warning.scm
+++ b/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
diff --git a/guix-data-service/model/package-derivation.scm b/guix-data-service/model/package-derivation.scm
index 1a71dd5..fc7dca7 100644
--- a/guix-data-service/model/package-derivation.scm
+++ b/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
diff --git a/guix-data-service/model/package-metadata.scm b/guix-data-service/model/package-metadata.scm
index 70e6a71..91a8445 100644
--- a/guix-data-service/model/package-metadata.scm
+++ b/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,
diff --git a/guix-data-service/model/package.scm b/guix-data-service/model/package.scm
index 3812747..395cbd4 100644
--- a/guix-data-service/model/package.scm
+++ b/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)
diff --git a/guix-data-service/model/system-test.scm b/guix-data-service/model/system-test.scm
index 1f341e8..9bbc228 100644
--- a/guix-data-service/model/system-test.scm
+++ b/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)
diff --git a/guix-data-service/model/utils.scm b/guix-data-service/model/utils.scm
index 5f5b6da..c3b0cee 100644
--- a/guix-data-service/model/utils.scm
+++ b/guix-data-service/model/utils.scm
@@ -17,22 +17,10 @@
(define-module (guix-data-service model utils)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-43)
- #:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 receive)
- #:use-module (ice-9 exceptions)
- #:use-module (ice-9 textual-ports)
- #:use-module (fibers)
- #:use-module (fibers channels)
- #:use-module (fibers operations)
- #:use-module (fibers conditions)
- #:use-module (knots)
- #:use-module (knots parallelism)
- #:use-module (knots resource-pool)
#:use-module (squee)
#:use-module (guix-data-service database)
#:use-module (guix-data-service utils)
@@ -51,28 +39,7 @@
bulk-select
bulk-insert
insert-and-return-id
- prepare-insert-and-return-id
-
- call-with-false-hidden-in-vector
-
- make-table-manager-thunk-placeholder
- spawn-table-manager-fiber
- table-manager-id-for-key
- table-manager-lookup-id-or-placeholder
- table-manager-placeholder?
- resolve-table-manager-placeholder
- table-manager-add-row
- table-manager-add-rows
- table-manager-add-raw-rows
- table-manager-close
- table-manager-insert-all
- filter-vectors-only-new
- group-ids-by-counts-vector
-
- spawn-table-manager-coordinator
- fetch-table-manager
- close-table-manager
- destroy-table-manager-coordinator))
+ prepare-insert-and-return-id))
(define (char-null? c)
(char=? c #\null))
@@ -684,1575 +651,3 @@ EXECUTE " table-name "PreparedInsertSelect("
(string-join (map value->sql field-vals) ", ")
");"))
(((id)) id))))))
-
-(define (call-with-false-hidden-in-vector v proc)
- (let* ((result
- (make-vector (vector-length v) #f))
- (indexes-without-#f
- (list->vector
- (reverse!
- (vector-fold
- (lambda (index result x)
- (if x
- (cons index result)
- result))
- '()
- v))))
- (temp-v
- (vector-map
- (lambda (_ index)
- (vector-ref v index))
- indexes-without-#f))
- (response-data
- (proc temp-v)))
-
- (vector-for-each
- (lambda (_ index val)
- (vector-set! result index val))
- indexes-without-#f
- response-data)
-
- result))
-
-(define-record-type
- (make-table-manager table-name columns-and-types dependencies
- key-columns key-columns-nullable id-column
- keyplaceholder-and-row-hash-table
- key->id-hash-table raw-rows
- channel state finished-condition)
- table-manager?
- (table-name table-manager-table-name)
- (columns-and-types table-manager-columns-and-types)
- (dependencies table-manager-dependencies)
- (key-columns table-manager-key-columns)
- (key-columns-nullable table-manager-key-columns-nullable)
- (id-column table-manager-id-column)
- (keyplaceholder-and-row-hash-table
- table-manager-key->placeholder-and-row-hash-table)
- (key->id-hash-table table-manager-key->id-hash-table)
- (raw-rows table-manager-raw-rows
- set-table-manager-raw-rows!)
- (channel table-manager-channel)
- (state table-manager-state
- set-table-manager-state!)
- (finished-condition table-manager-finished-condition))
-
-(define (table-manager-id-for-key table-manager key)
- (hash-ref (table-manager-key->id-hash-table table-manager)
- key))
-
-(set-record-type-printer!
-
- (lambda (record port)
- (simple-format port "#< table-name: ~A>"
- (table-manager-table-name record))))
-
-(define-record-type
- (make-table-manager-id-placeholder table-manager key id)
- table-manager-id-placeholder?
- (table-manager table-manager-id-placeholder-table-manager)
- (key table-manager-id-placeholder-key)
- (id table-manager-id-placeholder-id
- set-table-manager-id-placeholder-id!))
-
-(define unknown-id
- (make-symbol "unknown-id"))
-
-(set-record-type-printer!
-
- (lambda (record port)
- (simple-format port "#< table: ~A key: ~A id: ~A>"
- (table-manager-table-name
- (table-manager-id-placeholder-table-manager
- record))
- (table-manager-id-placeholder-key record)
- (table-manager-id-placeholder-id record))))
-
-(define-record-type
- (make-table-manager-thunk-placeholder thunk)
- table-manager-thunk-placeholder?
- (thunk table-manager-thunk-placeholder-thunk))
-
-(define (table-manager-placeholder? val)
- (or (table-manager-id-placeholder? val)
- (table-manager-thunk-placeholder? val)))
-
-(define (table-manager-lookup-id-or-placeholder table-manager unprocessed-key)
- (define key
- (let ((key-types
- (table-manager-key-column-types table-manager)))
- (if (and (list? key-types)
- (member "sorted-integer[]" key-types))
- (vector-map
- (lambda (_ type val)
- (if (and (string? type)
- (string=? type "sorted-integer[]"))
- (sort-sorted-integer-array val)
- val))
- (list->vector key-types)
- unprocessed-key)
- unprocessed-key)))
-
- (match (hash-ref (table-manager-key->id-hash-table table-manager)
- key)
- (#f
- (match (hashx-ref key-hash
- key-assoc
- (table-manager-key->placeholder-and-row-hash-table
- table-manager)
- key)
- (#f
- (let ((reply (make-channel)))
- ;; Maybe the hash table is being resized, so ask via the channel
- (put-message (table-manager-channel table-manager)
- (list 'lookup-id-or-placeholder
- key
- reply))
- (match (get-message reply)
- (#f
- (raise-exception
- (make-exception-with-message
- (simple-format
- #f "table-manager-lookup-id-or-placeholder can't find ~A in ~A"
- key
- table-manager))))
- (val val))))
- ((placeholder . _) placeholder)))
- (id id)))
-
-(define (table-manager-keyless-than type)
- (match type
- ('string (wrap-null-handlingequality type)
- (match type
- ('string (wrap-null-handling=? string=?))
- ('integer (wrap-null-handling=? =))
- ('boolean eq?)
- ("integer[]" integer-array=?)
- ("sorted-integer[]" integer-array=?)))
-
-(define (table-manager-key-column-types table-manager)
- (define columns-and-types
- (table-manager-columns-and-types table-manager))
- (define key-columns
- (table-manager-key-columns table-manager))
-
- (if (list? key-columns)
- (map (lambda (col)
- (assq-ref columns-and-types
- col))
- key-columns)
- (assq-ref columns-and-types key-columns)))
-
-(define (make-keyless-than
- (assq-ref columns-and-types key-columns))))
- (lambda (a b)
- (let ((a-val
- (if (table-manager-id-placeholder? a)
- (table-manager-id-placeholder-id a)
- a))
- (b-val
- (if (table-manager-id-placeholder? b)
- (table-manager-id-placeholder-id b)
- b)))
- (less-than a-val b-val))))
- (let ((less-than-procedures
- (map (lambda (column)
- (type->less-than
- (assq-ref columns-and-types column)))
- key-columns))
- (equality-procedures
- (map (lambda (column)
- (type->equality
- (assq-ref columns-and-types column)))
- key-columns)))
- (lambda (initial-a initial-b)
- (let loop ((index 0)
- (equality-procedures equality-procedures)
- (less-than-procedures less-than-procedures))
- (let ((a-val (let ((val (vector-ref initial-a index)))
- (if (table-manager-id-placeholder? val)
- (table-manager-id-placeholder-id val)
- val)))
- (b-val (let ((val (vector-ref initial-b index)))
- (if (table-manager-id-placeholder? val)
- (table-manager-id-placeholder-id val)
- val))))
- (if ((car equality-procedures) a-val b-val)
- (if (= (- (vector-length initial-a) 1)
- index)
- #f
- (loop (1+ index)
- (cdr equality-procedures)
- (cdr less-than-procedures)))
- ((car less-than-procedures) a-val b-val))))))))
-
-(define (table-manager-placeholderlist
- cons
- (table-manager-key->id-hash-table
- (table-manager-id-placeholder-table-manager val))))
-
- (raise-exception
- (make-exception
- (make-exception-with-message "unable to resolve placeholder")
- (make-exception-with-irritants
- (list val)))))
- id)))
- ((table-manager-thunk-placeholder? val)
- ((table-manager-thunk-placeholder-thunk val)))
- ((list? val)
- (map resolve-table-manager-placeholder val))
- ((vector? val)
- (vector-map
- (lambda (_ v)
- (resolve-table-manager-placeholder v))
- val))
- (else val)))
-
-(define (integer-arrayplaceholder-and-row-hash-table
- (make-hash-table initial-hash-table-size))
-
- (define key->id-hash-table
- (make-hash-table initial-hash-table-size))
-
- (define finished-condition
- (make-condition))
-
- (define key-columns-nullable
- (call-with-resource-from-pool
- connection-pool
- (lambda (conn)
- (if (symbol? key-columns)
- (field-can-be-null? conn
- table-name
- (symbol->string key-columns))
- (map (lambda (column)
- (field-can-be-null? conn table-name
- (symbol->string column)))
- key-columns)))))
-
- (define table-manager
- (make-table-manager table-name
- columns-and-types
- dependencies
- key-columns
- key-columns-nullable
- id-column
- (make-keyplaceholder-and-row-hash-table
- key->id-hash-table
- #f
- channel
- #f
- finished-condition))
-
- (define (perform-value-processing value types)
- (cond
- ((and (list? types)
- (member "sorted-integer[]" types))
- (if (vector? value)
- (vector-map
- (lambda (_ val type)
- (if (and (string? type)
- (string=? type "sorted-integer[]"))
- (sort! val <)
- val))
- value
- (list->vector types))
- (map
- (lambda (val type)
- (if (and (string? type)
- (string=? type "sorted-integer[]"))
- (sort! val <)
- val))
- value
- types)))
- ((and (string? types)
- (string=? types "sorted-integer[]"))
- (sort! value <))
- (else value)))
-
- (define column-names
- (map (lambda (column-and-type)
- (symbol->string (car column-and-type)))
- columns-and-types))
-
- (define (build-insert-query/raw-rows raw-rows)
- (call-with-output-string
- (lambda (port)
- (put-string
- port
- "
-INSERT INTO ")
- (put-string port table-name)
- (put-string port " (")
- (put-string port (string-join column-names ", "))
- (put-string port ") VALUES
-")
- (let* ((row-count
- (vector-length raw-rows))
- (last-index
- (- row-count 1)))
- (vector-for-each
- (lambda (index row)
- (put-string port "(")
- (let ((last-index
- (- (vector-length row) 1)))
- (vector-for-each
- (lambda (index val)
- (put-string port (value->sql val))
- (unless (= index last-index)
- (put-string port ",")))
- row))
- (put-string port ")")
-
- (unless (= index last-index)
- (put-string port ",")))
- raw-rows)))))
-
- (define (build-insert-query sorted-keys-and-rows)
- (define column-names
- (map (lambda (column-and-type)
- (symbol->string (car column-and-type)))
- columns-and-types))
-
- (call-with-output-string
- (lambda (port)
- (put-string
- port
- "
-INSERT INTO ")
- (put-string port table-name)
- (put-string port " (")
- (put-string port (string-join column-names ", "))
- (put-string port ") VALUES
-")
- (let loop ((sorted-keys-and-rows
- sorted-keys-and-rows))
- (let* ((key-and-row
- next
- (car+cdr sorted-keys-and-rows))
- (key
- row
- (car+cdr key-and-row)))
- (put-string port "(")
- (let ((last-index
- (- (vector-length row) 1)))
- (vector-for-each
- (lambda (index val)
- (put-string port (value->sql val))
- (unless (= index last-index)
- (put-string port ",")))
- row))
- (put-string port ")")
-
- (if (null? next)
- #f ; finished
- (begin
- (put-string port ",")
- (loop next)))))
-
- (put-string port "
-ON CONFLICT DO NOTHING")
- (when id-column
- (put-string port "
-RETURNING ")
- (put-string port (symbol->string id-column))))))
-
- (define (insert-all/raw-rows)
- (for-each table-manager-insert-all
- dependencies)
-
- (let ((count
- (vector-length (table-manager-raw-rows table-manager))))
-
- (if (= count 0)
- (simple-format
- (current-error-port)
- "no entries to insert for the ~A table\n"
- table-name)
- (with-time-logging
- (simple-format
- #f
- "inserting ~A entries to the ~A table\n"
- count table-name)
-
- (let ((raw-rows
- (table-manager-raw-rows table-manager)))
- (with-delay-logging
- "table-manager resolve raw-rows placeholders"
- (vector-map!
- (lambda (_ row)
- (vector-map!
- (lambda (_ val)
- (resolve-table-manager-placeholder val))
- row)
- row)
- raw-rows))
-
- (let ((query
- (with-delay-logging
- "table-manager insert-all build-query/raw-rows"
- (build-insert-query/raw-rows raw-rows))))
- (with-resource-from-pool connection-pool conn
- (exec-query conn query)))))))
- *unspecified*)
-
- (define* (insert-all #:key check-for-self-dependents?)
- (for-each table-manager-insert-all
- dependencies)
-
- (let* ((keys-and-rows
- (hash-fold
- (lambda (key value result)
- (if (and check-for-self-dependents?
- (vector-any
- (lambda (val)
- (and (table-manager-id-placeholder? val)
- (eq?
- (table-manager-id-placeholder-table-manager
- val)
- table-manager)))
- (cdr value)))
- result
- (cons
- (cons key (cdr value))
- result)))
- '()
- key->placeholder-and-row-hash-table))
- (count
- (length keys-and-rows)))
-
- (if (= count 0)
- (simple-format
- (current-error-port)
- "no entries to insert for the ~A table\n"
- table-name)
- (let ((sorted-keys-and-rows
- (with-delay-logging
- "table-manager insert-all sort rows"
- (fibers-sort!
- keys-and-rows
- (let ((keyplaceholder-and-row-hash-table
- (car key-and-row))))
- (set-table-manager-id-placeholder-id!
- (car placeholder-and-row)
- (string->number (car query-response)))
- (hashx-remove!
- key-hash
- key-assoc
- key->placeholder-and-row-hash-table
- (car key-and-row))))
- sorted-keys-and-rows-chunk
- result-rows)
- ;; Don't know which rows the id's correspond
- ;; to, so query for them all
- (let* ((keys-vector
- (list->vector (map car sorted-keys-and-rows-chunk)))
- (resolved-keys
- (map (lambda (key-and-row)
- (perform-value-processing
- (resolve-table-manager-placeholder
- (car key-and-row))
- (table-manager-key-column-types
- table-manager)))
- sorted-keys-and-rows-chunk))
- (keys-and-indexes
- (map cons
- resolved-keys
- (iota (length resolved-keys))))
- (select-result-rows
- (with-resource-from-pool connection-pool conn
- (exec-query conn
- (build-select-query-by-keys-and-indexes
- table-manager
- keys-and-indexes)))))
- (simple-format #t "debug: expected ~A rows, got ~A, querying returned ~A rows\n"
- (length sorted-keys-and-rows-chunk)
- (length result-rows)
- (length select-result-rows))
- (for-each
- (lambda (cols)
- (let* ((index (string->number (first cols)))
- (id (string->number (second cols)))
- (key (vector-ref keys-vector index)))
- (let* ((placeholder-and-row
- (hashx-ref
- key-hash
- key-assoc
- key->placeholder-and-row-hash-table
- key)))
- (set-table-manager-id-placeholder-id!
- (car placeholder-and-row)
- id)
- (hashx-remove!
- key-hash
- key-assoc
- key->placeholder-and-row-hash-table
- key))))
- select-result-rows))))
- (with-resource-from-pool connection-pool conn
- (exec-query conn query)))))
- insert-batch-size
- sorted-keys-and-rows))
-
- (when check-for-self-dependents?
- ;; All the processed rows should be removed from the hash table,
- ;; so process the ones with self dependents
- (insert-all))
-
- (hash-clear! key->placeholder-and-row-hash-table))))
-
- *unspecified*)
-
- (spawn-fiber
- (lambda ()
- (let loop ()
- (match (get-message channel)
- (('insert-all reply)
- (put-message
- reply
- (with-exception-handler
- (lambda (exn)
- (print-backtrace-and-exception/knots exn)
- (cons 'exception exn))
- (lambda ()
- (with-exception-handler
- (lambda (exn)
- (let ((stack
- (match (fluid-ref %stacks)
- ((stack-tag . prompt-tag)
- (make-stack #t
- 0 prompt-tag
- 0 (and prompt-tag 1)))
- (_
- (make-stack #t)))))
- (raise-exception
- (make-exception
- exn
- (make-knots-exception stack)))))
- (lambda ()
- (when (eq? (table-manager-state table-manager)
- 'closed)
- (if (table-manager-raw-rows table-manager)
- (insert-all/raw-rows)
- (insert-all #:check-for-self-dependents?
- dependent-on-self?)))))
- 'success)
- #:unwind? #t))
-
- (set-table-manager-state! table-manager 'all-rows-inserted)
- (signal-condition! finished-condition)
-
- (loop))
-
- (('close reply)
- (set-table-manager-state! table-manager 'closed)
- (put-message reply #t)
-
- (loop))
-
- (('destroy reply)
- (hash-clear! key->id-hash-table)
- (set-table-manager-state! table-manager 'destroyed)
- (put-message reply #t)
-
- ;; No loop
- *unspecified*)
-
- (('add-raw-rows raw-rows reply)
- (set-table-manager-raw-rows!
- table-manager
- (vector-append raw-rows
- (or (table-manager-raw-rows table-manager)
- (vector))))
- (put-message reply #t)
- (loop))
-
- (('cache-id key id reply)
- (hash-set! key->id-hash-table key id)
-
- (put-message reply #t)
- (loop))
-
- (('cache-ids data keys-vector reply)
- (with-delay-logging
- "table-manager add-rows cache-ids"
- (for-each
- (lambda (cols)
- (let* ((index (string->number (first cols)))
- (id (string->number (second cols)))
- (key (vector-ref keys-vector index)))
- (hash-set! key->id-hash-table key id)))
- data))
-
- (put-message reply #t)
- (loop))
-
- (('lookup-id-or-placeholder key reply)
- (put-message
- reply
- (match (hash-ref (table-manager-key->id-hash-table table-manager)
- key)
- (#f
- (match (hashx-ref
- key-hash
- key-assoc
- (table-manager-key->placeholder-and-row-hash-table
- table-manager)
- key)
- (#f #f)
- ((placeholder . _) placeholder)))
- (id id)))
- (loop))
-
- (('populate-results-vector keys-vector rows
- result-vector new?-vector
- reply)
- (with-delay-logging
- "table-manager populate-results-vector"
- (let ((result-vector-length (vector-length result-vector)))
- (let loop ((index 0))
- (if (= index result-vector-length)
- #f ; finished
- (let ((res (vector-ref result-vector index)))
- (unless res
- (vector-set!
- result-vector
- index
- (let* ((key (vector-ref keys-vector index))
- (entry
- (hashx-ref
- key-hash
- key-assoc
- key->placeholder-and-row-hash-table
- key)))
- (if (eq? #f entry)
- (let ((placeholder
- (make-table-manager-id-placeholder
- table-manager
- key
- unknown-id))
- (row (vector-ref rows index)))
- (hashx-set! key-hash
- key-assoc
- key->placeholder-and-row-hash-table
- key
- (cons placeholder row))
- (vector-set! new?-vector index #t)
- placeholder)
- (let ((placeholder (car entry)))
- (vector-set! new?-vector index #f)
- placeholder)))))
- (loop (1+ index)))))))
- (put-message reply #t)
- (loop))
-
- (('add-row key row reply)
- ;; Return two values, the placeholder, and whether this placeholder
- ;; is new?
- (match (hashx-ref key-hash
- key-assoc
- key->placeholder-and-row-hash-table
- key)
- ((placeholder . row)
- (put-message reply (list placeholder #f)))
- (#f
- (let ((placeholder
- (make-table-manager-id-placeholder
- table-manager
- key
- unknown-id)))
- (hashx-set! key-hash
- key-assoc
- key->placeholder-and-row-hash-table
- key
- (cons placeholder row))
- (put-message reply (list placeholder #t)))))
-
- (loop)))))
- #:parallel? #t)
-
- table-manager)
-
-(define (table-manager-row->key table-manager row)
- (define columns-and-types
- (table-manager-columns-and-types table-manager))
- (define (column-name->val col)
- (let ((index (list-index (lambda (col-and-type)
- (eq? col
- (car col-and-type)))
- columns-and-types)))
- (vector-ref row index)))
-
- (let ((key-columns (table-manager-key-columns table-manager)))
- (cond
- ((symbol? key-columns)
- (column-name->val key-columns))
- ;; Directly use the row as the key if all the columns are key columns
- ((= (vector-length row)
- (length key-columns))
- row)
- (else
- (let ((vec (list->vector key-columns)))
- (vector-map!
- (lambda (_ name)
- (column-name->val name))
- vec)
- vec)))))
-
-(define (key-contains-placeholder? key)
- (cond
- ((vector? key)
- (vector-any table-manager-placeholder? key))
- ((list? key)
- (any (lambda (v)
- (if (vector? v)
- (vector-any table-manager-placeholder? v)
- (table-manager-placeholder? v)))
- key))
- (else
- (table-manager-placeholder? key))))
-
-(define (sort-sorted-integer-array val)
- (sort! val
- (lambda (a b)
- (cond
- ((and (integer? a)
- (integer? b))
- (< a b))
- ((and (table-manager-placeholder? a)
- (table-manager-placeholder? b))
- (table-manager-placeholdervector types)
- unprocessed-row)
- unprocessed-row)))
-
-(define (process-rows table-manager unprocessed-rows)
- (let ((types
- (map cdr (table-manager-columns-and-types table-manager))))
- (if (member "sorted-integer[]" types)
- (begin
- (vector-map!
- (lambda (_ row)
- (vector-map!
- (lambda (_ val type)
- (if (and (string? type)
- (string=? type "sorted-integer[]")
- (> (vector-length val) 1))
- (sort-sorted-integer-array val)
- val))
- row
- (list->vector types))
- row)
- unprocessed-rows)
- unprocessed-rows)
- unprocessed-rows)))
-
-(define (query-for-single-row table-manager key)
- (define table-name
- (table-manager-table-name table-manager))
- (define id-column
- (table-manager-id-column table-manager))
- (define key-columns
- (table-manager-key-columns table-manager))
- (define key-columns-list
- (if (symbol? key-columns)
- (list key-columns)
- key-columns))
-
- (let ((query
- (string-append
- "
-SELECT " (if id-column
- (symbol->string id-column)
- "1") "
-FROM " table-name "
-WHERE " (string-join
- (map (lambda (index key-column key-value)
- (if (NULL? key-value)
- (string-append
- (symbol->string key-column)
- " IS NULL")
- (string-append
- (symbol->string key-column)
- " = $"
- (number->string index))))
- (iota (length key-columns-list) 1)
- key-columns-list
- (if (symbol? key-columns)
- (list key)
- (vector->list key)))
- " AND ") "
-FOR KEY SHARE")))
- (match (call-with-resource-from-pool
- (table-manager-connection-pool table-manager)
- (lambda (conn)
- (exec-query-with-null-handling
- conn
- query
- (filter-map
- (lambda (val)
- (if (NULL? val)
- #f
- (value->sql-literal val)))
- (if (symbol? key-columns)
- (list key)
- (vector->list key))))))
- (() #f)
- (((id-string))
- (string->number id-string)))))
-
-(define (table-manager-add-row table-manager unprocessed-row)
- (define table-name
- (table-manager-table-name table-manager))
- (define key-columns
- (table-manager-key-columns table-manager))
- (define id-column
- (table-manager-id-column table-manager))
- (define key->placeholder-and-row-hash-table
- (table-manager-key->placeholder-and-row-hash-table table-manager))
- (define key->id-hash-table
- (table-manager-key->id-hash-table table-manager))
-
- (define key-columns-list
- (if (symbol? key-columns)
- (list key-columns)
- key-columns))
-
- (define row (process-row table-manager unprocessed-row))
-
- (define key (table-manager-row->key table-manager row))
-
- (match (hash-ref key->id-hash-table key)
- (#f
- (match (hashx-ref key-hash
- key-assoc
- key->placeholder-and-row-hash-table
- key)
- ((placeholder . _)
- (values placeholder
- #f))
- (#f
- (if (key-contains-placeholder? key)
- (let ((reply (make-channel)))
- (put-message (table-manager-channel table-manager)
- (list 'add-row key row reply))
- (apply values (get-message reply)))
- (let ((id (query-for-single-row table-manager key)))
- (if id
- (let ((reply (make-channel)))
- (put-message (table-manager-channel table-manager)
- (list 'cache-id key id reply))
- (get-message reply)
- (values id #f))
- (let ((reply (make-channel)))
- (put-message (table-manager-channel table-manager)
- (list 'add-row key row reply))
- (apply values (get-message reply)))))))))
- (id (values id #f))))
-
-(define (table-manager-add-raw-rows table-manager raw-rows)
- (let ((reply (make-channel)))
- (put-message (table-manager-channel table-manager)
- (list 'add-raw-rows raw-rows reply))
-
- (get-message reply)))
-
-(define (build-select-query-by-keys-and-indexes table-manager
- keys-and-indexes)
- (define table-name
- (table-manager-table-name table-manager))
- (define id-column
- (table-manager-id-column table-manager))
- (define key-columns
- (table-manager-key-columns table-manager))
- (define key-columns-list
- (if (symbol? key-columns)
- (list key-columns)
- key-columns))
- (define key-column-types
- (let ((types (table-manager-columns-and-types table-manager)))
- (map (lambda (key-column)
- (assoc-ref types key-column))
- key-columns-list)))
- (define key-columns-nullable
- (table-manager-key-columns-nullable table-manager))
- (define key-columns-nullable-list
- (if (symbol? key-columns)
- (list key-columns-nullable)
- key-columns-nullable))
-
- (call-with-output-string
- (lambda (port)
- (put-string port
- "
-SELECT vals.tm_index")
- (when id-column
- (put-string port ", ")
- (put-string port table-name)
- (put-string port ".")
- (put-string port (symbol->string id-column)))
- (put-string port "
-FROM ")
- (put-string port table-name)
- (put-string port "
-JOIN (VALUES ")
- (let loop ((keys-and-indexes keys-and-indexes))
- (let* ((key-and-index
- (car keys-and-indexes))
- (key
- index
- (car+cdr key-and-index)))
- (put-string port "(")
- (put-string port (number->string index))
- (put-string port ",")
- (put-string
- port
- (string-join
- (map (lambda (key type)
- (value->sql
- (if (eq? key NULL)
- (cons
- (match type
- ('string "varchar")
- ('integer "integer"))
- NULL)
- key)))
- (if (symbol? key-columns)
- (list key)
- (vector->list key))
- key-column-types)
- ","))
- (put-string port ")"))
-
- (if (null? (cdr keys-and-indexes))
- #f ; finished
- (begin
- (put-string port ",")
- (loop (cdr keys-and-indexes)))))
-
- (put-string port "
-) AS vals (tm_index,")
-
- (put-string port
- (string-join
- (map symbol->string key-columns-list)
- ","))
-
- (put-string port ")
-ON ")
-
- (put-string
- port
- (string-join
- (map (lambda (field nullable?)
- (string-concatenate
- `("(" ,table-name "." ,field " = vals." ,field
- ,@(if nullable?
- `(" OR (" ,table-name "." ,field " IS NULL AND"
- " vals." ,field " IS NULL"
- ")")
- '())
- ")")))
- (map symbol->string key-columns-list)
- key-columns-nullable-list)
- " AND\n ")))))
-
-(define* (table-manager-add-rows table-manager unprocessed-rows)
- (define table-name
- (table-manager-table-name table-manager))
- (define key-columns
- (table-manager-key-columns table-manager))
- (define key-columns-nullable
- (table-manager-key-columns-nullable table-manager))
- (define id-column
- (table-manager-id-column table-manager))
- (define key->placeholder-and-row-hash-table
- (table-manager-key->placeholder-and-row-hash-table table-manager))
- (define key->id-hash-table
- (table-manager-key->id-hash-table table-manager))
-
- (define key-columns-list
- (if (symbol? key-columns)
- (list key-columns)
- key-columns))
-
- (define key-columns-nullable-list
- (if (symbol? key-columns)
- (list key-columns-nullable)
- key-columns-nullable))
-
- (define key-column-types
- (let ((types (table-manager-columns-and-types table-manager)))
- (map (lambda (key-column)
- (assoc-ref types key-column))
- key-columns-list)))
-
- (define start-time
- (current-time))
-
- (let* ((row-count (vector-length unprocessed-rows))
- (rows
- (with-delay-logging
- "table-manager add-rows process-rows"
- (process-rows table-manager unprocessed-rows)))
- (keys-vector
- (with-delay-logging
- "table-manager add-rows make keys-vector"
- (vector-map
- (lambda (_ row)
- (table-manager-row->key table-manager row))
- rows)))
- (result-vector
- (make-vector row-count #f))
- (new?-vector
- (make-vector row-count #f))
- (keys-and-indexes
- (with-delay-logging
- "table-manager add-rows make keys-and-indexes"
- (vector-fold
- (lambda (index result key)
- (match (hash-ref key->id-hash-table key)
- (#f
- (match (hashx-ref key-hash
- key-assoc
- key->placeholder-and-row-hash-table
- key)
- ((placeholder . _)
- (vector-set! result-vector index placeholder)
- result)
- (#f
- (if (key-contains-placeholder? key)
- result
- (cons (cons key index)
- result)))))
- (id
- (vector-set! result-vector index id)
- result)))
- '()
- keys-vector))))
-
- (let ((data
- (if (null? keys-and-indexes)
- '()
- (let ((query
- (with-delay-logging
- "table-manager add-rows build-query"
- (build-select-query-by-keys-and-indexes
- table-manager
- keys-and-indexes))))
- (call-with-resource-from-pool
- (table-manager-connection-pool table-manager)
- (lambda (conn)
- (with-delay-logging
- "table-manager add-rows exec-query"
- (exec-query-with-null-handling conn query))))))))
-
- (when id-column
- (let ((reply (make-channel)))
- (put-message (table-manager-channel table-manager)
- (list 'cache-ids
- data keys-vector reply))
- (get-message reply)))
-
- (if id-column
- (for-each
- (lambda (cols)
- (let* ((index (string->number (first cols)))
- (id (string->number (second cols))))
- (vector-set! result-vector index id)))
- data)
- (for-each
- (lambda (data-row)
- (let ((index (string->number (car data-row))))
- (vector-set! result-vector index #t)))
- data))
-
- (let ((reply (make-channel)))
- (put-message (table-manager-channel table-manager)
- (list 'populate-results-vector
- keys-vector rows
- result-vector new?-vector
- reply))
- (get-message reply))
-
- (let ((time-taken (- (current-time) start-time)))
- (when (> time-taken 0)
- (simple-format
- #t "table-manager-add-rows to ~A for ~A rows took ~A ~A\n"
- table-name
- row-count
- time-taken
- (if (= time-taken 1)
- "second"
- "seconds"))))
-
- (values result-vector
- new?-vector))))
-
-(define (table-manager-closed? table-manager)
- (memq (table-manager-state table-manager)
- '(closed all-rows-inserted destroyed)))
-
-(define (table-manager-all-rows-inserted? table-manager)
- (memq (table-manager-state table-manager)
- '(all-rows-inserted destroyed)))
-
-(define (table-manager-destroyed? table-manager)
- (eq? (table-manager-state table-manager)
- 'destroyed))
-
-(define (table-manager-close table-manager)
- (or (table-manager-closed? table-manager)
- (let ((reply (make-channel)))
- (put-message (table-manager-channel table-manager)
- (list 'close reply))
- (get-message reply))))
-
-(define (table-manager-insert-all table-manager)
- (let ((reply (make-channel)))
- (perform-operation
- (choice-operation
- (wrap-operation (put-operation
- (table-manager-channel table-manager)
- (list 'insert-all reply))
- (lambda _
- (match (get-message reply)
- (('exception . exn)
- (raise-exception exn))
- ('success #t))))
- (wait-operation
- (table-manager-finished-condition table-manager))))))
-
-(define (filter-vectors-only-new new?-vec . vecs)
- (let* ((new-length
- (vector-count (lambda (_ x) x) new?-vec))
- (dest-vecs
- (map (lambda _ (make-vector new-length))
- vecs)))
- (let loop ((dest-index 0)
- (new?-index 0))
- (if (= dest-index new-length)
- (apply values dest-vecs)
- (if (vector-ref new?-vec new?-index)
- (begin
- (for-each
- (lambda (source-vec dest-vec)
- (vector-set! dest-vec
- dest-index
- (vector-ref source-vec new?-index)))
- vecs
- dest-vecs)
- (loop (1+ dest-index)
- (1+ new?-index)))
- (loop dest-index
- (1+ new?-index)))))))
-
-(define (group-ids-by-counts-vector ids-vec counts-vec)
- (vector-unfold
- (lambda (index ids-vec-index)
- (let ((count (vector-ref counts-vec index)))
- (values
- (vector
- (vector-copy
- ids-vec
- ids-vec-index
- (+ ids-vec-index count)))
- (+ ids-vec-index count))))
- (vector-length counts-vec)
- 0))
-
-(define-record-type
- (make-table-manager-coordinator table-managers channel)
- table-manager-coordinator?
- (table-managers table-manager-coordinator-table-managers)
- (channel table-manager-coordinator-channel))
-
-(define (spawn-table-manager-coordinator seed-table-managers)
- (define all-ordered-table-managers
- (let loop ((seed-table-managers seed-table-managers)
- (result '()))
- (if (null? seed-table-managers)
- (delete-duplicates result eq?)
- (loop (cdr seed-table-managers)
- (let ((table-manager
- (first seed-table-managers)))
- (loop (table-manager-dependencies table-manager)
- (cons table-manager result)))))))
-
- (define table-managers-by-table
- (map (lambda (table-manager)
- (cons (table-manager-table-name table-manager)
- table-manager))
- all-ordered-table-managers))
-
- (define table-manager-first-level-dependents
- (map (lambda (table-manager)
- (cons
- table-manager
- (filter-map
- (lambda (other-table-manager)
- (if (eq? table-manager other-table-manager)
- #f
- (if (memq table-manager
- (table-manager-dependencies other-table-manager))
- other-table-manager
- #f)))
- all-ordered-table-managers)))
- all-ordered-table-managers))
-
- (define (table-manager-plus-recursive-dependents table-manager)
- (delete-duplicates
- (cons table-manager
- (append-map
- table-manager-plus-recursive-dependents
- (assq-ref table-manager-first-level-dependents
- table-manager)))
- eq?))
-
- (define table-manager-dependents
- (map (lambda (table-manager)
- (cons
- table-manager
- (append-map
- (lambda (other-table-manager)
- (if (eq? table-manager other-table-manager)
- '()
- (if (memq table-manager
- (table-manager-dependencies other-table-manager))
- ;; Placeholders might refer to dependencies, so
- ;; include them all
- (table-manager-plus-recursive-dependents
- other-table-manager)
- '())))
- all-ordered-table-managers)))
- all-ordered-table-managers))
-
- (define (destroy-table-manager table-manager)
- (let ((reply (make-channel)))
- (put-message (table-manager-channel table-manager)
- (list 'destroy reply))
- (get-message reply)))
-
- (define (destroy-unneeded-table-managers)
- (for-each
- (match-lambda
- ((table-manager . dependents)
- (unless (table-manager-destroyed? table-manager)
- (when (and (table-manager-all-rows-inserted? table-manager)
- (every table-manager-all-rows-inserted? dependents))
- (destroy-table-manager table-manager)))))
- table-manager-dependents))
-
- (define (close-table-manager table-manager)
- (table-manager-close table-manager)
-
- (destroy-unneeded-table-managers)
-
- (let* ((table-managers-to-insert-first
- (take-while (lambda (tm)
- (not (eq? table-manager tm)))
- all-ordered-table-managers))
- (open-table-managers-to-insert-first
- (remove table-manager-closed?
- table-managers-to-insert-first)))
- (if (null? open-table-managers-to-insert-first)
- (begin
- (for-each table-manager-insert-all
- table-managers-to-insert-first)
-
- (table-manager-insert-all table-manager)
-
- (destroy-unneeded-table-managers))
- (simple-format #t "info: unable to insert to ~A as the following table managers haven't been closed yet: ~A\n"
- (table-manager-table-name table-manager)
- (map table-manager-table-name
- open-table-managers-to-insert-first)))))
-
- (define channel (make-channel))
-
- (define table-manager-coordinator
- (make-table-manager-coordinator all-ordered-table-managers
- channel))
-
- (spawn-fiber
- (lambda ()
- (let loop ()
- (match (get-message channel)
- (('close table reply)
- (with-exception-handler
- (lambda (exn)
- (put-message reply (cons 'exception exn)))
- (lambda ()
- (close-table-manager
- (assoc-ref table-managers-by-table
- table))
- (put-message reply #t))
- #:unwind? #t)
- (loop))
- (('destroy reply)
- (let ((success?
- (with-exception-handler
- (lambda (exn)
- (put-message reply (cons 'exception exn))
- #f)
- (lambda ()
- (for-each
- (lambda (table-manager)
- (unless (table-manager-closed? table-manager)
- (simple-format #t "warning, table manager not closed ~A\n"
- table-manager)
- (close-table-manager table-manager)))
- all-ordered-table-managers)
-
- (put-message reply #t)
- #t)
- #:unwind? #t)))
- (if success?
- ;; No loop
- *unspecified*
- (loop))))))))
-
- table-manager-coordinator)
-
-(define (fetch-table-manager coordinator table-name)
- (find (lambda (table-manager)
- (string=? (table-manager-table-name table-manager)
- table-name))
- (table-manager-coordinator-table-managers coordinator)))
-
-(define (close-table-manager coordinator table-name)
- (let ((reply (make-channel)))
- (put-message (table-manager-coordinator-channel coordinator)
- (list 'close table-name reply))
- (match (get-message reply)
- (('exception exn)
- (raise-exception exn))
- (val val))))
-
-(define (destroy-table-manager-coordinator coordinator)
- (let ((reply (make-channel)))
- (put-message (table-manager-coordinator-channel coordinator)
- (list 'destroy reply))
- (match (get-message reply)
- (('exception exn)
- (raise-exception exn))
- (val val))))
diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index e2651ba..84b823d 100644
--- a/guix-data-service/utils.scm
+++ b/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)
diff --git a/scripts/guix-data-service-process-job.in b/scripts/guix-data-service-process-job.in
index eaf38bc..488a0b7 100644
--- a/scripts/guix-data-service-process-job.in
+++ b/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))))
diff --git a/tests/jobs-load-new-guix-revision.scm b/tests/jobs-load-new-guix-revision.scm
index 0ca26c4..84d78e8 100644
--- a/tests/jobs-load-new-guix-revision.scm
+++ b/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))))))))))))))
diff --git a/tests/model-derivation.scm b/tests/model-derivation.scm
new file mode 100644
index 0000000..59f3f75
--- /dev/null
+++ b/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)
diff --git a/tests/model-license-set.scm b/tests/model-license-set.scm
new file mode 100644
index 0000000..24cb4e1
--- /dev/null
+++ b/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)
diff --git a/tests/model-license.scm b/tests/model-license.scm
new file mode 100644
index 0000000..e34b4f8
--- /dev/null
+++ b/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)
diff --git a/tests/model-lint-checker.scm b/tests/model-lint-checker.scm
new file mode 100644
index 0000000..73ac405
--- /dev/null
+++ b/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)
diff --git a/tests/model-lint-warning-message.scm b/tests/model-lint-warning-message.scm
new file mode 100644
index 0000000..88cedd1
--- /dev/null
+++ b/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)
diff --git a/tests/model-package-metadata.scm b/tests/model-package-metadata.scm
new file mode 100644
index 0000000..5e9c897
--- /dev/null
+++ b/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)
diff --git a/tests/model-package.scm b/tests/model-package.scm
new file mode 100644
index 0000000..f58b887
--- /dev/null
+++ b/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)