bleh again

6 files changed, 160 insertions, 9 deletions

@@ -1,4 +1,6 @@
 ;; -*- scheme -*-
 (import (beaker system))
 
-(print "> (load-system \"boudin.egg\")")
+(define (setup-repl)
+  (load-system "boudin.egg")
+  )
@@ -5,8 +5,9 @@
  (version "0.0.0")
  (license "God Willing License")
 
- (dependencies chicanery r7rs utf8
+ (dependencies r7rs utf8
                html-parser
+               srfi-1
                srfi-152)
 
  (component-options
@@ -8,12 +8,15 @@
           (boudin schmaltz)
           ;; not portable
           (chicken pathname)
+          (chicken time posix)
           (html-parser)
           )
 
   (export site-url site-dest
           page-path-transformers page-text-transformers
-          page-template index-template feed-template)
+          page-date-formats
+          page-template index-template feed-template
+          build-time)
 
   (begin
     ;; Site information
@@ -42,4 +45,13 @@
       (make-parameter 'todo))
     (define feed-template
       (make-parameter 'todo))
-    ))
+    ;; Miscellaneous
+    (define page-date-formats
+      (make-parameter (list "%Y-%m-%d"
+                            "%Y-%m-%d%n%H:%M"
+                            "%Y-%m-%d%n%I:%M%n%p")))
+    ;; Not actually configuration, but state ... meh
+    (define build-time
+      (make-parameter
+       (time->string (seconds->utc-time) "%FT%TZ"))))
+    )
@@ -1,11 +1,18 @@
 (define-library (boudin types)
   (import (scheme base)
           (scheme case-lambda)
+          (scheme cxr)
           (scheme file)
+          (scheme write)
           (boudin config)
           (boudin util)
+          (srfi 1)
+          (srfi 152)
           ;; non-portable bits
+          (chicken file)
+          (chicken file posix)
           (chicken pathname)
+          (chicken time posix)
           (html-parser)
           )
 
@@ -15,10 +22,18 @@
    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
+   page-url page-slug page-updated
    read-page write-page
    ;; indeces
+   make-index index?
+   index-dest index-template index-writer index-pages index-meta
+   set-index-dest! set-index-template! set-index-writer! set-index-pages!
+   set-index-meta!
+   index-ref index-set! index-push!
+   index-for-each
+   write-index
    ;; static files
+   static-copy
    )
 
   (include "lib/types.sls"))
@@ -1,7 +1,9 @@
 ;;; (boudin types) --- pages, indeces, and static files
-
+;;
 ;; All paths are relative to the site directory unless otherwise noted
 
