A new start (again)

6 files changed, 311 insertions, 0 deletions

@@ -0,0 +1,45 @@
+;;; (boudin config) --- default values for configuration options
+;;
+;; To change these, make a `config.scm' in your site's root directory and change
+;; these.  They're all parameters so .. change em like that.
+
+(define-library (boudin config)
+  (import (scheme base)
+          (boudin schmaltz)
+          ;; not portable
+          (chicken pathname)
+          (html-parser)
+          )
+
+  (export site-url site-dest
+          page-path-transformers page-text-transformers
+          page-template index-template feed-template)
+
+  (begin
+    ;; Site information
+    (define site-url
+      (make-parameter "example.com"))
+    (define site-dest
+      (make-parameter "out/"))
+    ;; Transformers
+    (define page-path-transformers
+      (make-parameter
+       (list (lambda (path) (make-pathname (site-dest) path)))))
+    (define page-text-transformers
+      (make-parameter
+       (list wrap-paragraphs
+             render-string
+             html->sxml)))
+    ;; Templates --- note that we use quote but include unquote forms here.
+    ;; This is to simplify the configuration and to avoid a cyclical dependency
+    ;; with (boudin types).
+    (define page-template
+      (make-parameter
+       '(html (@ (lang "en-us"))
+              (head (title (or (page-ref pg "title") "[untitled]")))
+              (body ,@(page-sxml pg)))))
+    (define index-template
+      (make-parameter 'todo))
+    (define feed-template
+      (make-parameter 'todo))
+    ))
@@ -0,0 +1,17 @@
+(define-library (boudin schmaltz)
+  (export render
+          render-string
+          wrap-paragraphs)
+
+  (import (scheme base)
+          (scheme case-lambda)          ; case-lambda
+          (scheme eval)                 ; eval
+          (scheme read)                 ; read
+          (scheme repl)                 ; interaction-environment
+          (scheme write)                ; display
+          (only (html-parser)
+                sxml->html)
+          (only (srfi 152)
+                string-split string-trim))
+
+  (include "lib/schmaltz.sls"))
@@ -0,0 +1,103 @@
+;;; (boudin schmaltz) --- transform almost-html plus scheme into html
+
+;;; Embedded scheme code
+
+(define (->string x)
+  (call-with-port (open-output-string)
+    (lambda (port)
+      (display x port)
+      (get-output-string port))))
+
+(define render-string
+  (case-lambda
+    ((s) (render-string s (interaction-environment)))
+    ((s env)
+     (call-with-port (open-input-string s)
+       (lambda (port)
+         (render port env))))))
+
+(define (render port env)
+  ;; A few rough edges:
+  ;; #, x will try to render x
+  (define (burn-char)
+    ;; Throw a character away.  I've defined this for clarity below.
+    (read-char port))
+
+  (let loop ((ch (read-char port))
+             (acc '()))
+    (define (proceed) (loop (read-char port) (cons ch acc)))
+    (cond
+     ((not ch)
+      (loop (read-char port) acc))
+     ((eof-object? ch)
+      (list->string (reverse acc)))
+     ((eq? ch #\#)                      ; special processing to come
+      (case (peek-char port)
+        ((#\\)                          ; inhibit processing of the next char
+         (burn-char)
+         (loop (read-char port) (cons ch acc)))
+        ((#\,)                          ; scheme eval expansion
+         (burn-char)
+         (loop #f
+               (append (let ((s (->string
+                                 (eval (read port)
+                                       env))))
+                         (cond
+                          ((equal? s "#<unspecified>") ; XXX NOT PORTABLE
+                           '())
+                          ((equal? s "#!eof") ; XXX NOT PORTABLE
+                           '(#\, #\#))
+                          (else (reverse (string->list s)))))
+                       acc)))
+        ((#\@)                          ; embedded sxml
+         (burn-char)
+         (loop #f
+               (append (let ((h (eval `(sxml->html ,(list 'quasiquote
+                                                          (read port)))
+                                      env)))
+                         (cond
+                          ((equal? h "#!eof") ; XXX NOT PORTABLE
+                           '(#\@ #\#))
+                          (else (reverse (string->list h)))))
+                       acc)))
+        (else (proceed))))
+     (else (proceed)))))
+
+;;; Wrap paragraphs
+
+(define (split-paragraphs str)
+  (let loop ((lines (string-split str "\n"))
+             (par '())
+             (acc '()))
+    (cond
+     ((and (null? lines)                ; base case: no more lines
+           (null? par))                 ; ... or pending paragraph
+      (reverse acc))
+     ((null? lines)                     ; add the final paragraph
+      (loop '() '() (cons (apply string-append (reverse par)) acc)))
+     ((equal? (car lines) "")           ; paragraph break
+      (loop (cdr lines)
+            '()
+            (cons (apply string-append (reverse par)) acc)))
+     (else                              ; line break
+      (loop (cdr lines)
+            (cons (string-append (car lines) "\n") par)
+            acc)))))
+
+(define (wrap-paragraphs str)
+  (let loop ((pars (split-paragraphs str))
+             (acc '()))
+    (cond
+     ((null? pars)
+      (apply string-append (reverse acc)))
+     ((zero? (string-length (car pars)))
+      (loop (cdr pars)
+            acc))
+     ((eq? #\< (string-ref (string-trim (car pars)) 0))
+      (loop (cdr pars)
+            (cons (car pars)
+                  acc)))
+     (else
+      (loop (cdr pars)
+            (cons (string-append "<p>" (car pars) "</p>\n")
+                  acc))))))
@@ -0,0 +1,24 @@
+(define-library (boudin types)
+  (import (scheme base)
+          (scheme case-lambda)
+          (scheme file)
+          (boudin config)
+          (boudin util)
+          ;; non-portable bits
+          (chicken pathname)
+          (html-parser)
+          )
+
+  (export
+   ;; pages
+   make-page page?
+   page-path page-dest page-text page-sxml page-meta
+   set-page-dest! set-page-text! set-page-sxml! set-page-meta!
+   extract-metadata page-ref page-set!
+   page-url page-slug
+   read-page write-page
+   ;; indeces
+   ;; static files
+   )
+
+  (include "lib/types.sls"))
@@ -0,0 +1,72 @@
+;;; (boudin types) --- pages, indeces, and static files
+
+;; All paths are relative to the site directory unless otherwise noted
+
+(define-record-type page
+  (make-page path                       ; Input path
+             dest                       ; Output path (rel. to output directory)
+             text                       ; Input text
+             sxml                       ; Rendered sxml
+             meta                       ; Metadata (title, etc.)
+             )
+  page?
+  (path page-path)
+  (dest page-dest set-page-dest!)
+  (text page-text set-page-text!)
+  (sxml page-sxml set-page-sxml!)
+  (meta page-meta set-page-meta!))
+
+(define (page-ref pg key)
+  (assoc-ref key (page-meta pg) (identity #f)))
+
+(define (page-set! pg key val)
+  (set-page-meta! pg (cons (cons key val)
+                           (page-meta pg))))
+
+(define (extract-metadata sxml)
+  #f)
+
+(define (*urlify path)
+  (normalize-pathname
+   (make-pathname (list (site-url)
+                        (pathname-strip-extension path))
+                  "index.html")))
+
+(define (page-url pg)               ; foo.html => http://site.com/foo/index.html
+  (or (page-ref pg "url")           ; memoization
+      (let ((url (*urlify (page-path pg))))
+        (page-set! pg "url" url)
+        url)))
+
+(define (*slugify url)                  ; I don't love how this is written..
+  (let-values (((_ _ dirs) (decompose-directory url)))
+    (let loop ((this (car dirs))
+               (rest (cdr dirs)))
+      (if (null? (cdr rest))
+          (make-pathname (list "/" this) #f)
+          (loop (car rest)
+                (cdr rest))))))
+
+(define (page-slug pg)                 ; http://site.com/foo/index.html => /foo/
+  (or (page-ref pg "slug")             ; memoization
+      (let ((slug (*slugify (page-url pg))))
+        (page-set! pg "slug" slug)
+        slug)))
+
+(define (read-page path)
+  (let ((pg (make-page path #f #f #f #f)))
+    (set-page-dest! pg ((apply o (page-path-transformers)) path))
+    (set-page-text! pg (with-input-from-file path slurp))
+    (set-page-sxml! pg ((apply o (page-text-transformers)) (page-text pg)))
+    (set-page-meta! pg (extract-metadata (page-sxml pg)))
+    pg))
+
+(define write-page
+  (case-lambda
+    ((pg) (call-with-output-file (page-dest pg)
+            (lambda (port) (write-page pg port))))
+    ((pg port)
+     (sxml-display-as-html ((eval/q (page-template)) pg) port))))
+
+
+
@@ -0,0 +1,50 @@
+;;; (boudin util) --- utility functions
+
+(define-library (boudin util)
+  (import (scheme base)
+          (scheme case-lambda)
+          (scheme eval))
+
+  (export identity
+          o
+          assoc-ref
+          slurp
+          eval/q)
+
+  (begin
+    (define (identity x) x)
+
+    (define (o . procs)                     ; stole from chicken core
+      (if (null? procs)
+          identity
+          (let loop ((procs procs))
+            (let ((h (car procs))
+                  (t (cdr procs)))
+              (if (null? t)
+                  h
+                  (lambda (x) (h ((loop t) x))))))))
+
+    (define assoc-ref
+      (case-lambda
+        ((key alist)
+         (assoc-ref alist
+                    key
+                    (lambda () (error "Unrecognized key." key))))
+        ((key alist failure)
+         (cond ((assoc key alist) => cdr)
+               (else (failure))))))
+
+    (define slurp
+      (case-lambda
+        (() (slurp (current-input-port)))
+        ((port)
+         (let loop ((ch (read-char))
+                    (acc '()))
+           (if (eof-object? ch)
+               (list->string (reverse acc))
+               (loop (read-char) (cons ch acc)))))))
+
+    (define (eval/q form env)           ; this is probably a bad idea
+      (eval (list 'quasiquote form) env))
+
+    ))