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

122
guix-data-service/comparison.scm Normal file
View file

@ -0,0 +1,122 @@
(define-module (guix-data-service comparison)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (squee)
#:export (package-data->package-data-vhashes
package-differences-data
package-data-vhashes->new-packages
package-data-vhashes->removed-packages
package-data-version-changes
package-data-other-changes))
(define (package-differences-data conn base_guix_revision_id target_guix_revision_id)
(define query
"WITH base_packages AS (
SELECT packages.* FROM packages INNER JOIN guix_revision_packages ON packages.id = guix_revision_packages.package_id WHERE revision_id = $1
), target_packages AS (
SELECT packages.* FROM packages INNER JOIN guix_revision_packages ON packages.id = guix_revision_packages.package_id WHERE revision_id = $2
)
SELECT base_packages.name, base_packages.version, base_packages.package_metadata_id, base_packages.derivation_id, target_packages.name, target_packages.version, target_packages.package_metadata_id, target_packages.derivation_id
FROM base_packages
FULL OUTER JOIN target_packages ON base_packages.name = target_packages.name AND base_packages.version = target_packages.version
WHERE (base_packages.id IS NULL OR target_packages.id IS NULL OR base_packages.id != target_packages.id)
ORDER BY base_packages.name, base_packages.version, target_packages.name, target_packages.version")
(exec-query conn query (list base_guix_revision_id target_guix_revision_id)))
(define (package-data->package-data-vhashes package-data)
(define (add-data-to-vhash data vhash)
(let ((key (first data)))
(if (string-null? key)
vhash
(vhash-cons key
(drop data 1)
vhash))))
(apply values
(fold (lambda (row result)
(let-values (((base-row-part target-row-part) (split-at row 4)))
(match result
((base-package-data target-package-data)
(list (add-data-to-vhash base-row-part base-package-data)
(add-data-to-vhash target-row-part target-package-data))))))
(list vlist-null vlist-null)
package-data)))
(define (package-data-vhash->package-name-and-version-vhash vhash)
(vhash-fold (lambda (name details result)
(vhash-cons (cons name (first details))
(cdr details)
result))
vlist-null
vhash))
(define (package-data-vhashes->new-packages base-packages-vhash target-packages-vhash)
(vlist->list
(vlist-filter (match-lambda
((name . details)
(not (vhash-assoc name base-packages-vhash))))
target-packages-vhash)))
(define (package-data-vhashes->removed-packages base-packages-vhash target-packages-vhash)
(vlist->list
(vlist-filter (match-lambda
((name . details)
(not (vhash-assoc name target-packages-vhash))))
base-packages-vhash)))
(define (package-data-vhash->package-versions-vhash package-data-vhash)
(vhash-fold (lambda (name details result)
(let ((version (first details))
(known-versions (vhash-assoc name result)))
(if known-versions
(vhash-cons name
(cons version known-versions)
(vhash-delete name result))
(vhash-cons name
(list version)
result))))
vlist-null
package-data-vhash))
(define (package-data-version-changes base-packages-vhash target-packages-vhash)
(let ((base-versions (package-data-vhash->package-versions-vhash
base-packages-vhash))
(target-versions (package-data-vhash->package-versions-vhash
target-packages-vhash)))
(vhash-fold (lambda (name target-versions result)
(let ((base-versions (and=> (vhash-assoc name base-versions)
cdr)))
(if base-versions
(begin
(if (equal? base-versions target-versions)
result
`((,name . ((base . ,base-versions)
(target . ,target-versions)))
,@result)))
result)))
'()
target-versions)))
(define (package-data-other-changes base-packages-vhash target-packages-vhash)
(define base-package-details-by-name-and-version
(package-data-vhash->package-name-and-version-vhash base-packages-vhash))
(define target-package-details-by-name-and-version
(package-data-vhash->package-name-and-version-vhash target-packages-vhash))
(vhash-fold (lambda (name-and-version target-details result)
(let ((base-packages-entry
(vhash-assoc name-and-version base-package-details-by-name-and-version)))
(if base-packages-entry
(let ((base-details (cdr base-packages-entry)))
(if (equal? base-details target-details)
result
`((,name-and-version . ((base . ,base-details)
(target . ,target-details)))
,@result)))
result)))
'()
target-package-details-by-name-and-version))

35
guix-data-service/config.scm.in Normal file
View file

@ -0,0 +1,35 @@
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2017, 2018 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 config)
#:export (%config))
(define %config
(let ((config
;; Try to find the "assets" directory relative to the executable
;; first. This is useful when using "pre-inst-env".
`((assets-dir . ,(let ((maybe-dir
(string-append (getcwd) "/assets")))
(if (file-exists? maybe-dir)
maybe-dir
;; TODO: use @assetsdir@ variable here
"@prefix@/share/guix-data-service/assets")))
(host . "localhost")
(port . 8765))))
(lambda (key)
(assoc-ref config key))))

11
guix-data-service/jobs.scm Normal file
View file

@ -0,0 +1,11 @@
(define-module (guix-data-service jobs)
#:use-module (ice-9 match)
#:use-module (guix-data-service jobs load-new-guix-revision)
#:export (process-jobs))
(define (process-jobs conn)
(match (process-next-load-new-guix-revision-job conn)
(#f (begin (simple-format #t "Waiting for new jobs...")
(sleep 60)
(process-jobs conn)))
(_ (process-jobs conn))))

90
guix-data-service/jobs/load-new-guix-revision.scm Normal file
View file

@ -0,0 +1,90 @@
(define-module (guix-data-service jobs load-new-guix-revision)
#:use-module (ice-9 match)
#:use-module (squee)
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (guix channels)
#:use-module (guix inferior)
#:use-module (guix profiles)
#:use-module (guix derivations)
#:use-module (guix-data-service model package)
#:use-module (guix-data-service model guix-revision)
#:use-module (guix-data-service model guix-revision-package)
#:use-module (guix-data-service model package-metadata)
#:use-module (guix-data-service model derivation)
#:export (process-next-load-new-guix-revision-job))
(define (inferior-guix->package-ids store conn inf)
(let* ((packages (inferior-packages inf))
(packages-metadata-ids
(inferior-packages->package-metadata-ids conn packages))
(packages-derivation-ids
(inferior-packages->derivation-ids store conn packages)))
(inferior-packages->package-ids
conn packages packages-metadata-ids packages-derivation-ids)))
(define (channel->manifest-store-item store channel)
(define (build-and-get-output-path store profile-derv)
(run-with-store store
(mbegin %store-monad
(built-derivations (list profile-derv))
(return (derivation->output-path profile-derv)))))
(let ((instances (latest-channel-instances store (list channel))))
(run-with-store store
(mlet* %store-monad ((manifest (channel-instances->manifest instances))
(derv (profile-derivation manifest)))
((store-lift build-and-get-output-path) derv)))))
(define (channel->guix-store-item store channel)
(dirname
(readlink
(string-append (channel->manifest-store-item store channel)
"/bin"))))
(define (extract-information-from store conn url commit store_path)
(let ((inf (open-inferior store_path)))
(inferior-eval '(use-modules (guix grafts)) inf)
(inferior-eval '(%graft? #f) inf)
(let ((package-ids (inferior-guix->package-ids store conn inf)))
(exec-query conn "BEGIN")
(let ((guix-revision-id
(insert-guix-revision conn url commit store_path)))
(insert-guix-revision-packages conn guix-revision-id package-ids)))
(exec-query conn "COMMIT")
(close-inferior inf)))
(define (load-new-guix-revision conn url commit)
(if (guix-revision-exists? conn url commit)
#t
(with-store store
(let ((store-item (channel->guix-store-item
store
(channel (name 'guix)
(url url)
(commit commit)))))
(extract-information-from store conn url commit store-item)))))
(define (process-next-load-new-guix-revision-job conn)
(let ((next
(exec-query
conn
"SELECT * FROM load_new_guix_revision_jobs ORDER BY id ASC LIMIT 1")))
(match next
(((id url commit))
(begin
(simple-format #t "Processing job ~A (url: ~A, commit: ~A)\n\n"
id url commit)
(load-new-guix-revision conn url commit)
(exec-query
conn
(string-append "DELETE FROM load_new_guix_revision_jobs WHERE id = '"
id
"'"))))
(_ #f))))

70
guix-data-service/model/derivation.scm Normal file
View file

@ -0,0 +1,70 @@
(define-module (guix-data-service model derivation)
#:use-module (srfi srfi-1)
#:use-module (ice-9 vlist)
#:use-module (squee)
#:use-module (guix inferior)
#:use-module (guix derivations)
#:use-module (guix-data-service model utils)
#:export (select-existing-derivations
insert-into-derivations
inferior-packages->derivation-ids))
(define (select-existing-derivations file-names)
(string-append "SELECT id, file_name "
"FROM derivations "
"WHERE file_name IN "
"(" (string-join (map (lambda (file-name)
(simple-format #f "'~A'" file-name))
file-names)
",")
");"))
(define (insert-into-derivations file-names)
(string-append "INSERT INTO derivations (file_name) VALUES "
(string-join
(map
(lambda (file-name)
(simple-format #f "('~A')" file-name))
file-names)
",")
" RETURNING id"
";"))
(define (inferior-packages->derivation-ids store conn inferior-packages)
(let* ((package-derivation-file-names (map (lambda (package)
(derivation-file-name
(inferior-package-derivation
store package)))
inferior-packages))
(existing-derivation-entries (exec-query->vhash
conn
(select-existing-derivations
package-derivation-file-names)
second ;; file_name
first)) ;; id
(missing-derivation-file-names
(filter (lambda (file-name)
(not (vhash-assoc file-name
existing-derivation-entries)))
package-derivation-file-names))
(new-derivation-entries
(if (null? missing-derivation-file-names)
'()
(map car
(exec-query
conn
(insert-into-derivations
missing-derivation-file-names)))))
(new-entries-id-lookup-vhash
(two-lists->vhash missing-derivation-file-names
new-derivation-entries)))
(map (lambda (derivation-file-name)
(cdr
(or (vhash-assoc derivation-file-name
existing-derivation-entries)
(vhash-assoc derivation-file-name
new-entries-id-lookup-vhash)
(error "missing derivation id"))))
package-derivation-file-names)))

19
guix-data-service/model/guix-revision-package.scm Normal file
View file

@ -0,0 +1,19 @@
(define-module (guix-data-service model guix-revision-package)
#:use-module (squee)
#:export (insert-guix-revision-packages))
(define (insert-guix-revision-packages conn guix-revision-id package-ids)
(define insert
(string-append "INSERT INTO guix_revision_packages "
"(revision_id, package_id) "
"VALUES "
(string-join (map (lambda (package-id)
(simple-format
#f "(~A, ~A)"
guix-revision-id
package-id))
package-ids)
", ")
";"))
(exec-query conn insert))

39
guix-data-service/model/guix-revision.scm Normal file
View file

@ -0,0 +1,39 @@
(define-module (guix-data-service model guix-revision)
#:use-module (ice-9 match)
#:use-module (squee)
#:export (most-recent-n-guix-revisions
commit->revision-id
insert-guix-revision
guix-revision-exists?))
(define (most-recent-n-guix-revisions conn n)
(exec-query conn "SELECT * FROM guix_revisions ORDER BY id DESC LIMIT 10"))
(define (commit->revision-id conn commit)
(match (exec-query
conn "SELECT id FROM guix_revisions WHERE commit = $1 LIMIT 1"
(list commit))
(((id))
id)))
(define (insert-guix-revision conn url commit store_path)
(define insert
(string-append "INSERT INTO guix_revisions "
"(url, commit, store_path) VALUES "
"('" url "', '"
commit "', '"
store_path "') "
"RETURNING id;"))
(map car (exec-query conn insert)))
(define (guix-revision-exists? conn url commit)
(define query
(string-append "SELECT EXISTS("
"SELECT 1 FROM guix_revisions WHERE url = '" url "' "
"AND commit = '" commit "')"
";"))
(let ((result (caar
(exec-query conn query))))
(string=? result "t")))

96
guix-data-service/model/package-metadata.scm Normal file
View file

@ -0,0 +1,96 @@
(define-module (guix-data-service model package-metadata)
#:use-module (srfi srfi-1)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (squee)
#:use-module (gcrypt hash)
#:use-module (rnrs bytevectors)
#:use-module (guix base16)
#:use-module (guix inferior)
#:use-module (guix-data-service model utils)
#:export (select-package-metadata
insert-package-metadata
inferior-packages->package-metadata-ids))
(define (select-package-metadata hashes)
(string-append "SELECT id, sha1_hash "
"FROM package_metadata "
"WHERE sha1_hash IN ("
(string-join (map (lambda (hash)
(simple-format #f "'~A'" hash))
hashes)
",")
");"))
(define (insert-package-metadata metadata-rows)
(string-append "INSERT INTO package_metadata "
"(sha1_hash, synopsis, description, home_page) "
"VALUES "
(string-join
(map (match-lambda
((sha1_hash synopsis description home_page)
(string-append
"('" sha1_hash "',"
(value->quoted-string-or-null synopsis) ","
(value->quoted-string-or-null description) ","
(value->quoted-string-or-null home_page) ")")))
metadata-rows)
",")
" RETURNING id"
";"))
(define (inferior-packages->package-metadata-ids conn packages)
(define package-metadata
(map (lambda (package)
(let ((data (list (inferior-package-synopsis package)
(inferior-package-description package)
(inferior-package-home-page package))))
`(,(bytevector->base16-string
(sha1 (string->utf8
(string-join
(map (lambda (d)
(cond
((string? d) d)
((boolean? d) (simple-format #f "~A" d))
(else d)))
data)
":"))))
,@data)))
packages))
(define package-metadata-hashes
(map first package-metadata))
(let* ((existing-package-metadata-entries
(exec-query->vhash conn
(select-package-metadata
package-metadata-hashes)
second ;; sha1_hash
first)) ;; id))
(missing-package-metadata-entries
(delete-duplicates
(filter (lambda (metadata)
(not (vhash-assoc (first metadata)
existing-package-metadata-entries)))
package-metadata)))
(new-package-metadata-entries
(if (null? missing-package-metadata-entries)
'()
(map car (exec-query conn
(insert-package-metadata
missing-package-metadata-entries)))))
(new-entries-id-lookup-vhash
(two-lists->vhash (map first missing-package-metadata-entries)
new-package-metadata-entries)))
(map (lambda (sha1-hash)
(cdr
(or (vhash-assoc sha1-hash
existing-package-metadata-entries)
(vhash-assoc sha1-hash
new-entries-id-lookup-vhash)
(begin
sha1-hash
(error "missing package-metadata entry")))))
package-metadata-hashes)))

