653 lines
18 KiB
Scheme
653 lines
18 KiB
Scheme
;;; Guix Data Service -- Information about Guix over time
|
|
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
|
|
;;;
|
|
;;; This program is free software: you can redistribute it and/or
|
|
;;; modify it under the terms of the GNU Affero General Public License
|
|
;;; as published by the Free Software Foundation, either version 3 of
|
|
;;; the License, or (at your option) any later version.
|
|
;;;
|
|
;;; This program is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; Affero General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU Affero General Public
|
|
;;; License along with this program. If not, see
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (guix-data-service model 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 (string-delete-null
|
|
quote-string
|
|
value->quoted-string-or-null
|
|
non-empty-string-or-false
|
|
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
|
|
update-or-insert
|
|
bulk-select
|
|
bulk-insert
|
|
insert-and-return-id
|
|
prepare-insert-and-return-id))
|
|
|
|
(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$"))
|
|
|
|
(define (value->quoted-string-or-null value)
|
|
(if (string? value)
|
|
(string-append "$STR$" value "$STR$")
|
|
NULL))
|
|
|
|
(define (non-empty-string-or-false s)
|
|
(if (string? s)
|
|
(if (string-null? s)
|
|
#f
|
|
s)
|
|
#f))
|
|
|
|
(define (parse-postgresql-array-string s)
|
|
(if (string=? s "{}")
|
|
'()
|
|
(string-split
|
|
(string-drop-right
|
|
(string-drop s 1)
|
|
1)
|
|
#\,)))
|
|
|
|
(define (deduplicate-strings strings)
|
|
(pair-fold
|
|
(lambda (pair result)
|
|
(if (null? (cdr pair))
|
|
(cons (first pair) result)
|
|
(if (string=? (first pair) (second pair))
|
|
result
|
|
(cons (first pair) result))))
|
|
'()
|
|
(sort strings string<?)))
|
|
|
|
(define (group-list-by-first-n-fields n lists)
|
|
(fold (lambda (lst groups)
|
|
(receive (key vals)
|
|
(split-at lst n)
|
|
(append
|
|
(alist-delete key groups)
|
|
`((,key . ,(append
|
|
(or (assoc-ref groups key)
|
|
'())
|
|
(list vals)))))))
|
|
'()
|
|
lists))
|
|
|
|
(define (group-to-alist process lst)
|
|
(fold (lambda (element result)
|
|
(match (process element)
|
|
((key . value)
|
|
(match (assoc key result)
|
|
((_ . existing-values)
|
|
`((,key . ,(cons value existing-values))
|
|
,@(alist-delete key result)))
|
|
(#f
|
|
`((,key . (,value))
|
|
,@result))))))
|
|
'()
|
|
lst))
|
|
|
|
(define (group-to-alist/vector process lst)
|
|
(map
|
|
(match-lambda
|
|
((label . items)
|
|
(cons label (list->vector items))))
|
|
(group-to-alist process lst)))
|
|
|
|
(define (table-schema conn table-name)
|
|
(let ((results
|
|
(exec-query
|
|
conn
|
|
"
|
|
SELECT column_name, data_type, is_nullable
|
|
FROM information_schema.columns
|
|
WHERE table_name = $1"
|
|
(list table-name))))
|
|
(if (null? results)
|
|
(error
|
|
(simple-format #f "missing schema for ~A: ~A"
|
|
table-name
|
|
results))
|
|
(map
|
|
(match-lambda
|
|
((column_name data_type is_nullable)
|
|
(list column_name
|
|
data_type
|
|
(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)
|
|
(returning '(id)))
|
|
(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"
|
|
(if (and returning
|
|
(not (null? returning)))
|
|
(string-append
|
|
"
|
|
RETURNING " (string-join (map symbol->string returning)
|
|
", "))
|
|
"")))
|
|
|
|
(if (null? data)
|
|
#()
|
|
(if (and returning
|
|
(not (null? returning)))
|
|
(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)))
|
|
(begin
|
|
(exec-query conn query)
|
|
*unspecified*))))
|
|
|
|
(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 (id-proc string->number))
|
|
(define field-strings
|
|
(map symbol->string fields))
|
|
|
|
(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 " (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
|
|
"
|
|
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
|
|
"
|
|
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
|
|
" 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))))))
|