(define-module (guix-qa-frontpage view branch) #:use-module (srfi srfi-1) #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module ((guix-data-service model utils) #:select (group-to-alist)) #:use-module (guix-qa-frontpage manage-builds) #:use-module (guix-qa-frontpage derivation-changes) #:use-module (guix-qa-frontpage view util) #:use-module (guix-qa-frontpage view shared) #:export (branch-view branch-package-changes-view master-branch-view)) (define (branch-view branch revisions derivation-changes substitute-availability package-reproducibility up-to-date-with-master master-branch-systems-with-low-substitute-availability) (define derivation-changes-counts (if (assq-ref derivation-changes 'exception) derivation-changes (assq-ref derivation-changes 'counts))) (layout #:title (simple-format #f "Branch ~A" branch) #:head '((style " td.good { padding: 0.05rem 0.65rem; font-weight: bold; border: 0.3rem dashed green; } td.bad { padding: 0.05rem 0.65rem; font-weight: bold; border: 0.3rem dashed red; }")) #:body `((main (div (@ (class "large-screen-float-right")) (h3 "Links") (ul (li (a (@ (href ,(simple-format #f "~A/log/?h=~A&qt=range&q=~A..~A" "https://git.savannah.gnu.org/cgit/guix.git" branch (assq-ref revisions 'base) (assq-ref revisions 'target)))) "View Git branch")) (li (a (@ (href ,(simple-format #f "https://data.qa.guix.gnu.org/repository/2/branch/~A" branch))) "View branch with Guix Data Service")))) ,@(cond ((assq-ref up-to-date-with-master 'exception) (let ((base-commit-err (assq-ref (assoc-ref (assq-ref up-to-date-with-master 'invalid_query_parameters) "base_commit") 'error)) (target-commit-err (assq-ref (assoc-ref (assq-ref up-to-date-with-master 'invalid_query_parameters) "target_commit") 'error))) `((p (@ (style ,(string-join '("text-align: center;" "font-weight: bold;" "padding: 1rem;" "max-width: 46rem;" "border-width: 0.35em;" "border-style: dashed;" "border-color: red")))) ,@(cond ((member base-commit-err '(unknown-commit failed-to-process-revision yet-to-process-revision)) `("Unable to check changes between " branch " and master." (br) (a (@ (href ,(string-append "https://data.qa.guix.gnu.org/revision/" (assq-ref revisions 'base)))) "Merge base") ,(cond ((eq? base-commit-err 'unknown-commit) " is not a commit known to the data service.") ((eq? base-commit-err 'failed-to-process-revision) " was not processed successfully by the data service.") ((eq? base-commit-err 'yet-to-process-revision) " has not be processed by the data service yet.")))) (else `("Exception checking changes between " (a (@ (href ,(string-append "https://data.qa.guix.gnu.org/revision/" (assq-ref revisions 'base)))) "merge base") " and master."))))))) ((assq-ref up-to-date-with-master 'up-to-date?) '()) (else `((p (@ (style ,(string-join '("text-align: center;" "font-weight: bold;" "padding: 1rem;" "max-width: 46rem;" "border-width: 0.35em;" "border-style: dashed;" "border-color: red")))) "Too many changes (" ,(assq-ref up-to-date-with-master 'changes) " for " (span (@ (style "font-family: monospace;")) "x86_64-linux") ") between " (a (@ (href ,(string-append "https://data.qa.guix.gnu.org/revision/" (assq-ref revisions 'base)))) "merge base") " and master, this branch should be rebased or master merged in.")))) (h2 "Substitute availability") (div ,@(if substitute-availability (map (lambda (details) `(table (thead (tr (th (@ (colspan 3)) ,(assoc-ref (assoc-ref details "server") "url")))) (tbody ,@(map (lambda (system-and-target-details) (let* ((ratio (/ (assoc-ref system-and-target-details "known") (+ (assoc-ref system-and-target-details "known") (assoc-ref system-and-target-details "unknown")))) (color (cond ((> ratio 0.80) "green") ((< ratio 0.50) "red") (else "orange"))) (symbol (cond ((> ratio 0.80) '(*ENTITY* "#9788")) ((< ratio 0.50) '(*ENTITY* "#9729")) (else '(*ENTITY* "#9925"))))) `(tr (td (@ (style "font-family: monospace;")) ,(assoc-ref system-and-target-details "system")) (td ,(format #f "~,1f%" (* 100. ratio))) (td (@ (style ,(string-append "color: black;" (if color (simple-format #f "background-color: ~A;" color) "")))) ,symbol)))) (filter (lambda (details) (string-null? (assoc-ref details "target"))) (vector->list (assoc-ref details "availability"))))))) (vector->list substitute-availability)) '("Information unavailable"))) (h2 "Packages") ,@(if (or (null? master-branch-systems-with-low-substitute-availability) (not derivation-changes-counts) (assq-ref derivation-changes-counts 'exception) (null? derivation-changes-counts)) '() `((p (@ (style ,(string-join '("text-align: center;" "font-weight: bold;" "padding: 1rem;" "max-width: 46rem;" "border-width: 0.35em;" "border-style: dashed;" "border-color: red")))) "Submitting builds for this branch suspended as " (a (@ (href "/branch/master")) "master branch substitute availability") " is low for: " ,@(append-map (lambda (system) `((span (@ (style "font-family: monospace; white-space: nowrap;")) ,system " "))) master-branch-systems-with-low-substitute-availability)))) (div ,(package-changes-summary-table revisions derivation-changes-counts (string-append "/branch/" branch) %systems-to-submit-builds-for)) (h2 "Package reproducibility") (div ,(if package-reproducibility (package-reproducibility-table package-reproducibility) "Information unavailable")))))) (define* (delete-duplicates/sort! unsorted-lst less #:key (eq eq?)) (if (null? unsorted-lst) unsorted-lst (let ((sorted-lst (sort! unsorted-lst less))) (let loop ((lst (cdr sorted-lst)) (last-element (car sorted-lst)) (result (list (car sorted-lst)))) (if (null? lst) result (let ((current-element (car lst))) (if (eq current-element last-element) (loop (cdr lst) last-element result) (loop (cdr lst) current-element (cons current-element result))))))))) (define (branch-package-changes-view branch revisions derivation-changes up-to-date-with-master query-parameters) (package-changes-view (simple-format #f "Branch ~A" branch) derivation-changes query-parameters)) (define (master-branch-view substitute-availability package-reproducibility) (layout #:title "Branch master" #:body `((main (h2 "Substitute availability") (div ,@(map (lambda (details) `(table (thead (tr (th (@ (colspan 3)) ,(assoc-ref (assoc-ref details "server") "url")))) (tbody ,@(map (lambda (system-and-target-details) (let* ((ratio (/ (assoc-ref system-and-target-details "known") (+ (assoc-ref system-and-target-details "known") (assoc-ref system-and-target-details "unknown")))) (color (cond ((> ratio 0.80) "green") ((< ratio 0.50) "red") (else "orange"))) (symbol (cond ((> ratio 0.80) '(*ENTITY* "#9788")) ((< ratio 0.50) '(*ENTITY* "#9729")) (else '(*ENTITY* "#9925"))))) `(tr (td (@ (style "font-family: monospace;")) ,(assoc-ref system-and-target-details "system")) (td ,(format #f "~,1f%" (* 100. ratio))) (td (@ (style ,(string-append "color: black;" (if color (simple-format #f "background-color: ~A;" color) "")))) ,symbol)))) (filter (lambda (details) (string-null? (assoc-ref details "target"))) (vector->list (assoc-ref details "availability"))))))) (vector->list substitute-availability))) (h2 "Package reproducibility") (div ,(package-reproducibility-table package-reproducibility))))))