Add a page listing the available database dumps

4 files changed, 149 insertions, 0 deletions

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