cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Use knots

Browse source 
A library of extracted Guile Fibers patterns and utilities.
This commit is contained in:
Christopher Baines 2024-12-15 19:08:28 +00:00
parent a33e32275e
commit 8b49884816
13 changed files with 154 additions and 1205 deletions
Download patch file Download diff file Expand all files Collapse all files

22
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -38,6 +38,12 @@
#:use-module (fibers timers)
#:use-module (fibers channels)
#:use-module (fibers operations)
#:use-module (knots)
#:use-module (knots queue)
#:use-module (knots promise)
#:use-module (knots parallelism)
#:use-module (knots resource-pool)
#:use-module (knots worker-threads)
#:use-module (guix monads)
#:use-module (guix base32)
#:use-module (guix store)
@ -1127,7 +1133,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(insert-derivations)))
(unless (null? derivations)
(parallel-via-fibers
(fibers-parallel
(insert-sources derivations
derivation-ids)
(with-time-logging
@ -1906,7 +1912,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(inferior-lint-checkers inferior)))))
(when inferior-lint-checkers-data
(letpar& ((lint-checker-ids
(fibers-let ((lint-checker-ids
(with-resource-from-pool postgresql-connection-pool conn
(lint-checkers->lint-checker-ids
conn
@ -2181,7 +2187,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(with-time-logging
(simple-format #f "extract-information-from: ~A\n" store-item)
(parallel-via-fibers
(fibers-parallel
(begin
(fibers-force package-ids-promise)
#f)
@ -2267,7 +2273,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
extra-inferior-environment-variables)
(define utility-thread-channel
;; There might be high demand for this, so order the requests
(make-queueing-channel
(spawn-queueing-fiber
(call-with-default-io-waiters
(lambda ()
(make-worker-thread-channel
@ -2791,6 +2797,12 @@ SKIP LOCKED")
(exec-query conn "BEGIN")
;; (spawn-fiber
;; (lambda ()
;; (while #t
;; (sleep (* 60 5))
;; (profile-heap))))
(spawn-fiber
(lambda ()
(while (perform-operation
@ -2864,7 +2876,7 @@ SKIP LOCKED")
id))))))
(when result
(parallel-via-fibers
(fibers-parallel
(with-postgresql-connection
(simple-format #f "post load-new-guix-revision ~A counts" id)
(lambda (conn)

1120
guix-data-service/utils.scm
View file

File diff suppressed because it is too large Load diff

1
guix-data-service/web/build-server/controller.scm
View file

@ -22,6 +22,7 @@
#:use-module (json)
#:use-module (squee)
#:use-module (fibers)
#:use-module (knots resource-pool)
#:use-module (prometheus)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)

6
guix-data-service/web/build/controller.scm
View file

@ -18,6 +18,8 @@
(define-module (guix-data-service web build controller)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (knots parallelism)
#:use-module (knots resource-pool)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
@ -41,7 +43,7 @@
(define parse-build-server
(lambda (v)
(letpar& ((build-servers
(fibers-let ((build-servers
(call-with-resource-from-pool (connection-pool)
select-build-servers)))
(or (any (match-lambda
@ -88,7 +90,7 @@
'()))
(let ((system (assq-ref parsed-query-parameters 'system))
(target (assq-ref parsed-query-parameters 'target)))
(letpar& ((build-server-options
(fibers-let ((build-server-options
(with-resource-from-pool (connection-pool) conn
(map (match-lambda
((id url lookup-all-derivations

38
guix-data-service/web/compare/controller.scm
View file

@ -24,6 +24,8 @@
#:use-module (texinfo)
#:use-module (texinfo html)
#:use-module (texinfo plain-text)
#:use-module (knots parallelism)
#:use-module (knots resource-pool)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web sxml)
@ -229,7 +231,7 @@
(define (render-compare mime-types
query-parameters)
(if (any-invalid-query-parameters? query-parameters)
(letpar& ((base-job
(fibers-let ((base-job
(match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value)
(with-resource-from-pool (connection-pool) conn
@ -275,7 +277,7 @@
#f
#f
#f)))))
(letpar& ((base-revision-id
(fibers-let ((base-revision-id
(with-resource-from-pool (connection-pool) conn
(commit->revision-id
conn
@ -303,7 +305,7 @@
(version-changes
(package-data-version-changes base-packages-vhash
target-packages-vhash)))
(letpar& ((lint-warnings-data
(fibers-let ((lint-warnings-data
(with-resource-from-pool (connection-pool) conn
(group-list-by-first-n-fields
2
@ -396,7 +398,7 @@
lint-warnings-data))))
#:extra-headers http-headers-for-unchanging-content))
(else
(letpar& ((lint-warnings-locale-options
(fibers-let ((lint-warnings-locale-options
(map
(match-lambda
((locale)
@ -449,7 +451,7 @@
(target-branch (assq-ref query-parameters 'target_branch))
(target-datetime (assq-ref query-parameters 'target_datetime))
(locale (assq-ref query-parameters 'locale)))
(letpar& ((base-revision-details
(fibers-let ((base-revision-details
(with-resource-from-pool (connection-pool) conn
(select-guix-revision-for-branch-and-datetime
conn
@ -624,7 +626,7 @@
'(application/json text/html)
mime-types)
((application/json)
(letpar& ((base-job
(fibers-let ((base-job
(and=> (match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value)
(and (string? value) value))
@ -663,7 +665,7 @@
(base_job . ,base-job)
(target_job . ,target-job)))))
(else
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -695,7 +697,7 @@
(limit-results (assq-ref query-parameters 'limit_results)))
(let ((data
(concatenate!
(par-map&
(fibers-map
(lambda (system)
(with-resource-from-pool (connection-pool) conn
(package-derivation-differences-data
@ -734,7 +736,7 @@
. ,derivation-changes))
#:stream? #t))
(else
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -788,7 +790,7 @@
string->symbol))
(after-name (assq-ref query-parameters 'after_name))
(limit-results (assq-ref query-parameters 'limit_results)))
(letpar&
(fibers-let
((base-revision-details
(with-resource-from-pool (connection-pool) conn
(select-guix-revision-for-branch-and-datetime conn
@ -800,7 +802,7 @@
target-branch
target-datetime))))
(let ((data
(par-map&
(fibers-map
(lambda (system)
(with-resource-from-pool (connection-pool) conn
(package-derivation-differences-data
@ -875,7 +877,7 @@
(render-json
'((error . "invalid query"))))
(else
(letpar& ((base-job
(fibers-let ((base-job
(match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value)
(with-resource-from-pool (connection-pool) conn
@ -895,7 +897,7 @@
(let ((base-commit (assq-ref query-parameters 'base_commit))
(target-commit (assq-ref query-parameters 'target_commit)))
(letpar& ((base-revision-id
(fibers-let ((base-revision-id
(with-resource-from-pool (connection-pool) conn
(commit->revision-id
conn
@ -944,7 +946,7 @@
(render-json
'((error . "invalid query"))))
(else
(letpar& ((systems
(fibers-let ((systems
(with-resource-from-pool (connection-pool) conn
list-systems))
(build-server-urls
@ -963,7 +965,7 @@
(let ((base-commit (assq-ref query-parameters 'base_commit))
(target-commit (assq-ref query-parameters 'target_commit))
(system (assq-ref query-parameters 'system)))
(letpar& ((data
(fibers-let ((data
(with-resource-from-pool (connection-pool) conn
(system-test-derivations-differences-data
conn
@ -1014,7 +1016,7 @@
(render-json
'((error . "invalid query"))))
(else
(letpar& ((systems
(fibers-let ((systems
(with-resource-from-pool (connection-pool) conn
list-systems))
(build-server-urls
@ -1035,7 +1037,7 @@
(target-branch (assq-ref query-parameters 'target_branch))
(target-datetime (assq-ref query-parameters 'target_datetime))
(system (assq-ref query-parameters 'system)))
(letpar&
(fibers-let
((base-revision-details
(with-resource-from-pool (connection-pool) conn
(select-guix-revision-for-branch-and-datetime conn
@ -1046,7 +1048,7 @@
(select-guix-revision-for-branch-and-datetime conn
target-branch
target-datetime))))
(letpar& ((data
(fibers-let ((data
(with-resource-from-pool (connection-pool) conn
(system-test-derivations-differences-data
conn

18
guix-data-service/web/controller.scm
View file

@ -35,6 +35,8 @@
#:use-module (texinfo html)
#:use-module (squee)
#:use-module (json)
#:use-module (knots parallelism)
#:use-module (knots resource-pool)
#:use-module (prometheus)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service config)
@ -234,7 +236,7 @@
#:always-rollback? #t))
(lambda ()
(letpar& ((metric-values
(fibers-let ((metric-values
(with-exception-handler
(lambda (exn)
(simple-format
@ -456,12 +458,12 @@
(write-metrics registry port))))))))
(define (render-derivation derivation-file-name)
(letpar& ((derivation
(fibers-let ((derivation
(with-resource-from-pool (connection-pool) conn
(select-derivation-by-file-name conn derivation-file-name))))
(if derivation
(letpar& ((derivation-inputs
(fibers-let ((derivation-inputs
(with-resource-from-pool (connection-pool) conn
(select-derivation-inputs-by-derivation-id
conn
@ -495,7 +497,7 @@
(select-derivation-by-file-name conn
derivation-file-name))))
(if derivation
(letpar& ((derivation-inputs
(fibers-let ((derivation-inputs
(with-resource-from-pool (connection-pool) conn
(select-derivation-inputs-by-derivation-id
conn
@ -551,7 +553,7 @@
(select-derivation-by-file-name conn
derivation-file-name))))
(if derivation
(letpar& ((derivation-inputs
(fibers-let ((derivation-inputs
(with-resource-from-pool (connection-pool) conn
(select-derivation-inputs-by-derivation-id
conn
@ -596,7 +598,7 @@
#:sxml (view-narinfos narinfos)))))
(define (render-store-item filename)
(letpar& ((derivation
(fibers-let ((derivation
(with-resource-from-pool (connection-pool) conn
(select-derivation-by-output-filename conn filename))))
(match derivation
@ -619,7 +621,7 @@
filename)))
#:extra-headers http-headers-for-unchanging-content))))
(derivations
(letpar& ((nars
(fibers-let ((nars
(with-resource-from-pool (connection-pool) conn
(select-nars-for-output conn filename)))
(builds
@ -656,7 +658,7 @@
conn
filename))))))))))
(derivations
(letpar& ((nars
(fibers-let ((nars
(with-resource-from-pool (connection-pool) conn
(select-nars-for-output conn filename))))
(render-json

4
guix-data-service/web/jobs/controller.scm
View file

@ -17,6 +17,8 @@
(define-module (guix-data-service web jobs controller)
#:use-module (ice-9 match)
#:use-module (knots parallelism)
#:use-module (knots resource-pool)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
@ -74,7 +76,7 @@
(define (render-jobs mime-types query-parameters)
(define limit-results (assq-ref query-parameters 'limit_results))
(letpar& ((jobs
(fibers-let ((jobs
(with-resource-from-pool (connection-pool) conn
(select-jobs-and-events
conn

4
guix-data-service/web/nar/controller.scm
View file

@ -27,6 +27,8 @@
#:use-module (web uri)
#:use-module (web request)
#:use-module (web response)
#:use-module (knots parallelism)
#:use-module (knots resource-pool)
#:use-module (guix pki)
#:use-module (guix base32)
#:use-module (guix base64)
@ -155,7 +157,7 @@
#:code 200
#:headers '((content-type . (application/x-narinfo))))
(let ((derivation-file-name (second derivation)))
(letpar&
(fibers-let
((derivation-text
(with-resource-from-pool (reserved-connection-pool) conn
(select-serialized-derivation-by-file-name

4
guix-data-service/web/package/controller.scm
View file

@ -19,6 +19,8 @@
#:use-module (ice-9 match)
#:use-module (web uri)
#:use-module (web request)
#:use-module (knots parallelism)
#:use-module (knots resource-pool)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
@ -40,7 +42,7 @@
request
`((system ,parse-system #:default "x86_64-linux")
(target ,parse-target #:default "")))))
(letpar& ((package-versions-with-branches
(fibers-let ((package-versions-with-branches
(with-resource-from-pool (connection-pool) conn
(branches-by-package-version conn name
(assq-ref parsed-query-parameters

36
guix-data-service/web/repository/controller.scm
View file

@ -19,6 +19,8 @@
#:use-module (ice-9 match)
#:use-module (web uri)
#:use-module (web request)
#:use-module (knots parallelism)
#:use-module (knots resource-pool)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
@ -47,7 +49,7 @@
(match method-and-path-components
(('GET "repositories")
(letpar& ((git-repositories
(fibers-let ((git-repositories
(call-with-resource-from-pool (connection-pool)
all-git-repositories)))
(case (most-appropriate-mime-type
@ -71,7 +73,7 @@
(match (with-resource-from-pool (connection-pool) conn
(select-git-repository conn id))
((label url cgit-url-base fetch-with-authentication? poll-interval)
(letpar& ((branches
(fibers-let ((branches
(with-resource-from-pool (connection-pool) conn
(all-branches-with-most-recent-commit
conn
@ -119,7 +121,7 @@
`((after_date ,parse-datetime)
(before_date ,parse-datetime)
(limit_results ,parse-result-limit #:default 100)))))
(letpar& ((revisions
(fibers-let ((revisions
(with-resource-from-pool (connection-pool) conn
(most-recent-commits-for-branch
conn
@ -160,7 +162,7 @@
parsed-query-parameters
revisions)))))))))
(('GET "repository" repository-id "branch" branch-name "package" package-name)
(letpar& ((package-versions
(fibers-let ((package-versions
(with-resource-from-pool (connection-pool) conn
(package-versions-for-branch conn
(string->number repository-id)
@ -211,7 +213,7 @@
(parse-query-parameters
request
`((system ,parse-system #:default "x86_64-linux")))))
(letpar& ((system-test-history
(fibers-let ((system-test-history
(with-resource-from-pool (connection-pool) conn
(system-test-derivations-for-branch
conn
@ -256,7 +258,7 @@
valid-systems
system-test-history)))))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision")
(letpar& ((commit-hash
(fibers-let ((commit-hash
(with-resource-from-pool (connection-pool) conn
(latest-processed-commit-for-branch conn
repository-id
@ -273,7 +275,7 @@
repository-id
branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages")
(letpar& ((commit-hash
(fibers-let ((commit-hash
(with-resource-from-pool (connection-pool) conn
(latest-processed-commit-for-branch conn
repository-id
@ -313,7 +315,7 @@
repository-id
branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivations")
(letpar& ((commit-hash
(fibers-let ((commit-hash
(with-resource-from-pool (connection-pool) conn
(latest-processed-commit-for-branch conn
repository-id
@ -422,7 +424,7 @@
branch-name))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "system-tests")
(letpar& ((commit-hash
(fibers-let ((commit-hash
(with-resource-from-pool (connection-pool) conn
(latest-processed-commit-for-branch conn
repository-id
@ -440,7 +442,7 @@
repository-id
branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-reproducibility")
(letpar& ((commit-hash
(fibers-let ((commit-hash
(with-resource-from-pool (connection-pool) conn
(latest-processed-commit-for-branch conn
repository-id
@ -462,7 +464,7 @@
repository-id
branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-substitute-availability")
(letpar& ((commit-hash
(fibers-let ((commit-hash
(with-resource-from-pool (connection-pool) conn
(latest-processed-commit-for-branch conn
repository-id
@ -476,7 +478,7 @@
branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision"
"lint-warnings")
(letpar& ((commit-hash
(fibers-let ((commit-hash
(with-resource-from-pool (connection-pool) conn
(latest-processed-commit-for-branch conn
repository-id
@ -510,7 +512,7 @@
repository-id
branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version)
(letpar& ((commit-hash
(fibers-let ((commit-hash
(with-resource-from-pool (connection-pool) conn
(latest-processed-commit-for-branch conn
repository-id
@ -583,7 +585,7 @@
(assq-ref parsed-query-parameters 'system))
(target
(assq-ref parsed-query-parameters 'target)))
(letpar&
(fibers-let
((package-derivations
(with-resource-from-pool (connection-pool) conn
(package-derivations-for-branch conn
@ -620,7 +622,7 @@
. ,(list->vector builds)))))
package-derivations))))))
(else
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -657,7 +659,7 @@
(assq-ref parsed-query-parameters 'target))
(output-name
(assq-ref parsed-query-parameters 'output)))
(letpar&
(fibers-let
((package-outputs
(with-resource-from-pool (connection-pool) conn
(package-outputs-for-branch conn
@ -695,7 +697,7 @@
. ,(list->vector builds)))))
package-outputs))))))
(else
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets

62
guix-data-service/web/revision/controller.scm
View file

@ -24,6 +24,8 @@
#:use-module (texinfo html)
#:use-module (texinfo plain-text)
#:use-module (json)
#:use-module (knots parallelism)
#:use-module (knots resource-pool)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
@ -84,7 +86,7 @@
status))))
(define (parse-build-server v)
(letpar& ((build-servers
(fibers-let ((build-servers
(call-with-resource-from-pool (connection-pool)
select-build-servers)))
(or (any (match-lambda
@ -395,7 +397,7 @@
`((unknown_commit . ,commit-hash))
#:code 404))
(else
(letpar& ((job
(fibers-let ((job
(with-resource-from-pool (connection-pool) conn
(select-job-for-commit conn commit-hash)))
(git-repositories-and-branches
@ -423,7 +425,7 @@
`((unknown_commit . ,commit-hash))
#:code 404))
(else
(letpar& ((job
(fibers-let ((job
(with-resource-from-pool (connection-pool) conn
(select-job-for-commit conn commit-hash)))
(git-repositories-and-branches
@ -448,7 +450,7 @@
(header-text
`("Revision " (samp ,commit-hash)))
(max-age cache-control-default-max-age))
(letpar& ((packages-count
(fibers-let ((packages-count
(with-resource-from-pool (connection-pool) conn
(count-packages-in-revision conn commit-hash)))
(git-repositories-and-branches
@ -514,7 +516,7 @@
`("Revision " (samp ,commit-hash)))
(header-link
(string-append "/revision/" commit-hash)))
(letpar& ((system-tests
(fibers-let ((system-tests
(with-resource-from-pool (connection-pool) conn
(select-system-tests-for-guix-revision
conn
@ -542,7 +544,7 @@
(builds . ,(list->vector builds)))))
system-tests))))))
(else
(letpar& ((git-repositories
(fibers-let ((git-repositories
(with-resource-from-pool (connection-pool) conn
(git-repositories-containing-commit conn
commit-hash)))
@ -568,7 +570,7 @@
(header-link
(string-append "/revision/"
commit-hash)))
(letpar& ((channel-instances
(fibers-let ((channel-instances
(with-resource-from-pool (connection-pool) conn
(select-channel-instances-for-guix-revision conn commit-hash))))
(case (most-appropriate-mime-type
@ -596,7 +598,7 @@
(define* (render-revision-package-substitute-availability mime-types
commit-hash
#:key path-base)
(letpar& ((substitute-availability
(fibers-let ((substitute-availability
(with-resource-from-pool (connection-pool) conn
(select-package-output-availability-for-revision conn
commit-hash)))
@ -610,7 +612,7 @@
((application/json)
(render-json
`((commit . ,commit-hash)
(substitute_servers
(xsubstitute_servers
. ,(list->vector
(map (match-lambda
((build-server-id . data)
@ -642,7 +644,7 @@
(header-link
(string-append "/revision/"
commit-hash)))
(letpar& ((output-consistency
(fibers-let ((output-consistency
(with-resource-from-pool (connection-pool) conn
(select-output-consistency-for-revision conn commit-hash))))
(case (most-appropriate-mime-type
@ -676,7 +678,7 @@
#:sxml (view-revision-news commit-hash
query-parameters
'()))))
(letpar& ((news-entries
(fibers-let ((news-entries
(with-resource-from-pool (connection-pool) conn
(select-channel-news-entries-contained-in-guix-revision
conn
@ -735,7 +737,7 @@
99999)) ; TODO There shouldn't be a limit
(fields (assq-ref query-parameters 'field))
(locale (assq-ref query-parameters 'locale)))
(letpar&
(fibers-let
((packages
(with-resource-from-pool (connection-pool) conn
(if search-query
@ -832,7 +834,7 @@
"/revision/" commit-hash))
(header-text
`("Revision " (samp ,commit-hash))))
(letpar& ((package-synopsis-counts
(fibers-let ((package-synopsis-counts
(with-resource-from-pool (connection-pool) conn
(synopsis-counts-by-locale conn
(commit->revision-id
@ -872,7 +874,7 @@
(header-link
(string-append
"/revision/" commit-hash)))
(letpar& ((package-versions
(fibers-let ((package-versions
(with-resource-from-pool (connection-pool) conn
(select-package-versions-for-revision conn
commit-hash
@ -929,7 +931,7 @@
(define has-replacement? (assq-ref query-parameters 'has_replacement))
(letpar& ((metadata
(fibers-let ((metadata
(with-resource-from-pool (connection-pool) conn
(select-package-metadata-by-revision-name-and-version
conn
@ -1041,7 +1043,7 @@
(render-json
`((error . "invalid query"))))
(else
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -1067,7 +1069,7 @@
(assq-ref query-parameters 'search_query))
(fields
(assq-ref query-parameters 'field)))
(letpar&
(fibers-let
((derivations
(if search-query
(with-resource-from-pool (connection-pool) conn
@ -1090,7 +1092,7 @@
#:after-name (assq-ref query-parameters 'after_name)
#:include-builds? (member "builds" fields)))
(concatenate!
(par-map&
(fibers-map
(lambda (system)
(with-resource-from-pool (connection-pool) conn
(select-package-derivations-in-revision
@ -1149,7 +1151,7 @@
derivations))))
#:stream? #t))
(else
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -1187,7 +1189,7 @@
(render-json
`((error . "invalid query"))))
(else
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -1213,7 +1215,7 @@
(assq-ref query-parameters 'search_query))
(fields
(assq-ref query-parameters 'field)))
(letpar&
(fibers-let
((derivations
(with-resource-from-pool (connection-pool) conn
(select-fixed-output-package-derivations-in-revision
@ -1242,7 +1244,7 @@
(render-json
`((derivations . ,(list->vector derivations)))))
(else
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -1284,7 +1286,7 @@
(render-json
`((error . "invalid query"))))
(else
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -1308,7 +1310,7 @@
(assq-ref query-parameters 'all_results))
(fields
(assq-ref query-parameters 'field)))
(letpar&
(fibers-let
((derivation-outputs
(with-resource-from-pool (connection-pool) conn
(select-derivation-outputs-in-revision
@ -1390,7 +1392,7 @@
"not-matching")))))))
derivation-outputs))))))
(else
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -1419,7 +1421,7 @@
(header-link
(string-append "/revision/" commit-hash)))
(if (any-invalid-query-parameters? query-parameters)
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -1437,7 +1439,7 @@
'())))
(let ((system (assq-ref query-parameters 'system))
(target (assq-ref query-parameters 'target)))
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -1492,7 +1494,7 @@
(header-link
(string-append "/revision/" commit-hash)))
(if (any-invalid-query-parameters? query-parameters)
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -1509,7 +1511,7 @@
'())))
(let ((system (assq-ref query-parameters 'system))
(target (assq-ref query-parameters 'target)))
(letpar& ((systems
(fibers-let ((systems
(call-with-resource-from-pool (connection-pool)
list-systems))
(targets
@ -1592,7 +1594,7 @@
(linters (assq-ref query-parameters 'linter))
(message-query (assq-ref query-parameters 'message_query))
(fields (assq-ref query-parameters 'field)))
(letpar&
(fibers-let
((git-repositories
(with-resource-from-pool (connection-pool) conn
(git-repositories-containing-commit conn

11
guix-data-service/web/server.scm
View file

@ -30,6 +30,8 @@
#:use-module (fibers channels)
#:use-module (fibers scheduler)
#:use-module (fibers conditions)
#:use-module (knots web-server)
#:use-module (knots resource-pool)
#:use-module ((guix build syscalls)
#:select (set-thread-name))
#:use-module (prometheus)
@ -246,7 +248,7 @@ port. Also, the port used can be changed by passing the --port option.\n"
(make-counter-metric registry
"resource_pool_checkout_timeouts_total"
#:labels '(pool_name))))
(%resource-pool-timeout-handler
(resource-pool-default-timeout-handler
(lambda (pool proc timeout)
(let ((pool-name
(cond
@ -269,11 +271,12 @@ port. Also, the port used can be changed by passing the --port option.\n"
request-scheduler)
(let ((render-metrics (make-render-metrics registry)))
(run-server/patched
(lambda (request body)
(run-knots-web-server
(lambda (request)
(metric-increment requests-metric)
(let ((reply (make-channel)))
(let ((body (read-request-body request))
(reply (make-channel)))
(spawn-fiber
(lambda ()
(call-with-values