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 timers)
#:use-module (fibers channels) #:use-module (fibers channels)
#:use-module (fibers operations) #: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 monads)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix store) #:use-module (guix store)
@ -1127,7 +1133,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(insert-derivations))) (insert-derivations)))
(unless (null? derivations) (unless (null? derivations)
(parallel-via-fibers (fibers-parallel
(insert-sources derivations (insert-sources derivations
derivation-ids) derivation-ids)
(with-time-logging (with-time-logging
@ -1906,7 +1912,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(inferior-lint-checkers inferior))))) (inferior-lint-checkers inferior)))))
(when inferior-lint-checkers-data (when inferior-lint-checkers-data
(letpar& ((lint-checker-ids (fibers-let ((lint-checker-ids
(with-resource-from-pool postgresql-connection-pool conn (with-resource-from-pool postgresql-connection-pool conn
(lint-checkers->lint-checker-ids (lint-checkers->lint-checker-ids
conn conn
@ -2181,7 +2187,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(with-time-logging (with-time-logging
(simple-format #f "extract-information-from: ~A\n" store-item) (simple-format #f "extract-information-from: ~A\n" store-item)
(parallel-via-fibers (fibers-parallel
(begin (begin
(fibers-force package-ids-promise) (fibers-force package-ids-promise)
#f) #f)
@ -2267,7 +2273,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
extra-inferior-environment-variables) extra-inferior-environment-variables)
(define utility-thread-channel (define utility-thread-channel
;; There might be high demand for this, so order the requests ;; There might be high demand for this, so order the requests
(make-queueing-channel (spawn-queueing-fiber
(call-with-default-io-waiters (call-with-default-io-waiters
(lambda () (lambda ()
(make-worker-thread-channel (make-worker-thread-channel
@ -2791,6 +2797,12 @@ SKIP LOCKED")
(exec-query conn "BEGIN") (exec-query conn "BEGIN")
;; (spawn-fiber
;; (lambda ()
;; (while #t
;; (sleep (* 60 5))
;; (profile-heap))))
(spawn-fiber (spawn-fiber
(lambda () (lambda ()
(while (perform-operation (while (perform-operation
@ -2864,7 +2876,7 @@ SKIP LOCKED")
id)))))) id))))))
(when result (when result
(parallel-via-fibers (fibers-parallel
(with-postgresql-connection (with-postgresql-connection
(simple-format #f "post load-new-guix-revision ~A counts" id) (simple-format #f "post load-new-guix-revision ~A counts" id)
(lambda (conn) (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 (json)
#:use-module (squee) #:use-module (squee)
#:use-module (fibers) #:use-module (fibers)
#:use-module (knots resource-pool)
#:use-module (prometheus) #:use-module (prometheus)
#:use-module (guix-data-service utils) #:use-module (guix-data-service utils)
#:use-module (guix-data-service database) #: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) (define-module (guix-data-service web build controller)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (ice-9 match) #: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 utils)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service web render) #:use-module (guix-data-service web render)
@ -41,7 +43,7 @@
(define parse-build-server (define parse-build-server
(lambda (v) (lambda (v)
(letpar& ((build-servers (fibers-let ((build-servers
(call-with-resource-from-pool (connection-pool) (call-with-resource-from-pool (connection-pool)
select-build-servers))) select-build-servers)))
(or (any (match-lambda (or (any (match-lambda
@ -88,7 +90,7 @@
'())) '()))
(let ((system (assq-ref parsed-query-parameters 'system)) (let ((system (assq-ref parsed-query-parameters 'system))
(target (assq-ref parsed-query-parameters 'target))) (target (assq-ref parsed-query-parameters 'target)))
(letpar& ((build-server-options (fibers-let ((build-server-options
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(map (match-lambda (map (match-lambda
((id url lookup-all-derivations ((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)
#:use-module (texinfo html) #:use-module (texinfo html)
#:use-module (texinfo plain-text) #: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 utils)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service web sxml) #:use-module (guix-data-service web sxml)
@ -229,7 +231,7 @@
(define (render-compare mime-types (define (render-compare mime-types
query-parameters) query-parameters)
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
(letpar& ((base-job (fibers-let ((base-job
(match (assq-ref query-parameters 'base_commit) (match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value) (($ <invalid-query-parameter> value)
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
@ -275,7 +277,7 @@
#f #f
#f #f
#f))))) #f)))))
(letpar& ((base-revision-id (fibers-let ((base-revision-id
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(commit->revision-id (commit->revision-id
conn conn
@ -303,7 +305,7 @@
(version-changes (version-changes
(package-data-version-changes base-packages-vhash (package-data-version-changes base-packages-vhash
target-packages-vhash))) target-packages-vhash)))
(letpar& ((lint-warnings-data (fibers-let ((lint-warnings-data
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(group-list-by-first-n-fields (group-list-by-first-n-fields
2 2
@ -396,7 +398,7 @@
lint-warnings-data)))) lint-warnings-data))))
#:extra-headers http-headers-for-unchanging-content)) #:extra-headers http-headers-for-unchanging-content))
(else (else
(letpar& ((lint-warnings-locale-options (fibers-let ((lint-warnings-locale-options
(map (map
(match-lambda (match-lambda
((locale) ((locale)
@ -449,7 +451,7 @@
(target-branch (assq-ref query-parameters 'target_branch)) (target-branch (assq-ref query-parameters 'target_branch))
(target-datetime (assq-ref query-parameters 'target_datetime)) (target-datetime (assq-ref query-parameters 'target_datetime))
(locale (assq-ref query-parameters 'locale))) (locale (assq-ref query-parameters 'locale)))
(letpar& ((base-revision-details (fibers-let ((base-revision-details
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(select-guix-revision-for-branch-and-datetime (select-guix-revision-for-branch-and-datetime
conn conn
@ -624,7 +626,7 @@
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
((application/json) ((application/json)
(letpar& ((base-job (fibers-let ((base-job
(and=> (match (assq-ref query-parameters 'base_commit) (and=> (match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value) (($ <invalid-query-parameter> value)
(and (string? value) value)) (and (string? value) value))
@ -663,7 +665,7 @@
(base_job . ,base-job) (base_job . ,base-job)
(target_job . ,target-job))))) (target_job . ,target-job)))))
(else (else
(letpar& ((systems (fibers-let ((systems
(call-with-resource-from-pool (connection-pool) (call-with-resource-from-pool (connection-pool)
list-systems)) list-systems))
(targets (targets
@ -695,7 +697,7 @@
(limit-results (assq-ref query-parameters 'limit_results))) (limit-results (assq-ref query-parameters 'limit_results)))
(let ((data (let ((data
(concatenate! (concatenate!
(par-map& (fibers-map
(lambda (system) (lambda (system)
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(package-derivation-differences-data (package-derivation-differences-data
@ -734,7 +736,7 @@
. ,derivation-changes)) . ,derivation-changes))
#:stream? #t)) #:stream? #t))
(else (else
(letpar& ((systems (fibers-let ((systems
(call-with-resource-from-pool (connection-pool) (call-with-resource-from-pool (connection-pool)
list-systems)) list-systems))
(targets (targets
@ -788,7 +790,7 @@
string->symbol)) string->symbol))
(after-name (assq-ref query-parameters 'after_name)) (after-name (assq-ref query-parameters 'after_name))
(limit-results (assq-ref query-parameters 'limit_results))) (limit-results (assq-ref query-parameters 'limit_results)))
(letpar& (fibers-let
((base-revision-details ((base-revision-details
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(select-guix-revision-for-branch-and-datetime conn (select-guix-revision-for-branch-and-datetime conn
@ -800,7 +802,7 @@
target-branch target-branch
target-datetime)))) target-datetime))))
(let ((data (let ((data
(par-map& (fibers-map
(lambda (system) (lambda (system)
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(package-derivation-differences-data (package-derivation-differences-data
@ -875,7 +877,7 @@
(render-json (render-json
'((error . "invalid query")))) '((error . "invalid query"))))
(else (else
(letpar& ((base-job (fibers-let ((base-job
(match (assq-ref query-parameters 'base_commit) (match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value) (($ <invalid-query-parameter> value)
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
@ -895,7 +897,7 @@
(let ((base-commit (assq-ref query-parameters 'base_commit)) (let ((base-commit (assq-ref query-parameters 'base_commit))
(target-commit (assq-ref query-parameters 'target_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 (with-resource-from-pool (connection-pool) conn
(commit->revision-id (commit->revision-id
conn conn
@ -944,7 +946,7 @@
(render-json (render-json
'((error . "invalid query")))) '((error . "invalid query"))))
(else (else
(letpar& ((systems (fibers-let ((systems
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
list-systems)) list-systems))
(build-server-urls (build-server-urls
@ -963,7 +965,7 @@
(let ((base-commit (assq-ref query-parameters 'base_commit)) (let ((base-commit (assq-ref query-parameters 'base_commit))
(target-commit (assq-ref query-parameters 'target_commit)) (target-commit (assq-ref query-parameters 'target_commit))
(system (assq-ref query-parameters 'system))) (system (assq-ref query-parameters 'system)))
(letpar& ((data (fibers-let ((data
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(system-test-derivations-differences-data (system-test-derivations-differences-data
conn conn
@ -1014,7 +1016,7 @@
(render-json (render-json
'((error . "invalid query")))) '((error . "invalid query"))))
(else (else
(letpar& ((systems (fibers-let ((systems
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
list-systems)) list-systems))
(build-server-urls (build-server-urls
@ -1035,7 +1037,7 @@
(target-branch (assq-ref query-parameters 'target_branch)) (target-branch (assq-ref query-parameters 'target_branch))
(target-datetime (assq-ref query-parameters 'target_datetime)) (target-datetime (assq-ref query-parameters 'target_datetime))
(system (assq-ref query-parameters 'system))) (system (assq-ref query-parameters 'system)))
(letpar& (fibers-let
((base-revision-details ((base-revision-details
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(select-guix-revision-for-branch-and-datetime conn (select-guix-revision-for-branch-and-datetime conn
@ -1046,7 +1048,7 @@
(select-guix-revision-for-branch-and-datetime conn (select-guix-revision-for-branch-and-datetime conn
target-branch target-branch
target-datetime)))) target-datetime))))
(letpar& ((data (fibers-let ((data
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(system-test-derivations-differences-data (system-test-derivations-differences-data
conn conn

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

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

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

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

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

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

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

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

33
guix-dev.scm
View file

@ -41,6 +41,38 @@
(gnu packages ruby) (gnu packages ruby)
(srfi srfi-1)) (srfi srfi-1))
(define guile-knots
(let ((commit "0fab93e9ff5b16813ae1356c13d3c974d7277d81")
(revision "1"))
(package
(name "guile-knots")
(version (git-version "0" revision commit))
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://git.cbaines.net/git/guile/knots")
(commit commit)))
(sha256
(base32
"1x0wirq0db2704784ig00kz5kh8j6szp2gwm67wn714m1jbhz9ky"))
(file-name (string-append name "-" version "-checkout"))))
(build-system gnu-build-system)
(native-inputs
(list pkg-config
autoconf
automake
guile-3.0
guile-fibers))
(inputs
(list guile-3.0))
(propagated-inputs
(list guile-fibers))
(home-page "https://git.cbaines.net/guile/knots")
(synopsis "Patterns and functionality to use with Guile Fibers")
(description
"")
(license license:gpl3+))))
(package (package
(name "guix-data-service") (name "guix-data-service")
(version "0.0.0") (version "0.0.0")
@ -52,6 +84,7 @@
guile-json-4 guile-json-4
guile-squee guile-squee
guile-fibers guile-fibers
guile-knots
guile-gcrypt guile-gcrypt
guile-lzlib guile-lzlib
guile-readline guile-readline