summaryrefslogtreecommitdiff
path: root/src/html.scm
diff options
context:
space:
mode:
authorEkaitz Zarraga <ekaitz@elenq.tech>2023-10-04 14:27:39 +0200
committerEkaitz Zarraga <ekaitz@elenq.tech>2023-10-04 15:45:25 +0200
commit4c37bf195c00fe0c9f771aa7eadc0b04767f0426 (patch)
tree57fe54e3bb3528369587805b581e30b61dbb5115 /src/html.scm
parentec4e08838b8debbe6848d605dc4b7a5f7905d782 (diff)
html: add simple html index implementation
Diffstat (limited to 'src/html.scm')
-rw-r--r--src/html.scm162
1 files changed, 161 insertions, 1 deletions
diff --git a/src/html.scm b/src/html.scm
index 7d37fbd..107b78c 100644
--- a/src/html.scm
+++ b/src/html.scm
@@ -1,2 +1,162 @@
(define-module (src html)
- #:use-module (src mime-types))
+ #:use-module (src dates)
+ #:use-module (srfi srfi-9)
+ #:use-module (sxml simple)
+ #:use-module (src mime-types)
+ #:export (render
+ person
+ post
+ index
+ media
+ css
+ js))
+
+(define-record-type <index>
+ (make-index title description uri author posts styles scripts)
+ index?
+ (title index-title)
+ (description index-description)
+ (uri index-uri)
+ (author index-author)
+ (posts index-posts)
+ (styles index-styles)
+ (scripts index-scripts))
+
+(define-record-type <post>
+ (make-post id
+ title
+ published
+ updated
+ authors
+ summary-html
+ content-html
+ categories
+ contributors
+ media)
+ post?
+ (id post-id)
+ (title post-title)
+ (published post-published)
+ (updated post-updated)
+ (authors post-authors)
+ (summary-html post-summary-html)
+ (content-html post-content-html)
+ (categories post-categories)
+ (contributors post-contributors)
+ (media post-media))
+
+(define-record-type <media>
+ (make-media type uri path)
+ media?
+ (type media-type)
+ (uri media-uri)
+ (path media-path))
+
+(define-record-type <person>
+ (make-person name email uri)
+ person?
+ (name person-name)
+ (email person-email)
+ (uri person-uri))
+
+
+(define* (index #:key (title "")
+ (description "")
+ (uri "")
+ (author (person ""))
+ (posts '())
+ (styles '())
+ (scripts '())
+ #:allow-other-keys)
+ (make-index title description uri author posts styles scripts))
+
+
+(define* (post #:key (id #f)
+ (title "")
+ (published unix-date)
+ (updated unix-date)
+ (authors '())
+ (summary-html '())
+ (content-html '())
+ (categories '())
+ (contributors '())
+ (media '())
+ #:allow-other-keys)
+
+ (define (id-from-title title)
+ (string-map (lambda (c)
+ (if (char-set-contains? char-set:letter c) c #\-))
+ title))
+ (make-post (or id (id-from-title title))
+ title
+ published
+ (find-newest (list published updated))
+ authors
+ summary-html
+ content-html
+ categories
+ contributors
+ media))
+
+(define* (media path #:key (uri "")
+ #:allow-other-keys)
+ (define (type path)
+ (let* ((extension (car (last-pair (string-split path #\.))))
+ (type (assoc-ref mime-types extension)))
+ (if (string? type) type (throw "Unknown mime-type"))))
+
+ (make-media (type path)
+ uri
+ path))
+
+(define css media)
+(define js media)
+
+(define* (person name #:key (email "")
+ (uri "")
+ #:allow-other-keys)
+ (make-person name email uri))
+
+; Rendering
+(define (render-author author)
+ `(address (@(class author))
+ (a (@(rel author)) ,(person-name author))))
+
+(define (render-post post)
+ `(article (@(class "post")
+ (id ,(post-id post))) ;; For anchors
+ (h2 ,(post-title post))
+ (time (@(datetime ,(date->string/RFC3339 (post-published post)))
+ (pubdate #t))
+ ,(date->string/RFC3339 (post-published post))) ;; TODO make human readable
+ ,@(map render-author (post-authors post))
+ (section (@(class summary))
+ ,(post-summary-html post))
+ (section (@(class content))
+ ,(post-content-html post))))
+
+(define (render-style style)
+ ;; TODO it escapes the contents!! if added inline :(
+ `(link (@(rel stylesheet)
+ (href ,(media-uri style)))))
+(define (render-script script)
+ ;; TODO it escapes the contents!! if added inline :(
+ `(script (@(src ,(media-uri script)))))
+
+(define (render-index index)
+ `(html
+ (head
+ (meta (@(author ,(person-name (index-author index)))))
+ (meta (@(charset "utf-8")))
+ (meta (@(name "viewport")
+ (content "width=device-width, initial-scale=1")))
+ (meta (@(name "description")
+ (content ,(index-description index))))
+ ,@(map render-style (index-styles index)))
+ (body
+ ,@(map render-post (index-posts index))
+ ,@(map render-script (index-scripts index)))))
+
+(define (render index)
+ (display "<!DOCTYPE html>")
+ (sxml->xml (render-index index)))