90
guix-data-service/model/package.scm Normal file
View file

@ -0,0 +1,90 @@
(define-module (guix-data-service model package)
#:use-module (srfi srfi-1)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (squee)
#:use-module (guix inferior)
#:use-module (guix-data-service model utils)
#:export (select-existing-package-entries
insert-into-package-entries
inferior-packages->package-ids))
(define (select-existing-package-entries package-entries)
(string-append "SELECT id, packages.name, packages.version, "
"packages.package_metadata_id, packages.derivation_id "
"FROM packages "
"JOIN (VALUES "
(string-join (map (lambda (package-entry)
(apply
simple-format
#f "('~A', '~A', ~A, ~A)"
package-entry))
package-entries)
", ")
") AS vals (name, version, package_metadata_id, derivation_id) "
"ON packages.name = vals.name AND "
"packages.version = vals.version AND "
"packages.package_metadata_id = vals.package_metadata_id AND "
"packages.derivation_id = vals.derivation_id"
";"))
(define (insert-into-package-entries package-entries)
(string-append "INSERT INTO packages "
"(name, version, package_metadata_id, derivation_id) VALUES "
(string-join
(map
(match-lambda
((name version package_metadata_id derivation_id)
(simple-format #f "('~A', '~A', ~A, ~A)"
name
version
package_metadata_id
derivation_id)))
package-entries)
",")
" RETURNING id"
";"))
(define (inferior-packages->package-ids conn packages metadata-ids derivation-ids)
(define package-entries
(map (lambda (package metadata-id derivation-id)
(list (inferior-package-name package)
(inferior-package-version package)
metadata-id
derivation-id))
packages
metadata-ids
derivation-ids))
(let* ((existing-package-entry-ids
(exec-query->vhash conn
(select-existing-package-entries package-entries)
;; name, version, package_metadata_id and
;; derivation_id
cdr
first)) ;;id
(missing-package-entries
(filter (lambda (package-entry)
(not (vhash-assoc package-entry
existing-package-entry-ids)))
package-entries))
(new-package-entry-ids
(if (null? missing-package-entries)
'()
(map car
(exec-query
conn
(insert-into-package-entries
missing-package-entries)))))
(new-entries-id-lookup-vhash
(two-lists->vhash missing-package-entries
new-package-entry-ids)))
(map (lambda (package-entry)
(cdr
(or (vhash-assoc package-entry
existing-package-entry-ids)
(vhash-assoc package-entry
new-entries-id-lookup-vhash)
(error "missing package entry"))))
package-entries)))

27
guix-data-service/model/utils.scm Normal file
View file

@ -0,0 +1,27 @@
(define-module (guix-data-service model utils)
#:use-module (srfi srfi-1)
#:use-module (ice-9 vlist)
#:use-module (squee)
#:export (value->quoted-string-or-null
exec-query->vhash
two-lists->vhash))
(define (value->quoted-string-or-null value)
(if (string? value)
(string-append "$STR$" value "$STR$")
"NULL"))
(define (exec-query->vhash conn query field-function value-function)
(fold (lambda (row result)
(vhash-cons (field-function row)
(value-function row)
result))
vlist-null
(exec-query conn query)))
(define (two-lists->vhash l1 l2)
(fold (lambda (key value result)
(vhash-cons key value result))
vlist-null
l1
l2))

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?"))))))