A newerer beginning

1 files changed, 78 insertions, 0 deletions

@@ -0,0 +1,78 @@
+(declare (module (boudin page))
+         (export make-page
+                 page-content
+                 page-meta
+                 page-meta-set!
+                 page-output
+                 page-ref
+                 page-set!
+                 page-slug
+                 page-template
+                 page-updated
+                 page-url
+                 page-writer
+                 page?)
+         (import (boudin site)
+                 (boudin util)
+                 (chicken file posix)
+                 (chicken file)
+                 (chicken pathname)
+                 (chicken time posix)
+                 (srfi 1)))
+
+(define-record-type page
+  (make-page content output template writer meta)
+  page?
+  (content page-content)
+  (output page-output)
+  (template page-template)
+  (writer page-writer)
+  (meta page-meta page-meta-set!))
+
+(define (page-ref pg k)
+  (assoc-ref k (or (page-meta pg) '())))
+
+(define (page-set! pg k v)
+  (page-meta-set! pg (cons (cons k v)
+                           (page-meta pg))))
+
+(define (*urlify path)
+  (normalize-pathname
+   (make-pathname (list (string-append "https://" (site-host))
+                        (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-ref pg "source"))))
+        (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 (*page-mtime pg)
+  (let ((file (page-ref pg "source")))
+    (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                ; memoization
+             (find (lambda (fmt) (string->time meta-date fmt))
+                   (site-date-formats)))
+        (*page-mtime pg)
+        (site-build-time))))