Add utility functions for configuring the database
This commit is contained in:
parent
8b49884816
commit
73b53f46a3
3 changed files with 329 additions and 2 deletions
|
|
@ -16,11 +16,15 @@
|
|||
;;; <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (guix-data-service model build-server)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (squee)
|
||||
#:use-module (guix-data-service database)
|
||||
#:use-module (guix-data-service model utils)
|
||||
#:export (select-build-servers
|
||||
select-build-server
|
||||
select-build-server-urls-by-id))
|
||||
select-build-server-urls-by-id
|
||||
specify-build-servers))
|
||||
|
||||
(define (select-build-servers conn)
|
||||
(define query
|
||||
|
|
@ -58,3 +62,173 @@ WHERE id = $1")
|
|||
((id url lookup-all-derivations? lookup-builds?)
|
||||
(cons id url)))
|
||||
(select-build-servers conn)))
|
||||
|
||||
(define (specify-build-servers build-servers)
|
||||
(define (specify-token-seeds conn
|
||||
build-server-id
|
||||
token-seeds)
|
||||
(define string-build-server-id
|
||||
(number->string build-server-id))
|
||||
|
||||
(let* ((db-token-seeds
|
||||
(map
|
||||
car
|
||||
(exec-query
|
||||
conn
|
||||
"
|
||||
SELECT token_seed
|
||||
FROM build_server_token_seeds
|
||||
WHERE build_server_id = $1"
|
||||
(list string-build-server-id))))
|
||||
(token-seeds-to-delete
|
||||
(lset-difference string=?
|
||||
db-token-seeds
|
||||
token-seeds))
|
||||
(token-seeds-to-insert
|
||||
(lset-difference string=?
|
||||
token-seeds
|
||||
db-token-seeds)))
|
||||
|
||||
(for-each
|
||||
(lambda (seed)
|
||||
(exec-query
|
||||
conn
|
||||
"
|
||||
DELETE FROM build_server_token_seeds
|
||||
WHERE build_server_id = $1
|
||||
AND token_seed = $2"
|
||||
(list string-build-server-id
|
||||
seed)))
|
||||
token-seeds-to-delete)
|
||||
|
||||
(for-each
|
||||
(lambda (seed)
|
||||
(exec-query
|
||||
conn
|
||||
"
|
||||
INSERT INTO build_server_token_seeds
|
||||
VALUES ($1, $2)"
|
||||
(list string-build-server-id
|
||||
seed)))
|
||||
token-seeds-to-insert)))
|
||||
|
||||
(define (specify-build-config conn
|
||||
build-server-id
|
||||
systems-and-targets)
|
||||
(define string-build-server-id
|
||||
(number->string build-server-id))
|
||||
|
||||
(define pair-equal?
|
||||
(match-lambda*
|
||||
(((s1 . t1) (s2 . t2))
|
||||
(and (string=? s1 s2)
|
||||
(string=? t1 t2)))))
|
||||
|
||||
(let* ((db-systems-and-targets
|
||||
(map
|
||||
(match-lambda
|
||||
((system target)
|
||||
(cons system target)))
|
||||
(exec-query
|
||||
conn
|
||||
"
|
||||
SELECT system, target
|
||||
FROM build_servers_build_config
|
||||
WHERE build_server_id = $1"
|
||||
(list string-build-server-id))))
|
||||
(systems-and-targets-to-delete
|
||||
(lset-difference pair-equal?
|
||||
db-systems-and-targets
|
||||
systems-and-targets))
|
||||
(systems-and-targets-to-insert
|
||||
(lset-difference pair-equal?
|
||||
systems-and-targets
|
||||
db-systems-and-targets)))
|
||||
|
||||
(for-each
|
||||
(match-lambda
|
||||
((system . target)
|
||||
(exec-query
|
||||
conn
|
||||
"
|
||||
DELETE FROM build_servers_build_config
|
||||
WHERE build_server_id = $1
|
||||
AND system = $2
|
||||
AND target = $3"
|
||||
(list string-build-server-id
|
||||
system
|
||||
target))))
|
||||
systems-and-targets-to-delete)
|
||||
|
||||
(for-each
|
||||
(match-lambda
|
||||
((system . target)
|
||||
(exec-query
|
||||
conn
|
||||
"
|
||||
INSERT INTO build_servers_build_config
|
||||
VALUES ($1, $2, $3)"
|
||||
(list string-build-server-id
|
||||
system
|
||||
target))))
|
||||
systems-and-targets-to-insert)))
|
||||
|
||||
(with-postgresql-connection
|
||||
"specify-build-servers"
|
||||
(lambda (conn)
|
||||
(with-postgresql-transaction
|
||||
conn
|
||||
(lambda (conn)
|
||||
(let* ((existing-ids
|
||||
(map first (select-build-servers conn)))
|
||||
(target-ids
|
||||
(map (lambda (repo)
|
||||
(or (assq-ref repo 'id)
|
||||
(error "build server missing id")))
|
||||
build-servers))
|
||||
(build-servers-to-delete
|
||||
(lset-difference equal?
|
||||
existing-ids
|
||||
target-ids)))
|
||||
(for-each
|
||||
(lambda (id-to-remove)
|
||||
(simple-format (current-error-port)
|
||||
"deleting build server ~A\n"
|
||||
id-to-remove)
|
||||
(exec-query
|
||||
conn
|
||||
"DELETE FROM build_servers WHERE id = $1"
|
||||
(list (number->string id-to-remove))))
|
||||
build-servers-to-delete)
|
||||
|
||||
(for-each
|
||||
(lambda (build-server)
|
||||
(let* ((related-table-keys '(systems-and-targets
|
||||
token-seeds))
|
||||
(build-servers-without-related-data
|
||||
(filter-map
|
||||
(lambda (pair)
|
||||
(if (memq (car pair) related-table-keys)
|
||||
#f
|
||||
pair))
|
||||
build-server))
|
||||
(fields (map car build-servers-without-related-data))
|
||||
(field-vals (map cdr build-servers-without-related-data)))
|
||||
(update-or-insert
|
||||
conn
|
||||
"build_servers"
|
||||
fields
|
||||
field-vals)
|
||||
|
||||
(specify-token-seeds
|
||||
conn
|
||||
(assq-ref build-server 'id)
|
||||
(or (assq-ref build-server 'token-seeds)
|
||||
'()))
|
||||
|
||||
(specify-build-config
|
||||
conn
|
||||
(assq-ref build-server 'id)
|
||||
(or (assq-ref build-server 'systems-and-targets)
|
||||
'()))))
|
||||
build-servers)))))))
|
||||
|
|
|
|||
|
|
@ -20,9 +20,11 @@
|
|||
#:use-module (ice-9 match)
|
||||
#:use-module (json)
|
||||
#:use-module (squee)
|
||||
#:use-module (guix-data-service database)
|
||||
#:use-module (guix-data-service model utils)
|
||||
#:export (all-git-repositories
|
||||
select-git-repository
|
||||
specify-git-repositories
|
||||
git-repository-query-substitutes?
|
||||
git-repository-id->url
|
||||
select-includes-and-excluded-branches-for-git-repository
|
||||
|
|
@ -68,6 +70,46 @@ WHERE id = $1"
|
|||
(string=? fetch_with_authentication "t")
|
||||
(and=> poll-interval string->number)))))
|
||||
|
||||
(define (specify-git-repositories repositories)
|
||||
(with-postgresql-connection
|
||||
"specify-git-repositories"
|
||||
(lambda (conn)
|
||||
(with-postgresql-transaction
|
||||
conn
|
||||
(lambda (conn)
|
||||
(let* ((existing-ids
|
||||
(map first (all-git-repositories conn)))
|
||||
(target-ids
|
||||
(map (lambda (repo)
|
||||
(or (assq-ref repo 'id)
|
||||
(error "repository missing id")))
|
||||
repositories))
|
||||
(repositories-to-delete
|
||||
(lset-difference equal?
|
||||
existing-ids
|
||||
target-ids)))
|
||||
(for-each
|
||||
(lambda (id-to-remove)
|
||||
(simple-format (current-error-port)
|
||||
"deleting repository ~A\n"
|
||||
id-to-remove)
|
||||
(exec-query
|
||||
conn
|
||||
"DELETE FROM git_repositories WHERE id = $1"
|
||||
(list (number->string id-to-remove))))
|
||||
repositories-to-delete)
|
||||
|
||||
(for-each
|
||||
(lambda (repo)
|
||||
(let ((fields (map car repo))
|
||||
(field-vals (map cdr repo)))
|
||||
(update-or-insert
|
||||
conn
|
||||
"git_repositories"
|
||||
fields
|
||||
field-vals)))
|
||||
repositories)))))))
|
||||
|
||||
(define (git-repository-query-substitutes? conn id)
|
||||
(match (exec-query
|
||||
conn
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@
|
|||
group-to-alist/vector
|
||||
insert-missing-data-and-return-all-ids
|
||||
insert-missing-data
|
||||
update-or-insert
|
||||
bulk-select
|
||||
insert-and-return-id
|
||||
prepare-insert-and-return-id))
|
||||
|
|
@ -188,7 +189,7 @@ WHERE table_name = $1"
|
|||
((? number? n)
|
||||
(number->string n))
|
||||
((? boolean? b)
|
||||
(if b "TRUE" "FALSE"))
|
||||
(if b "t" "f"))
|
||||
((? vector? v)
|
||||
(string-append
|
||||
"{" (string-join (map value->sql-literal (vector->list v)) ",") "}"))
|
||||
|
|
@ -395,6 +396,116 @@ RETURNING id"))
|
|||
|
||||
(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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue