cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit

Browse source 
This is a service designed to provide information about Guix. At the
moment, this initial prototype gathers up information about packages,
the associated metadata and derivations.

The initial primary use case is to compare two different revisions of
Guix, detecting which packages are new, no longer present, updated or
otherwise different.

It's based on the Mumi project.

[1]: https://git.elephly.net/software/mumi.git
This commit is contained in:
Christopher Baines 2019-02-06 16:14:44 +00:00
commit 5a9262b38d
Signed by: cbaines
GPG key ID: 5E28A33B0B84F577
32 changed files with 9457 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

96
guix-data-service/web/controller.scm Normal file
View file

@ -0,0 +1,96 @@
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; 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 controller)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (web request)
#:use-module (web uri)
#:use-module (squee)
#:use-module (guix-data-service comparison)
#:use-module (guix-data-service model guix-revision)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web util)
#:use-module (guix-data-service web view html)
#:export (controller))
(define-syntax-rule (-> target functions ...)
(fold (lambda (f val) (and=> val f))
target
(list functions ...)))
(define (render-with-error-handling page message)
(apply render-html (page))
;; (catch #t
;; (lambda ()
;; (receive (sxml headers)
;; (pretty-print (page))
;; (render-html sxml headers)))
;; (lambda (key . args)
;; (format #t "ERROR: ~a ~a\n"
;; key args)
;; (render-html (error-page message))))
)
(define (controller request body)
(define conn (connect-to-postgres-paramstring "dbname=guix_data_service"))
(match-lambda
((GET)
(apply render-html (index (most-recent-n-guix-revisions conn 10))))
((GET "compare")
(let ((base-commit (-> request
request-uri
uri-query
parse-query-string
(cut assoc-ref <> "base_commit")))
(target-commit (-> request
request-uri
uri-query
parse-query-string
(cut assoc-ref <> "target_commit"))))
(let-values
(((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes
(package-differences-data conn
(commit->revision-id conn base-commit)
(commit->revision-id conn target-commit)))))
(let* ((new-packages
(package-data-vhashes->new-packages base-packages-vhash
target-packages-vhash))
(removed-packages
(package-data-vhashes->removed-packages base-packages-vhash
target-packages-vhash))
(version-changes
(package-data-version-changes base-packages-vhash
target-packages-vhash))
(other-changes
(package-data-other-changes base-packages-vhash
target-packages-vhash)))
(apply render-html
(compare base-commit
target-commit
new-packages
removed-packages
version-changes
other-changes))))))
((GET path ...)
(render-static-asset request))))

127
guix-data-service/web/render.scm Normal file
View file

