blob: 840ee96361343bb379524d3f97cd553ecb18153e (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
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))))
|