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

Last change on this file since 21337 was 21337, checked in by Moritz Heidkamp, 11 years ago

hyde: add link-shortcuts and improve error formatting a bit

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