blob: db5e7a29ce4daff85cfd7c513d2e30282846e4f2 (
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
|
(define-module (tekuti projects)
#:use-module ((tekuti config) #:select (*projects-dir*))
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (tekuti git)
#:use-module (tekuti page-helpers)
#:export (page-projects))
(use-modules (ice-9 ftw)
(ice-9 match))
(define remove-stat
(match-lambda
((name stat)
name)
((name stat children ...)
(list name (map remove-stat children)))))
(define (list-projects)
(remove-stat
(file-system-tree
*projects-dir*
(lambda (name stat)
(not (file-exists? (string-append name "/config")))))))
(define (project-description project)
(let ((dfile-name
(string-append project "/description")))
(if (file-exists? dfile-name)
(with-input-from-file dfile-name
(lambda ()
(read-line)))
"Unknown")))
(define (remove-suffix str suffix)
(let ((pos (string-contains str suffix)))
(if pos
(substring str 0 pos)
str)))
(define (project->row dir project prefix)
(let ((project-dir (string-append dir "/" project))
(project-name (remove-suffix project ".git")))
`(tr
(td (@ (class "span3"))
(a (@ (href "http://code.ryuslash.org/cgit.cgi/"
,prefix "/" ,project-name))
,project-name))
(td (@ (class "span6")) ,(project-description project-dir))
(td (@ (class "span2")) ,(git-last-update project-dir))
(td (@ (class "span1")) ""))))
(define (project-list->table top-dir list lvl prefix)
(let ((head (car list))
(body (cadr list)))
`((,(string->symbol (string-append "h" (number->string lvl))) ,head)
(table
(@ (class "table table-condensed table-striped"))
(thead
(tr
(th "Name")
(th "Description")
(th "Last update")
(th "")))
(tbody
,@(map (lambda (elt)
(project->row top-dir elt prefix))
(filter (lambda (elt)
(and (string? elt)
(access? (string-append top-dir "/" elt) R_OK)))
body))))
,@(map (lambda (elt) (project-list->table
(string-append top-dir (car elt)) elt (1+ lvl)
(string-append prefix (car elt))))
(filter
(lambda (elt)
(and (list? elt)
(access? (string-append top-dir (car elt)) X_OK)))
body)))))
(define (page-projects request body index)
(respond (project-list->table *projects-dir* (list-projects) 1 "")
#:extra-headers '((pragma . (no-cache (broccoli . "tastyy"))))))
|
