source: project/release/4/hyde/trunk/hyde.scm @ 27133

Last change on this file since 27133 was 27133, checked in by Moritz Heidkamp, 9 years ago

hyde: Fix escaping issue in colorize-code (thanks Peter Bex for the patch)

File size: 16.6 KB
Line 
1(module hyde
2
3(load-hyde-file
4 hyde-environment
5 hyde-environments
6 define-hyde-environment
7 initialize-site
8 generate-page
9 pathify
10 make-external-translator
11 serve
12 source-dir
13 output-dir
14 layouts-dir
15 default-layouts
16 clean-before-build
17 excluded-paths
18 default-extension
19 default-page-vars
20 page-eval-env
21 translators
22 compile-pages
23 uri-path-prefix
24 markdown-program
25 link-shortcuts
26 sxml-conversion-rules
27 ignore-page?)
28
29(import chicken scheme files data-structures extras srfi-1 ports srfi-13 utils)
30(require-extension regex)
31(import irregex)
32
33(use posix
34     (rename filepath (filepath:make-relative pathname-relative-from))
35     environments
36     sxml-transforms
37     doctype
38     matchable
39     scss
40     spiffy
41     srfi-18
42     colorize
43     intarweb
44     uri-common
45     svnwiki-sxml
46     defstruct
47     (rename multidoc (html-transformation-rules
48                       multidoc-html-transformation-rules)))
49
50(defstruct page source-path path (vars '()) reader writer type)
51
52(define (with-page page proc #!optional (key page))
53  (cond ((page? page) (parameterize ((current-page page)) (proc page)))
54        ((string? page) (with-page (alist-ref page (pages) string=?) proc page))
55        (else (die (conc "unknown page: " key) 3))))
56
57(define (write-page page)
58  ((with-page page page-writer)))
59
60(define (read-page page #!rest layouts)
61  (with-page page
62     (lambda (page)
63       (parameterize ((current-page page))
64         (wrap-with-layouts ((with-page page page-reader)) layouts)))))
65
66(define hyde-environment (make-parameter 'default))
67(define hyde-environments (make-parameter '(default)))
68(define source-dir (make-parameter "src"))
69(define output-dir (make-parameter "out"))
70(define layouts-dir (make-parameter "layouts"))
71(define default-layouts (make-parameter '("default.sxml")))
72(define clean-before-build (make-parameter #t))
73(define excluded-paths (make-parameter (list (irregex '(seq "~" eos)))))
74(define default-extension (make-parameter "html"))
75(define default-page-vars (make-parameter '()))
76(define uri-path-prefix (make-parameter ""))
77(define markdown-program (make-parameter "markdown"))
78(define link-shortcuts (make-parameter '()))
79(define ignore-page? (make-parameter #f))
80
81(define translators (make-parameter '()))
82(define current-page (make-parameter #f))
83(define pages (make-parameter '()))
84(define page-eval-env
85  (make-parameter
86   (environment-copy
87    (cond-expand
88     (module-environments
89      (module-environment 'big-chicken))
90     (else
91      (interaction-environment)))
92    #t)))
93
94(define-syntax define-hyde-environment 
95  (syntax-rules ()
96    ((_ name e1 e2 ...)
97     (begin
98       (hyde-environments (cons 'name (hyde-environments)))
99       (when (eq? 'name (hyde-environment))
100         e1 e2 ...)))))
101
102(define (with-current-page-default accessor)
103  (lambda (#!optional (page (current-page)))
104    (accessor page)))
105
106(for-each (lambda (b)
107            (environment-set! (page-eval-env) (car b) (cdr b)))
108          `((read-page . ,read-page)
109            (page-vars . ,(with-current-page-default page-vars))
110            (page-path . ,(with-current-page-default page-path))
111            (page-type . ,(with-current-page-default page-type))
112            (page-source-path . ,(with-current-page-default page-source-path))
113            (current-page . ,current-page)
114            ($ . ,(lambda (name #!optional (page (current-page)))
115                    (alist-ref name (page-vars page))))))
116
117(define default-layout-template #<<END
118()
119`((xhtml-1.0-strict)
120  (html
121   (head
122    (title ,($ 'title)))
123   (body
124    (h1 ,($ 'title))
125    (inject ,contents))))
126END
127)
128
129(define (output-xml doc rules)
130  (SRV:send-reply (fold (lambda (rule doc)
131                          (pre-post-order* doc rule))
132                        doc
133                        rules)))
134
135(define (colorize-code language code)
136  (let* ((class (conc "highlight " language "-language"))
137         (code (map (lambda (s)
138                      (handle-exceptions exn
139                        (htmlize s)
140                        (html-colorize language s)))
141                    code)))
142
143    `(pre (@ (class ,class)) (inject . ,code))))
144
145(define sxml-colorize-rules
146  `((highlight *macro* . ,(lambda (tag els)
147                            (cons 'colorize els)))
148    (colorize *preorder* . ,(lambda (tag els)
149                              (colorize-code (car els) (cdr els))))
150    ,@alist-conv-rules*))
151
152(define sxml-conversion-rules 
153  `((inject *preorder* . ,(lambda (tag sxml) sxml))
154    (shortcut . ,(lambda (tag attrs)
155                   (apply expand-link-shortcut attrs)))
156    ,@doctype-rules
157    ,@universal-conversion-rules*))
158
159(define (expand-link-shortcut alias . args)
160  (let ((uri-template (alist-ref alias (link-shortcuts))))
161    (cond ((not uri-template)
162           (error 'expand-link-shortcut
163                  (format "invalid link shortcut: ~S" alias)))
164          ((procedure? uri-template)
165           (apply uri-template args))
166          (else
167           (apply format uri-template (map uri-encode-string args))))))
168
169(define (print-error error)
170  (with-output-to-port (current-error-port)
171    (cut print "ERROR: " error)))
172
173(define (die error exit-code)
174  (print-error error)
175  (exit exit-code))
176
177(define (load-hyde-file #!optional (die-when-missing? #t))
178  (if (file-exists? "hyde.scm")
179      (begin
180        (load "hyde.scm")
181        (unless (memq (hyde-environment) (hyde-environments))
182          (die (format "environment '~A' is not defined for this site" (hyde-environment)) 1)))
183      (begin
184        (print-error "no hyde.scm found")
185       
186        (if die-when-missing? 
187            (exit 1)
188            (begin (newline) #f)))))
189
190(define (create-directory-verbose name)
191  (print "creating " name)
192  (create-directory name #t))
193
194(define (initialize-site)
195  (unless (null? (directory))
196    (die "unable to initialize site, directory is not empty" 2))
197 
198  (create-directory-verbose (layouts-dir))
199  (create-directory-verbose (source-dir))
200  (create-directory-verbose (output-dir))
201
202  (print "creating hyde.scm")
203  (with-output-to-file "hyde.scm" (cut write '(use hyde)))
204  (let ((default-layout (make-pathname (layouts-dir) (car (default-layouts)))))
205    (print "creating " default-layout)
206    (with-output-to-file default-layout
207      (cut print default-layout-template))))
208
209(define (pathify string)
210  (let* ((path  (string-downcase string))
211         (path  (irregex-replace/all '(submatch (+ (~ alpha #\- #\space))) path ""))
212         (path  (irregex-replace/all '(submatch (+ (" -"))) path "-")))
213    (string-trim-both path #\-)))
214
215(define (generate-page ext title)
216  (let* ((title (string-intersperse title))
217         (path (pathify title))
218         (path (make-pathname (source-dir) path ext)))
219    (with-output-to-file path (cut write `((title . ,title))))
220    (print path)))
221
222(define (page-by-path path)
223  (let* ((path (if (string=? "" (car path))
224                   path
225                   (cons "" path)))
226         (path (cons (car path)
227                     (remove string-null? (cdr path))))
228         (path (string-join path "/"))
229         (path (if (string=? "" path) "/" path))
230         (page (find (lambda (page)
231                       (string=? (page-path (cdr page)) path))
232                     (pages))))
233    (and page (cdr page))))
234
235(define (send-page page)
236  (print-page-paths page)
237  (send-response body: (parameterize ((current-page page))
238                         (wrap-with-layouts (read-page page)))
239                 headers: `((content-type ,(file-extension->mime-type
240                                            (pathname-extension (page-path page)))))))
241
242(define (serve)
243  (root-path (source-dir))
244 
245  (vhost-map `((".*" . 
246                ,(lambda (continue)
247                   (with-pages
248                    (lambda () 
249                      (let* ((path (cdr (uri-path (request-uri (current-request)))))
250                             (page (page-by-path path)))
251
252                        (case (and page (page-type page))
253                          ((dynamic) (send-page page))
254
255                          ((directory) 
256                           (call/cc (lambda (break)
257                                      (for-each (lambda (index-file)
258                                                  (let* ((index-path (append path (list index-file)))
259                                                         (index-page (page-by-path index-path)))
260
261                                                    (when index-page
262                                                      (send-page index-page)
263                                                      (break index-page))))
264                                                (index-files))
265
266                                      (continue))))
267
268                          (else (continue))))))))))
269
270  (print (format "spiffy serving hyde on port ~A" (server-port)))
271  (start-server))
272
273(define (cmd name . args)
274  (receive (_ exited-normally status)
275    (process-wait (process-run name args))
276    (unless (and exited-normally (zero? status))
277      (error (format "error executing ~A ~A" name (string-intersperse args))))))
278
279(define (make-output-path path #!optional page)
280  (let ((output-file (make-pathname (output-dir) (pathname-relative-from (source-dir) path))))
281    (if page
282        (pathname-replace-extension output-file (->string (or (alist-ref 'ext (page-vars page)) (default-extension))))
283        output-file)))
284
285(define (make-access-path path #!optional page)
286  (let ((path (pathname-relative-from 
287               (output-dir) 
288               (make-output-path path page))))
289    (make-absolute-pathname 
290     (uri-path-prefix)
291     (if (string=? path ".") 
292         "/"
293         path))))
294
295(define (call-with-returning value proc)
296  (proc value)
297  value)
298
299(define (wrap-with-layout layout contents)
300  (with-input-from-source-file layout
301    (lambda (meta)
302      (match (translator-for layout)
303        ((translate . translator-page-vars)
304         (page-vars-set! (current-page) (append (page-vars (current-page)) meta translator-page-vars))
305         (environment-set! (page-eval-env) 'contents contents)
306         (translate))
307        (else (format "unknown layout format: ~A" layout))))))
308
309(define (wrap-with-layouts contents #!optional layouts)
310  (let* ((layouts (or layouts (alist-ref 'layouts (page-vars (current-page))) (default-layouts))))
311    (fold (cut wrap-with-layout <> <>)
312          contents
313          (map (cut make-pathname (layouts-dir) <>) layouts))))
314
315(define (with-input-from-source-file source-file proc)
316  (with-input-from-file source-file
317    (lambda ()
318      (proc (read)))))
319
320(define (compile-page-by-extension file translate page #!optional (env (environment-copy (page-eval-env))))
321  (with-input-from-source-file file 
322    (lambda (meta)
323      (parameterize ((current-page page) (page-eval-env env))
324        (translate)))))
325
326(define (translator-for file)
327  (and-let* ((ext (pathname-extension file))
328             (translator (alist-ref ext (translators) string=?)))
329    (cons (lambda () 
330            (with-output-to-string (car translator)))
331          (cdr translator))))
332
333(define (default-page-vars-for page)
334  (append-map cdr (filter (lambda (d)
335                            (if (procedure? (car d))
336                                ((car d) page)
337                                (irregex-search (car d) (page-source-path page))))
338                          (default-page-vars))))
339
340(define (classify-path path)
341  (let* ((source-path (pathname-relative-from (source-dir) path))
342         (source-path (if (string=? "." source-path) "" source-path)))
343    (cons source-path
344          (cond ((directory? path)
345                 (make-page type: 'directory
346                            source-path: source-path
347                            path: (make-access-path path)
348                            reader: (lambda () (directory path))
349                            writer: (lambda () (create-directory (make-output-path path) #t))))
350                ((translator-for path) =>
351                 (lambda (translator)
352                   (let* ((translate (car translator))
353                          (translator-page-vars (cdr translator))
354                          (local-page-vars (or (with-input-from-file path read) '()))
355                          (page (make-page type: 'dynamic
356                                           source-path: source-path
357                                           vars: (append local-page-vars translator-page-vars)))
358                          (page (update-page page path: (make-access-path path page)))
359                          (page (update-page page vars: (append local-page-vars
360                                                                (default-page-vars-for page)
361                                                                translator-page-vars)))
362                          (reader (let ((contents #f))
363                                    (lambda ()
364                                      (unless contents
365                                        (set! contents (compile-page-by-extension path translate page)))
366                                      contents)))
367                          (writer (lambda () 
368                                    (with-output-to-file (make-output-path path page)
369                                      (lambda ()
370                                        (parameterize ((current-page page))
371                                          (display (wrap-with-layouts (reader)))))))))
372                     (update-page page writer: writer reader: reader))))
373                (else (make-page type: 'static
374                                 source-path: source-path
375                                 path: (make-access-path path)
376                                 reader: (lambda () (read-all path))
377                                 writer: (lambda () (file-copy path (make-output-path path) #t))))))))
378
379(define (print-page-paths page)
380  (display (page-source-path page))
381  (print " -> " (substring (page-path page) 1)))
382
383(define (compile-page page)
384  (unless (and (ignore-page?) ((ignore-page?) page))
385    (unless (eq? 'directory (page-type page))
386      (print-page-paths page))
387    (write-page page)))
388
389(define (exclude-file? file)
390  (any (cut irregex-search <> file) (excluded-paths)))
391
392(define (with-pages thunk #!optional include-file?)
393  (parameterize ((pages '()))
394    (prepare-compilation (or include-file? (constantly #t)))
395    (thunk)))
396
397(define (prepare-compilation include-file?)
398  (pages (list (classify-path (source-dir))))
399  (environment-set! (page-eval-env) 'uri-path-prefix (uri-path-prefix))
400  (environment-set! (page-eval-env) 'pages pages)
401
402  (find-files (source-dir)
403              test: (conjoin (complement exclude-file?)
404                             include-file?)
405              action: (lambda (file _)
406                        (pages (cons (classify-path file) (pages))))))
407
408(define (compile-pages path-prefixes)
409  (when (clean-before-build)
410    (print "cleaning output directory")
411    (cmd "rm" "-rf" (output-dir))
412    (create-directory (output-dir) #t))
413
414  (print "preparing compilation")
415  (with-pages
416   (lambda ()
417     (print "compiling pages")
418     (for-each (compose compile-page cdr) (reverse (pages))))
419   (and (not (null? path-prefixes))
420        (lambda (file)
421          (any (lambda (prefix)
422                 (string-prefix? prefix file))
423               path-prefixes)))))
424
425(define (translate/sxml)
426  (output-xml (map (lambda (e) (eval e (page-eval-env))) (read-file))
427              (list sxml-colorize-rules sxml-conversion-rules)))
428
429(translators (cons (list "sxml" translate/sxml) (translators)))
430
431(define-syntax make-external-translator
432  (syntax-rules ()
433    ((_ name)
434     (let ((read/write-lines
435            (lambda () (port-for-each print read-line))))
436       (lambda ()
437         (receive (in out pid err)
438                  (process* name)
439                  (with-output-to-port out read/write-lines)
440                  (close-output-port out)
441                  (with-input-from-port in read/write-lines)
442                  (close-input-port in)
443                  (close-input-port err)))))))
444
445(define translate/markdown (make-external-translator (markdown-program)))
446
447(translators (cons (list "md" translate/markdown) (translators)))
448
449(define (translate/scss)
450  (let loop ((sexp (read)))
451    (unless (eof-object? sexp)
452      (let ((scss (eval sexp (page-eval-env))))
453        (scss->css (if (memq (car scss) '(css css+))
454                       scss
455                       (cons 'css+ scss))))
456      (loop (read)))))
457
458(translators (cons (list "scss" translate/scss '(ext . css) '(layouts))
459                   (translators)))
460
461(define +svnwiki-shortcut-link+ 
462  (irregex `(seq (submatch (+ (~ #\:))) #\: (submatch (+ any)))))
463
464(define (expand-link-shortcut/svnwiki tag attrs)
465  (let* ((m (irregex-match +svnwiki-shortcut-link+ (car attrs)))
466         (uri (cond ((and m (irregex-match-substring m 1)) =>
467                     (lambda (alias)
468                       (expand-link-shortcut (string->symbol alias)
469                                             (irregex-match-substring m 2))))
470                    (else (car attrs)))))
471                                                     
472    (list (if (absolute-uri? (uri-reference uri))
473              'link
474              'int-link)
475          uri
476          (cdr attrs))))
477
478(define (translate/svnwiki)
479  (let* ((doc (svnwiki->sxml (current-input-port)))
480         (doc (pre-post-order* doc `((int-link . ,expand-link-shortcut/svnwiki)
481                                     ,@alist-conv-rules*)))
482         (rules (multidoc-html-transformation-rules doc))
483         (rules (append (butlast rules)
484                        (list (cons (assq 'inject sxml-conversion-rules)
485                                    (last rules))))))
486
487    (output-xml doc (cons sxml-colorize-rules rules))))
488
489(translators (cons* (list "wiki" translate/svnwiki)
490                    (list "sw" translate/svnwiki)
491                    (translators)))
492
493)
494
Note: See TracBrowser for help on using the repository browser.