aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service/web/revision
diff options
context:
space:
mode:
Diffstat (limited to 'guix-data-service/web/revision')
-rw-r--r--guix-data-service/web/revision/controller.scm507
-rw-r--r--guix-data-service/web/revision/html.scm704
2 files changed, 1211 insertions, 0 deletions
diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm
new file mode 100644
index 0000000..fdd2dc3
--- /dev/null
+++ b/guix-data-service/web/revision/controller.scm
@@ -0,0 +1,507 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-data-service web revision controller)
+ #:use-module (ice-9 match)
+ #:use-module (web uri)
+ #:use-module (web request)
+ #:use-module (texinfo)
+ #:use-module (texinfo html)
+ #:use-module (texinfo plain-text)
+ #:use-module (guix-data-service web render)
+ #:use-module (guix-data-service web sxml)
+ #:use-module (guix-data-service web query-parameters)
+ #:use-module (guix-data-service web util)
+ #:use-module (guix-data-service jobs load-new-guix-revision)
+ #:use-module (guix-data-service model package)
+ #:use-module (guix-data-service model git-branch)
+ #:use-module (guix-data-service model git-repository)
+ #:use-module (guix-data-service model derivation)
+ #:use-module (guix-data-service model package-derivation)
+ #:use-module (guix-data-service model package-metadata)
+ #:use-module (guix-data-service model lint-checker)
+ #:use-module (guix-data-service model lint-warning)
+ #:use-module (guix-data-service model guix-revision)
+ #:use-module (guix-data-service web revision html)
+ #:export (revision-controller
+
+ render-revision-lint-warnings
+ render-revision-package-version
+ render-revision-packages
+ render-unknown-revision
+ render-view-revision))
+
+(define cache-control-default-max-age
+ (* 60 60 24)) ; One day
+
+(define http-headers-for-unchanging-content
+ `((cache-control
+ . (public
+ (max-age . ,cache-control-default-max-age)))))
+
+(define (revision-controller request
+ method-and-path-components
+ mime-types
+ body
+ conn)
+ (define path
+ (uri-path (request-uri request)))
+
+ (match method-and-path-components
+ (('GET "revision" commit-hash) (if (guix-commit-exists? conn commit-hash)
+ (render-view-revision mime-types
+ conn
+ commit-hash
+ #:path-base path)
+ (render-unknown-revision mime-types
+ conn
+ commit-hash)))
+ (('GET "revision" commit-hash "packages")
+ (if (guix-commit-exists? conn commit-hash)
+ (let ((parsed-query-parameters
+ (guard-against-mutually-exclusive-query-parameters
+ (parse-query-parameters
+ request
+ `((after_name ,identity)
+ (field ,identity #:multi-value
+ #:default ("version" "synopsis"))
+ (search_query ,identity)
+ (limit_results ,parse-result-limit
+ #:no-default-when (all_results)
+ #:default 100)
+ (all_results ,parse-checkbox-value)))
+ ;; You can't specify a search query, but then also limit the
+ ;; results by filtering for after a particular package name
+ '((after_name search_query)
+ (limit_results all_results)))))
+
+ (render-revision-packages mime-types
+ conn
+ commit-hash
+ parsed-query-parameters
+ #:path-base path))
+ (render-unknown-revision mime-types
+ conn
+ commit-hash)))
+ (('GET "revision" commit-hash "package" name)
+ (if (guix-commit-exists? conn commit-hash)
+ (render-revision-package mime-types
+ conn
+ commit-hash
+ name)
+ (render-unknown-revision mime-types
+ conn
+ commit-hash)))
+ (('GET "revision" commit-hash "package" name version)
+ (if (guix-commit-exists? conn commit-hash)
+ (render-revision-package-version mime-types
+ conn
+ commit-hash
+ name
+ version)
+ (render-unknown-revision mime-types
+ conn
+ commit-hash)))
+ (('GET "revision" commit-hash "lint-warnings")
+ (if (guix-commit-exists? conn commit-hash)
+ (let ((parsed-query-parameters
+ (parse-query-parameters
+ request
+ `((package_query ,identity)
+ (linter ,identity #:multi-value)
+ (message_query ,identity)
+ (field ,identity #:multi-value
+ #:default ("linter"
+ "message"
+ "location"))))))
+
+ (render-revision-lint-warnings mime-types
+ conn
+ commit-hash
+ parsed-query-parameters
+ #:path-base path))
+ (render-unknown-revision mime-types
+ conn
+ commit-hash)))))
+
+(define (texinfo->variants-alist s)
+ (let ((stexi (texi-fragment->stexi s)))
+ `((source . ,s)
+ (html . ,(with-output-to-string
+ (lambda ()
+ (sxml->html (stexi->shtml stexi)))))
+ (plain . ,(stexi->plain-text stexi)))))
+
+(define (render-unknown-revision mime-types conn commit-hash)
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ '((unknown_commit . ,commit-hash))
+ #:code 404))
+ (else
+ (render-html
+ #:code 404
+ #:sxml (unknown-revision
+ commit-hash
+ (select-job-for-commit
+ conn commit-hash)
+ (git-branches-with-repository-details-for-commit conn commit-hash)
+ (select-jobs-and-events-for-commit 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
+ (git-branches-with-repository-details-for-commit conn commit-hash))
+ (derivations-counts
+ (count-packages-derivations-in-revision conn commit-hash))
+ (jobs-and-events
+ (select-jobs-and-events-for-commit conn commit-hash))
+ (lint-warning-counts
+ (lint-warning-count-by-lint-checker-for-revision conn commit-hash)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((packages_count . ,(caar packages-count))
+ (derivations_counts . ,(list->vector
+ (map (match-lambda
+ ((system target derivation_count)
+ `((system . ,system)
+ (target . ,target)
+ (derivation_count . ,derivation_count))))
+ derivations-counts)))
+ (lint_warning_counts . ,(map (match-lambda
+ ((name description network-dependent count)
+ `(,name . ((description . ,description)
+ (network_dependent . ,(string=? network-dependent "t"))
+ (count . ,(string->number count))))))
+ lint-warning-counts)))
+ #:extra-headers http-headers-for-unchanging-content))
+ (else
+ (render-html
+ #:sxml (view-revision
+ commit-hash
+ packages-count
+ git-repositories-and-branches
+ derivations-counts
+ jobs-and-events
+ lint-warning-counts
+ #:path-base path-base
+ #:header-text header-text)
+ #:extra-headers http-headers-for-unchanging-content)))))
+
+(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)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((error . "invalid query"))))
+ (else
+ (render-html
+ #:sxml (view-revision-packages commit-hash
+ query-parameters
+ '()
+ '()
+ #f
+ #:path-base path-base
+ #:header-text header-text
+ #:header-link header-link))))
+
+ (let* ((search-query (assq-ref query-parameters 'search_query))
+ (limit-results (or (assq-ref query-parameters 'limit_results)
+ 99999)) ; TODO There shouldn't be a limit
+ (fields (assq-ref query-parameters 'field))
+ (packages
+ (if search-query
+ (search-packages-in-revision
+ conn
+ commit-hash
+ search-query
+ #:limit-results limit-results)
+ (select-packages-in-revision
+ conn
+ commit-hash
+ #:limit-results limit-results
+ #:after-name (assq-ref query-parameters 'after_name))))
+ (git-repositories
+ (git-repositories-containing-commit conn
+ commit-hash))
+ (show-next-page?
+ (and (not search-query)
+ (>= (length packages)
+ limit-results))))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((revision
+ . ((commit . ,commit-hash)))
+ (packages
+ . ,(list->vector
+ (map (match-lambda
+ ((name version synopsis description home-page
+ location-file location-line
+ location-column-number licenses)
+ `((name . ,name)
+ ,@(if (member "version" fields)
+ `((version . ,version))
+ '())
+ ,@(if (member "synopsis" fields)
+ `((synopsis
+ . ,(texinfo->variants-alist synopsis)))
+ '())
+ ,@(if (member "description" fields)
+ `((description
+ . ,(texinfo->variants-alist description)))
+ '())
+ ,@(if (member "home-page" fields)
+ `((home-page . ,home-page))
+ '())
+ ,@(if (member "location" fields)
+ `((location
+ . ((file . ,location-file)
+ (line . ,location-line)
+ (column . ,location-column-number))))
+ '())
+ ,@(if (member "licenses" fields)
+ `((licenses
+ . ,(if (string-null? licenses)
+ #()
+ (json-string->scm licenses))))
+ '()))))
+ packages))))
+ #:extra-headers http-headers-for-unchanging-content))
+ (else
+ (render-html
+ #:sxml (view-revision-packages commit-hash
+ query-parameters
+ packages
+ git-repositories
+ 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
+ #:key
+ (path-base "/revision/")
+ (header-text
+ `("Revision "
+ (samp ,commit-hash)))
+ (header-link
+ (string-append
+ "/revision/" commit-hash)))
+ (let ((package-versions
+ (select-package-versions-for-revision conn
+ commit-hash
+ name))
+ (git-repositories-and-branches
+ (git-branches-with-repository-details-for-commit conn
+ commit-hash)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((versions . ,(list->vector package-versions)))
+ #:extra-headers http-headers-for-unchanging-content))
+ (else
+ (render-html
+ #:sxml (view-revision-package commit-hash
+ name
+ package-versions
+ git-repositories-and-branches
+ #:path-base path-base
+ #:header-text header-text
+ #:header-link header-link)
+ #:extra-headers http-headers-for-unchanging-content)))))
+
+(define* (render-revision-package-version 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
+ commit-hash
+ name
+ version))
+ (derivations
+ (select-derivations-by-revision-name-and-version
+ conn
+ commit-hash
+ name
+ version))
+ (git-repositories
+ (git-repositories-containing-commit conn
+ commit-hash))
+ (lint-warnings
+ (select-lint-warnings-by-revision-package-name-and-version
+ conn
+ commit-hash
+ name
+ version)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((name . ,name)
+ (version . ,version)
+ ,@(match metadata
+ (((synopsis description home-page))
+ `((synopsis . ,synopsis)
+ (description . ,description)
+ (home-page . ,home-page))))
+ (derivations . ,(list->vector
+ (map (match-lambda
+ ((system target file-name status)
+ `((system . ,system)
+ (target . ,target)
+ (derivation . ,file-name))))
+ derivations))))
+ #:extra-headers http-headers-for-unchanging-content))
+ (else
+ (render-html
+ #:sxml (view-revision-package-and-version commit-hash
+ name
+ version
+ metadata
+ derivations
+ git-repositories
+ lint-warnings
+ #:header-text header-text
+ #:header-link header-link)
+ #:extra-headers http-headers-for-unchanging-content)))))
+
+(define* (render-revision-lint-warnings mime-types
+ conn
+ commit-hash
+ query-parameters
+ #:key
+ (path-base "/revision/")
+ (header-text
+ `("Revision " (samp ,commit-hash)))
+ (header-link
+ (string-append "/revision/" commit-hash)))
+ (define lint-checker-options
+ (map (match-lambda
+ ((name description network-dependent)
+ (cons (string-append name ": " description )
+ name)))
+ (lint-checkers-for-revision conn commit-hash)))
+
+ (if (any-invalid-query-parameters? query-parameters)
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((error . "invalid query"))))
+ (else
+ (render-html
+ #:sxml (view-revision-lint-warnings commit-hash
+ query-parameters
+ '()
+ lint-checker-options
+ #:path-base path-base
+ #:header-text header-text
+ #:header-link header-link))))
+
+ (let* ((package-query (assq-ref query-parameters 'package_query))
+ (linters (assq-ref query-parameters 'linter))
+ (message-query (assq-ref query-parameters 'message_query))
+ (fields (assq-ref query-parameters 'field))
+ (git-repositories
+ (git-repositories-containing-commit conn
+ commit-hash))
+ (lint-warnings
+ (lint-warnings-for-guix-revision conn commit-hash
+ #:package-query package-query
+ #:linters linters
+ #:message-query message-query)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((revision
+ . ((commit . ,commit-hash)))
+ (lint_warnings
+ . ,(list->vector
+ (map (match-lambda
+ ((id lint-checker-name lint-checker-description
+ lint-checker-network-dependent
+ package-name package-version
+ file line-number column-number
+ message)
+ `((package . ((name . ,package-name)
+ (version . ,package-version)))
+ ,@(if (member "message" fields)
+ `((message . ,message))
+ '())
+ ,@(if (member "location" fields)
+ `((location . ((file . ,file)
+ (line-number . ,line-number)
+ (column-number . ,column-number))))
+ '()))))
+ lint-warnings))))
+ #:extra-headers http-headers-for-unchanging-content))
+ (else
+ (render-html
+ #:sxml (view-revision-lint-warnings commit-hash
+ query-parameters
+ lint-warnings
+ git-repositories
+ lint-checker-options
+ #:path-base path-base
+ #:header-text header-text
+ #:header-link header-link)
+ #:extra-headers http-headers-for-unchanging-content))))))
diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm
new file mode 100644
index 0000000..1f3189a
--- /dev/null
+++ b/guix-data-service/web/revision/html.scm
@@ -0,0 +1,704 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-data-service web revision html)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
+ #:use-module (texinfo)
+ #:use-module (texinfo html)
+ #:use-module (guix-data-service web util)
+ #:use-module (guix-data-service web query-parameters)
+ #:use-module (guix-data-service web view html)
+ #:export (view-revision-package
+ view-revision-package-and-version
+ view-revision
+ view-revision-packages
+ view-revision-lint-warnings))
+
+(define* (view-revision-package revision-commit-hash
+ name
+ versions
+ git-repositories-and-branches
+ #:key path-base
+ header-text
+ header-link)
+ (layout
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container"))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h3 (a (@ (href ,header-link))
+ ,@header-text))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ ,(append-map
+ (match-lambda
+ (((id label url cgit-url-base) . branches)
+ (map (match-lambda
+ ((branch-name datetime)
+ `(a (@ (class "btn btn-default btn-lg pull-right")
+ (href ,(simple-format
+ #f "/repository/~A/branch/~A/package/~A"
+ id branch-name name)))
+ ,(simple-format #f "View ~A branch version history"
+ branch-name))))
+ branches)))
+ git-repositories-and-branches)
+ (h1 "Package " ,name)))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h3 "Versions")
+ (table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th (@ (class "col-sm-10")) "Version")
+ (th (@ (class "col-sm-2")) "")))
+ (tbody
+ ,@(map
+ (lambda (version)
+ `(tr
+ (td (samp ,version))
+ (td
+ (a (@ (href ,(string-append
+ path-base
+ revision-commit-hash
+ "/package/" name "/" version)))
+ "More information"))))
+ versions)))))))))
+
+(define* (view-revision-package-and-version revision-commit-hash name version
+ package-metadata
+ derivations git-repositories
+ lint-warnings
+ #:key header-text
+ header-link)
+ (layout
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container"))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h3 (a (@ (href ,header-link))
+ ,@header-text))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h1 "Package " ,name " @ " ,version)))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ ,(match package-metadata
+ (((synopsis description home-page file line column-number
+ licenses))
+ `(dl
+ (@ (class "dl-horizontal"))
+ (dt "Synopsis")
+ (dd ,(stexi->shtml (texi-fragment->stexi synopsis)))
+ (dt "Description")
+ (dd ,(stexi->shtml (texi-fragment->stexi description)))
+ (dt "Home page")
+ (dd (a (@ (href ,home-page)) ,home-page))
+ ,@(if (and file (not (string-null? file))
+ (not (null? git-repositories)))
+ `((dt "Location")
+ (dd ,@(map
+ (match-lambda
+ ((id label url cgit-url-base)
+ (if
+ (and cgit-url-base
+ (not (string-null? cgit-url-base)))
+ `(a (@ (href
+ ,(string-append
+ cgit-url-base "tree/"
+ file "?id=" revision-commit-hash
+ "#n" line)))
+ ,file
+ " (line: " ,line
+ ", column: " ,column-number ")")
+ '())))
+ git-repositories)))
+ '())
+ ,@(if (> (vector-length licenses) 0)
+ `((dt ,(if (eq? (vector-length licenses) 1)
+ "License"
+ "Licenses"))
+ (dd (ul
+ ,@(map (lambda (license)
+ `(li (a (@ (href ,(assoc-ref license "uri")))
+ ,(assoc-ref license "name"))))
+ (vector->list licenses)))))
+ '()))))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h3 "Derivations")
+ (table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th "System")
+ (th "Target")
+ (th "Derivation")
+ (th "Build status")))
+ (tbody
+ ,@(map
+ (match-lambda
+ ((system target file-name status)
+ `(tr
+ (td (samp ,system))
+ (td (samp ,target))
+ (td (a (@ (href ,file-name))
+ ,(display-store-item-short file-name)))
+ (td ,(build-status-span status)))))
+ derivations)))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h3 "Lint warnings")
+ (table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th "Linter")
+ (th "Message")
+ (th "Location")))
+ (tbody
+ ,@(map
+ (match-lambda
+ ((id lint-checker-name lint-checker-description
+ lint-checker-network-dependent
+ file line-number column-number
+ message)
+ `(tr
+ (td (span (@ (style "font-family: monospace; display: block;"))
+ ,lint-checker-name)
+ (p (@ (style "font-size: small; margin: 6px 0 0px;"))
+ ,lint-checker-description))
+ (td ,message)
+ (td
+ ,@(if (and file (not (string-null? file)))
+ `((ul
+ ,@(map
+ (match-lambda
+ ((id label url cgit-url-base)
+ (let ((output
+ `(,file
+ " "
+ (span
+ (@ (style "white-space: nowrap"))
+ "(line: " ,line-number
+ ", column: " ,column-number ")"))))
+ (if
+ (and cgit-url-base
+ (not (string-null? cgit-url-base)))
+ `(li
+ (a (@ (href
+ ,(string-append
+ cgit-url-base "tree/"
+ file "?id=" revision-commit-hash
+ "#n" line-number)))
+ ,@output))
+ `(li ,@output)))))
+ git-repositories)))
+ '())))))
+ lint-warnings)))))))))
+
+(define (view-revision/git-repositories git-repositories-and-branches
+ commit-hash)
+ `((h3 "Git repositories")
+ ,@(map
+ (match-lambda
+ (((id label url cgit-url-base) . branches)
+ `((a (@ (href ,(string-append
+ "/repository/" id)))
+ (h4 ,url))
+ ,@(map
+ (match-lambda
+ ((name datetime)
+ `(div
+ (a (@ (href ,(string-append "/repository/" id
+ "/branch/" name)))
+ ,name)
+ " at " ,datetime
+ ,@(if (string-null? cgit-url-base)
+ '()
+ `(" "
+ (a (@ (href ,(string-append
+ cgit-url-base
+ "commit/?id="
+ commit-hash)))
+ "(View cgit)"))))))
+ branches))))
+ git-repositories-and-branches)))
+
+(define (view-revision/jobs-and-events jobs-and-events)
+ `((h3 "Jobs")
+ (table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th "Source")
+ (th "Events")
+ (th "")))
+ (tbody
+ ,@(map (match-lambda
+ ((id commit source git-repository-id created-at succeeded-at
+ events log-exists?)
+ `(tr
+ (@ (class
+ ,(let ((event-names
+ (map (lambda (event)
+ (assoc-ref event "event"))
+ (vector->list events))))
+ (cond
+ ((member "success" event-names)
+ "success")
+ ((member "failure" event-names)
+ "danger")
+ ((member "start" event-names)
+ "info")
+ (else
+ ""))))
+ (title ,(simple-format #f "Job id: ~A" id)))
+ (td ,source)
+ (td
+ (dl
+ ,@(map
+ (lambda (event)
+ `((dt ,(assoc-ref event "event"))
+ (dd ,(assoc-ref event "occurred_at"))))
+ (cons
+ `(("event" . "created")
+ ("occurred_at" . ,created-at))
+ (vector->list events)))))
+ (td
+ ,@(if log-exists?
+ `((a (@ (href ,(string-append "/job/" id)))
+ "View log"))
+ '())))))
+ jobs-and-events)))))
+
+(define (view-revision/lint-warning-counts path-base lint-warning-counts)
+ `((h3 "Lint warnings")
+ (a (@ (href ,(string-append path-base "/lint-warnings")))
+ "View lint warnings")
+ (table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th "Linter")
+ (th "Count")))
+ (tbody
+ ,@(map (match-lambda
+ ((name description network-dependent count)
+ `(tr
+ (td (span (@ (style "font-family: monospace; display: block;"))
+ ,name)
+ (p (@ (style "margin: 6px 0 0px;"))
+ ,description))
+ (td ,count))))
+ lint-warning-counts)))))
+
+(define* (view-revision commit-hash packages-count
+ git-repositories-and-branches derivations-count
+ jobs-and-events
+ lint-warning-counts
+ #:key (path-base "/revision/")
+ header-text)
+ (layout
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container"))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (h1 (@ (style "white-space: nowrap;"))
+ ,@header-text)))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-6"))
+ (h2 "Packages")
+ (strong (@ (class "text-center")
+ (style "font-size: 2em; display: block;"))
+ ,packages-count)
+ (a (@ (href ,(string-append path-base "/packages")))
+ "View packages")
+
+ ,@(if (null? git-repositories-and-branches)
+ '()
+ (view-revision/git-repositories git-repositories-and-branches
+ commit-hash))
+ ,@(view-revision/jobs-and-events jobs-and-events)
+ ,@(view-revision/lint-warning-counts path-base
+ lint-warning-counts))
+ (div
+ (@ (class "col-md-6"))
+ (h3 "Derivations")
+ (table
+ (@ (class "table")
+ (style "white-space: nowrap;"))
+ (thead
+ (tr
+ (th "System")
+ (th "Target")
+ (th "Derivations")))
+ (tbody
+ ,@(map (match-lambda
+ ((system target count)
+ (if (string=? system target)
+ `(tr
+ (td (@ (class "text-center")
+ (colspan 2))
+ (samp ,system))
+ (td (samp ,count)))
+ `(tr
+ (td (samp ,system))
+ (td (samp ,target))
+ (td (samp ,count))))))
+ derivations-count)))))))))
+
+(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)
+ (cons field
+ (hyphenate-words
+ (string-downcase field))))
+ '("Version" "Synopsis" "Description"
+ "Home page" "Location" "Licenses")))
+
+ (layout
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container"))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h3 (a (@ (style "white-space: nowrap;")
+ (href ,header-link))
+ ,@header-text))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (div
+ (@ (class "well"))
+ (form
+ (@ (method "get")
+ (action "")
+ (style "padding-bottom: 0")
+ (class "form-horizontal"))
+ ,(form-horizontal-control
+ "Search query" query-parameters
+ #:help-text
+ "List packages where the name or synopsis match the query.")
+ ,(form-horizontal-control
+ "Fields" query-parameters
+ #:name "field"
+ #:options field-options
+ #:help-text "Fields to return in the response.")
+ ,(form-horizontal-control
+ "After name" query-parameters
+ #:help-text
+ "List packages that are alphabetically after the given name.")
+ ,(form-horizontal-control
+ "Limit results" query-parameters
+ #:help-text "The maximum number of packages by name to return.")
+ ,(form-horizontal-control
+ "All results" query-parameters
+ #:type "checkbox"
+ #:help-text "Return all results.")
+ (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-sm-12"))
+ (a (@ (class "btn btn-default btn-lg pull-right")
+ (href ,(let ((query-parameter-string
+ (query-parameters->string query-parameters)))
+ (string-append
+ path-base ".json"
+ (if (string-null? query-parameter-string)
+ ""
+ (string-append "?" query-parameter-string))))))
+ "View JSON")))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h1 "Packages")
+ (table
+ (@ (class "table table-responsive"))
+ (thead
+ (tr
+ (th (@ (class "col-md-3")) "Name")
+ ,@(filter-map
+ (match-lambda
+ ((label . value)
+ (if (member value (assq-ref query-parameters 'field))
+ `(th (@ (class "col-md-3")) ,label)
+ #f)))
+ field-options)
+ (th (@ (class "col-md-3")) "")))
+ (tbody
+ ,@(let ((fields (assq-ref query-parameters 'field)))
+ (map
+ (match-lambda
+ ((name version synopsis description home-page
+ location-file location-line
+ location-column-number licenses)
+ `(tr
+ (td ,name)
+ ,@(if (member "version" fields)
+ `((td ,version))
+ '())
+ ,(if (member "synopsis" fields)
+ `((td ,(stexi->shtml (texi-fragment->stexi synopsis))))
+ '())
+ ,(if (member "description" fields)
+ `((td ,(stexi->shtml (texi-fragment->stexi description))))
+ '())
+ ,(if (member "home-page" fields)
+ `((td ,home-page))
+ '())
+ ,(if (member "location" fields)
+ `((td
+ ,@(if (and location-file
+ (not (string-null? location-file)))
+ `((ul
+ ,@(map
+ (match-lambda
+ ((id label url cgit-url-base)
+ (if
+ (and cgit-url-base
+ (not (string-null? cgit-url-base)))
+ `(li
+ (a (@ (href
+ ,(string-append
+ cgit-url-base "tree/"
+ location-file "?id=" revision-commit-hash
+ "#n" location-line)))
+ ,location-file
+ " (line: " ,location-line
+ ", column: " ,location-column-number ")"))
+ `(li ,location-file
+ " (line: " ,location-line
+ ", column: " ,location-column-number ")"))))
+ git-repositories)))
+ '())))
+ '())
+ ,(if (member "licenses" fields)
+ `((td
+ (ul
+ (@ (class "list-inline"))
+ ,@(map (lambda (license)
+ `(li (a (@ (href ,(assoc-ref license "uri")))
+ ,(assoc-ref license "name"))))
+ (vector->list
+ (json-string->scm licenses))))))
+ '())
+ (td (@ (class "text-right"))
+ (a (@ (href ,(string-append
+ (string-drop-right path-base 1)
+ "/" name "/" version)))
+ "More information")))))
+ packages))))))
+ ,@(if show-next-page?
+ `((div
+ (@ (class "row"))
+ (a (@ (href ,(string-append path-base
+ "?after_name="
+ (car (last packages)))))
+ "Next page")))
+ '())))))
+
+(define* (view-revision-lint-warnings revision-commit-hash
+ query-parameters
+ lint-warnings
+ git-repositories
+ lint-checker-options
+ #:key path-base
+ header-text header-link)
+ (define field-options
+ (map
+ (lambda (field)
+ (cons field
+ (hyphenate-words
+ (string-downcase field))))
+ '("Linter" "Message" "Location")))
+
+ (layout
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container"))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h3 (a (@ (style "white-space: nowrap;")
+ (href ,header-link))
+ ,@header-text))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (div
+ (@ (class "well"))
+ (form
+ (@ (method "get")
+ (action "")
+ (style "padding-bottom: 0")
+ (class "form-horizontal"))
+ ,(form-horizontal-control
+ "Package query" query-parameters
+ #:help-text
+ "Lint warnings where the package name matches the query.")
+ ,(form-horizontal-control
+ "Linter" query-parameters
+ #:options lint-checker-options
+ #:help-text
+ "Lint warnings for specific lint checkers.")
+ ,(form-horizontal-control
+ "Message query" query-parameters
+ #:help-text
+ "Lint warnings where the message matches the query.")
+ ,(form-horizontal-control
+ "Fields" query-parameters
+ #:name "field"
+ #:options field-options
+ #:help-text "Fields to return in the response.")
+ (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-sm-12"))
+ (a (@ (class "btn btn-default btn-lg pull-right")
+ (href ,(let ((query-parameter-string
+ (query-parameters->string query-parameters)))
+ (string-append
+ path-base ".json"
+ (if (string-null? query-parameter-string)
+ ""
+ (string-append "?" query-parameter-string))))))
+ "View JSON")))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h1 "Lint warnings")
+ (table
+ (@ (class "table table-responsive"))
+ (thead
+ (tr
+ (th (@ (class "col-md-3")) "Package")
+ ,@(filter-map
+ (match-lambda
+ ((label . value)
+ (if (member value (assq-ref query-parameters 'field))
+ `(th (@ (class "col-md-3")) ,label)
+ #f)))
+ field-options)
+ (th (@ (class "col-md-3")) "")))
+ (tbody
+ ,@(let ((fields (assq-ref query-parameters 'field)))
+ (map
+ (match-lambda
+ ((id lint-checker-name lint-checker-description
+ lint-checker-network-dependent
+ package-name package-version file line-number column-number
+ message)
+ `(tr
+ (td (a (@ (href ,(string-append
+ (string-join
+ (drop-right (string-split path-base #\/) 1)
+ "/")
+ "/package/" package-name "/" package-version)))
+ ,package-name " @ " ,package-version))
+ ,@(if (member "linter" fields)
+ `((td (span (@ (style "font-family: monospace; display: block;"))
+ ,lint-checker-name)
+ (p (@ (style "font-size: small; margin: 6px 0 0px;"))
+ ,lint-checker-description)))
+ '())
+ ,@(if (member "message" fields)
+ `((td ,message))
+ '())
+ ,@(if (member "location" fields)
+ `((td
+ ,@(if (and file (not (string-null? file)))
+ `((ul
+ ,@(map
+ (match-lambda
+ ((id label url cgit-url-base)
+ (let ((output
+ `(,file
+ " "
+ (span
+ (@ (style "white-space: nowrap"))
+ "(line: " ,line-number
+ ", column: " ,column-number ")"))))
+ (if
+ (and cgit-url-base
+ (not (string-null? cgit-url-base)))
+ `(li
+ (a (@ (href
+ ,(string-append
+ cgit-url-base "tree/"
+ file "?id=" revision-commit-hash
+ "#n" line-number)))
+ ,@output))
+ `(li ,@output)))))
+ git-repositories)))
+ '())))
+ '()))))
+ lint-warnings))))))))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-06-14 19:31:10 +0000