From 510e13f1759dee59ba6bc155951db1a6dff49058 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 22 Feb 2020 23:24:24 +0000 Subject: Add a page listing the available database dumps --- Makefile.am | 2 + guix-data-service/config.scm.in | 7 +++ guix-data-service/web/controller.scm | 3 + guix-data-service/web/dumps/controller.scm | 89 ++++++++++++++++++++++++++++++ guix-data-service/web/dumps/html.scm | 50 +++++++++++++++++ 5 files changed, 151 insertions(+) create mode 100644 guix-data-service/web/dumps/controller.scm create mode 100644 guix-data-service/web/dumps/html.scm diff --git a/Makefile.am b/Makefile.am index 4531c65..c233372 100644 --- a/Makefile.am +++ b/Makefile.am @@ -103,6 +103,8 @@ SOURCES = \ guix-data-service/web/build/html.scm \ guix-data-service/web/compare/controller.scm \ guix-data-service/web/compare/html.scm \ + guix-data-service/web/dumps/controller.scm \ + guix-data-service/web/dumps/html.scm \ guix-data-service/web/controller.scm \ guix-data-service/web/html-utils.scm \ guix-data-service/web/jobs/controller.scm \ diff --git a/guix-data-service/config.scm.in b/guix-data-service/config.scm.in index 6532641..9941fca 100644 --- a/guix-data-service/config.scm.in +++ b/guix-data-service/config.scm.in @@ -40,6 +40,13 @@ (if (file-exists? install-dir) install-dir dev-dir))) + (dumps-dir . ,(let ((install-dir + "/var/lib/guix-data-service/dumps") + (dev-dir + (string-append (getcwd) "/dumps"))) + (if (file-exists? install-dir) + install-dir + dev-dir))) (host . "localhost") (port . 8765) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 5a89ed7..111c2e5 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -54,6 +54,7 @@ #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web util) #:use-module (guix-data-service web build controller) + #:use-module (guix-data-service web dumps controller) #:use-module (guix-data-service web revision controller) #:use-module (guix-data-service web nar controller) #:use-module (guix-data-service web jobs controller) @@ -319,6 +320,8 @@ (render-narinfos conn filename)) (('GET "build-servers") (delegate-to-with-secret-key-base build-server-controller)) + (('GET "dumps" _ ...) + (delegate-to dumps-controller)) (((or 'GET 'POST) "build-server" _ ...) (delegate-to-with-secret-key-base build-server-controller)) (('GET "compare" _ ...) (delegate-to compare-controller)) diff --git a/guix-data-service/web/dumps/controller.scm b/guix-data-service/web/dumps/controller.scm new file mode 100644 index 0000000..840ee96 --- /dev/null +++ b/guix-data-service/web/dumps/controller.scm @@ -0,0 +1,89 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2020 Christopher Baines +;;; +;;; 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 +;;; . + +(define-module (guix-data-service web dumps controller) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (ice-9 regex) + #:use-module (web response) + #:use-module (guix-data-service config) + #:use-module (guix-data-service web render) + #:use-module (guix-data-service web dumps html) + #:export (dumps-controller)) + +(define (dumps-controller request + method-and-path-components + mime-types + body + conn) + (match method-and-path-components + (('GET "dumps") + (render-dumps request + mime-types)) + (('GET "dumps" _ ...) + (list (build-response #:code 504) + "requests for individual files should be handled before the request +reaches the Guix Data Service")) + (_ #f))) + +(define (available-dumps) + (define (enter? name stat result) + (or (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]" + (basename name)) + (string=? (%config 'dumps-dir) + name))) + + (define (leaf name stat result) + (match result + (() result) + (((directory-name . files) other-directories ...) + `((,directory-name . ,(sort (cons (basename name) files) + string? (car a) (car b))))) + +(define (render-dumps request mime-types) + (render-html + #:sxml (view-dumps (available-dumps)))) + + + + + + diff --git a/guix-data-service/web/dumps/html.scm b/guix-data-service/web/dumps/html.scm new file mode 100644 index 0000000..71e69c8 --- /dev/null +++ b/guix-data-service/web/dumps/html.scm @@ -0,0 +1,50 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2020 Christopher Baines +;;; +;;; 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 +;;; . + +(define-module (guix-data-service web dumps html) + #:use-module (ice-9 match) + #:use-module (guix-data-service web html-utils) + #:use-module (guix-data-service web view html) + #:export (view-dumps)) + +(define (view-dumps available-dumps) + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h1 "Database dumps"))) + ,@(map + (match-lambda + ((date-string . files) + `(div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h3 ,date-string) + (ul + ,@(map (lambda (name) + `(li (a (@ (href ,(string-join + `("/dumps" ,date-string ,name) + "/"))) + ,name))) + files)))))) + available-dumps))))) -- cgit v1.2.3