2019-02-06 17:14:44 +01:00
|
|
|
(define-module (guix-data-service model utils)
|
|
|
|
#:use-module (srfi srfi-1)
|
2019-08-31 13:07:58 +02:00
|
|
|
#:use-module (ice-9 match)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (ice-9 vlist)
|
2019-05-18 13:34:37 +02:00
|
|
|
#:use-module (ice-9 receive)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (squee)
|
2019-09-04 12:57:06 +02:00
|
|
|
#:use-module (guix-data-service database)
|
|
|
|
#:export (NULL
|
|
|
|
quote-string
|
2019-02-10 10:42:22 +01:00
|
|
|
value->quoted-string-or-null
|
2019-08-04 10:39:40 +02:00
|
|
|
non-empty-string-or-false
|
2019-02-06 17:14:44 +01:00
|
|
|
exec-query->vhash
|
2019-03-24 11:49:49 +01:00
|
|
|
two-lists->vhash
|
2019-05-18 13:34:37 +02:00
|
|
|
deduplicate-strings
|
2019-08-31 13:09:54 +02:00
|
|
|
group-list-by-first-n-fields
|
|
|
|
insert-missing-data-and-return-all-ids))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
2019-09-04 12:57:06 +02:00
|
|
|
(define NULL '())
|
|
|
|
|
2019-02-10 10:42:22 +01:00
|
|
|
(define (quote-string s)
|
2019-08-31 13:09:31 +02:00
|
|
|
(string-append "$STR$" s "$STR$"))
|
2019-02-10 10:42:22 +01:00
|
|
|
|
2019-02-06 17:14:44 +01:00
|
|
|
(define (value->quoted-string-or-null value)
|
|
|
|
(if (string? value)
|
|
|
|
(string-append "$STR$" value "$STR$")
|
|
|
|
"NULL"))
|
|
|
|
|
2019-08-04 10:39:40 +02:00
|
|
|
(define (non-empty-string-or-false s)
|
|
|
|
(if (string? s)
|
|
|
|
(if (string-null? s)
|
|
|
|
#f
|
|
|
|
s)
|
|
|
|
#f))
|
|
|
|
|
2019-02-06 17:14:44 +01:00
|
|
|
(define (exec-query->vhash conn query field-function value-function)
|
|
|
|
(fold (lambda (row result)
|
|
|
|
(vhash-cons (field-function row)
|
|
|
|
(value-function row)
|
|
|
|
result))
|
|
|
|
vlist-null
|
2019-09-04 12:57:06 +02:00
|
|
|
(exec-query-with-null-handling conn query)))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
|
|
|
(define (two-lists->vhash l1 l2)
|
|
|
|
(fold (lambda (key value result)
|
|
|
|
(vhash-cons key value result))
|
|
|
|
vlist-null
|
|
|
|
l1
|
|
|
|
l2))
|
2019-03-24 11:49:49 +01:00
|
|
|
|
|
|
|
(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))))
|
|
|
|
'()
|
2019-03-24 18:31:38 +01:00
|
|
|
(sort strings string<?)))
|
2019-05-18 13:34:37 +02:00
|
|
|
|
|
|
|
(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))
|
2019-08-31 13:09:54 +02:00
|
|
|
|
2019-09-04 12:57:06 +02:00
|
|
|
(define* (insert-missing-data-and-return-all-ids
|
|
|
|
conn
|
|
|
|
table-name
|
|
|
|
fields
|
|
|
|
data
|
|
|
|
#:key
|
2019-09-05 13:51:42 +02:00
|
|
|
sets-of-data?
|
|
|
|
delete-duplicates?)
|
2019-09-04 12:57:06 +02:00
|
|
|
(define field-strings
|
|
|
|
(map symbol->string fields))
|
2019-08-31 13:09:54 +02:00
|
|
|
|
2019-09-04 12:57:06 +02:00
|
|
|
(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")
|
|
|
|
(v
|
|
|
|
(error
|
|
|
|
(simple-format #f "error: unknown type for value: ~A" v)))))
|
2019-08-31 13:09:54 +02:00
|
|
|
|
|
|
|
(define select-query
|
|
|
|
(string-append
|
|
|
|
"SELECT id, "
|
|
|
|
(string-join (map (lambda (field)
|
|
|
|
(string-append table-name "." field))
|
2019-09-04 12:57:06 +02:00
|
|
|
field-strings)
|
2019-08-31 13:09:54 +02:00
|
|
|
", ")
|
|
|
|
" FROM " table-name
|
|
|
|
" JOIN (VALUES "
|
|
|
|
(string-join
|
|
|
|
(map
|
|
|
|
(lambda (field-values)
|
|
|
|
(string-append
|
|
|
|
"("
|
2019-09-04 12:57:06 +02:00
|
|
|
(string-join (map value->sql field-values) ",")
|
2019-08-31 13:09:54 +02:00
|
|
|
")"))
|
2019-09-04 12:57:06 +02:00
|
|
|
(if sets-of-data?
|
|
|
|
(delete-duplicates
|
|
|
|
(concatenate data))
|
|
|
|
data))
|
2019-08-31 13:09:54 +02:00
|
|
|
", ")
|
2019-09-04 12:57:06 +02:00
|
|
|
") AS vals (" (string-join field-strings ", ") ") "
|
2019-08-31 13:09:54 +02:00
|
|
|
"ON "
|
|
|
|
(string-join
|
|
|
|
(map (lambda (field)
|
|
|
|
(string-append
|
2019-09-04 12:57:06 +02:00
|
|
|
"(" table-name "." field " = vals." field
|
|
|
|
" OR (" table-name "." field " IS NULL AND"
|
|
|
|
" vals." field " IS NULL))"))
|
|
|
|
field-strings)
|
2019-08-31 13:09:54 +02:00
|
|
|
" AND ")))
|
|
|
|
|
|
|
|
(define (insert-sql missing-data)
|
|
|
|
(string-append
|
|
|
|
"INSERT INTO " table-name " ("
|
2019-09-04 12:57:06 +02:00
|
|
|
(string-join field-strings ", ")
|
2019-08-31 13:09:54 +02:00
|
|
|
") VALUES "
|
|
|
|
(string-join
|
|
|
|
(map (lambda (field-values)
|
|
|
|
(string-append
|
|
|
|
"("
|
|
|
|
(string-join
|
2019-09-04 12:57:06 +02:00
|
|
|
(map (lambda (value)
|
|
|
|
(value->sql value))
|
|
|
|
field-values)
|
2019-08-31 13:09:54 +02:00
|
|
|
", ")
|
|
|
|
")"))
|
|
|
|
missing-data)
|
|
|
|
", ")
|
|
|
|
" RETURNING id"))
|
|
|
|
|
2019-09-02 18:17:01 +02:00
|
|
|
(define (normalise-values data)
|
2019-08-31 13:09:54 +02:00
|
|
|
(map (match-lambda
|
|
|
|
((? boolean? b)
|
|
|
|
(if b "t" "f"))
|
|
|
|
((? number? n)
|
|
|
|
(number->string n))
|
|
|
|
((? symbol? s)
|
|
|
|
(symbol->string s))
|
|
|
|
((? string? s)
|
2019-09-04 12:57:06 +02:00
|
|
|
s)
|
2019-09-05 13:53:51 +02:00
|
|
|
((? null? n)
|
2019-09-04 12:57:06 +02:00
|
|
|
;; exec-query-with-null-handling specifies NULL values as '()
|
2019-09-05 13:53:51 +02:00
|
|
|
n)
|
|
|
|
(unknown
|
|
|
|
(error (simple-format #f "normalise-values: error: ~A\n" unknown))))
|
2019-08-31 13:09:54 +02:00
|
|
|
data))
|
|
|
|
|
|
|
|
(let* ((existing-entries
|
|
|
|
(exec-query->vhash conn
|
|
|
|
select-query
|
|
|
|
cdr
|
2019-09-04 19:24:22 +02:00
|
|
|
(lambda (result)
|
|
|
|
(string->number (first result)))))
|
2019-08-31 13:09:54 +02:00
|
|
|
(missing-entries
|
|
|
|
(filter (lambda (field-values)
|
2019-09-04 12:57:06 +02:00
|
|
|
(not (vhash-assoc
|
|
|
|
;; Normalise at this point, so that the proper value
|
|
|
|
;; to insert is carried forward
|
|
|
|
(normalise-values field-values)
|
|
|
|
existing-entries)))
|
|
|
|
(if sets-of-data?
|
|
|
|
(delete-duplicates (concatenate data))
|
2019-09-05 13:51:42 +02:00
|
|
|
(if delete-duplicates?
|
|
|
|
(delete-duplicates data)
|
|
|
|
data))))
|
2019-08-31 13:09:54 +02:00
|
|
|
(new-entries
|
|
|
|
(if (null? missing-entries)
|
|
|
|
'()
|
2019-09-04 19:24:22 +02:00
|
|
|
(map (lambda (result)
|
|
|
|
(string->number (first result)))
|
2019-08-31 13:09:54 +02:00
|
|
|
(exec-query conn (insert-sql missing-entries)))))
|
|
|
|
(new-entries-lookup-vhash
|
|
|
|
(two-lists->vhash missing-entries
|
|
|
|
new-entries)))
|
|
|
|
|
2019-09-04 12:57:06 +02:00
|
|
|
(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
|
2019-09-04 19:24:22 +02:00
|
|
|
(sort
|
2019-09-04 12:57:06 +02:00
|
|
|
(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))))
|
2019-09-04 19:24:22 +02:00
|
|
|
field-value-lists)
|
|
|
|
<))
|
2019-09-04 12:57:06 +02:00
|
|
|
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))))
|