aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service/model/utils.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix-data-service/model/utils.scm')
-rw-r--r--guix-data-service/model/utils.scm832
1 files changed, 503 insertions, 329 deletions
diff --git a/guix-data-service/model/utils.scm b/guix-data-service/model/utils.scm
index c05f20d..707c697 100644
--- a/guix-data-service/model/utils.scm
+++ b/guix-data-service/model/utils.scm
@@ -17,26 +17,34 @@
(define-module (guix-data-service model utils)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-43)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 receive)
#:use-module (squee)
#:use-module (guix-data-service database)
#:use-module (guix-data-service utils)
- #:export (NULL
+ #:export (string-delete-null
quote-string
value->quoted-string-or-null
non-empty-string-or-false
- exec-query->vhash
- two-lists->vhash
parse-postgresql-array-string
deduplicate-strings
group-list-by-first-n-fields
group-to-alist
group-to-alist/vector
- insert-missing-data-and-return-all-ids))
+ insert-missing-data-and-return-all-ids
+ insert-missing-data
+ update-or-insert
+ bulk-select
+ insert-and-return-id
+ prepare-insert-and-return-id))
-(define NULL '())
+(define (char-null? c)
+ (char=? c #\null))
+
+(define (string-delete-null s)
+ (string-delete char-null? s))
(define (quote-string s)
(string-append "$STR$" s "$STR$"))
@@ -44,7 +52,7 @@
(define (value->quoted-string-or-null value)
(if (string? value)
(string-append "$STR$" value "$STR$")
- "NULL"))
+ NULL))
(define (non-empty-string-or-false s)
(if (string? s)
@@ -53,22 +61,6 @@
s)
#f))
-(define* (exec-query->vhash conn query field-function value-function
- #:key (vhash vlist-null))
- (fold (lambda (row result)
- (vhash-cons (field-function row)
- (value-function row)
- result))
- vhash
- (exec-query-with-null-handling conn query)))
-
-(define (two-lists->vhash l1 l2)
- (fold (lambda (key value result)
- (vhash-cons key value result))
- vlist-null
- l1
- l2))
-
(define (parse-postgresql-array-string s)
(if (string=? s "{}")
'()
@@ -145,322 +137,504 @@ WHERE table_name = $1"
(string=? is_nullable "YES"))))
results))))
+(define %field-can-be-null-cache
+ (make-hash-table))
+
+(define (field-can-be-null? conn table-name field)
+ (let ((cache-key (cons table-name field)))
+ (match (hash-get-handle %field-can-be-null-cache
+ cache-key)
+ ((_ . res) res)
+ (#f
+ (let ((schema-details
+ (table-schema conn table-name)))
+ (match (find (lambda (column-data)
+ (string=? field
+ (car column-data)))
+ schema-details)
+ ((column-name data-type is-nullable?)
+ (hash-set! %field-can-be-null-cache
+ cache-key
+ is-nullable?)
+ is-nullable?)
+ (#f
+ (simple-format
+ (current-error-port)
+ "error: couldn't find data for ~A in ~A\n"
+ field
+ schema-details)
+ (error "error: field-can-be-null?"))))))))
+
+(define value->sql
+ (match-lambda
+ ((? string? s)
+ (string-append "$STR$" s "$STR$"))
+ ((? NULL?)
+ "NULL")
+ ((? symbol? s)
+ (value->sql (symbol->string s)))
+ ((? number? n)
+ (number->string n))
+ ((? boolean? b)
+ (if b "TRUE" "FALSE"))
+ ((? vector? v)
+ (string-append
+ "ARRAY[" (string-join (map value->sql (vector->list v)) ",") "]"))
+ ((cast . value)
+ (string-append
+ (value->sql value) "::" cast))
+ (v
+ (error
+ (simple-format #f "error: unknown type for value: ~A" v)))))
+
+(define value->sql-literal
+ (match-lambda
+ ((? string? s) s)
+ ((? NULL?)
+ "NULL")
+ ((? symbol? s) (symbol->string s))
+ ((? number? n)
+ (number->string n))
+ ((? boolean? b)
+ (if b "t" "f"))
+ ((? vector? v)
+ (string-append
+ "{" (string-join (map value->sql-literal (vector->list v)) ",") "}"))
+ ((cast . value)
+ (string-append
+ (value->sql-literal value) "::" cast))
+ (v
+ (error
+ (simple-format #f "error: unknown type for value: ~A" v)))))
+
+(define* (bulk-select conn
+ table-name
+ fields
+ data
+ #:key (id-proc string->number))
+ (define field-strings
+ (map symbol->string fields))
+
+ (define query
+ (string-append
+ "
+SELECT vals.bulk_select_index, id
+FROM " table-name "
+JOIN (VALUES "
+(string-join
+ (if (vector? data)
+ (vector-fold
+ (lambda (index result field-values)
+ (cons
+ (string-append
+ "("
+ (number->string index) ", "
+ (string-join (map value->sql field-values) ",")
+ ")")
+ result))
+ '()
+ data)
+ (map
+ (lambda (index field-values)
+ (string-append
+ "("
+ (number->string index) ", "
+ (string-join (map value->sql field-values) ",")
+ ")"))
+ (iota (length data))
+ data))
+ ", ")
+")\n AS vals (bulk_select_index, " (string-join field-strings ", ") ") "
+"ON "
+(string-join
+ (map (lambda (field)
+ (string-concatenate
+ `("("
+ ,table-name "." ,field " = vals." ,field
+ ,@(if (field-can-be-null? conn table-name field)
+ `(" OR (" ,table-name "." ,field " IS NULL AND"
+ " vals." ,field " IS NULL"
+ ")")
+ '())
+ ")")))
+ field-strings)
+ " AND\n ")))
+
+ (let ((result (make-vector (if (vector? data)
+ (vector-length data)
+ (length data))
+ #f)))
+ (for-each
+ (match-lambda
+ ((index id)
+ (vector-set! result (string->number index)
+ (id-proc id))))
+ (exec-query conn query))
+
+ result))
+
+(define* (bulk-insert
+ conn
+ table-name
+ fields
+ data
+ #:key (id-proc string->number))
+ (define field-strings
+ (map symbol->string fields))
+
+ (define query
+ (string-append
+ "
+INSERT INTO " table-name " (" (string-join field-strings ", ") ") VALUES
+" (string-join
+ (map (lambda (field-values)
+ (string-append
+ "("
+ (string-join
+ (map (lambda (value)
+ (value->sql value))
+ field-values)
+ ", ")
+ ")"))
+ data)
+ ", ") "
+ON CONFLICT DO NOTHING
+RETURNING id"))
+
+ (if (null? data)
+ #()
+ (let* ((query-result (exec-query conn query))
+ (expected-ids (length data))
+ (returned-ids (length query-result)))
+ (if (= expected-ids returned-ids)
+ (let ((result
+ (make-vector returned-ids)))
+ (fold
+ (lambda (row index)
+ (match row
+ ((id)
+ (vector-set! result index
+ (id-proc id))))
+ (1+ index))
+ 0
+ query-result)
+ result)
+ ;; Can't match up the ids to the data, so just query for them
+ (bulk-select conn
+ table-name
+ fields
+ data
+ #:id-proc id-proc)))))
+
+(define* (insert-missing-data
+ conn
+ table-name
+ fields
+ data)
+ (define field-strings
+ (map symbol->string fields))
+
+ (let* ((result
+ (bulk-select
+ conn
+ table-name
+ fields
+ data))
+ (missing-data-indexes
+ (vector-fold
+ (lambda (i missing-data-indexes id-or-f)
+ (if id-or-f
+ missing-data-indexes
+ (cons i missing-data-indexes)))
+ '()
+ result)))
+
+ (bulk-insert
+ conn
+ table-name
+ fields
+ (map (lambda (index)
+ (vector-ref data index))
+ missing-data-indexes))
+
+ *unspecified*))
+
(define* (insert-missing-data-and-return-all-ids
conn
table-name
fields
data
- #:key
- sets-of-data?
- delete-duplicates?
- use-temporary-table?)
+ #:key (id-proc string->number))
(define field-strings
(map symbol->string fields))
- (define value->sql
- (match-lambda
- ((? string? s)
- (string-append "$STR$" s "$STR$"))
- ((? symbol? s)
- (string-append "$STR$"
- (symbol->string s)
- "$STR$"))
- ((? number? n)
- (number->string n))
- ((? boolean? b)
- (if b "TRUE" "FALSE"))
- ((? null?)
- "NULL")
- ((cast . value)
- (string-append
- (value->sql value) "::" cast))
- (v
- (error
- (simple-format #f "error: unknown type for value: ~A" v)))))
-
- (define (delete-duplicates* data)
- (delete-duplicates/sort!
- (list-copy data)
- (lambda (full-a full-b)
- (let loop ((a full-a)
- (b full-b))
- (if (null? a)
- #f
- (let ((a-val (match (car a)
- ((_ . val) val)
- ((? symbol? val) (symbol->string val))
- (val val)))
- (b-val (match (car b)
- ((_ . val) val)
- ((? symbol? val) (symbol->string val))
- (val val))))
- (cond
- ((null? a-val)
- (if (null? b-val)
- (loop (cdr a) (cdr b))
- #t))
- ((null? b-val)
- #f)
- (else
- (match a-val
- ((? string? v)
- (if (string=? a-val b-val)
- (loop (cdr a) (cdr b))
- (string<? a-val b-val)))
- ((? number? v)
- (if (= a-val b-val)
- (loop (cdr a) (cdr b))
- (< a-val b-val)))
- ((? boolean? v)
- (if (eq? a-val b-val)
- (loop (cdr a) (cdr b))
- a-val)))))))))))
-
- (define schema-details
- (table-schema conn table-name))
-
- (define (field-can-be-null? field)
- (match (find (lambda (column-data)
- (string=? field
- (car column-data)))
- schema-details)
- ((column-name data-type is-nullable?) is-nullable?)
- (#f
- (simple-format
- (current-error-port)
- "error: couldn't find data for ~A in ~A\n"
- field
- schema-details)
- (error "error: field-can-be-null?"))))
-
- (define (select-query data)
+ (let* ((result
+ (bulk-select
+ conn
+ table-name
+ fields
+ data
+ #:id-proc id-proc))
+ (missing-data-indexes
+ (vector-fold
+ (lambda (i missing-data-indexes id-or-f)
+ (if id-or-f
+ missing-data-indexes
+ (cons i missing-data-indexes)))
+ '()
+ result))
+ (new-ids
+ (bulk-insert
+ conn
+ table-name
+ fields
+ (map (lambda (index)
+ (vector-ref data index))
+ missing-data-indexes)
+ #:id-proc id-proc)))
+
+ (fold
+ (lambda (missing-data-index index)
+ (let ((new-id (vector-ref new-ids index)))
+ (vector-set! result missing-data-index new-id))
+ (1+ index))
+ 0
+ missing-data-indexes)
+
+ (values result new-ids)))
+
+(define* (update-or-insert conn
+ table-name
+ fields
+ field-vals
+ #:key (id-fields '(id)))
+ (define id-field-strings
+ (map symbol->string id-fields))
+
+ (define id-field-values
+ (map (lambda (id-field)
+ (any (lambda (field val)
+ (if (eq? field id-field)
+ (value->sql-literal val)
+ #f))
+ fields
+ field-vals))
+ id-fields))
+
+ (define field-strings
+ (map symbol->string fields))
+
+ (define select
(string-append
- "SELECT id,\n"
- (string-join (map (lambda (field)
- (string-append table-name "." field))
- field-strings)
- ",\n")
- " FROM " table-name
- " JOIN (VALUES "
- (string-join
- (map
- (lambda (field-values)
- (string-append
- "("
- (string-join (map value->sql field-values) ",")
- ")"))
- data)
- ", ")
- ")\n AS vals (" (string-join field-strings ", ") ") "
- "ON "
- (string-join
- (map (lambda (field)
- (string-concatenate
- `("("
- ,table-name "." ,field " = vals." ,field
- ,@(if (field-can-be-null? field)
- `(" OR (" ,table-name "." ,field " IS NULL AND"
- " vals." ,field " IS NULL"
- ")")
- '())
- ")")))
- field-strings)
- " AND\n ")))
-
- (define (temp-table-select-query temp-table-name)
+ "
+SELECT " (string-join field-strings ", ") " FROM " table-name "
+WHERE "
+(string-join
+ (filter-map
+ (lambda (i field)
+ (simple-format #f "(~A = $~A)" field i))
+ (iota (length id-fields) 1)
+ id-field-strings)
+ " AND\n ")
+";"))
+
+ (define insert
(string-append
- "SELECT " table-name ".id, "
- (string-join (map (lambda (field)
- (string-append table-name "." field))
- field-strings)
- ", ")
- " FROM " table-name
- " INNER JOIN " temp-table-name
- " ON "
- (string-join
- (map (lambda (field)
- (string-concatenate
- `("("
- ,table-name "." ,field " = " ,temp-table-name "." ,field
- ,@(if (field-can-be-null? field)
- `(" OR ("
- ,table-name "." ,field " IS NULL"
- " AND "
- ,temp-table-name "." ,field " IS NULL"
- ")")
- '())
- ")")))
- field-strings)
- " AND ")))
-
- (define* (insert-sql missing-data
- #:key
- (table-name table-name))
+ "
+INSERT INTO " table-name " (" (string-join field-strings ", ") ")
+VALUES (" (string-join
+ (map (lambda (i)
+ (simple-format #f "$~A" i))
+ (iota (length fields) 1))
+ ", ") ")
+ON CONFLICT DO NOTHING
+RETURNING " (string-join id-field-strings ", ") ";"))
+
+ (define (update fields-to-update)
+ (define update-field-strings
+ (map symbol->string fields-to-update))
+
(string-append
- "INSERT INTO " table-name " (\n"
- (string-join field-strings ",\n")
- ") VALUES "
- (string-join
- (map (lambda (field-values)
+ "
+UPDATE " table-name "
+SET " (string-join
+ (map (lambda (field i)
+ (simple-format #f "~A = $~A" field i))
+ update-field-strings
+ (iota (length update-field-strings) 1))
+ ", ") "
+WHERE "
+(string-join
+ (filter-map
+ (lambda (i field)
+ (simple-format #f "(~A = $~A)" field i))
+ (iota (length id-fields) (+ 1 (length fields-to-update)))
+ id-field-strings)
+ " AND\n ")))
+
+ (let ((sql-field-values
+ (map value->sql-literal field-vals)))
+ (match (exec-query
+ conn
+ select
+ id-field-values)
+ ((db-field-values)
+ (let* ((normalised-field-values
+ (map value->sql-literal
+ db-field-values))
+ (fields-to-update
+ (filter-map
+ (lambda (field db-val target-val)
+ ;; TODO This might incorrectly detect differences
+ (if (equal? db-val target-val)
+ #f
+ field))
+ fields
+ normalised-field-values
+ sql-field-values))
+ (update-field-values
+ (filter-map
+ (lambda (field val)
+ (if (memq field fields-to-update)
+ val
+ #f))
+ fields
+ sql-field-values)))
+ (unless (null? fields-to-update)
+ (exec-query
+ conn
+ (update fields-to-update)
+ (append update-field-values
+ id-field-values)))))
+ (()
+ (exec-query
+ conn
+ insert
+ sql-field-values))))
+ *unspecified*)
+
+(define* (insert-and-return-id conn
+ table-name
+ fields
+ field-vals
+ #:key (id-proc string->number))
+ (define field-strings
+ (map symbol->string fields))
+
+ (define select
+ (string-append
+ "
+SELECT id FROM " table-name "
+WHERE "
+(string-join
+ (map (lambda (i field)
+ (string-append
+ "(" field " = $" i
+ (if (field-can-be-null? conn table-name field)
(string-append
- "("
- (string-join
- (map (lambda (value)
- (value->sql value))
- field-values)
- ", ")
- ")"))
- missing-data)
- ", ")
- " RETURNING id"))
-
- (define (format-json json)
- ;; PostgreSQL formats JSON strings differently to guile-json, so use
- ;; PostgreSQL to do the formatting
- (caar
- (exec-query
- conn
- (string-append
- "SELECT $STR$" json "$STR$::jsonb"))))
-
- (define (normalise-values data)
- (map (match-lambda
- ((? boolean? b)
- (if b "t" "f"))
- ((? number? n)
- (number->string n))
- ((? symbol? s)
- (symbol->string s))
- ((? string? s)
- s)
- ((? null? n)
- ;; exec-query-with-null-handling specifies NULL values as '()
- n)
- ((cast . value)
- (if (string=? cast "jsonb")
- (format-json value)
- value))
- (unknown
- (error (simple-format #f "normalise-values: error: ~A\n" unknown))))
- data))
-
- (let* ((existing-entries
- (if use-temporary-table?
- (let ((temp-table-name
- (string-append "temp_" table-name))
- (data
- (if sets-of-data?
- (delete-duplicates* (concatenate data))
- (if delete-duplicates?
- (delete-duplicates* data)
- data))))
- ;; Create a temporary table to store the data
- (exec-query
- conn
- (string-append "CREATE TEMPORARY TABLE "
- temp-table-name
- " (LIKE "
- table-name
- " INCLUDING ALL)"))
- (exec-query
- conn
- (string-append
- "ANALYZE " temp-table-name))
-
- ;; Populate the temporary table
- (if (null? data)
- '()
- (with-time-logging (string-append "populating " temp-table-name)
- (exec-query conn
- (insert-sql data
- #:table-name temp-table-name))))
- ;; Use the temporary table to find the existing values
- (let ((result
- (with-time-logging
- (string-append "querying the " temp-table-name)
- (exec-query->vhash
- conn
- (temp-table-select-query temp-table-name)
- cdr
- (lambda (result)
- (string->number (first result)))))))
-
- (exec-query conn (string-append "DROP TABLE " temp-table-name))
- result))
-
- ;; If not using a temporary table, just do a single SELECT query
- (if (null? data)
- '()
- (fold
- (lambda (data-chunk result)
- (exec-query->vhash conn
- (select-query data-chunk)
- cdr
- (lambda (result)
- (string->number (first result)))
- #:vhash result))
- vlist-null
- (chunk (if sets-of-data?
- (delete-duplicates*
- (concatenate data))
- data)
- 3000)))))
- (missing-entries
- (let loop ((lst (if sets-of-data?
- (concatenate data)
- data))
- (result '()))
- (if (null? lst)
- (if delete-duplicates?
- (delete-duplicates* result)
- result)
- (let ((field-values (car lst)))
- (if (vhash-assoc
- ;; Normalise at this point, so that the proper value
- ;; to insert is carried forward
- (normalise-values field-values)
- existing-entries)
- (loop (cdr lst)
- result)
- (loop (cdr lst)
- (cons field-values result)))))))
- (new-entries
- (if (null? missing-entries)
- '()
- (append-map!
- (lambda (missing-entries-chunk)
- (map (lambda (result)
- (string->number (first result)))
- (exec-query conn
- (insert-sql missing-entries-chunk))))
- (chunk missing-entries 3000))))
-
- (new-entries-lookup-vhash
- (two-lists->vhash missing-entries
- new-entries))
- (all-ids
- (if sets-of-data?
- (map (lambda (field-value-lists)
- ;; Normalise the result at this point, ensuring that the id's
- ;; in the set are sorted
- (sort
- (map (lambda (field-values)
- (cdr
- (or (vhash-assoc (normalise-values field-values)
- existing-entries)
- (vhash-assoc field-values
- new-entries-lookup-vhash)
- (error "missing entry" field-values))))
- field-value-lists)
- <))
- data)
- (map (lambda (field-values)
- (cdr
- (or (vhash-assoc (normalise-values field-values)
- existing-entries)
- (vhash-assoc field-values
- new-entries-lookup-vhash)
- (error "missing entry" field-values))))
- data))))
- (values all-ids
- new-entries)))
+ " OR (" field " IS NULL AND $" i " IS NULL)")
+ "")
+ ")"))
+ (map number->string
+ (iota (length fields) 1))
+ field-strings)
+ " AND\n ")
+";"))
+
+ (define insert
+ (string-append
+ "
+INSERT INTO " table-name " (" (string-join field-strings ", ") ")
+VALUES (" (string-join
+ (map (lambda (i)
+ (simple-format #f "$~A" i))
+ (iota (length fields) 1))
+ ", ") ")
+ON CONFLICT DO NOTHING
+RETURNING id;"))
+
+ (let ((sql-field-values
+ (map value->sql-literal field-vals)))
+ (id-proc
+ (match (exec-query
+ conn
+ select
+ sql-field-values)
+ (((id)) id)
+ (()
+ (match (exec-query
+ conn
+ insert
+ sql-field-values)
+ (((id)) id)
+ (()
+ (match (exec-query
+ conn
+ select
+ sql-field-values)
+ (((id)) id)))))))))
+
+(define (prepare-insert-and-return-id conn
+ table-name
+ fields
+ types)
+ (define field-strings
+ (map symbol->string fields))
+
+ (define prepared-insert-select
+ (string-append
+ "
+PREPARE " table-name "PreparedInsertSelect
+ (" (string-join (map symbol->string types) ",") ") AS
+SELECT id FROM " table-name "
+WHERE "
+(string-join
+ (map (lambda (i field)
+ (string-append
+ "(" field " = $" i
+ (if (field-can-be-null? conn table-name field)
+ (string-append
+ " OR (" field " IS NULL AND $" i " IS NULL)")
+ "")
+ ")"))
+ (map number->string
+ (iota (length fields) 1))
+ field-strings)
+ " AND\n ")
+";"))
+
+ (define prepared-insert
+ (string-append
+ "
+PREPARE " table-name "PreparedInsert
+ (" (string-join (map symbol->string types) ",") ") AS
+INSERT INTO " table-name " (\n" (string-join field-strings ",\n") ")
+VALUES (" (string-join
+ (map (lambda (i)
+ (simple-format #f "$~A" i))
+ (iota (length fields) 1))
+ ", ") ")
+ON CONFLICT DO NOTHING
+RETURNING id;"))
+
+ (exec-query conn prepared-insert)
+ (exec-query conn prepared-insert-select)
+
+ (lambda (conn field-vals)
+ (match (exec-query
+ conn
+ (string-append
+ "
+EXECUTE " table-name "PreparedInsert("
+ (string-join (map value->sql field-vals) ", ")
+ ");"))
+ (((id)) id)
+ (()
+ (match (exec-query
+ conn
+ (string-append
+ "
+EXECUTE " table-name "PreparedInsertSelect("
+(string-join (map value->sql field-vals) ", ")
+");"))
+ (((id)) id))))))
generated by cgit v1.2.3 (git 2.49.0) at 2025-07-09 00:48:22 +0000