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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
|
;;; guix-forge --- Guix software forge meta-service
;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of guix-forge.
;;;
;;; guix-forge is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; guix-forge 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
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with guix-forge. If not, see
;;; <https://www.gnu.org/licenses/>.
(define-module (forge cgit)
#:use-module (forge environment)
#:use-module (forge fcgiwrap)
#:use-module (forge nginx)
#:use-module (forge socket)
#:use-module ((gnu packages emacs) #:select (emacs-minimal))
#:use-module ((gnu packages mail) #:select (mailcap))
#:use-module ((gnu packages version-control)
#:select (cgit git-minimal))
#:use-module (gnu services)
#:use-module ((gnu services web) #:select (nginx-server-configuration
nginx-location-configuration))
#:use-module (gnu system file-systems)
#:use-module (guix gexp)
#:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:export (%cgit-readme
<cgit-configuration>
cgit-configuration
cgit-configuration?
cgit-configuration-cgit
cgit-configuration-git
cgit-configuration-server-name
cgit-configuration-repository-directory
cgit-configuration-socket
cgit-configuration-readme
cgit-configuration-snapshots
cgit-configuration-about-filter
cgit-configuration-commit-filter
cgit-configuration-email-filter
cgit-configuration-source-filter
cgit-configuration-mimetype-file
cgit-configuration-repository-sort
cgit-configuration-plain-email?
cgit-configuration-extra-options
cgit-service-type))
(define %cgit-readme
(append (list "README.md" "README.markdown" "README.mdown" "README.mkd"
"README.org" "README.rst")
;; man page READMEs
(map (lambda (n)
(string-append "README." (number->string n)))
(iota 9 1))
(list "README.htm" "README.html"
"README.txt"
"README")))
(define-record-type* <cgit-configuration>
cgit-configuration make-cgit-configuration
cgit-configuration?
this-cgit-configuration
(cgit cgit-configuration-cgit
(default cgit))
(git cgit-configuration-git
(default git-minimal))
(server-name cgit-configuration-server-name)
(repository-directory cgit-configuration-repository-directory
(default "/srv/git"))
(socket cgit-configuration-socket
(default (forge-unix-socket
(path "/var/run/fcgiwrap/cgit/socket"))))
;; TODO: Support org mode and gemtext READMEs too.
(readme cgit-configuration-readme
(default %cgit-readme))
(snapshots cgit-configuration-snapshots
(default (list "tar.gz"))
(sanitize sanitize-cgit-snapshots))
(about-filter cgit-configuration-about-filter
(default (program-file "about-filter"
(about-filter-gexp this-cgit-configuration)))
(thunked))
(commit-filter cgit-configuration-commit-filter
(default #f))
(email-filter cgit-configuration-email-filter
(default #f))
(source-filter cgit-configuration-source-filter
(default (file-append (cgit-configuration-cgit
this-cgit-configuration)
"/lib/cgit/filters/syntax-highlighting.py"))
(thunked))
(mimetype-file cgit-configuration-mimetype-file
(default (file-append mailcap "/etc/mime.types")))
(repository-sort cgit-configuration-repository-sort
(default 'age)
(sanitize sanitize-cgit-repository-sort))
(plain-email? cgit-configuration-noplainemail?
(default #false))
(extra-options cgit-configuration-extra-options
(default '())))
(define (sanitize-cgit-snapshots snapshots)
(let ((valid-snapshots (list "tar" "tar.gz" "tar.bz2" "tar.lz"
"tar.xz" "tar.zst" "zip")))
(for-each (lambda (snapshot)
(unless (member snapshot valid-snapshots)
(leave (G_ "Snapshot ~a is not one of ~s.~%"
snapshot
valid-snapshots))))
snapshots)
snapshots))
(define (sanitize-cgit-repository-sort repository-sort)
(case repository-sort
((name age) repository-sort)
(else
(leave (G_ "Invalid cgit repository-sort '~s. It should either be 'age or 'name.~%")
repository-sort))))
(define (about-filter-gexp config)
"Return G-expression for a cgit about-filter. Use cgit package
configured in @var{config}."
(match-record config <cgit-configuration>
(cgit)
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils)
(ice-9 match)
(srfi srfi-1))
(match (command-line)
((_ about-file)
(cond
((or (string-suffix-ci? ".markdown" about-file)
(string-suffix-ci? ".mdown" about-file)
(string-suffix-ci? ".md" about-file)
(string-suffix-ci? ".mkd" about-file))
(invoke #$(file-append cgit "/lib/cgit/filters/html-converters/md2html")
about-file))
((string-suffix-ci? ".org" about-file)
(invoke #$(file-append emacs-minimal "/bin/emacs")
"--script"
#$(local-file "org2html.el")))
((string-suffix-ci? ".rst" about-file)
(invoke #$(file-append cgit "/lib/cgit/filters/html-converters/rst2html")
about-file))
((any (lambda (n)
(string-suffix-ci? (string-append "." (number->string n))
about-file))
(iota 9 1))
(invoke #$(file-append cgit "/lib/cgit/filters/html-converters/rst2html")
about-file))
((or (string-suffix-ci? ".htm" about-file)
(string-suffix-ci? ".html" about-file))
(put-bytevector (current-output-port)
(call-with-input-file about-file
get-bytevector-all)))
(else
(invoke #$(file-append cgit "/lib/cgit/filters/html-converters/txt2html")
about-file)))))))))
(define (cgitrc-gexp config)
"Return G-expression to serialize @var{config} into cgitrc."
(match-record config <cgit-configuration>
(repository-directory
readme snapshots
about-filter commit-filter email-filter source-filter
mimetype-file repository-sort plain-email? extra-options)
#~(begin
(use-modules (ice-9 match))
(call-with-output-file #$output
(lambda (port)
(for-each (match-lambda
((key #t)
(format port "~a=1~%" key))
((key #f)
(format port "~a=0~%" key))
((key value)
(format port "~a=~a~%" key value)))
'#$(append (map (lambda (file)
(list "readme" (string-append ":" file)))
readme)
(if about-filter
`(("about-filter" ,about-filter))
(list))
(if commit-filter
`(("commit-filter" ,commit-filter))
(list))
(if email-filter
`(("email-filter" ,email-filter))
(list))
(if source-filter
`(("source-filter" ,source-filter))
(list))
(if mimetype-file
`(("mimetype-file" ,mimetype-file))
(list))
;; The order of settings in cgitrc is
;; significant.
`(("snapshots" ,(string-join snapshots))
("repository-sort" ,(symbol->string repository-sort))
("noplainemail" ,(not plain-email?))
("enable-index-owner" #f)
("virtual-root" "/")
,@(map (match-lambda
((key . value)
(list key value)))
extra-options)
("scan-path" ,repository-directory)))))))))
(define (cgit-fcgiwrap-instance config)
(match-record config <cgit-configuration>
(cgit git repository-directory)
(let ((cgitrc (computed-file "cgitrc" (cgitrc-gexp config))))
(fcgiwrap-instance
(name "cgit")
(user "nginx")
(group "nginx")
(environment-variables (list (environment-variable
(name "CGIT_CONFIG")
(value cgitrc))))
(mappings (list (file-system-mapping
(source repository-directory)
(target source))
(file-system-mapping
(source cgit)
(target source))
(file-system-mapping
(source cgitrc)
(target source))
(file-system-mapping
(source (file-append git "/libexec/git-core/git-http-backend"))
(target source))))))))
(define cgit-nginx-server-block
(match-record-lambda <cgit-configuration>
(cgit git server-name socket repository-directory)
(nginx-server-configuration
(server-name (list server-name))
;; cgit static files
(root (file-append cgit "/share/cgit"))
(try-files (list "$uri" "@cgit"))
(locations
(list
;; git-http-backend for the smart HTTP protocol
(nginx-location-configuration
(uri "~ ^/.*/(HEAD|info/refs|git-receive-pack|git-upload-pack).*$")
(body (list "fastcgi_param SCRIPT_FILENAME "
(file-append git "/libexec/git-core/git-http-backend;")
(string-append "fastcgi_param GIT_PROJECT_ROOT "
repository-directory
";")
"fastcgi_param GIT_HTTP_EXPORT_ALL yes;"
"fastcgi_param PATH_INFO $uri;"
"fastcgi_param QUERY_STRING $query_string;"
"fastcgi_param REQUEST_METHOD $request_method;"
"fastcgi_param CONTENT_TYPE $content_type;"
(string-append "fastcgi_pass "
(nginx-socket->string socket)
";"))))
;; cgit web interface
(nginx-location-configuration
(uri "@cgit")
(body (list
#~(string-append "fastcgi_param SCRIPT_FILENAME "
#$(file-append cgit "/lib/cgit/cgit.cgi")
";")
"fastcgi_param PATH_INFO $uri;"
"fastcgi_param QUERY_STRING $query_string;"
"fastcgi_param HTTP_HOST $server_name;"
(string-append "fastcgi_pass "
(nginx-socket->string socket)
";")))))))))
(define cgit-service-type
(service-type
(name 'cgit)
(description "Run cgit.")
(extensions (list (service-extension fcgiwrap-service-type
(compose list cgit-fcgiwrap-instance))
(service-extension forge-nginx-service-type
(compose list cgit-nginx-server-block))))))
|