@ -0,0 +1,127 @@
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; 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/>.
;; This code was snarfed from David Thompson's guix-web.
(define-module (guix-data-service web render)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (ice-9 binary-ports)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
#:use-module (json)
#:use-module (guix-data-service config)
#:use-module (guix-data-service web sxml)
#:use-module (guix-data-service web util)
#:export (render-static-asset
render-html
render-json
not-found
unprocessable-entity
created
redirect))
(define file-mime-types
'(("css" . (text/css))
("js" . (text/javascript))
("svg" . (image/svg+xml))
("png" . (image/png))
("gif" . (image/gif))
("woff" . (application/font-woff))
("ttf" . (application/octet-stream))
("html" . (text/html))))
(define (render-static-asset request)
(render-static-file (%config 'assets-dir) request))
(define %not-slash
(char-set-complement (char-set #\/)))
(define (render-static-file root request)
(define path
(uri-path (request-uri request)))
(define failure
(not-found (build-uri 'http
#:host (%config 'host)
#:port (%config 'port)
#:path path)))
(let ((file-name (string-append root "/" path)))
(if (not (any (cut string-contains <> "..")
(string-tokenize path %not-slash)))
(let* ((stat (stat file-name #f))
(modified (and stat
(make-time time-utc 0 (stat:mtime stat)))))
(define (send-file)
(list `((content-type
. ,(assoc-ref file-mime-types
(file-extension file-name)))
(last-modified . ,(time-utc->date modified)))
(call-with-input-file file-name get-bytevector-all)))
(if (and stat (not (eq? 'directory (stat:type stat))))
(cond ((assoc-ref (request-headers request) 'if-modified-since)
=>
(lambda (client-date)
(if (time>? modified (date->time-utc client-date))
(send-file)
(list (build-response #:code 304) ;"Not Modified"
#f))))
(else
(send-file)))
failure))
failure)))
(define* (render-html #:key sxml (extra-headers '()))
(list (append extra-headers
'((content-type . (text/html))))
(lambda (port)
(sxml->html sxml port))))
(define (render-json json)
(list '((content-type . (application/json)))
(lambda (port)
(scm->json json port))))
(define (not-found uri)
(list (build-response #:code 404)
(string-append "Resource not found: " (uri->string uri))))
(define (unprocessable-entity)
(list (build-response #:code 422)
""))
(define (created)
(list (build-response #:code 201)
""))
(define (redirect path)
(let ((uri (build-uri 'http
#:host (%config 'host)
#:port (%config 'port)
#:path (string-append
"/" (encode-and-join-uri-path path)))))
(list (build-response
#:code 301
#:headers `((content-type . (text/html))
(location . ,uri)))
(format #f "Redirect to ~a" (uri->string uri)))))

45
guix-data-service/web/server.scm Normal file
View file

@ -0,0 +1,45 @@
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; 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 server)
#:use-module (srfi srfi-1)
#:use-module (web http)
#:use-module (web request)
#:use-module (web uri)
#:use-module (fibers web server)
#:use-module (guix-data-service web controller)
#:use-module (guix-data-service web util)
#:export (start-guix-data-service-web-server))
(define (run-controller controller request body)
((controller request body)
(cons (request-method request)
(request-path-components request))))
(define (handler request body controller)
(format #t "~a ~a\n"
(request-method request)
(uri-path (request-uri request)))
(apply values
(run-controller controller request body)))
(define (start-guix-data-service-web-server port)
(run-server (lambda (request body)
(handler request body controller))
#:addr INADDR_ANY
#:port port))

371
guix-data-service/web/sxml.scm Normal file
View file

@ -0,0 +1,371 @@
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; 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/>.
;;; Commentary:
;;
;; SXML to HTML conversion.
;;
;;; Code:
(define-module (guix-data-service web sxml)
#:use-module (sxml simple)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 hash-table)
#:export (sxml->html))
(define %self-closing-tags
'(area
base
br
col
command
embed
hr
img
input
keygen
link
meta
param
source
track
wbr))
(define (self-closing-tag? tag)
"Return #t if TAG is self-closing."
(pair? (memq tag %self-closing-tags)))
(define %escape-chars
(alist->hash-table
'((#\" . "quot")
(#\& . "amp")
(#\' . "apos")
(#\< . "lt")
(#\> . "gt")
(#\¡ . "iexcl")
(#\¢ . "cent")
(#\£ . "pound")
(#\¤ . "curren")
(#\¥ . "yen")
(#\¦ . "brvbar")
(#\§ . "sect")
(#\¨ . "uml")
(#\© . "copy")
(#\ª . "ordf")
(#\« . "laquo")
(#\¬ . "not")
(#\® . "reg")
(#\¯ . "macr")
(#\° . "deg")
(#\± . "plusmn")
(#\² . "sup2")
(#\³ . "sup3")
(#\´ . "acute")
(#\µ . "micro")
(#\¶ . "para")
(#\· . "middot")
(#\¸ . "cedil")
(#\¹ . "sup1")
(#\º . "ordm")
(#\» . "raquo")
(#\¼ . "frac14")
(#\½ . "frac12")
(#\¾ . "frac34")
(#\¿ . "iquest")
(#\À . "Agrave")
(#\Á . "Aacute")
(#\Â . "Acirc")
(#\Ã . "Atilde")
(#\Ä . "Auml")
(#\Å . "Aring")
(#\Æ . "AElig")
(#\Ç . "Ccedil")
(#\È . "Egrave")
(#\É . "Eacute")
(#\Ê . "Ecirc")
(#\Ë . "Euml")
(#\Ì . "Igrave")
(#\Í . "Iacute")
(#\Î . "Icirc")
(#\Ï . "Iuml")
(#\Ð . "ETH")
(#\Ñ . "Ntilde")
(#\Ò . "Ograve")
(#\Ó . "Oacute")
(#\Ô . "Ocirc")
(#\Õ . "Otilde")
(#\Ö . "Ouml")
(#\× . "times")
(#\Ø . "Oslash")
(#\Ù . "Ugrave")
(#\Ú . "Uacute")
(#\Û . "Ucirc")
(#\Ü . "Uuml")
(#\Ý . "Yacute")
(#\Þ . "THORN")
(#\ß . "szlig")
(#\à . "agrave")
(#\á . "aacute")
(#\â . "acirc")
(#\ã . "atilde")
(#\ä . "auml")
(#\å . "aring")
(#\æ . "aelig")
(#\ç . "ccedil")
(#\è . "egrave")
(#\é . "eacute")
(#\ê . "ecirc")
(#\ë . "euml")
(#\ì . "igrave")
(#\í . "iacute")
(#\î . "icirc")
(#\ï . "iuml")
(#\ð . "eth")
(#\ñ . "ntilde")
(#\ò . "ograve")
(#\ó . "oacute")
(#\ô . "ocirc")
(#\õ . "otilde")
(#\ö . "ouml")
(#\÷ . "divide")
(#\ø . "oslash")
(#\ù . "ugrave")
(#\ú . "uacute")
(#\û . "ucirc")
(#\ü . "uuml")
(#\ý . "yacute")
(#\þ . "thorn")
(#\ÿ . "yuml")
(#\Π. "OElig")
(#\œ . "oelig")
(#\Š . "Scaron")
(#\š . "scaron")
(#\Ÿ . "Yuml")
(#\ƒ . "fnof")
(#\ˆ . "circ")
(#\˜ . "tilde")
(#\Α . "Alpha")
(#\Β . "Beta")
(#\Γ . "Gamma")
(#\Δ . "Delta")
(#\Ε . "Epsilon")
(#\Ζ . "Zeta")
(#\Η . "Eta")
(#\Θ . "Theta")
(#\Ι . "Iota")
(#\Κ . "Kappa")
(#\Λ . "Lambda")
(#\Μ . "Mu")
(#\Ν . "Nu")
(#\Ξ . "Xi")
(#\Ο . "Omicron")
(#\Π . "Pi")
(#\Ρ . "Rho")
(#\Σ . "Sigma")
(#\Τ . "Tau")
(#\Υ . "Upsilon")
(#\Φ . "Phi")
(#\Χ . "Chi")
(#\Ψ . "Psi")
(#\Ω . "Omega")
(#\α . "alpha")
(#\β . "beta")
(#\γ . "gamma")
(#\δ . "delta")
(#\ε . "epsilon")
(#\ζ . "zeta")
(#\η . "eta")
(#\θ . "theta")
(#\ι . "iota")
(#\κ . "kappa")
(#\λ . "lambda")
(#\μ . "mu")
(#\ν . "nu")
(#\ξ . "xi")
(#\ο . "omicron")
(#\π . "pi")
(#\ρ . "rho")
(#\ς . "sigmaf")
(#\σ . "sigma")
(#\τ . "tau")
(#\υ . "upsilon")
(#\φ . "phi")
(#\χ . "chi")
(#\ψ . "psi")
(#\ω . "omega")
(#\ϑ . "thetasym")
(#\ϒ . "upsih")
(#\ϖ . "piv")
(#\  . "ensp")
(#\  . "emsp")
(#\  . "thinsp")
(#\– . "ndash")
(#\— . "mdash")
(#\‘ . "lsquo")
(#\’ . "rsquo")
(#\‚ . "sbquo")
(#\“ . "ldquo")
(#\” . "rdquo")
(#\„ . "bdquo")
(#\† . "dagger")
(#\‡ . "Dagger")
(#\• . "bull")
(#\… . "hellip")
(#\‰ . "permil")
(#\′ . "prime")
(#\″ . "Prime")
(#\‹ . "lsaquo")
(#\› . "rsaquo")
(#\‾ . "oline")
(#\⁄ . "frasl")
(#\€ . "euro")
(#\ℑ . "image")
(#\℘ . "weierp")
(#\ℜ . "real")
(#\™ . "trade")
(#\ℵ . "alefsym")
(#\← . "larr")
(#\↑ . "uarr")
(#\→ . "rarr")
(#\↓ . "darr")
(#\↔ . "harr")
(#\↵ . "crarr")
(#\⇐ . "lArr")
(#\⇑ . "uArr")
(#\⇒ . "rArr")
(#\⇓ . "dArr")
(#\⇔ . "hArr")
(#\∀ . "forall")
(#\∂ . "part")
(#\∃ . "exist")
(#\∅ . "empty")
(#\∇ . "nabla")
(#\∈ . "isin")
(#\∉ . "notin")
(#\∋ . "ni")
(#\∏ . "prod")
(#\∑ . "sum")
(#\− . "minus")
(#\∗ . "lowast")
(#\√ . "radic")
(#\∝ . "prop")
(#\∞ . "infin")
(#\∠ . "ang")
(#\∧ . "and")
(#\∨ . "or")
(#\∩ . "cap")
(#\∪ . "cup")
(#\∫ . "int")
(#\∴ . "there4")
(#\∼ . "sim")
(#\≅ . "cong")
(#\≈ . "asymp")
(#\≠ . "ne")
(#\≡ . "equiv")
(#\≤ . "le")
(#\≥ . "ge")
(#\⊂ . "sub")
(#\⊃ . "sup")
(#\⊄ . "nsub")
(#\⊆ . "sube")
(#\⊇ . "supe")
(#\⊕ . "oplus")
(#\⊗ . "otimes")
(#\⊥ . "perp")
(#\⋅ . "sdot")
(#\⋮ . "vellip")
(#\⌈ . "lceil")
(#\⌉ . "rceil")
(#\⌊ . "lfloor")
(#\⌋ . "rfloor")
(#\〈 . "lang")
(#\〉 . "rang")
(#\◊ . "loz")
(#\♠ . "spades")
(#\♣ . "clubs")
(#\♥ . "hearts")
(#\♦ . "diams"))))
(define (string->escaped-html s port)
"Write the HTML escaped form of S to PORT."
(define (escape c)
(let ((escaped (hash-ref %escape-chars c)))
(if escaped
(format port "&~a;" escaped)
(display c port))))
(string-for-each escape s))
(define (object->escaped-html obj port)
"Write the HTML escaped form of OBJ to PORT."
(string->escaped-html
(call-with-output-string (cut display obj <>))
port))
(define (attribute-value->html value port)
"Write the HTML escaped form of VALUE to PORT."
(if (string? value)
(string->escaped-html value port)
(object->escaped-html value port)))
(define (attribute->html attr value port)
"Write ATTR and VALUE to PORT."
(format port "~a=\"" attr)
(attribute-value->html value port)
(display #\" port))
(define (element->html tag attrs body port)
"Write the HTML TAG to PORT, where TAG has the attributes in the
list ATTRS and the child nodes in BODY."
(format port "<~a" tag)
(for-each (match-lambda
((attr value)
(display #\space port)
(attribute->html attr value port)))
attrs)
(if (and (null? body) (self-closing-tag? tag))
(display " />" port)
(begin
(display #\> port)
(for-each (cut sxml->html <> port) body)
(format port "</~a>" tag))))
(define (doctype->html doctype port)
(format port "<!DOCTYPE ~a>" doctype))
(define* (sxml->html tree #:optional (port (current-output-port)))
"Write the serialized HTML form of TREE to PORT."
(match tree
(() *unspecified*)
(('doctype type)
(doctype->html type port))
;; Unescaped, raw HTML output
(('raw html)
(display html port))
(((? symbol? tag) ('@ attrs ...) body ...)
(element->html tag attrs body port))
(((? symbol? tag) body ...)
(element->html tag '() body port))
((nodes ...)
(for-each (cut sxml->html <> port) nodes))
((? string? text)
(string->escaped-html text port))
;; Render arbitrary Scheme objects, too.
(obj (object->escaped-html obj port))))

45
guix-data-service/web/util.scm Normal file
View file

@ -0,0 +1,45 @@
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; 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 util)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (web request)
#:use-module (web uri)
#:export (parse-query-string
request-path-components
file-extension
directory?))
(define (parse-query-string query)
"Parse and decode the URI query string QUERY and return an alist."
(let lp ((lst (map uri-decode (string-split query (char-set #\& #\=)))))
(match lst
((key value . rest)
(cons (cons key value) (lp rest)))
(() '()))))
(define (request-path-components request)
(split-and-decode-uri-path (uri-path (request-uri request))))
(define (file-extension file-name)
(last (string-split file-name #\.)))
(define (directory? filename)
(string=? filename (dirname filename)))

246
guix-data-service/web/view/html.scm Normal file
View file

@ -0,0 +1,246 @@
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; 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 view html)
#:use-module (guix-data-service config)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:export (index
compare
unknown
error-page))
(define* (header)
`(nav
(@ (id "header") (class "navbar navbar-default"))
(div
(@ (class "container-fluid"))
(div
(@ (class "navbar-header"))
(div (@ (class "navbar-brand"))
(a (@ (href "/") (class "logo"))))))))
(define* (layout #:key
(head '())
(body '())
(title "Guix Data Service")
(extra-headers '()))
`(#:sxml ((doctype "html")
(html
(head
(title ,title)
(meta (@ (http-equiv "Content-Type")
(content "text/html; charset=UTF-8")))
(meta (@ (http-equiv "Content-Language") (content "en")))
(meta (@ (name "author") (content "Christopher Baines")))
(meta (@ (name "viewport")
(content "width=device-width, initial-scale=1")))
(link
(@ (rel "stylesheet")
(media "screen")
(type "text/css")
(href "/css/reset.css")))
(link
(@ (rel "stylesheet")
(media "screen")
(type "text/css")
(href "/css/bootstrap.css")))
,@head
(link
(@ (rel "stylesheet")
(media "screen")
(type "text/css")
(href "/css/screen.css"))))
(body ,@body
(footer
(p "Copyright © 2016—2019 by the GNU Guix community."
(br)
"Now with even more " (span (@ (class "lambda")) "λ") "! ")
(p "This is free software. Download the "
(a (@ (href "https://git.cbaines.net/guix/data-service/"))
"source code here") ".")))))
#:extra-headers ,extra-headers))
(define (index guix-revisions)
(layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body
`(,(header)
(div
(@ (class "container"))
(h1 "Guix Data Service")
(form (@ (id "compare")
(action "/compare"))
(div
(@ (class "form-group"))
(label (@ (for "base_commit"))
"Base commit")
(input (@ (type "text")
(class "form-control")
(id "base_commit")
(name "base_commit")
(placeholder "base commit"))))
(div
(@ (class "form-group"))
(label (@ (for "target_commit"))
"Target commit")
(input (@ (type "text")
(class "form-control")
(id "target_commit")
(name "target_commit")
(placeholder "target commit"))))
(button
(@ (type "submit")
(class "btn btn-lg btn-primary"))
"Compare"))
(h3 "Recent fetched revisions")
,(if (null? guix-revisions)
'(p "No revisions")
`(table
(@ (class "table"))
(thead
(tr
(th (@ (class "col-md-6")) "Source Repository URL")
(th (@ (class "col-md-6")) "Commit")))
(tbody
,@(map
(match-lambda
((id url commit store_path)
`(tr
(td ,url)
(td (samp ,commit)))))
guix-revisions))))))))
(define (compare base-commit
target-commit
new-packages
removed-packages
version-changes
other-changes)
(layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body
`(,(header)
(div
(@ (class "container"))
(h1 "Comparing "
(samp ,(string-take base-commit 8) "…")
" and "
(samp ,(string-take target-commit 8) "…"))
(h3 "New packages")
,(if (null? new-packages)
'(p "No new packages")
`(table
(@ (class "table"))
(thead
(tr
(th (@ (class "col-md-3")) "Name")
(th (@ (class "col-md-9")) "Version")))
(tbody
,@(map
(match-lambda
((name . version)
`(tr
(td ,name)
(td ,version))))
new-packages))))
(h3 "Removed packages")
,(if (null? removed-packages)
'(p "No removed packages")
`(table
(@ (class "table"))
(thead
(tr
(th (@ (class "col-md-3")) "Name")
(th (@ (class "col-md-9")) "Version")))
(tbody
,@(map
(match-lambda
((name . version)
`(tr
(td ,name)
(td ,version))))
removed-packages))))
(h3 "Version changes")
,(if (null? version-changes)
'(p "No version changes")
`(table
(@ (class "table"))
(thead
(tr
(th (@ (class "col-md-3")) "Name")
(th (@ (class "col-md-9")) "Versions")))
(tbody
,@(map
(match-lambda
((name . versions)
`(tr
(td ,name)
(td (ul
,@(map (match-lambda
((type . version)
`(li (@ (class ,(if (eq? type 'base)
"text-danger"
"text-success")))
,version
,(if (eq? type 'base)
" (old)"
" (new)"))))
versions))))))
version-changes))))
(h3 "Other changed packages")
,@(if (null? other-changes)
'((p "No other changes"))
`((p "The metadata or derivation for these packages has changed.")
(table
(@ (class "table"))
(thead
(tr
(th (@ (class "col-md-3")) "Name")
(th (@ (class "col-md-9")) "Version")))
(tbody
,@(map
(match-lambda
(((name . version) . (metadata-id derivation-id))
`(tr
(td ,name)
(td ,version))))
other-changes)))))))))
(define (unknown id)
(layout
#:body
`(,(header)
(div (@ (class "container"))
(h1 "Patch not found")
(p "There is no submission with id " (strong ,id))
(p (a (@ (href "/")) "Try another one?"))))))
(define (error-page message)
(layout
#:body
`(,(header)
(div (@ (class "container"))
(h1 "Error")
(p "An error occurred. Sorry about that!")
,message
(p (a (@ (href "/")) "Try something else?"))))))