mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
Continue improving pages and linking things together
This commit is contained in:
parent
0380c84a67
commit
a1e481cc4d
|
@ -2,6 +2,7 @@
|
||||||
#:use-module (squee)
|
#:use-module (squee)
|
||||||
#:export (select-build-stats
|
#:export (select-build-stats
|
||||||
select-builds-with-context
|
select-builds-with-context
|
||||||
|
select-builds-with-context-by-derivation-id
|
||||||
select-build-by-build-server-and-id
|
select-build-by-build-server-and-id
|
||||||
insert-build
|
insert-build
|
||||||
ensure-build-exists))
|
ensure-build-exists))
|
||||||
|
@ -42,6 +43,25 @@
|
||||||
|
|
||||||
(exec-query conn query))
|
(exec-query conn query))
|
||||||
|
|
||||||
|
(define (select-builds-with-context-by-derivation-id conn derivation-id)
|
||||||
|
(define query
|
||||||
|
(string-append
|
||||||
|
"SELECT builds.id, build_servers.url, "
|
||||||
|
"latest_build_status.status_fetched_at, latest_build_status.starttime, "
|
||||||
|
"latest_build_status.stoptime, latest_build_status.status "
|
||||||
|
"FROM builds "
|
||||||
|
"INNER JOIN build_servers ON build_servers.id = builds.build_server_id "
|
||||||
|
"INNER JOIN "
|
||||||
|
"(SELECT DISTINCT ON (internal_build_id) * "
|
||||||
|
"FROM build_status "
|
||||||
|
"ORDER BY internal_build_id, status_fetched_at DESC"
|
||||||
|
") AS latest_build_status "
|
||||||
|
"ON latest_build_status.internal_build_id = builds.internal_id "
|
||||||
|
"WHERE builds.derivation_id = $1 "
|
||||||
|
"ORDER BY latest_build_status.status_fetched_at DESC "))
|
||||||
|
|
||||||
|
(exec-query conn query (list derivation-id)))
|
||||||
|
|
||||||
(define (select-build-by-build-server-and-id
|
(define (select-build-by-build-server-and-id
|
||||||
conn build-server-id id)
|
conn build-server-id id)
|
||||||
(exec-query conn
|
(exec-query conn
|
||||||
|
|
|
@ -9,6 +9,8 @@
|
||||||
#:use-module (guix-data-service model utils)
|
#:use-module (guix-data-service model utils)
|
||||||
#:export (select-derivation-by-file-name
|
#:export (select-derivation-by-file-name
|
||||||
select-derivation-outputs-by-derivation-id
|
select-derivation-outputs-by-derivation-id
|
||||||
|
select-derivation-by-output-filename
|
||||||
|
select-derivations-using-output
|
||||||
select-derivation-inputs-by-derivation-id
|
select-derivation-inputs-by-derivation-id
|
||||||
select-existing-derivations
|
select-existing-derivations
|
||||||
select-derivations-by-id
|
select-derivations-by-id
|
||||||
|
@ -34,6 +36,32 @@
|
||||||
",")
|
",")
|
||||||
")"))
|
")"))
|
||||||
|
|
||||||
|
(define (select-derivation-by-output-filename conn filename)
|
||||||
|
(define query
|
||||||
|
(string-append
|
||||||
|
"SELECT derivations.file_name, derivation_outputs.id "
|
||||||
|
"FROM derivation_output_details "
|
||||||
|
"INNER JOIN derivation_outputs"
|
||||||
|
" ON derivation_output_details.id = derivation_outputs.derivation_output_details_id "
|
||||||
|
"INNER JOIN derivations"
|
||||||
|
" ON derivation_outputs.derivation_id = derivations.id "
|
||||||
|
"WHERE derivation_output_details.path = $1"))
|
||||||
|
|
||||||
|
(exec-query conn query (list filename)))
|
||||||
|
|
||||||
|
(define (select-derivations-using-output conn output-id)
|
||||||
|
(define query
|
||||||
|
(string-append
|
||||||
|
"SELECT derivations.file_name "
|
||||||
|
"FROM derivations "
|
||||||
|
"INNER JOIN derivation_inputs"
|
||||||
|
" ON derivation_inputs.derivation_id = derivations.id "
|
||||||
|
"WHERE derivation_output_id = $1 "
|
||||||
|
"ORDER BY derivations.file_name "
|
||||||
|
"LIMIT 100 "))
|
||||||
|
|
||||||
|
(exec-query conn query (list output-id)))
|
||||||
|
|
||||||
(define (insert-derivation-outputs conn
|
(define (insert-derivation-outputs conn
|
||||||
derivation-id
|
derivation-id
|
||||||
names-and-derivation-outputs)
|
names-and-derivation-outputs)
|
||||||
|
|
|
@ -210,17 +210,31 @@
|
||||||
(first derivation)))
|
(first derivation)))
|
||||||
(derivation-outputs (select-derivation-outputs-by-derivation-id
|
(derivation-outputs (select-derivation-outputs-by-derivation-id
|
||||||
conn
|
conn
|
||||||
(first derivation))))
|
(first derivation)))
|
||||||
|
(builds (select-builds-with-context-by-derivation-id
|
||||||
|
conn
|
||||||
|
(first derivation))))
|
||||||
(apply render-html
|
(apply render-html
|
||||||
(view-derivation derivation
|
(view-derivation derivation
|
||||||
derivation-inputs
|
derivation-inputs
|
||||||
derivation-outputs)))
|
derivation-outputs
|
||||||
|
builds)))
|
||||||
#f ;; TODO
|
#f ;; TODO
|
||||||
)))
|
)))
|
||||||
|
|
||||||
(define (render-store-item conn filename)
|
(define (render-store-item conn filename)
|
||||||
(apply render-html
|
(let ((derivation (select-derivation-by-output-filename conn filename)))
|
||||||
(view-store-item filename)))
|
(match derivation
|
||||||
|
(()
|
||||||
|
#f)
|
||||||
|
((derivation)
|
||||||
|
(apply render-html
|
||||||
|
(view-store-item filename
|
||||||
|
derivation
|
||||||
|
(match derivation
|
||||||
|
((file-name output-id rest ...)
|
||||||
|
(select-derivations-using-output
|
||||||
|
conn output-id)))))))))
|
||||||
|
|
||||||
(define (controller request body conn)
|
(define (controller request body conn)
|
||||||
(match-lambda
|
(match-lambda
|
||||||
|
@ -237,6 +251,11 @@
|
||||||
(view-revision commit-hash
|
(view-revision commit-hash
|
||||||
(select-packages-in-revision conn
|
(select-packages-in-revision conn
|
||||||
commit-hash))))
|
commit-hash))))
|
||||||
|
((GET "revision" commit-hash "package" name version)
|
||||||
|
(apply render-html
|
||||||
|
(view-revision-package-and-version commit-hash
|
||||||
|
name
|
||||||
|
version)))
|
||||||
((GET "gnu" "store" filename)
|
((GET "gnu" "store" filename)
|
||||||
(if (string-suffix? ".drv" filename)
|
(if (string-suffix? ".drv" filename)
|
||||||
(render-derivation conn (string-append "/gnu/store/" filename))
|
(render-derivation conn (string-append "/gnu/store/" filename))
|
||||||
|
|
|
@ -24,6 +24,7 @@
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-19)
|
#:use-module (srfi srfi-19)
|
||||||
#:export (index
|
#:export (index
|
||||||
|
view-revision-package-and-version
|
||||||
view-revision
|
view-revision
|
||||||
view-builds
|
view-builds
|
||||||
view-derivation
|
view-derivation
|
||||||
|
@ -144,7 +145,9 @@
|
||||||
((id url commit store_path)
|
((id url commit store_path)
|
||||||
`(tr
|
`(tr
|
||||||
(td ,url)
|
(td ,url)
|
||||||
(td (samp ,commit)))))
|
(td (a (@ (href ,(string-append
|
||||||
|
"/revision/" commit)))
|
||||||
|
(samp ,commit))))))
|
||||||
guix-revisions)))))
|
guix-revisions)))))
|
||||||
(div
|
(div
|
||||||
(@ (class "row"))
|
(@ (class "row"))
|
||||||
|
@ -168,6 +171,18 @@
|
||||||
(td ,source))))
|
(td ,source))))
|
||||||
queued-guix-revisions)))))))))
|
queued-guix-revisions)))))))))
|
||||||
|
|
||||||
|
(define (view-revision-package-and-version revision-commit-hash name version)
|
||||||
|
(layout
|
||||||
|
#:extra-headers
|
||||||
|
'((cache-control . ((max-age . 60))))
|
||||||
|
#:body
|
||||||
|
`(,(header)
|
||||||
|
(div
|
||||||
|
(@ (class "container"))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(h1 "Package " ,name " @ " ,version))))))
|
||||||
|
|
||||||
(define (view-revision commit-hash packages)
|
(define (view-revision commit-hash packages)
|
||||||
(layout
|
(layout
|
||||||
#:extra-headers
|
#:extra-headers
|
||||||
|
@ -187,13 +202,16 @@
|
||||||
(thead
|
(thead
|
||||||
(tr
|
(tr
|
||||||
(th (@ (class "col-md-3")) "Name")
|
(th (@ (class "col-md-3")) "Name")
|
||||||
(th (@ (class "col-md-9")) "Version")))
|
(th (@ (class "col-md-3")) "Version")))
|
||||||
(tbody
|
(tbody
|
||||||
,@(map
|
,@(map
|
||||||
(match-lambda
|
(match-lambda
|
||||||
((name version rest ...)
|
((name version rest ...)
|
||||||
`(tr
|
`(tr
|
||||||
(td ,name)
|
(td (a (@ (href ,(string-append
|
||||||
|
"/revision/" commit-hash
|
||||||
|
"/package/" name "/" version)))
|
||||||
|
,name))
|
||||||
(td ,version))))
|
(td ,version))))
|
||||||
packages))))))))
|
packages))))))))
|
||||||
|
|
||||||
|
@ -258,7 +276,7 @@
|
||||||
(define (display-store-item-short item)
|
(define (display-store-item-short item)
|
||||||
`((span (@ (style "font-size: small; font-family: monospace; display: block;"))
|
`((span (@ (style "font-size: small; font-family: monospace; display: block;"))
|
||||||
,(string-take item 44))
|
,(string-take item 44))
|
||||||
(span (@ (style "font-size: x-large; font-family: monospace;"))
|
(span (@ (style "font-size: x-large; font-family: monospace; display: block;"))
|
||||||
,(string-drop item 44))))
|
,(string-drop item 44))))
|
||||||
|
|
||||||
(define (display-store-item item)
|
(define (display-store-item item)
|
||||||
|
@ -267,7 +285,22 @@
|
||||||
(span (@ (style "font-size: x-large; font-family: monospace;"))
|
(span (@ (style "font-size: x-large; font-family: monospace;"))
|
||||||
,(string-drop item 44))))
|
,(string-drop item 44))))
|
||||||
|
|
||||||
(define (view-store-item filename)
|
(define (display-store-item-title item)
|
||||||
|
`(h1 (span (@ (style "font-size: 1em; font-family: monospace; display: block;"))
|
||||||
|
,(string-take item 44))
|
||||||
|
(span (@ (style "line-height: 1.7em; font-size: 1.5em; font-family: monospace;"))
|
||||||
|
,(string-drop item 44))))
|
||||||
|
|
||||||
|
(define (display-file-in-store-item filename)
|
||||||
|
(match (string-split filename #\/)
|
||||||
|
(("" "gnu" "store" item fileparts ...)
|
||||||
|
`(,(let ((full-item (string-append "/gnu/store/" item)))
|
||||||
|
`(a (@ (href ,full-item))
|
||||||
|
,(display-store-item-short full-item)))
|
||||||
|
,(string-append
|
||||||
|
"/" (string-join fileparts "/"))))))
|
||||||
|
|
||||||
|
(define (view-store-item filename derivation derivations-using-store-item)
|
||||||
(layout
|
(layout
|
||||||
#:extra-headers
|
#:extra-headers
|
||||||
'((cache-control . ((max-age . 60))))
|
'((cache-control . ((max-age . 60))))
|
||||||
|
@ -277,9 +310,32 @@
|
||||||
(@ (class "container"))
|
(@ (class "container"))
|
||||||
(div
|
(div
|
||||||
(@ (class "row"))
|
(@ (class "row"))
|
||||||
(h1 (samp ,filename)))))))
|
,(display-store-item-title filename))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(h4 "Derivation: ")
|
||||||
|
,(match derivation
|
||||||
|
((file-name output-id)
|
||||||
|
`(a (@ (href ,file-name))
|
||||||
|
,(display-store-item file-name)))))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(h2 "Derivations using this store item "
|
||||||
|
,(let ((count (length derivations-using-store-item)))
|
||||||
|
(if (eq? count 100)
|
||||||
|
"(> 100)"
|
||||||
|
(simple-format #f "(~A)" count))))
|
||||||
|
(ul
|
||||||
|
(@ (class "list-unstyled"))
|
||||||
|
,(map
|
||||||
|
(match-lambda
|
||||||
|
((file-name)
|
||||||
|
`(li (a (@ (href ,file-name))
|
||||||
|
,(display-store-item file-name)))))
|
||||||
|
derivations-using-store-item)))))))
|
||||||
|
|
||||||
(define (view-derivation derivation derivation-inputs derivation-outputs)
|
(define (view-derivation derivation derivation-inputs derivation-outputs
|
||||||
|
builds)
|
||||||
(layout
|
(layout
|
||||||
#:extra-headers
|
#:extra-headers
|
||||||
'((cache-control . ((max-age . 60))))
|
'((cache-control . ((max-age . 60))))
|
||||||
|
@ -291,7 +347,7 @@
|
||||||
((id file-name builder args env-vars system)
|
((id file-name builder args env-vars system)
|
||||||
`(div
|
`(div
|
||||||
(@ (class "row"))
|
(@ (class "row"))
|
||||||
(h1 "Derivation " (samp ,file-name)))))
|
,(display-store-item-title file-name))))
|
||||||
(div
|
(div
|
||||||
(@ (class "row"))
|
(@ (class "row"))
|
||||||
(div
|
(div
|
||||||
|
@ -311,7 +367,31 @@
|
||||||
derivation-inputs))))
|
derivation-inputs))))
|
||||||
(div
|
(div
|
||||||
(@ (class "col-md-4"))
|
(@ (class "col-md-4"))
|
||||||
"Details")
|
(h3 "Derivation details")
|
||||||
|
,(match derivation
|
||||||
|
((id file-name builder args env-vars system)
|
||||||
|
`(table
|
||||||
|
(@ (class "table"))
|
||||||
|
(tbody
|
||||||
|
(tr
|
||||||
|
(td "Builder")
|
||||||
|
(td (a (@ (href ,builder))
|
||||||
|
,(display-file-in-store-item builder))))
|
||||||
|
(tr
|
||||||
|
(td "System")
|
||||||
|
(td (samp ,system)))))))
|
||||||
|
(h3 "Build status")
|
||||||
|
,@(map
|
||||||
|
(match-lambda
|
||||||
|
((build-id build-server-url status-fetched-at
|
||||||
|
starttime stoptime status)
|
||||||
|
`(div
|
||||||
|
(@ (class "text-center"))
|
||||||
|
(div ,status)
|
||||||
|
(a (@ (href ,(simple-format
|
||||||
|
#f "~Abuild/~A" build-server-url build-id)))
|
||||||
|
"View build on " ,build-server-url))))
|
||||||
|
builds))
|
||||||
(div
|
(div
|
||||||
(@ (class "col-md-4"))
|
(@ (class "col-md-4"))
|
||||||
(h3 "Outputs")
|
(h3 "Outputs")
|
||||||
|
|
Loading…
Reference in a new issue