diff options
| -rw-r--r-- | guix-qa-frontpage/guix-data-service.scm | 17 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-patch-branches.scm | 9 | ||||
| -rw-r--r-- | guix-qa-frontpage/server.scm | 119 | ||||
| -rw-r--r-- | scripts/guix-qa-frontpage.in | 17 |
4 files changed, 89 insertions, 73 deletions
diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm index 427fd2f..92ec1a2 100644 --- a/guix-qa-frontpage/guix-data-service.scm +++ b/guix-qa-frontpage/guix-data-service.scm @@ -70,16 +70,13 @@ (alist-delete "derivation_changes" json-body))))))) -(define* (patch-series-compare-url issue-number #:key (json? #t)) - (and=> - (get-issue-branch-base-and-target-refs issue-number) - (lambda (base-and-target) - (string-append - "https://data.qa.guix.gnu.org/compare" - (if json? ".json" "") - "?" - "base_commit=" (assq-ref base-and-target 'base) - "&target_commit=" (assq-ref base-and-target 'target))))) +(define* (patch-series-compare-url base-and-target-refs #:key (json? #t)) + (string-append + "https://data.qa.guix.gnu.org/compare" + (if json? ".json" "") + "?" + "base_commit=" (assq-ref base-and-target-refs 'base) + "&target_commit=" (assq-ref base-and-target-refs 'target))) (define (patch-series-comparison url) (retry-on-error diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm index 2a0c289..f1d26b1 100644 --- a/guix-qa-frontpage/manage-patch-branches.scm +++ b/guix-qa-frontpage/manage-patch-branches.scm @@ -54,10 +54,10 @@ (define (get-issue-branch-base-and-target-refs issue) (define base-tag - (simple-format #f "base-for-issue-~A" issue)) + (string-append "base-for-issue-" (number->string issue))) (define target-branch - (simple-format #f "patches/issue-~A" issue)) + (string-append "patches/issue-" (number->string issue))) (let ((base (get-commit base-tag)) (target (get-commit target-branch))) @@ -241,7 +241,10 @@ (string->number issue-number))) (comparison-url (and series - (patch-series-compare-url issue-number)))) + (and=> + (get-issue-branch-base-and-target-refs + issue-number) + patch-series-compare-url)))) (with-exception-handler (lambda (exn) (if (and diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm index 89d7941..fe3d344 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -314,62 +314,74 @@ #:ttl 1200) (string->number number)))) (if series - (let ((derivation-changes - change-details - (call-with-values - (lambda () - (and=> - (get-issue-branch-base-and-target-refs number) - (lambda (base-and-target-refs) - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception fetching derivation changes: ~A\n" - exn) - - (values #f #f)) - (lambda () - (with-sqlite-cache - database - 'derivation-changes - patch-series-derivation-changes - #:args - (list - (patch-series-derivation-changes-url - base-and-target-refs - #:systems %systems-to-submit-builds-for)) - #:ttl 6000)) - #:unwind? #t)))) - (lambda res - (match res - ((#f) - (values #f #f)) - (_ (apply values res)))))) - (comparison-details - (and=> - (patch-series-compare-url number) - (lambda (url) - (with-exception-handler - (lambda (exn) - (if (guix-data-service-error? exn) - exn - (raise-exception exn))) + (let* ((derivation-changes + change-details + (call-with-values (lambda () - (with-sqlite-cache - database - 'lint-warnings - patch-series-comparison - #:args - (list url) - #:ttl 6000)) - #:unwind? #t))))) + (and=> + (with-sqlite-cache + database + 'issue-branch-base-and-target-refs + get-issue-branch-base-and-target-refs + #:args (list (string->number number)) + #:ttl 1200) + (lambda (base-and-target-refs) + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "exception fetching derivation changes: ~A\n" + exn) + + (values #f #f)) + (lambda () + (with-sqlite-cache + database + 'derivation-changes + patch-series-derivation-changes + #:args + (list + (patch-series-derivation-changes-url + base-and-target-refs + #:systems %systems-to-submit-builds-for)) + #:ttl 6000)) + #:unwind? #t)))) + (lambda res + (match res + ((#f) + (values #f #f)) + (_ (apply values res)))))) + (base-and-target-refs + (get-issue-branch-base-and-target-refs + (string->number number))) + (comparison-details + (and=> + base-and-target-refs + (lambda (base-and-target-refs) + (with-exception-handler + (lambda (exn) + (if (guix-data-service-error? exn) + exn + (raise-exception exn))) + (lambda () + (with-sqlite-cache + database + 'lint-warnings + patch-series-comparison + #:args + (list (patch-series-compare-url + base-and-target-refs)) + #:ttl 6000)) + #:unwind? #t))))) (render-html #:sxml (issue-view number series (assq-ref (assq-ref series 'mumi) 'tags) - (patch-series-compare-url number #:json? #f) + (and base-and-target-refs + (patch-series-compare-url + base-and-target-refs + #:json? #f)) derivation-changes change-details comparison-details))) @@ -478,7 +490,12 @@ port. Also, the port used can be changed by passing the --port option.\n" #f) (lambda () (and=> - (get-issue-branch-base-and-target-refs (car series)) + (with-sqlite-cache + database + 'issue-branch-base-and-target-refs + get-issue-branch-base-and-target-refs + #:args (list (car series)) + #:ttl 1200) (lambda (base-and-target-refs) (with-sqlite-cache database diff --git a/scripts/guix-qa-frontpage.in b/scripts/guix-qa-frontpage.in index 7c4e42e..9debaf7 100644 --- a/scripts/guix-qa-frontpage.in +++ b/scripts/guix-qa-frontpage.in @@ -112,15 +112,14 @@ (assq-ref opts 'host) (assq-ref opts 'port)) - (let* ((metrics-registry (make-metrics-registry - #:namespace - "guixqafrontpage")) - (database - (setup-database (assq-ref opts 'database) - metrics-registry))) - - (parameterize - ((%git-repository-location (string-append (getcwd) "/guix.git"))) + (parameterize + ((%git-repository-location (string-append (getcwd) "/guix.git"))) + (let* ((metrics-registry (make-metrics-registry + #:namespace + "guixqafrontpage")) + (database + (setup-database (assq-ref opts 'database) + metrics-registry))) (start-refresh-data-thread database) |