aboutsummaryrefslogtreecommitdiff
path: root/guix-qa-frontpage
diff options
context:
space:
mode:
Diffstat (limited to 'guix-qa-frontpage')
-rw-r--r--guix-qa-frontpage/debbugs.scm1
-rw-r--r--guix-qa-frontpage/guix-data-service.scm45
-rw-r--r--guix-qa-frontpage/issue.scm99
-rw-r--r--guix-qa-frontpage/manage-builds.scm9
-rw-r--r--guix-qa-frontpage/manage-patch-branches.scm32
-rw-r--r--guix-qa-frontpage/patchwork.scm29
-rw-r--r--guix-qa-frontpage/server.scm19
-rw-r--r--guix-qa-frontpage/utils.scm28
-rw-r--r--guix-qa-frontpage/view/issue.scm2
9 files changed, 156 insertions, 108 deletions
diff --git a/guix-qa-frontpage/debbugs.scm b/guix-qa-frontpage/debbugs.scm
index 656865d..b1614db 100644
--- a/guix-qa-frontpage/debbugs.scm
+++ b/guix-qa-frontpage/debbugs.scm
@@ -24,6 +24,7 @@
fetch-issues-with-guix-tag))
(define (debbugs-get-issues-with-guix-usertag)
+ ;; TODO Ideally this would be non-blocking
(soap-invoke (%gnu) get-usertag "guix"))
(define (fetch-issues-with-guix-tag tag)
diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm
index 9bf7997..af9fb0b 100644
--- a/guix-qa-frontpage/guix-data-service.scm
+++ b/guix-qa-frontpage/guix-data-service.scm
@@ -90,46 +90,12 @@
(guix-data-service-error-response-body exn)
"query_parameters")))))
-;; Returns the port as well as the raw socket
-(define* (open-socket-for-uri* uri
- #:key (verify-certificate? #t))
- (define tls-wrap
- (@@ (web client) tls-wrap))
-
- (define https?
- (eq? 'https (uri-scheme uri)))
-
- (define plain-uri
- (if https?
- (build-uri
- 'http
- #:userinfo (uri-userinfo uri)
- #:host (uri-host uri)
- #:port (or (uri-port uri) 443)
- #:path (uri-path uri)
- #:query (uri-query uri)
- #:fragment (uri-fragment uri))
- uri))
-
- (let ((s (open-socket-for-uri plain-uri)))
- (values
- (if https?
- (tls-wrap s (uri-host uri)
- #:verify-certificate? verify-certificate?)
- s)
- s)))
-
(define* (guix-data-service-request url #:key (retry-times 0) (retry-delay 5))
(define (make-request)
(let ((port
socket
(open-socket-for-uri* (string->uri url))))
- ;; This can't be done earlier as tls-wrap/guile-gnutls doesn't support
- ;; handshake on a non blocking socket
- (let ((flags (fcntl socket F_GETFL)))
- (fcntl socket F_SETFL (logior O_NONBLOCK flags)))
-
(let ((response
body
(http-get (string->uri url)
@@ -143,13 +109,10 @@
(let ((json-body
(match (response-content-encoding response)
(('gzip)
- ;; Stop fibers from triggering dynamic-wind in (zlib)
- (call-with-blocked-asyncs
- (lambda ()
- (call-with-zlib-input-port
- body
- json->scm
- #:format 'gzip))))
+ (call-with-zlib-input-port*
+ body
+ json->scm
+ #:format 'gzip))
(_
(json->scm body)))))
(if (or (> (response-code response)
diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm
index 94267a5..ea124c3 100644
--- a/guix-qa-frontpage/issue.scm
+++ b/guix-qa-frontpage/issue.scm
@@ -23,7 +23,7 @@
#:use-module (ice-9 threads)
#:use-module (prometheus)
#:use-module ((guix-build-coordinator utils)
- #:select (with-time-logging))
+ #:select (with-time-logging call-with-delay-logging))
#:use-module ((guix build syscalls)
#:select (set-thread-name))
#:use-module (fibers)
@@ -213,45 +213,61 @@
#:unwind? #t))
(let* ((base-and-target-refs
- (get-issue-branch-base-and-target-refs
- number))
+ (call-with-delay-logging
+ get-issue-branch-base-and-target-refs
+ #:args (list number)))
(derivation-changes-raw-data
(if base-and-target-refs
(call-with-data-service-error-handling
(lambda ()
- (compare-package-derivations
- (compare-package-derivations-url
- base-and-target-refs
- #:systems %systems-to-submit-builds-for))))
+ (call-with-delay-logging
+ compare-package-derivations
+ #:args
+ (list
+ (compare-package-derivations-url
+ base-and-target-refs
+ #:systems %systems-to-submit-builds-for)))))
#f))
(derivation-changes-data
(if (and derivation-changes-raw-data
(not (assq-ref derivation-changes-raw-data 'exception)))
- (derivation-changes
- derivation-changes-raw-data
- %systems-to-submit-builds-for)
+ (call-with-delay-logging
+ derivation-changes
+ #:args
+ (list
+ derivation-changes-raw-data
+ %systems-to-submit-builds-for))
#f))
(cross-derivation-changes-raw-data
(if base-and-target-refs
(call-with-data-service-error-handling
(lambda ()
- (compare-package-derivations
- (compare-package-cross-derivations-url
- base-and-target-refs
- #:systems %systems-to-submit-builds-for))))
+ (call-with-delay-logging
+ compare-package-derivations
+ #:args
+ (list
+ (compare-package-cross-derivations-url
+ base-and-target-refs
+ #:systems %systems-to-submit-builds-for)))))
#f))
(cross-derivation-changes-data
(if (and cross-derivation-changes-raw-data
(not (assq-ref cross-derivation-changes-raw-data 'exception)))
- (derivation-changes
- cross-derivation-changes-raw-data
- %systems-to-submit-builds-for)
+ (call-with-delay-logging
+ derivation-changes
+ #:args
+ (list
+ cross-derivation-changes-raw-data
+ %systems-to-submit-builds-for))
#f))
(builds-missing?
(if derivation-changes-data
- (builds-missing-for-derivation-changes?
- (assoc-ref derivation-changes-raw-data
- "derivation_changes"))
+ (call-with-delay-logging
+ builds-missing-for-derivation-changes?
+ #:args
+ (list
+ (assoc-ref derivation-changes-raw-data
+ "derivation_changes")))
#t))
(comparison-details
(and
@@ -290,9 +306,11 @@
"query_parameters"))))
`((exception . ,(simple-format #f "~A" exn)))))
(lambda ()
- (revision-comparison
- (revision-comparison-url
- base-and-target-refs)))
+ (call-with-delay-logging
+ revision-comparison
+ #:args (list
+ (revision-comparison-url
+ base-and-target-refs))))
#:unwind? #t))))
(values
@@ -312,6 +330,19 @@
(define frequency
(* 15 60))
+ (define issue-data/fiberized+cached
+ (fiberize
+ (lambda (issue-number)
+ (with-sqlite-cache
+ database
+ 'issue-data
+ issue-data
+ #:args
+ (list issue-number)
+ #:version 3
+ #:ttl (/ frequency 2)))
+ #:parallelism 5))
+
(define (refresh-data)
(simple-format (current-error-port)
"refreshing patch branches data...\n")
@@ -328,6 +359,17 @@
(take latest-series number-of-series-to-refresh)
latest-series)))
+ (for-each
+ (match-lambda
+ ((issue-number . data)
+ (with-sqlite-cache
+ database
+ 'latest-patchwork-series-for-issue
+ (const data)
+ #:args (list issue-number)
+ #:ttl 0)))
+ latest-series)
+
(non-blocking
(lambda ()
(update-repository!)))
@@ -351,14 +393,7 @@
change-details
builds-missing?
comparison-details
- (with-sqlite-cache
- database
- 'issue-data
- issue-data
- #:args
- (list issue-number)
- #:version 3
- #:ttl (/ frequency 2))))
+ (issue-data/fiberized+cached issue-number)))
(with-sqlite-cache
database
@@ -388,7 +423,7 @@
#:args (list issue-number)
#:ttl 0)))
#:unwind? #t)))
- 5
+ 50
series-to-refresh)))
(spawn-fiber
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
index d07a773..8f4c96f 100644
--- a/guix-qa-frontpage/manage-builds.scm
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -45,6 +45,7 @@
"i686-linux"
"aarch64-linux"
"armhf-linux"
+ "riscv64-linux"
"powerpc64le-linux"
"i586-gnu"))
@@ -210,7 +211,7 @@
(lambda (exn)
(simple-format
(current-error-port)
- "exception in submit patch builds thread: ~A\n"
+ "exception in submit patch builds fiber: ~A\n"
exn))
(lambda ()
(with-throw-handler #t
@@ -426,7 +427,9 @@
((name . details)
(->bool (assoc-ref details "issue_number"))))
all-branches)
- 2))
+ ;; TODO The builds for the first branch should be mostly
+ ;; complete before submitting builds for any others
+ 1))
(branch-names
(map car branches)))
@@ -464,7 +467,7 @@
(lambda (exn)
(simple-format
(current-error-port)
- "exception in submit branch builds thread: ~A\n"
+ "exception in submit branch builds fiber: ~A\n"
exn))
(lambda ()
(with-throw-handler #t
diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm
index 16bfbd9..fc389e1 100644
--- a/guix-qa-frontpage/manage-patch-branches.scm
+++ b/guix-qa-frontpage/manage-patch-branches.scm
@@ -127,7 +127,8 @@
(close-pipe pipe)
result))
-(define (create-branch-for-issue database issue-number patchwork-series)
+(define (create-branch-for-issue database latest-processed-master-revision
+ issue-number patchwork-series)
(define branch-name
(simple-format #f "issue-~A" issue-number))
@@ -138,8 +139,7 @@
(let ((branch
(assq-ref patchwork-series 'branch)))
(if (string=? branch "master")
- (get-latest-processed-branch-revision "master")
-
+ latest-processed-master-revision
(with-bare-git-repository
(lambda ()
(invoke "git" "fetch" "--prune" "origin")
@@ -166,14 +166,16 @@
'issue-patches-overall-status
#:args (list issue-number)))
- (define (insert-log results)
+ (define (insert-log base-commit-hash results)
(define log
- (string-join
- (map
- (lambda (patch)
- (assq-ref patch 'output))
- results)
- "\n\n"))
+ (string-append
+ "Using base commit " base-commit-hash "\n\n"
+ (string-join
+ (map
+ (lambda (patch)
+ (assq-ref patch 'output))
+ results)
+ "\n\n")))
(insert-create-branch-for-issue-log database issue-number log))
@@ -193,7 +195,7 @@
(results '()))
(if (null? patch-data)
(begin
- (insert-log results)
+ (insert-log base-commit-hash results)
(if (string=? base-commit-hash
(with-repository (getcwd) repository
@@ -244,7 +246,8 @@
(begin
(simple-format
#t "Failed to apply \"~A.patch\" (~A)\n" id name)
- (insert-log new-results)
+ (insert-log base-commit-hash
+ new-results)
#f)))))))))
(delete-create-branch-for-issue-log database issue-number)
@@ -435,7 +438,9 @@
'latest-patchwork-series-by-issue
latest-patchwork-series-by-issue
#:args `(#:count ,series-count)
- #:ttl 120)))
+ #:ttl 120))
+ (latest-processed-master-revision
+ (get-latest-processed-branch-revision "master")))
(for-each
(match-lambda
((issue-number . patchwork-series)
@@ -478,6 +483,7 @@
(const #t)
(lambda ()
(create-branch-for-issue database
+ latest-processed-master-revision
issue-number
patchwork-series))
#:unwind? #t))))
diff --git a/guix-qa-frontpage/patchwork.scm b/guix-qa-frontpage/patchwork.scm
index 049012f..08bf62f 100644
--- a/guix-qa-frontpage/patchwork.scm
+++ b/guix-qa-frontpage/patchwork.scm
@@ -16,10 +16,13 @@
#:use-module ((guix-build-coordinator utils fibers)
#:select (retry-on-error))
#:use-module (guix-qa-frontpage mumi)
+ #:use-module (guix-qa-frontpage utils)
#:use-module (guix-qa-frontpage debbugs)
#:export (%patchwork-instance
- latest-patchwork-series-by-issue))
+ %patchwork-series-default-count
+ latest-patchwork-series-by-issue
+ latest-patchwork-series-for-issue))
(define %patchwork-instance
(make-parameter "https://patches.guix-patches.cbaines.net"))
@@ -77,12 +80,16 @@
(retry-on-error
(lambda ()
(http-request uri
- #:decode-body? #f))
+ #:port (open-socket-for-uri* uri)
+ #:decode-body? #f
+ #:streaming? #t))
#:times 2
#:delay 3)))
(values
- (json-string->scm (utf8->string body))
+ (let ((json (json->scm body)))
+ (close-port body)
+ json)
(and=> (assq-ref (response-headers response) 'link)
(lambda (link-header)
(and=>
@@ -167,9 +174,12 @@
(assoc-ref first-patch "name"))))
(assq-ref details 'branch)))))
+(define %patchwork-series-default-count
+ (make-parameter #f))
+
(define* (latest-patchwork-series-by-issue
#:key patchwork
- count)
+ (count (%patchwork-series-default-count)))
(define (string->issue-number str)
(string->number
(match:substring
@@ -240,7 +250,10 @@
;; Need more series, so keep going
(let* ((series-batch
next-page-uri
- (request-patchwork-series patchwork-uri))
+ (with-fibers-port-timeouts
+ (lambda ()
+ (request-patchwork-series patchwork-uri))
+ #:timeout 60))
(batch-hash-table
(make-hash-table)))
@@ -320,6 +333,6 @@
series-by-issue-number
mumi-data)))))))
-
-
-
+(define* (latest-patchwork-series-for-issue issue-number #:key patchwork)
+ (assq-ref (latest-patchwork-series-by-issue #:patchwork patchwork)
+ issue-number))
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index ccfa985..a46777a 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -595,13 +595,12 @@
</svg>"))
port)))))
(('GET "issue" number)
- (let ((series (assq-ref (with-sqlite-cache
- database
- 'latest-patchwork-series-by-issue
- latest-patchwork-series-by-issue
- #:args `(#:count ,patch-issues-to-show)
- #:ttl 1800)
- (string->number number))))
+ (let ((series (with-sqlite-cache
+ database
+ 'latest-patchwork-series-for-issue
+ latest-patchwork-series-for-issue
+ #:args (list (string->number number))
+ #:ttl 1800)))
(if series
(let* ((base-and-target-refs
derivation-changes
@@ -825,6 +824,7 @@ has no patches or has been closed.")
database metrics-registry
#:key (controller-args '())
submit-builds?
+ manage-patch-branches?
patch-issues-to-show
generate-reproducible.json)
(define controller
@@ -834,6 +834,11 @@ has no patches or has been closed.")
(when generate-reproducible.json
(start-generate-reproducible.json-thread))
+ (when manage-patch-branches?
+ (start-manage-patch-branches-thread database
+ metrics-registry
+ #:series-count patch-issues-to-show))
+
(let ((finished? (make-condition)))
(call-with-new-thread
(lambda ()
diff --git a/guix-qa-frontpage/utils.scm b/guix-qa-frontpage/utils.scm
index f0b47a9..12610f0 100644
--- a/guix-qa-frontpage/utils.scm
+++ b/guix-qa-frontpage/utils.scm
@@ -21,16 +21,20 @@
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
+ #:use-module (zlib)
#:use-module (fibers)
#:use-module (fibers channels)
- #:use-module ((guix-build-coordinator utils) #:select (with-port-timeouts))
+ #:use-module ((guix-build-coordinator utils) #:select (with-port-timeouts
+ open-socket-for-uri*))
#:use-module (guix-build-coordinator utils fibers)
#:export (fiberize
fibers-map
fibers-batch-for-each
fibers-for-each
- non-blocking)
- #:re-export (with-fibers-port-timeouts))
+ non-blocking
+ call-with-zlib-input-port*)
+ #:re-export (with-fibers-port-timeouts
+ open-socket-for-uri*))
(define* (fiberize proc #:key (parallelism 1))
(let ((channel (make-channel)))
@@ -158,3 +162,21 @@
(apply values results))
(('exception . exn)
(raise-exception exn)))))
+
+(define* (call-with-zlib-input-port* port proc
+ #:key
+ (format 'zlib)
+ (buffer-size %default-buffer-size))
+ "Call PROC with a port that wraps PORT and decompresses data read from it.
+PORT is closed upon completion. The zlib internal buffer size is set to
+BUFFER-SIZE bytes."
+ (let ((zlib (make-zlib-input-port port
+ #:format format
+ #:buffer-size buffer-size
+ #:close? #t)))
+ (call-with-values
+ (lambda ()
+ (proc zlib))
+ (lambda vals
+ (close-port zlib)
+ (apply values vals)))))
diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm
index 4e851f8..57256ea 100644
--- a/guix-qa-frontpage/view/issue.scm
+++ b/guix-qa-frontpage/view/issue.scm
@@ -475,5 +475,5 @@ Guix QA review form submission:"
(uri-encode email-text))))
(b "Open mail client to send review email"))
(p "If the above link doesn't work for you, the contents of the suggested email is given below, and can be sent "
- (strong "to control@debbugs.gnu.org and 66195@debbugs.gnu.org"))
+ (strong "to control@debbugs.gnu.org and " issue-number "@debbugs.gnu.org"))
(pre ,email-text)))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-06-14 07:05:27 +0000