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

Add a page listing the available database dumps

Browse source
This commit is contained in:
Christopher Baines 2020-02-22 23:24:24 +00:00
parent 9178bd51a9
commit 510e13f175
5 changed files with 151 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Makefile.am
View file

@ -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 \

7
guix-data-service/config.scm.in
View file

@ -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)

3
guix-data-service/web/controller.scm
View file

@ -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))

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

@ -0,0 +1,89 @@
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2020 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 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<?))
,@other-directories))))
(define (down name stat result)
(if (string=? (%config 'dumps-dir)
name)
result
`((,(basename name) . ())
,@result)))
(define (up name stat result) result)
(define (skip name stat result) result)
(define (error name stat errno result)
(format (current-error-port) "warning: ~a: ~a~%"
name (strerror errno))
result)
(sort (file-system-fold enter? leaf down up skip error
'() ; Start with an empty alist
(%config 'dumps-dir))
(lambda (a b)
;; Sort so that the recent dumps are first
(string>? (car a) (car b)))))
(define (render-dumps request mime-types)
(render-html
#:sxml (view-dumps (available-dumps))))

50
guix-data-service/web/dumps/html.scm Normal file
View file

@ -0,0 +1,50 @@
;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2020 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 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)))))