aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service
diff options
context:
space:
mode:
Diffstat (limited to 'guix-data-service')
-rw-r--r--guix-data-service/model/lint-checker.scm5
-rw-r--r--guix-data-service/model/lint-warning-message.scm3
-rw-r--r--guix-data-service/model/lint-warning.scm5
-rw-r--r--guix-data-service/model/utils.scm135
4 files changed, 88 insertions, 60 deletions
diff --git a/guix-data-service/model/lint-checker.scm b/guix-data-service/model/lint-checker.scm
index 7ab7715..061e806 100644
--- a/guix-data-service/model/lint-checker.scm
+++ b/guix-data-service/model/lint-checker.scm
@@ -12,10 +12,7 @@
(insert-missing-data-and-return-all-ids
conn
"lint_checkers"
- `((name . ,(lambda (value)
- (quote-string (symbol->string value))))
- (description . ,quote-string)
- (network_dependent . ,value->sql-boolean))
+ '(name description network_dependent)
lint-checkers-data))
(define (lint-warning-count-by-lint-checker-for-revision conn commit-hash)
diff --git a/guix-data-service/model/lint-warning-message.scm b/guix-data-service/model/lint-warning-message.scm
index 70851d9..7e54e41 100644
--- a/guix-data-service/model/lint-warning-message.scm
+++ b/guix-data-service/model/lint-warning-message.scm
@@ -12,8 +12,7 @@
(insert-missing-data-and-return-all-ids
conn
"lint_warning_messages"
- `((locale . ,quote-string)
- (message . ,quote-string))
+ '(locale message)
(map (match-lambda
((locale . message)
(list locale message)))
diff --git a/guix-data-service/model/lint-warning.scm b/guix-data-service/model/lint-warning.scm
index 7cd3ae4..1d70976 100644
--- a/guix-data-service/model/lint-warning.scm
+++ b/guix-data-service/model/lint-warning.scm
@@ -13,10 +13,7 @@
(insert-missing-data-and-return-all-ids
conn
"lint_warnings"
- `((lint_checker_id . ,identity)
- (package_id . ,identity)
- (location_id . ,identity)
- (lint_warning_message_set_id . ,identity))
+ '(lint_checker_id package_id location_id lint_warning_message_set_id)
lint-warnings-data))
(define (insert-guix-revision-lint-warnings conn
diff --git a/guix-data-service/model/utils.scm b/guix-data-service/model/utils.scm
index ac2a3f7..1d187b8 100644
--- a/guix-data-service/model/utils.scm
+++ b/guix-data-service/model/utils.scm
@@ -4,9 +4,10 @@
#:use-module (ice-9 vlist)
#:use-module (ice-9 receive)
#:use-module (squee)
- #:export (quote-string
+ #:use-module (guix-data-service database)
+ #:export (NULL
+ quote-string
value->quoted-string-or-null
- value->sql-boolean
non-empty-string-or-false
exec-query->vhash
two-lists->vhash
@@ -14,6 +15,8 @@
group-list-by-first-n-fields
insert-missing-data-and-return-all-ids))
+(define NULL '())
+
(define (quote-string s)
(string-append "$STR$" s "$STR$"))
@@ -22,16 +25,6 @@
(string-append "$STR$" value "$STR$")
"NULL"))
-(define (value->sql-boolean v)
- (match v
- ((? boolean? x)
- (if x "TRUE" "FALSE"))
- ((? string? x)
- (if (or (string=? x "t")
- (string=? x "TRUE"))
- "TRUE"
- "FALSE"))))
-
(define (non-empty-string-or-false s)
(if (string? s)
(if (string-null? s)
@@ -45,7 +38,7 @@
(value-function row)
result))
vlist-null
- (exec-query conn query)))
+ (exec-query-with-null-handling conn query)))
(define (two-lists->vhash l1 l2)
(fold (lambda (key value result)
@@ -78,63 +71,79 @@
'()
lists))
-(define (insert-missing-data-and-return-all-ids
- conn
- table-name
- fields-and-handlers
- data)
- (define fields (map symbol->string
- (map first fields-and-handlers)))
+(define* (insert-missing-data-and-return-all-ids
+ conn
+ table-name
+ fields
+ data
+ #:key
+ sets-of-data?)
+ (define field-strings
+ (map symbol->string fields))
- (define handlers (map cdr fields-and-handlers))
+ (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)))))
(define select-query
(string-append
"SELECT id, "
(string-join (map (lambda (field)
(string-append table-name "." field))
- fields)
+ field-strings)
", ")
" FROM " table-name
" JOIN (VALUES "
- ;; TODO This doesn't handle NULL values
(string-join
(map
(lambda (field-values)
(string-append
"("
- (string-join
- (map (lambda (value handler)
- (handler value))
- field-values
- handlers)
- ",")
+ (string-join (map value->sql field-values) ",")
")"))
- data)
+ (if sets-of-data?
+ (delete-duplicates
+ (concatenate data))
+ data))
", ")
- ") AS vals (" (string-join fields ", ") ") "
+ ") AS vals (" (string-join field-strings ", ") ") "
"ON "
(string-join
(map (lambda (field)
(string-append
- table-name "." field " = vals." field))
- fields)
+ "(" table-name "." field " = vals." field
+ " OR (" table-name "." field " IS NULL AND"
+ " vals." field " IS NULL))"))
+ field-strings)
" AND ")))
(define (insert-sql missing-data)
(string-append
"INSERT INTO " table-name " ("
- (string-join fields ", ")
+ (string-join field-strings ", ")
") VALUES "
(string-join
(map (lambda (field-values)
(string-append
"("
(string-join
- (map (lambda (value handler)
- (handler value))
- field-values
- handlers)
+ (map (lambda (value)
+ (value->sql value))
+ field-values)
", ")
")"))
missing-data)
@@ -150,9 +159,16 @@
((? symbol? s)
(symbol->string s))
((? string? s)
- s))
+ s)
+ ((? null? s)
+ ;; exec-query-with-null-handling specifies NULL values as '()
+ '()))
data))
+ (define (sort-ids ids)
+ (map number->string
+ (sort (map string->number ids) <)))
+
(let* ((existing-entries
(exec-query->vhash conn
select-query
@@ -160,9 +176,14 @@
first))
(missing-entries
(filter (lambda (field-values)
- (not (vhash-assoc (normalise-values field-values)
- existing-entries)))
- data))
+ (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))
+ data)))
(new-entries
(if (null? missing-entries)
'()
@@ -172,11 +193,25 @@
(two-lists->vhash missing-entries
new-entries)))
- (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)))
+ (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-ids
+ (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))))