[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/05: Add a page for package output history on a branch
|
From: |
Christopher Baines |
|
Subject: |
02/05: Add a page for package output history on a branch |
|
Date: |
Mon, 23 Mar 2020 05:14:27 -0400 (EDT) |
cbaines pushed a commit to branch master
in repository data-service.
commit 7d2309d3447b1e83e869b39fec3d247a85971f4c
Author: Christopher Baines <address@hidden>
AuthorDate: Sat Mar 21 10:38:20 2020 +0000
Add a page for package output history on a branch
This complements the existing pages for the version history, and derivation
history. As well as the new page, the buttons and styling of the two
existing
pages has been made to match better to enable easier navigation between the
pages.
---
guix-data-service/web/repository/controller.scm | 78 +++++++
guix-data-service/web/repository/html.scm | 261 +++++++++++++++++++++++-
2 files changed, 335 insertions(+), 4 deletions(-)
diff --git a/guix-data-service/web/repository/controller.scm
b/guix-data-service/web/repository/controller.scm
index af77737..f31c41f 100644
--- a/guix-data-service/web/repository/controller.scm
+++ b/guix-data-service/web/repository/controller.scm
@@ -126,6 +126,14 @@
repository-id
branch-name
package-name))
+ (('GET "repository" repository-id "branch" branch-name
+ "package" package-name "output-history")
+ (render-branch-package-output-history request
+ mime-types
+ conn
+ repository-id
+ branch-name
+ package-name))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision")
(let ((commit-hash
(latest-processed-commit-for-branch conn repository-id
branch-name)))
@@ -308,3 +316,73 @@
(valid-targets conn))
build-server-urls
package-derivations)))))))
+
+(define (render-branch-package-output-history request
+ mime-types
+ conn
+ repository-id
+ branch-name
+ package-name)
+ (let ((parsed-query-parameters
+ (parse-query-parameters
+ request
+ `((output ,identity
+ #:default "out")
+ (system ,(parse-build-system conn)
+ #:default "x86_64-linux")
+ (target ,parse-target
+ #:default "")))))
+ (let* ((system
+ (assq-ref parsed-query-parameters 'system))
+ (target
+ (assq-ref parsed-query-parameters 'target))
+ (output-name
+ (assq-ref parsed-query-parameters 'output))
+ (package-outputs
+ (package-outputs-for-branch conn
+ (string->number repository-id)
+ branch-name
+ system
+ target
+ package-name
+ output-name))
+ (build-server-urls
+ (group-to-alist
+ (match-lambda
+ ((id url lookup-all-derivations)
+ (cons id url)))
+ (select-build-servers conn))))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((derivations . ,(list->vector
+ (map (match-lambda
+ ((package-version derivation-file-name
+
first-guix-revision-commit
+ first-datetime
+ last-guix-revision-commit
+ last-datetime)
+ `((version . ,package-version)
+ (derivation . ,derivation-file-name)
+ (first_revision
+ . ((commit .
,first-guix-revision-commit)
+ (datetime . ,first-datetime)))
+ (last_revision
+ . ((commit .
,last-guix-revision-commit)
+ (datetime . ,last-datetime))))))
+ package-outputs))))))
+ (else
+ (render-html
+ #:sxml (view-branch-package-outputs
+ parsed-query-parameters
+ repository-id
+ branch-name
+ package-name
+ output-name
+ (valid-systems conn)
+ (valid-targets->options
+ (valid-targets conn))
+ build-server-urls
+ package-outputs)))))))
diff --git a/guix-data-service/web/repository/html.scm
b/guix-data-service/web/repository/html.scm
index 8f1a6d5..f21a9f2 100644
--- a/guix-data-service/web/repository/html.scm
+++ b/guix-data-service/web/repository/html.scm
@@ -26,7 +26,8 @@
view-branches
view-branch
view-branch-package
- view-branch-package-derivations))
+ view-branch-package-derivations
+ view-branch-package-outputs))
(define* (view-git-repositories git-repositories)
(layout
@@ -198,7 +199,7 @@
#:body
`(,(header)
(div
- (@ (class "container"))
+ (@ (class "container-fluid"))
(div
(@ (class "row"))
(div
@@ -208,9 +209,23 @@
(a (@ (href ,(string-append "/repository/" git-repository-id
"/branch/" branch-name)))
(h3 ,(string-append branch-name " branch")))
+ (a (@ (class "btn btn-default btn-lg pull-right")
+ (style "margin-left: 0.5em;")
+ (href ,(string-append
+ "/repository/" git-repository-id
+ "/branch/" branch-name
+ "/package/" package-name
+ ".json")))
+ "View JSON")
(div
(@ (class "btn-group pull-right")
(role "group"))
+ (a (@ (class "btn btn-default btn-lg disabled")
+ (href ,(string-append
+ "/repository/" git-repository-id
+ "/branch/" branch-name
+ "/package/" package-name)))
+ "Versions only")
(a (@ (class "btn btn-default btn-lg")
(href ,(string-append
"/repository/" git-repository-id
@@ -223,8 +238,8 @@
"/repository/" git-repository-id
"/branch/" branch-name
"/package/" package-name
- ".json")))
- "View JSON"))
+ "/output-history")))
+ "Include outputs"))
(h1 (@ (style "white-space: nowrap;"))
(samp ,package-name))))
(div
@@ -361,12 +376,36 @@
"/branch/" branch-name)))
(h3 ,(string-append branch-name " branch")))
(a (@ (class "btn btn-default btn-lg pull-right")
+ (style "margin-left: 0.5em;")
(href ,(string-append
"/repository/" git-repository-id
"/branch/" branch-name
"/package/" package-name
"/derivation-history.json")))
"View JSON")
+ (div
+ (@ (class "btn-group pull-right")
+ (role "group"))
+ (a (@ (class "btn btn-default btn-lg")
+ (href ,(string-append
+ "/repository/" git-repository-id
+ "/branch/" branch-name
+ "/package/" package-name)))
+ "Versions only")
+ (a (@ (class "btn btn-default btn-lg disabled")
+ (href ,(string-append
+ "/repository/" git-repository-id
+ "/branch/" branch-name
+ "/package/" package-name
+ "/derivation-history")))
+ "Include derivations")
+ (a (@ (class "btn btn-default btn-lg")
+ (href ,(string-append
+ "/repository/" git-repository-id
+ "/branch/" branch-name
+ "/package/" package-name
+ "/output-history")))
+ "Include outputs"))
(h1 (@ (style "white-space: nowrap;"))
(samp ,package-name))))
(div
@@ -528,3 +567,217 @@
(map second
(cdr derivations-by-revision-range))
'(#f))))))))))))
+
+(define (view-branch-package-outputs query-parameters
+ git-repository-id
+ branch-name
+ package-name
+ output-name
+ valid-systems
+ valid-targets
+ build-server-urls
+ outputs-by-revision-range)
+ (define versions-list
+ (pair-fold (match-lambda*
+ (((last) (count result ...))
+ (cons (cons last count)
+ result))
+ (((a b rst ...) (count result ...))
+ (if (string=? a b)
+ (cons (+ 1 count)
+ (cons #f result))
+ (cons 1
+ (cons (cons a count)
+ result)))))
+ '(1)
+ (reverse
+ (map first outputs-by-revision-range))))
+
+ (layout
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container-fluid"))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (a (@ (href ,(string-append "/repository/" git-repository-id)))
+ (h3 "Repository"))
+ (a (@ (href ,(string-append "/repository/" git-repository-id
+ "/branch/" branch-name)))
+ (h3 ,(string-append branch-name " branch")))
+ (a (@ (class "btn btn-default btn-lg pull-right")
+ (style "margin-left: 0.5em;")
+ (href ,(string-append
+ "/repository/" git-repository-id
+ "/branch/" branch-name
+ "/package/" package-name
+ "/output-history.json")))
+ "View JSON")
+ (div
+ (@ (class "btn-group pull-right")
+ (role "group"))
+ (a (@ (class "btn btn-default btn-lg")
+ (href ,(string-append
+ "/repository/" git-repository-id
+ "/branch/" branch-name
+ "/package/" package-name)))
+ "Versions only")
+ (a (@ (class "btn btn-default btn-lg")
+ (href ,(string-append
+ "/repository/" git-repository-id
+ "/branch/" branch-name
+ "/package/" package-name
+ "/derivation-history")))
+ "Include derivations")
+ (a (@ (class "btn btn-default btn-lg disabled")
+ (href ,(string-append
+ "/repository/" git-repository-id
+ "/branch/" branch-name
+ "/package/" package-name
+ "/output-history")))
+ "Include outputs"))
+ (h1 (@ (style "white-space: nowrap;"))
+ (samp ,package-name))))
+ (div
+ (@ (class "col-md-12"))
+ (div
+ (@ (class "well"))
+ (form
+ (@ (method "get")
+ (action "")
+ (class "form-horizontal"))
+ ,(form-horizontal-control
+ "Output" query-parameters
+ #:help-text "Show this output for the package.")
+ ,(form-horizontal-control
+ "System" query-parameters
+ #:options valid-systems
+ #:allow-selecting-multiple-options #f
+ #:help-text "Show derivations with this system.")
+ ,(form-horizontal-control
+ "Target" query-parameters
+ #:options valid-targets
+ #:allow-selecting-multiple-options #f
+ #:help-text "Show derivations with this target.")
+ (div (@ (class "form-group form-group-lg"))
+ (div (@ (class "col-sm-offset-2 col-sm-10"))
+ (button (@ (type "submit")
+ (class "btn btn-lg btn-primary"))
+ "Update results"))))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (table
+ (@ (class "table")
+ (style "table-layout: fixed;"))
+ (thead
+ (tr
+ (th (@ (class "col-sm-1")) "Version")
+ (th (@ (class "col-sm-6")) "Output")
+ (th (@ (class "col-sm-2")) "Builds")
+ (th (@ (class "col-sm-2")) "From")
+ (th (@ (class "col-sm-2")) "To")))
+ (tbody
+ ,@(let* ((times-in-seconds
+ (map (lambda (d)
+ (time-second
+ (date->time-monotonic
+ (string->date d "~Y-~m-~d ~H:~M:~S"))))
+ (append (map fourth outputs-by-revision-range)
+ (map sixth outputs-by-revision-range))))
+ (earliest-date-seconds
+ (apply min
+ times-in-seconds))
+ (latest-date-seconds
+ (apply max
+ times-in-seconds))
+ (min-to-max-seconds
+ (- latest-date-seconds
+ earliest-date-seconds)))
+ (map
+ (match-lambda*
+ ((version-column-entry
+ (package-version output-path
+ first-guix-revision-commit
+ first-datetime
+ last-guix-revision-commit
+ last-datetime
+ builds))
+ `((tr
+ (@ (style "border-bottom: 0;"))
+ ,@(match version-column-entry
+ (#f '())
+ ((package-version . rowspan)
+ `((td (@ (rowspan ,(* 2 ; To account for the extra
rows
+ rowspan)))
+ ,package-version))))
+ (td
+ (a (@ (href ,output-path))
+ ,(display-store-item output-path)))
+ (td
+ (dl
+ ,@(append-map
+ (lambda (build)
+ (let ((build-server-id
+ (assoc-ref build "build_server_id")))
+ `((dt
+ (@ (style "font-weight: unset;"))
+ (a (@ (href
+ ,(assq-ref build-server-urls
+ build-server-id)))
+ ,(assq-ref build-server-urls
+ build-server-id)))
+ (dd
+ (a (@ (href
+ ,(simple-format
+ #f
"/build-server/~A/build?derivation_file_name=~A"
+ build-server-id
+ (assoc-ref build
"derivation_file_name"))))
+ ,(build-status-alist->build-icon
build))))))
+ builds)))
+ (td (a (@ (href ,(string-append
+ "/revision/"
first-guix-revision-commit)))
+ ,first-datetime))
+ (td (a (@ (href ,(string-append
+ "/revision/"
last-guix-revision-commit)))
+ ,last-datetime)))
+ (tr
+ (td
+ (@ (colspan 4)
+ (style "border-top: 0; padding-top: 0;"))
+ (div
+ (@
+ (style
+ ,(let* ((start-seconds
+ (time-second
+ (date->time-monotonic
+ (string->date first-datetime
+ "~Y-~m-~d ~H:~M:~S"))))
+ (end-seconds
+ (time-second
+ (date->time-monotonic
+ (string->date last-datetime
+ "~Y-~m-~d ~H:~M:~S"))))
+ (margin-left
+ (min
+ (* (/ (- start-seconds
earliest-date-seconds)
+ min-to-max-seconds)
+ 100)
+ 98))
+ (width
+ (max
+ (- (* (/ (- end-seconds
earliest-date-seconds)
+ min-to-max-seconds)
+ 100)
+ margin-left)
+ 2)))
+ (simple-format
+ #f
+ "margin-left: ~A%; width: ~A%; height: 10px;
background: #DCDCDC;"
+ (rationalize margin-left 1)
+ (rationalize width 1)))))))))))
+ versions-list
+ outputs-by-revision-range))))))))))