HOORAY!!!!!!!
My blog is up and running! Like so many hackers I've written my own blogging engine (so what's new?). Blogger wasn't working out for me - I like Vi and text :-).
So anyway, I think this will finally get me a blog the way I like it!
The blog generator is written in Scheme Lisp and took me about two weeks to get to this stage. A lot of that time was spent in discovering what I wanted. Coding in Lisp, as always, was fun.
The generator does the following:
- Optionally runs an arbitary pre-start command. I use it to synchronize across my machines.
- Parses all posts. Recognizes tags, code blocks, images, hrefs, formatting etc..
- Wipes out and re-creates the site. Uses the template engine to generate all posts and landing pages.
- Generates the RSS Feed.
- Removes links to hidden posts
- Creates available backdoors
- Finally, copies any additional supporting files
The coolest part of the engine, for me, was the template engine. I figured out a good blog format pretty quickly and wrote the parser. Then I had to make all the parsed data available to the HTML template in a useful form.
For a couple of days I toyed with different approaches - the problem is the data can be used in so many different ways. For instance take the list of posts alone:
- sometimes I need it ordered by date
- sometimes I need it ordered by relevance to another post
- sometimes I need it filtered by tag
- sometimes I need the count
- ... and so on
At last, in a
Lisp Lightbulb Moment (cue melodramatic music) I figured
the way to do it - use Lisp itself!
My environment now extends to the templates themselves. My templates are HTML with embedded Lisp. No syntax headaches and the complete power of my environment to do whatever I want! What could be cooler? :-)
Following is the code for the
parser, the
site generator and a
sample template with embedded Lisp.
_
UPDATE: 2010-03-07__
Newer version of the code can be found
here.
Starting with some helper code:
helper.scm
;; Ensure that we have regular expressions
(require 'regex)
;; We need date functions as well
(require 'posix)
;; We need list and string functions
(require 'srfi-1)
(require 'srfi-13)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helper functions
(define bd-strip-ws #f)
;; Removes whitespace from both ends of a string ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((strip (regexp "[ \t]*(.*[^ \t])[ \t]*")))
(regexp-optimize strip) ; To call this only once, the function
(set! bd-strip-ws ; is set here.
(lambda (_str)
(let ((ss (string-match strip _str)))
(if ss (list-ref ss 1) ""))))) ; Fails to match == empty string
(define (bd-display-date dt)
;; Converts the given date into a nice visual representation ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(set! dt (seconds->local-time dt))
(let ((y (+ 1900 (vector-ref dt 5)))
(m (+ 1 (vector-ref dt 4)))
(d (vector-ref dt 3)))
(if (> 10 m) (set! m (format "0~A" m)))
(if (> 10 d) (set! d (format "0~A" d)))
(format "~S-~A-~A" y m d)))
(define (bd-display-yymm dt)
;; Converts the given date into a visual representation of month-year ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(set! dt (seconds->local-time dt))
(let ((y (+ 1900 (vector-ref dt 5)))
(m (+ 1 (vector-ref dt 4))))
(if (> 10 m) (set! m (format "0~A" m)))
(format "~S-~A" y m)))
(define (bd-rss-date dt)
;; Converts the given date into RSS required format (RFC822) ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(set! dt (seconds->local-time dt))
(let ((y (+ 1900 (vector-ref dt 5)))
(m (vector-ref (vector "Jan" "Feb" "Mar" "Apr" "May" "Jun"
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
(vector-ref dt 4)))
(d (vector-ref dt 3))
(wd (vector-ref (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")
(vector-ref dt 6))))
(format "~A, ~A ~A ~A 00:00:00 GMT" wd d m y)))
(define (bd-make-html-safe _str)
;; Replaces HTML entities with their safe equivalents ;;
;; < becomes < > becomes > ;;
;; " becomes " & becomes & ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(string-substitute
"<" "<"
(string-substitute
">" ">"
(string-substitute
"\"" """
(string-substitute
"\\&" "&" _str 'g) 'g) 'g) 'g))
;; A single post
(define-record post fname ofname link title date tags quot content teaser)
(define (bd-posts-by-similarity _post _posts)
;; Returns posts sorted by similarity to the given post ;;
;; Similarity is checked by number of matching tags ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((bd-pbs-1
(lambda (p)
(let ((i 0))
(for-each (lambda (tg)
(if (member tg (post-tags _post))
(set! i (+ i 1)))) (post-tags p))
i))))
(filter (lambda (p) (not (eq? p _post)))
(sort _posts
(lambda (p1 p2)
(let ((i1 (bd-pbs-1 p1))(i2 (bd-pbs-1 p2)))
(cond ((< i1 i2) #f)
((> i1 i2) #t)
(#t (> (post-date p1) (post-date p2))))))))))
(define (bd-post-teaser _line)
;; Cleans up formatting and trims the line as a small teaser ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(set! _line (string-substitute (regexp* "<.*>" '(ungreedy)) "" _line 'g))
(if (> (string-length _line) 64)
(string-append (substring _line 0 64) "...")
_line))
(define (bd-file-copy _src _dest)
;; Copies a file from source to destination ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(call-with-input-file _src
(lambda (ip) (call-with-output-file _dest
(lambda (op)
(let loop ((c (read-char ip)))
(when (not (eof-object? c))
(write-char c op)
(loop (read-char ip))))) #:binary)) #:binary))
(define (bd-tag-file _tag)
;; Generates a tag file name from a tag ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(string-append "tag-" (string-downcase (string-delete #\/ _tag)) ".htm"))
(define *bdfc-buf-size* 2048)
(define (bd-file-copy _src _dest)
;; Copies a file from source to destination ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(call-with-input-file _src
(lambda (ip) (call-with-output-file _dest
(lambda (op)
(let ((data (make-string *bdfc-buf-size*)))
(let loop ((n *bdfc-buf-size*))
(when (= n *bdfc-buf-size*)
(set! n (read-string! *bdfc-buf-size* data ip))
(write-string data n op)
(loop n)))))
#:binary))
#:binary))
(define (bd-copy-dir _src _dest _filterfn)
;; Recursively copies a directory from source to destination ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (not (directory? _src))
(error (format "Cannot copy ~S as directory!" _src)))
(if (not (directory? _dest))
(create-directory _dest))
(for-each
(lambda (f)
(let ((src (string-append _src "/" f))
(dest (string-append _dest "/" f)))
(if (_filterfn src)
(if (directory? src)
(bd-copy-dir src dest _filterfn)
(bd-file-copy src dest)))))
(directory _src #t)))
(define (bd-delete-dir _dir)
;; Recursively deletes the given directory (BE CAREFUL!) ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(for-each
(lambda (f)
(set! f (string-append _dir "/" f))
(if (directory? f)
(bd-delete-dir f)
(delete-file f)))
(directory _dir #t))
(delete-directory _dir))
Here is the code for the parser:
parser.scm
;; Blog Parser for http://www.the-brown-dragon.com ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(include "helper.scm")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Error handling functions
;; Current processing context (for error reporting)
(define-record context line name num)
(define-record-printer (context ctx port)
(fprintf port "#,(context ~S ~S ~S)"
(context-line ctx)
(context-name ctx)
(context-num ctx)))
;; We will return to this point on error
(define *bd-err-return* #f)
(define (bd-error-msg msg why _ctx)
;; Display error message in standard format ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (not (context? _ctx))
(if (string? _ctx)
(set! _ctx (make-context #f _ctx 0))
(error "Incorrect _ctx parameter to bd-error-msg!")))
(newline)
(if (context-name _ctx)
(begin
(display (context-name _ctx))
(if (context-num _ctx)
(display
(string-append "(" (number->string (context-num _ctx)) ")")))
(display " : ")))
(display (string-append msg ": "))
(if (context-line _ctx)
(display (string-append "'" (context-line _ctx) "' : ")))
(display why)
(newline))
(define (bd-parse-error errno why ctx)
;; Display parse errors and quit ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(bd-error-msg (string-append "error e" (number->string errno)) why ctx)
;; Escape out of the current context completely
(*bd-err-return* #t))
(define (bd-parse-warn warnno why ctx)
;; Display warning to user ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(bd-error-msg (string-append "warning w" (number->string errno)) why ctx))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; General framework for parsing a file
(define (bd-load-file _fname _fn)
;; Loads a file into the environment for the passed function to process ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((ctx #f)(cur-lines #f)(cur-linenum 0))
(call-with-input-file _fname (lambda (f) (set! cur-lines (read-lines f))))
(for-each (lambda (l)
(set! cur-linenum (+ cur-linenum 1))
(set! ctx (make-context l _fname cur-linenum))
(set! _fn (_fn ctx))) cur-lines)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Content management
;; Properties attached to a content line
(define-record cont-prop start end fn)
(define-record-printer (cont-prop prop port)
(fprintf port "#,(cont-prop ~S ~S ~S)"
(cont-prop-start prop)
(cont-prop-end prop)
(cont-prop-fn prop)))
(define (bd-record-props _rule _ctx)
;; Returns a list of 'properties' to be applied for the given line ;;
;; for the given rule. ;;
;; Expects rules in the format: (regexp . function) ;;
;; where: regexp must have exactly two ;;
;; parts: (before-match)(match) ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let loop ((r '())(s 0))
(let ((m (string-match (car _rule) (context-line _ctx) s)))
(if (not m) (reverse r) ; Terminating condition
(let ((start (string-length (list-ref m 1)))
(end (string-length (list-ref m 2))))
(set! start (+ start s))
(set! end (+ start end))
(loop (cons (make-cont-prop start end (cdr _rule)) r) end))))))
(define (bd-parse-cont-ln _ctx _parse-table)
;; Parses a single context line and returns a list of properties ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((pl '()))
(for-each (lambda (r) (set! pl (append pl (bd-record-props r _ctx))))
_parse-table)
(cons _ctx pl)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parsing functions
(define (bd-parse-tags _fname)
;; Parses a tag file that keeps a list of tags ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(letrec ((tags '())
(bd-pt-1
(lambda (c)
(set! tags (cons (bd-strip-ws (context-line c)) tags))
bd-pt-1)))
(bd-load-file _fname bd-pt-1)
(reverse tags)))
(define (bd-parse-post-date _ctx)
;; Parses a date in format 2008-11-21 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((m #f) (dt (bd-strip-ws (context-line _ctx))))
(set! m (string-match "(\\d\\d\\d\\d)-(\\d\\d)-(\\d\\d)" dt))
(if (not m) ; unexpected input - fail
(bd-parse-error 4523 "Expected date: yyyy-mm-dd" _ctx))
(let ((yr (string->number (list-ref m 1)))
(mn (string->number (list-ref m 2)))
(dy (string->number (list-ref m 3))))
(local-time->seconds (vector 0 0 0 dy (- mn 1) (- yr 1900) 0 0 0 0)))))
(define (bd-parse-post-tags _ctx _tags)
;; Parses a line of the form ;;
;; Tags: tag1, tag2, tag3 tag4 tag5, tag6 ;;
;; into a list of tags ;;
;; (tag1 tag2 tag3 tag4 tag5 tag6) ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(letrec ((tags '())(tagline (bd-strip-ws (context-line _ctx)))
(bd-ppt-1
(lambda (curtg)
(let ((ct (find (cut string-ci= <> curtg) _tags)))
(if (not ct)
(bd-parse-error 2435
(format "Failed to find tag: ~S" curtg)
_ctx)
(set! tags (cons ct tags)))))))
(if (or (< (string-length tagline) (string-length "Tags:"))
(not (string-match "Tags:.*" tagline)))
(bd-parse-error 2723 "Expected tags line to start with 'Tags:'" _ctx))
(set! tagline
(bd-strip-ws
(substring tagline
(string-length "Tags:") (string-length tagline))))
(let loop ((t tagline))
(let ((m (string-match "([^, ]+)[, ]+(.*)" t)))
(if (not m)
(if (not (string-match "[, ]*" t)) (bd-ppt-1 t))
(let ((curtg (list-ref m 1)))
(bd-ppt-1 (list-ref m 1))
(loop (list-ref m 2))))))
(if (eq? tags '()) (bd-parse-error 2725 "No tags found!" _ctx))
tags))
(define (bd-parse-post _fname _parse-table _tags)
;; Parses a "post" in a text file with the following format ;;
;; +------------------------------------------------------+ ;;
;; | Title Of Post | ;;
;; | Date Of Post | ;;
;; | Tags: tag1, tag2, tag3 | ;;
;; | | ;;
;; | Content of post. | ;;
;; | *bold* **multi word bold** | ;;
;; | _italic_ __multi-word italic__ | ;;
;; | [href http://www.tbdb.com Link] | ;;
;; | [code mycodefile.c] | ;;
;; | | ;;
;; +------------------------------------------------------+ ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(letrec ((r (make-post _fname #f #f #f #f #f '() '() #f))
(bd-pp-1 (lambda (c) (post-title-set! r (context-line c)) bd-pp-2))
(bd-pp-2 (lambda (c) (post-date-set! r (bd-parse-post-date c))
bd-pp-3))
(bd-pp-3 (lambda (c) (post-tags-set! r (bd-parse-post-tags c _tags))
(lambda (c) (bd-pp-4 bd-pp-5 c))))
(bd-pp-4
(lambda (f c) ; Ignore blank lines before input
(if (string=? (bd-strip-ws (context-line c)) "")
(cut bd-pp-4 f <>)
(f c))))
(bd-pp-5
(lambda (c) ; Quote is terminated by a single '.'
(if (string=? (bd-strip-ws (context-line c)) ".")
(lambda (c) (bd-pp-4 bd-pp-6 c))
(begin
(post-quot-set! r (cons (bd-parse-cont-ln c _parse-table)
(post-quot r)))
bd-pp-5))))
(bd-pp-6
(lambda (c)
(post-teaser-set! r (bd-parse-cont-ln c _parse-table))
(bd-pp-7 c)))
(bd-pp-7
(lambda (c)
(post-content-set! r (cons (bd-parse-cont-ln c _parse-table)
(post-content r)))
bd-pp-7)))
(bd-load-file _fname bd-pp-1)
(cond ((not (post-title r))
(bd-parse-error 7830 "No title found!" _fname))
((not (post-date r))
(bd-parse-error 7831 "No date found!" _fname))
((not (post-tags r))
(bd-parse-error 7832 "No tags found!" _fname))
((eq? (post-quot r) '())
(bd-parse-error 7833 "No quote found!" _fname))
((eq? (post-content r) '())
(bd-parse-error 7834 "No content found!" _fname))
(#t (post-quot-set! r (reverse (post-quot r)))
(post-content-set! r (reverse (post-content r)))
r))))
Here is the code for the generator:
generator.scm
;; Site generator for http://www.the-brown-dragon.com ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(include "parser.scm")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helper Functions
(define (bd-adjust-prps _start _end _sshift _eshift _prps _ctx)
;; Adjusts the properties of the rules so that they remain ;;
;; valid for the newly updated string. ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(map (lambda (p)
(let ((s (cont-prop-start p))(e (cont-prop-end p)))
(if (>= s _end)
(set! s (+ s _eshift))
(if (> s _start)
(if (= 0 _sshift)
(bd-parse-error 9325
"Embedded rule within a block rule"
_ctx)
(set! s (+ s _sshift)))))
(if (> e _end)
(set! e (+ e _eshift))
(if (> e _start)
(if (and (= 0 _sshift) (not (= e _end)))
(bd-parse-error 9326
"Embedded rule within a block rule"
_ctx)
(set! e (+ e _sshift)))))
(cont-prop-start-set! p s)
(cont-prop-end-set! p e))) _prps))
(define (bd-replace-str _str _from _to _with _sshift _prps _ctx)
;; Replaces a section of a string with another string ;;
;; Also adjusts the properties so that other rules continue ;;
;; pointing to the correct area. ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((fp (substring _str 0 _from))
(ep (substring _str _to (string-length _str)))
(es (- (string-length _with) (- _to _from))))
(bd-adjust-prps _from _to _sshift es _prps _ctx)
(string-append fp _with ep)))
(define (bd-wrap-with _str _st _et _srl _erl _p _prps _ctx)
;; 'Wraps' a section of the given string with the start tag (_st) ;;
;; and end tag (_et). Also expects to offset the start and end ;;
;; of the string by start/end replace length (_srl/_erl). ;;
;; Also adjusts the properties so that they remain valid in the ;;
;; new string. ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((start (cont-prop-start _p))(end (cont-prop-end _p))(rep #f))
(set! rep (substring _str start end))
(set! rep
(string-append _st
(substring rep _srl (- (string-length rep) _erl))
_et))
(bd-replace-str _str start end rep (- (string-length _st) _srl)
_prps _ctx)))
(define-macro (bd-parsetable-add _tbl _re _fn)
;; Adds the regexp - function pair to the given parse table ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
`(set! ,_tbl (cons (cons ,_re ,_fn) ,_tbl)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HTML content formatting
;; HTML rule map
(define *html-map* '())
;; Code HTML rule map
(define *code-html-map* '())
;; HTML formatting functions
(define (bd-bold _str _p _prps _ctx)
(bd-wrap-with _str "<b>" "</b>" 1 1 _p _prps _ctx))
(define (bd-mbold _str _p _prps _ctx)
(bd-wrap-with _str "<b>" "</b>" 2 2 _p _prps _ctx))
(define (bd-italic _str _p _prps _ctx)
(bd-wrap-with _str "<i>" "</i>" 1 1 _p _prps _ctx))
(define (bd-mitalic _str _p _prps _ctx)
(bd-wrap-with _str "<i>" "</i>" 2 2 _p _prps _ctx))
(define (bd-href _str _p _prps _ctx)
(let ((start (cont-prop-start _p))(end (cont-prop-end _p))(m #f)(r #f))
(set! m (string-match "\\[href ([^ ]+) ([^\\]]+)\\].*" _str start))
(set! r (string-match "img:([^:]+):(.+)" (list-ref m 2)))
(if r
(set! r
(string-append "<img src=\"" (list-ref r 1) "\" alt=\""
(string-translate (list-ref r 2) ":" " ") "\"/>"))
(set! r (list-ref m 2)))
(set! r
(string-append "<a href=\"" (list-ref m 1) "\" "
"title=\"" (list-ref m 1) "\">" r "</a>"))
(bd-replace-str _str start end r 0 _prps _ctx)))
(define (bd-lit _str _p _prps _ctx)
(let ((start (cont-prop-start _p))(end (cont-prop-end _p))(m #f)(r #f))
(set! m (string-match "\\[lit ([^\\]]+)\\].*" _str start))
(set! r (list-ref m 1))
(if (string= r "/")
(set! r "</div>")
(set! r (string-append "<div " r ">")))
(bd-replace-str _str start end r 0 _prps _ctx)))
(define (bd-image _str _p _prps _ctx)
(let ((start (cont-prop-start _p))(end (cont-prop-end _p))(m #f)(r #f))
(set! m (string-match "\\[image ([^ ]+) ([^\\]]+)\\].*"
_str start))
(set! r
(string-append "<img src=\"" (list-ref m 1) "\" alt=\""
(list-ref m 2) "\"/>"))
(bd-replace-str _str start end r 0 _prps _ctx)))
(define (bd-inline _str _p _prps _ctx)
(bd-wrap-with _str "<code>" "</code>" 4 4 _p _prps _ctx))
(define (bd-codefile _str _p _prps _ctx)
(if (not (eq? '() (cdr _prps)))
(bd-parse-error 89348
"codefile line cannot contain other directives!" _ctx))
(letrec ((start (cont-prop-start _p))(end (cont-prop-end _p))
(m #f)(r #f)(dcode #f)
(pl (make-post #f #f #f #f #f #f '() '() #f))
(bd-cf-1
(lambda (c)
(post-content-set! pl (cons (bd-parse-cont-ln c *code-html-map*)
(post-content pl)))
bd-cf-1)))
(set! r (string-match "\\[code ([^\\]]+)\\].*" _str start))
(set! m (make-pathname (pathname-directory (context-name _ctx))
(list-ref r 1)))
(set! m (make-context #f m #f))
(post-fname-set! pl (context-name m))
(bd-load-file (post-fname pl) bd-cf-1)
(post-content-set! pl (reverse (post-content pl)))
(set! pl (bd-map-2-html (post-content pl) #t))
(set! dcode
(string-append "</p><div class='code'><p><a href=\""
(list-ref r 1)
"\">"
(last (string-split (list-ref r 1) "/"))
"</a></p><code>"))
(bd-wrap-with pl dcode "</code></div><p>" 0 0
(make-cont-prop 0 (string-length pl) #f) '() m)))
(define (bd-leading-sp _str _p _prps _ctx)
(let ((start (cont-prop-start _p))(r " "))
(let loop ((i start))
(when (< 1 i) (set! r (string-append " " r)) (loop (- i 1))))
(bd-replace-str _str 0 start (string-append "<code>" r "</code>") 0
_prps _ctx)))
(define (bd-< _str _p _prps _ctx)
(bd-replace-str _str (cont-prop-start _p) (cont-prop-end _p)
"<" 0 _prps _ctx))
(define (bd-> _str _p _prps _ctx)
(bd-replace-str _str (cont-prop-start _p) (cont-prop-end _p)
">" 0 _prps _ctx))
(define (bd-q _str _p _prps _ctx)
(bd-replace-str _str (cont-prop-start _p) (cont-prop-end _p)
""" 0 _prps _ctx))
(define (bd-& _str _p _prps _ctx)
(bd-replace-str _str (cont-prop-start _p) (cont-prop-end _p)
"&" 0 _prps _ctx))
(define (bd-sp _str _p _prps _ctx)
(bd-replace-str _str (cont-prop-start _p) (cont-prop-end _p)
" " 0 _prps _ctx))
;; Fill HTML rule Map
(bd-parsetable-add *html-map* (regexp* "(.*)(\\*[^ *]+\\*).*" '(ungreedy))
bd-bold)
(bd-parsetable-add *html-map* (regexp* "(.*)(\\*\\*.+\\*\\*).*" '(ungreedy))
bd-mbold)
(bd-parsetable-add *html-map* (regexp* "(.*)(_[^ _]+_)[ .!?].*" '(ungreedy))
bd-italic)
(bd-parsetable-add *html-map* (regexp* "(.*)(__.+__).*" '(ungreedy))
bd-mitalic)
(bd-parsetable-add *html-map* (regexp* "(.*)(%%%%.+%%%%).*" '(ungreedy))
bd-inline)
(bd-parsetable-add *html-map* "( +)(.*)" bd-leading-sp)
(bd-parsetable-add *html-map* (regexp* "(.*)(\\[lit [^]]+\\]).*" '(ungreedy))
bd-lit)
(bd-parsetable-add *html-map* (regexp* "(.*)(\\[href [^]]+\\]).*" '(ungreedy))
bd-href)
(bd-parsetable-add *html-map* (regexp* "(.*)(\\[image [^]]+\\]).*" '(ungreedy))
bd-image)
(bd-parsetable-add *html-map* (regexp* "(.*)(\\[code [^]]+\\]).*" '(ungreedy))
bd-codefile)
(bd-parsetable-add *html-map* "([^<]*)(<).*" bd-<)
(bd-parsetable-add *html-map* "([^>]*)(>).*" bd->)
(bd-parsetable-add *html-map* "([^\"]*)(\").*" bd-q)
(bd-parsetable-add *html-map* "([^\\&]*)(\\&).*" bd-&)
;; Fill Code HTML rule Map
(bd-parsetable-add *code-html-map* "([^<]*)(<).*" bd-<)
(bd-parsetable-add *code-html-map* "([^>]*)(>).*" bd->)
(bd-parsetable-add *code-html-map* "([^\"]*)(\").*" bd-q)
(bd-parsetable-add *code-html-map* "([^&]*)(&).*" bd-&)
(bd-parsetable-add *code-html-map* (regexp* "(.*)( ).*" '(ungreedy)) bd-sp)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Convert map-ped content to output!
(define (bd-map-1-2-html _c)
;; Applies the rules across a single line to generate content ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((ctx (car _c))(prps (cdr _c))(str #f))
(set! str (context-line ctx))
(if (not (eq? '() prps))
(map (lambda (prp)
(set! str
((cont-prop-fn prp) str prp prps ctx))) prps))
str))
(define (bd-map-2-html _content . br?)
;; Applies the rules across the content map to generate the actual content ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(set! _content (map bd-map-1-2-html _content))
(if (eq? br? '())
(let ((s (car _content)))
(let loop ((c (cdr _content)))
(when (not (eq? c '()))
(if (string=? (car c) "")
(set! s (string-append s "</p><p>"))
(set! s (string-append s "<br/>" (car c))))
(loop (cdr c))))
(string-append "<p>" s "</p>"))
(string-intersperse _content "<br/>")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The generator itself
;; Record to hold the overall site
(define-record site dir tags posts)
(define (bd-error?)
;; This continuation is used to jump out of processing any file ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(call/cc
(lambda (s)
(call/cc
(lambda (e)
(set! *bd-err-return* e)
(s #f))))))
(define (bd-apply-template _template _inp _ofile _curr _site)
;; Applies the given template to generate _ofile. The template ;;
;; itself contains embedded lisp code, which is executed in ;;
;; the context of the "_curr" object and the entire "_site". ;;
;; "_inp" is used for reporting what is currently being ;;
;; processed. ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(letrec ((disp #f) (ml #f)
(bd-at-1
(lambda (c)
(let ((m ; Single line embedded code
(string-match "(.*)<%(\\(.*\\))%>(.*)" (context-line c))))
(if m
(let ((f (string-append "(lambda (_curr _site)"
(caddr m)
")")))
(set! f (eval (with-input-from-string f read)))
(disp (string-append (cadr m) (f _curr _site) (cadddr m)))
bd-at-1)
(let ((m ; Multi-line embedded code
(string-match "(.*)<%(\\(.*)" (context-line c))))
(if m
(begin
(set! ml (caddr m))
(disp (cadr m))
bd-at-2)
(begin
(disp (context-line c))
bd-at-1)))))))
(bd-at-2
(lambda (c) ; End of multi-line embedded code
(let ((m (string-match "(.*\\))%>(.*)" (context-line c))))
(if m
(let ((f (string-append "(lambda (_curr _site)"
(string-append ml (cadr m))
")")))
(set! f (eval (with-input-from-string f read)))
(disp (string-append (f _curr _site) (caddr m)))
bd-at-1)
(begin
(set! ml (string-append ml (context-line c)))
bd-at-2))))))
(call-with-output-file _ofile
(lambda (port)
(display (format "Processing ~S to ~S..." _inp _ofile))
(newline)
(set! disp (lambda (s) (display s port)))
(bd-load-file _template bd-at-1)))))
(define (bd-gen-main _contentdir
_outdir
_copydirs
_backdoor
_tagfile
_ndx-template
_tag-template
_post-template
_rdf-templates
_pre-gen-cmd)
;; Main function that generates the site! ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((posts #f)(site (make-site _outdir #f #f))
(ndx (make-pathname _outdir "index.htm"))
(hidden-posts (lambda (t) (string= "hidden" t))))
;; If we have a command to run before proceeding
(when _pre-gen-cmd
;; Let's do it!
(display (format "Running ~S..." _pre-gen-cmd))
(let*-values (((ip op pid)(process _pre-gen-cmd))
((pid_ norm status)(process-wait pid)))
;; Any problems?
(when (or (not norm)
(not (= 0 status)))
(display (format "~S failed to execute!"
_pre-gen-cmd))(newline)
(*bd-err-return* #t)))
(display "done")(newline))
;; Let's clean up and get ready for new output
(if (directory? _outdir)
(begin
(display (format "Cleaning ~A..." _outdir))(newline)
(bd-delete-dir _outdir)))
;; Start parsing
(display "Parsing tags...")(newline)
(site-tags-set! site (bd-parse-tags _tagfile))
(display "Parsing blogs...")(newline)
(set! posts (map (lambda (f)
(let ((p (bd-parse-post f
*html-map*
(site-tags site))))
(post-teaser-set!
p (bd-map-1-2-html (post-teaser p)))
(post-content-set!
p (bd-map-2-html (post-content p)))
(post-quot-set!
p (bd-map-2-html (post-quot p) #t))
p))
(find-files _contentdir ".*\\.blog")))
;; Right - parsing done! Set up the site information
(display "Setting up site information...")(newline)
(site-tags-set! site (remove hidden-posts (site-tags site)))
(site-posts-set!
site
(sort (remove (lambda (p) (find hidden-posts (post-tags p))) posts)
(lambda (p1 p2) (> (post-date p1) (post-date p2)))))
(for-each (lambda (p)
(post-ofname-set!
p
(make-pathname _outdir (pathname-file (post-fname p)) ".htm"))
(post-link-set!
p
(string-append (pathname-file (post-fname p)) ".htm")))
posts)
;; Create output dir
(display "Creating posts...")(newline)
(create-directory _outdir)
;; Create posts
(for-each (lambda (p)
(bd-apply-template _post-template
(post-fname p) (post-ofname p) p site))
posts)
;; Create tag landing pages
(display "Creating tag landing pages...")(newline)
(for-each (lambda (tg)
(bd-apply-template _tag-template
`(tag ,tg)
(make-pathname _outdir (bd-tag-file tg))
tg site))
(site-tags site))
;; Create index.htm(l), default.htm(l) [4 files]
(display "Creating index pages...")(newline)
(bd-apply-template
_ndx-template '(all posts) ndx #f site)
(bd-file-copy ndx (make-pathname _outdir "index.html"))
(bd-file-copy ndx (make-pathname _outdir "default.htm"))
(bd-file-copy ndx (make-pathname _outdir "default.html"))
;; Create RDF feeds (this can be improved when I'm not feeling lazy)
(display "Creating feed files...")(newline)
(for-each
(lambda (ft)
(bd-apply-template
ft '(rdf feed) (make-pathname _outdir (pathname-file ft) "xml")
#f site))
_rdf-templates)
;; Copy backdoor files
(if (and (not (member "/quickrun" (argv)))
_backdoor)
(begin
(display "Copying backdoor files...")(newline)
(bd-copy-dir _backdoor _outdir (constantly #t))))
;; Copy all additional supporting files
(display "Copying supporting files...")(newline)
(for-each
(lambda (cpy)
(bd-copy-dir cpy _outdir
(lambda (f)
(and (not (string-match ".*\\.htm" f))
(not (string-match ".*\\.blog" f))
(not (string-match ".*\\.nocopy" f))))))
_copydirs)))
(define (bd-go!)
;; Shortcut for generating the site as my per current configuration ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (bd-error?)
(begin (display "Stopping due to error...")(newline))
(bd-gen-main "content"
"site/www"
'("template" "content")
"backdoor"
"content/tags.nocopy"
"template/ndx.htm"
"template/tag.htm"
"template/post.htm"
'("template/rss.rdf" "template/rss-egg.rdf")
"cpylatest.bat")))
For example, here's the template that generates this page. Note the embedded lisp (between <%( and )%> markers):
post.txt
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en-us">
<head>
<meta http-equiv="content-type" content="text/html; charset=utf-8"/>
<title><%(bd-make-html-safe (post-title _curr))%>
- The Brown Dragon Blog</title>
<link rel="stylesheet" type="text/css" href="bd.css"/>
<link rel="icon" type="image/gif" href="favicon.gif"/>
<link href="rss.xml" rel="alternate" type="application/rss+xml" title="The Brown Dragon RSS Feed" />
</head>
<body>
<!-- <div id="sof">(</div> -->
<div class="sidbr">
<div class="about">
<div class="logo"> </div>
<%(post-quot _curr)%>
</div>
</div>
<div class="ctnt">
<div class="hdr">
<h1><a href="index.html">the brown-dragon blog</a></h1>
<h2><%(bd-make-html-safe (post-title _curr))%></h2>
<h3><a href="index.html"><%(bd-display-date (post-date _curr))%></a></h3>
<div class="keywords">
<%(let loop ((ak (site-tags _site))
(mk (post-tags _curr))
(s ""))
(if (eq? ak '()) s
(let ((ck (car ak))
(spc "o-keyword"))
(if (member ck mk) (set! spc "t-keyword"))
(loop (cdr ak) mk (string-append s (format
"<span class=~S><a href=~S>" spc
(bd-tag-file ck))
(if (member ck mk) "<b>" "")
ck "("
(number->string
(length (filter
(lambda (p)
(member ck (post-tags p)))
(site-posts _site))))
")"
(if (member ck mk) "</b>" "")
"</a></span>"
"<span class='o-keyword'>|</span>")))))%>
</div>
</div>
<p/>
<div class="bdy">
<%(post-content _curr)%>
</div>
<div class="ftr">
<h1>Other Posts</h1>
<span class="ordby">(ordered by <span class="ordbyw">Tags</span>
then <a href="index.html" class="ordbyw">Date</a>)</span>
<ul>
<%(let ((s "")
(l (bd-posts-by-similarity _curr (site-posts _site))))
(for-each
(lambda (p)
(set! s (string-append
s
(format "<li><a href=~S class='postlink'><span class='postdate'>[" (post-link p))
(bd-display-date (post-date p))
"] </span>"
(bd-make-html-safe (post-title p))
(if (eq? '() (post-tags p)) ""
(string-append " <span class='posttags'>("
(string-intersperse (post-tags p) ",") ")</span>"))
" <span class='posttease'> "
(bd-make-html-safe (bd-post-teaser (post-teaser p)))
"</span></a></li>")))
l)
s)%>
</ul>
</div>
</div>
<div class="postlogo"><a href="rss.xml"><img alt="RSS Feed" src="rss.png"/></a></div>
</body>
</html>
Neat yes? :-)
