diff options
Diffstat (limited to 'guix-data-service')
| -rw-r--r-- | guix-data-service/model/lint-checker.scm | 5 | ||||
| -rw-r--r-- | guix-data-service/model/lint-warning-message.scm | 3 | ||||
| -rw-r--r-- | guix-data-service/model/lint-warning.scm | 5 | ||||
| -rw-r--r-- | guix-data-service/model/utils.scm | 135 |
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)))) |