diff options
| -rw-r--r-- | guix-data-service/web/controller.scm | 97 | ||||
| -rw-r--r-- | guix-data-service/web/view/html.scm | 54 |
2 files changed, 107 insertions, 44 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 76b6a59..9ef0554 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -92,9 +92,12 @@ target-commit (commit->revision-id conn target-commit)))) -(define (render-view-revision mime-types - conn - commit-hash) +(define* (render-view-revision mime-types + conn + commit-hash + #:key path-base + (header-text + `("Revision " (samp ,commit-hash)))) (let ((packages-count (count-packages-in-revision conn commit-hash)) (git-repositories-and-branches @@ -121,7 +124,9 @@ commit-hash packages-count git-repositories-and-branches - derivations-counts) + derivations-counts + #:path-base path-base + #:header-text header-text) #:extra-headers http-headers-for-unchanging-content))))) (define (texinfo->variants-alist s) @@ -148,10 +153,16 @@ (select-job-for-commit conn commit-hash)))))) -(define (render-revision-packages mime-types - conn - commit-hash - query-parameters) +(define* (render-revision-packages mime-types + conn + commit-hash + query-parameters + #:key + (path-base "/revision/") + (header-text + `("Revision " (samp ,commit-hash))) + (header-link + (string-append "/revision/" commit-hash))) (if (any-invalid-query-parameters? query-parameters) (case (most-appropriate-mime-type '(application/json text/html) @@ -238,14 +249,24 @@ query-parameters packages git-repositories - show-next-page?) + show-next-page? + #:path-base path-base + #:header-text header-text + #:header-link header-link) #:extra-headers http-headers-for-unchanging-content)))))) -(define (render-revision-package mime-types - conn - commit-hash - name - version) +(define* (render-revision-package mime-types + conn + commit-hash + name + version + #:key + (header-text + `("Revision " + (samp ,commit-hash))) + (header-link + (string-append + "/revision/" commit-hash))) (let ((metadata (select-package-metadata-by-revision-name-and-version conn @@ -288,7 +309,9 @@ version metadata derivations - git-repositories) + git-repositories + #:header-text header-text + #:header-link header-link) #:extra-headers http-headers-for-unchanging-content))))) (define (render-compare-unknown-commit mime-types @@ -586,6 +609,9 @@ uri-query parse-query-string)) + (define path + (uri-path (request-uri request))) + (match method-and-path-components ((GET) (render-html @@ -617,7 +643,8 @@ ((GET "revision" commit-hash) (if (guix-commit-exists? conn commit-hash) (render-view-revision mime-types conn - commit-hash) + commit-hash + #:path-base path) (render-unknown-revision mime-types conn commit-hash))) @@ -643,7 +670,8 @@ (render-revision-packages mime-types conn commit-hash - parsed-query-parameters)) + parsed-query-parameters + #:path-base path)) (render-unknown-revision mime-types conn commit-hash))) @@ -688,7 +716,11 @@ (if commit-hash (render-view-revision mime-types conn - commit-hash) + commit-hash + #:path-base path + #:header-text + `("Latest processed revision for branch " + (samp ,branch-name))) (render-unknown-revision mime-types conn commit-hash)))) @@ -716,7 +748,34 @@ (render-revision-packages mime-types conn commit-hash - parsed-query-parameters)) + parsed-query-parameters + #:path-base path + #:header-text + `("Latest processed revision for branch " + (samp ,branch-name)) + #:header-link + (string-append + "/branch/" branch-name + "/latest-processed-revision"))) + (render-unknown-revision mime-types + conn + commit-hash)))) + ((GET "branch" branch-name "latest-processed-revision" "package" name version) + (let ((commit-hash + (latest-processed-commit-for-branch conn branch-name))) + (if commit-hash + (render-revision-package mime-types + conn + commit-hash + name + version + #:header-text + `("Latest processed revision for branch " + (samp ,branch-name)) + #:header-link + (string-append + "/branch/" branch-name + "/latest-processed-revision")) (render-unknown-revision mime-types conn commit-hash)))) diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 61a24f2..5373ad7 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -316,9 +316,11 @@ (style "font-size: 2em; display: block;")) ,derivations-count))))))) -(define (view-revision-package-and-version revision-commit-hash name version - package-metadata - derivations git-repositories) +(define* (view-revision-package-and-version revision-commit-hash name version + package-metadata + derivations git-repositories + #:key header-text + header-link) (layout #:body `(,(header) @@ -328,9 +330,8 @@ (@ (class "row")) (div (@ (class "col-sm-12")) - (h3 (a (@ (href ,(string-append - "/revision/" revision-commit-hash))) - "Revision " (samp ,revision-commit-hash))))) + (h3 (a (@ (href ,header-link)) + ,@header-text)))) (div (@ (class "row")) (div @@ -405,8 +406,10 @@ (td ,(build-status-span status))))) derivations))))))))) -(define (view-revision commit-hash packages-count - git-repositories-and-branches derivations-count) +(define* (view-revision commit-hash packages-count + git-repositories-and-branches derivations-count + #:key (path-base "/revision/") + header-text) (layout #:body `(,(header) @@ -417,17 +420,16 @@ (div (@ (class "col-md-12")) (h1 (@ (style "white-space: nowrap;")) - "Revision " (samp ,commit-hash)))) + ,@header-text))) (div (@ (class "row")) (div (@ (class "col-md-6")) - (h3 "Packages") + (h2 "Packages") (strong (@ (class "text-center") (style "font-size: 2em; display: block;")) ,packages-count) - (a (@ (href ,(string-append "/revision/" commit-hash - "/packages"))) + (a (@ (href ,(string-append path-base "/packages"))) "View packages") ,@(if @@ -476,11 +478,13 @@ (td (samp ,count)))))) derivations-count))))))))) -(define (view-revision-packages revision-commit-hash - query-parameters - packages - git-repositories - show-next-page?) +(define* (view-revision-packages revision-commit-hash + query-parameters + packages + git-repositories + show-next-page? + #:key path-base + header-text header-link) (define field-options (map (lambda (field) @@ -499,9 +503,9 @@ (@ (class "row")) (div (@ (class "col-sm-12")) - (h3 (a (@ (href ,(string-append - "/revision/" revision-commit-hash))) - "Revision " (samp ,revision-commit-hash))))) + (h3 (a (@ (style "white-space: nowrap;") + (href ,header-link)) + ,@header-text)))) (div (@ (class "row")) (div @@ -546,7 +550,7 @@ (href ,(let ((query-parameter-string (query-parameters->string query-parameters))) (string-append - "/revision/" revision-commit-hash "/packages.json" + path-base ".json" (if (string-null? query-parameter-string) "" (string-append "?" query-parameter-string)))))) @@ -628,20 +632,20 @@ '()) (td (@ (class "text-right")) (a (@ (href ,(string-append - "/revision/" revision-commit-hash - "/package/" name "/" version))) + (string-drop-right path-base 1) + "/" name "/" version))) "More information"))))) packages)))))) ,@(if show-next-page? `((div (@ (class "row")) - (a (@ (href ,(string-append "/revision/" revision-commit-hash + (a (@ (href ,(string-append path-base revision-commit-hash "/packages?after_name=" (car (last packages))))) "Next page"))) '()))))) -(define (view-branches branches-with-most-recent-commits) +(define* (view-branches branches-with-most-recent-commits) (layout #:body `(,(header) |