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
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
(define-module (tekuti projects)
#:use-module ((tekuti config) #:select (*projects-dir*))
#:use-module ((tekuti page) #:select (page-not-found))
#: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)
#:use-module (web uri)
#:use-module (web request)
#:export (page-projects page-project))
(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-url prefix name)
(uri-encode
(string-append prefix (if (string-null? prefix) "" "/") name)))
(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 ,(project-url 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"))))))
(define (project-pages-menu request project page)
(let ((page-list '("summary" "refs" "log" "tree" "commit" "diff"
"stats" "about")))
`((div (@ (class "navbar"))
(div (@ (class "navbar-inner"))
(a (@ (class "brand") (href ".")) ,project)
(ul (@ (class "nav"))
,@(map
(lambda (elm)
`(li (@ (class ,(if (string= page elm)
"active"
"")))
,(rellink `("projects" ,project ,elm)
(string-capitalize elm))))
page-list)))))))
(define* (page-project request body index project page)
(if (file-exists? (string-append *projects-dir* project ".git"))
(respond `(,(project-pages-menu request project (or page "summary"))
(p "Goto: "
(a (@ (href "http://code.ryuslash.org/cgit.cgi/"
,project "/" ,(or page "")))
"cgit " ,(or page "summary")))))
(page-not-found request body index)))
|
