You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

117 lines
4.8 KiB
Scheme

9 years ago
(import chicken scheme srfi-1)
(use general-utils (only waffle waffle-sxml->html add-widget widgets widget-rules) md5 message-digest scss)
(include "global.scm")
(include "widgets.scm")
(define (file-md5-hash path)
(message-digest-string (md5-primitive)
(with-input-from-file path (lambda () (read-string)))))
(define (hash-file->src-url file path)
(update-uri path query: `((v ,(file-md5-hash file)))))
(define (compile-scss in out)
(with-output-to-file out
(lambda () (write-css (with-input-from-file in (lambda () (eval (read))))))))
(for-each
(lambda (f)
(compile-scss (++ (filesystem-path-scss) "/" f ".scss")
(++ (filesystem-path-css) "/" f ".css")))
'("news"))
(define (concat-files files)
(with-output-to-string
(lambda ()
(for-each
(lambda (f)
(display (with-input-from-file f read-string)))
files))))
(define (concat-files-and-write resources output)
(let ((combined (with-output-to-string (lambda () (concat-files resources)))))
(with-output-to-file output (lambda () (display combined)))
combined))
(define (md5-hash str)
(message-digest-string (md5-primitive) str))
(define (md5-versioned-path path str)
(update-uri path query: `((v ,(md5-hash str)))))
(define (concat-files-and-version-path files output-file path)
(let ((s (concat-files files)))
(with-output-to-file output-file (lambda () (display s)))
(md5-versioned-path path s)))
(define (waffle-sxml->string sxml)
(with-output-to-string
(lambda ()
(parameterize ((widgets *widgets*) (widget-rules *widget-rules*))
(waffle-sxml->html sxml)))))
;; Takes a list of files, concatenates them together, outputs the
;; result to 'output-file', and returns a URL with an md5 hashed
;; version parameter.
(define (concat-files->html files output-file path proc)
(waffle-sxml->string
(proc (concat-files-and-version-path files output-file path))))
(define (make-javascript-html-proc)
(lambda (url) `(script (@ (type "text/javascript") (language "javascript")
(src ,(uri->string url))))))
(define (make-stylesheet-html-proc)
(lambda (url) `(stylesheet (@ (path ,(uri->string url))))))
(with-output-to-file "pre-generated-html.scm"
(lambda ()
(write `((news-stylesheet-html
. ,(++
(concat-files->html (map (lambda (f) (++ (filesystem-path-css) "/" f))
'("normalize.css" "foundation.min.css"
"font-awesome.min.css"))
(filesystem-path-css-lib)
(uri-css-lib)
(make-stylesheet-html-proc))
(waffle-sxml->string
`(stylesheet
(@ (path
,(uri->string (hash-file->src-url (filesystem-path-css-news)
(uri-css-news)))))))
(waffle-sxml->string
`(link (@ (rel "icon") (type "image/png")
(href ,(uri->string
(hash-file->src-url (filesystem-path-site-icon)
(uri-site-icon)))))))))
(news-javascript-html
. ,(begin (concat-files->html `(,(filesystem-path-js-jquery))
(filesystem-path-js-lib)
(uri-js-lib)
(make-javascript-html-proc))
(conc
"<script src='" (uri->string (hash-file->src-url
(filesystem-path-js-lib)
(uri-js-lib)))
"'></script>"
"<script src='" (uri->string (hash-file->src-url
(filesystem-path-js-news)
(uri-js-news)))
"'></script>")))
(news-logo-normal-uri
.
,(uri->string
(hash-file->src-url (filesystem-path-site-logo-normal)
(uri-site-logo-normal))))
(news-load-javascript
. ,(++
js-uri-var
" var jsFiles = ['"
(string-intersperse
`(,(uri->string (hash-file->src-url (filesystem-path-js-lib)
(uri-js-lib)))
,(uri->string (hash-file->src-url (filesystem-path-js-news)
(uri-js-news)))) "', '")
"']; "))))))