+;;; Pages
+
 (define-record-type page
   (make-page path                       ; Input path
              dest                       ; Output path (rel. to output directory)
@@ -17,14 +19,33 @@
   (meta page-meta set-page-meta!))
 
 (define (page-ref pg key)
-  (assoc-ref key (page-meta pg) (identity #f)))
+  (assoc-ref key (page-meta pg) (lambda _ #f)))
 
 (define (page-set! pg key val)
   (set-page-meta! pg (cons (cons key val)
                            (page-meta pg))))
 
 (define (extract-metadata sxml)
-  #f)
+  (let loop ((tree sxml)
+             (acc '()))
+    (cond
+     ((not (pair? tree))
+      (reverse acc))
+     ((and (list? (car tree))
+           (eq? (caar tree) '*COMMENT*))
+      (loop (cdr tree)
+            (map (lambda (ln)
+                   (let ((kv (string-split ln ":" 'infix 1)))
+                     (cons (string-trim-both (car kv))
+                           (string-trim (cdr kv)))))
+                 (string-split (cadar tree) "\n"))))
+     ((list? (car tree))
+      (loop (cdr tree)
+            (let ((subtree (loop (car tree) '())))
+              (if (null? subtree)
+                  acc
+                  (cons subtree acc)))))
+     (else (loop (cdr tree) acc)))))
 
 (define (*urlify path)
   (normalize-pathname
@@ -53,6 +74,20 @@
         (page-set! pg "slug" slug)
         slug)))
 
+(define (*page-mtime pg)
+  (let ((file (page-path pg)))
+    (and file
+         (file-exists? file)
+         (time->string (seconds->utc-time (file-modification-time file))))))
+
+(define (page-updated pg)
+  (let ((meta-date (page-ref pg "date")))
+    (or (and meta-date
+             (find (lambda (fmt) (string->time meta-date fmt))
+                   (page-date-formats)))
+        (*page-mtime pg)
+        (build-time))))
+
 (define (read-page path)
   (let ((pg (make-page path #f #f #f #f)))
     (set-page-dest! pg ((apply o (page-path-transformers)) path))
@@ -69,4 +104,54 @@
      (sxml-display-as-html ((eval/q (page-template)) pg) port))))
 
 
+;;; Indeces
+;; These are generated pages from collections of other pages.  Think index.html,
+;; feed.xml, possibly tag indeces and the like.  These pages don't have a source
+;; file, but they have a destination and a template.  Because there are
+;; different file formats here and ... stuff, there's also a slot for the index
+;; writer function.  Finally, pages and meta are the pages and various other
+;; metadata of the index.
+
+(define-record-type index
+  (make-index dest                      ; Relative to (site-dest)
+              template                  ; Template to put pages in
+              writer                    ; Proc to write sxml out to a file
+              pages                     ; Input pages
+              meta                      ; Various other metadata
+              )
+  index?
+  (dest index-dest set-index-dest!)
+  (template index-template set-index-template!)
+  (writer index-writer set-index-writer!)
+  (pages index-pages set-index-pages!)
+  (meta index-meta set-index-meta!))
+
+(define (index-ref idx key)
+  (assoc-ref key (index-meta idx) (lambda _ #f)))
+
+(define (index-set! idx key val)
+  (set-index-meta! idx (cons (cons key val)
+                             (index-meta idx))))
+
+(define (index-push! idx pg)
+  (set-index-pages! idx (cons pg (index-pages idx))))
+
+(define (index-for-each idx proc)
+  (for-each proc (index-pages idx)))
+
+(define write-index
+  (case-lambda
+    ((idx) (call-with-output-file (index-dest idx)
+             (lambda (port) (write-index idx (current-output-port)))))
+    ((idx port)
+     ((index-writer idx) ((index-template idx) (index-pages idx)) port))))
+
+
+;;; Static files
+;; These are simply copied from the input to the output, possibly with a changed
+;; path.  Because these are just files, we don't need a record type.
 
+(define (static-copy path)
+  (copy-file path
+              (make-pathname (site-dest) path)
+              'clobber))
@@ -7,9 +7,12 @@
 
   (export identity
           o
+          constantly
           assoc-ref
           slurp
-          eval/q)
+          eval/q
+          intersperse
+          string-intersperse)
 
   (begin
     (define (identity x) x)
@@ -24,6 +27,9 @@
                   h
                   (lambda (x) (h ((loop t) x))))))))
 
+    (define (constantly x)
+      (lambda _ x))
+
     (define assoc-ref
       (case-lambda
         ((key alist)
@@ -47,4 +53,34 @@
     (define (eval/q form env)           ; this is probably a bad idea
       (eval (list 'quasiquote form) env))
 
+    (define (intersperse xs delim)
+      (if (null? xs)
+          '()
+          (let loop ((acc (list (car xs)))
+                     (rest (cdr xs)))
+            (if (null? rest)
+                (reverse acc)
+                (loop (cons (car rest) (cons delim acc))
+                      (cdr rest))))))
+
+    (define (string-intersperse ss delim)
+      (apply string-append (intersperse ss delim)))
+
+    (define index
+      (case-lambda
+        ((xs needle)
+         (index xs needle eq? (constantly #f)))
+        ((xs needle comparator)
+         (index xs needle comparator (constantly #f)))
+        ((xs needle comparator fail)
+         (let loop ((i 0)
+                    (xs xs))
+           (cond
+            ((null? xs) (fail))
+            ((comparator (car xs) needle) i)
+            (else (loop (+ i 1) (cdr xs))))))))
+
+    (define (string-index str ch)
+      (index (string->list str) ch))
+
     ))