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

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

hyde: get rid of `current-output-dir' again

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