API: move `src` to `ss`

1 files changed, 214 insertions, 0 deletions

diff --git a/ss/html.scm b/ss/html.scm
new file mode 100644
index 0000000..7f31f85
--- /dev/null
+++ b/ss/html.scm
@@ -0,0 +1,214 @@
+(define-module (ss html)
+  #:use-module (ss dates)
+  #:use-module (srfi srfi-9)
+  #:use-module (sxml simple)
+  #:use-module (ss mime-types)
+  #:export (render
+            person
+            person?
+            person-name
+            person-email
+            person-uri
+
+            post
+            post?
+            post-id
+            post-title
+            post-published
+            post-updated
+            post-authors
+            post-summary-html
+            post-content-html
+            post-categories
+            post-contributors
+            post-media
+
+            index
+            index?
+            index-title
+            index-short-description
+            index-long-description
+            index-uri
+            index-atom-feed-uri
+            index-author
+            index-posts
+            index-styles
+            index-scripts
+
+            media
+            media?
+            media-type
+            media-uri
+            media-path))
+
+(define-record-type <index>
+  (%make-index title short-description long-description uri atom-feed-uri author posts styles scripts)
+  index?
+  (title index-title)
+  (short-description index-short-description)
+  (long-description index-long-description)
+  (uri index-uri)
+  (atom-feed-uri index-atom-feed-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 "")
+                      (short-description "")
+                      (long-description "")
+                      (uri "")
+                      (atom-feed-uri #f)
+                      (author (person ""))
+                      (posts '())
+                      (styles '())
+                      (scripts '())
+                #:allow-other-keys)
+         (%make-index
+           title
+           short-description
+           long-description
+           uri
+           atom-feed-uri
+           author
+           (sort posts (lambda (a b)
+                         (date>? (post-published a) (post-published b))))
+           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* (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)
+  (if (media? style)
+    `(link (@(rel stylesheet)
+             (href ,(media-uri style))))
+    `(style ,(lambda () (display style)))))
+
+(define (render-script script)
+ (if (media? script)
+   `(script (@(src ,(media-uri script))))
+   `(script ,(lambda () (display script)))))
+
+(define (render-index index)
+  `(html
+     (head
+       (meta (@(author ,(person-name (index-author index)))))
+       (meta (@(charset "utf-8")))
+       (meta (@(name "color-scheme") (content "light dark")))
+       (meta (@(name "viewport")
+               (content "width=device-width, initial-scale=1")))
+       (meta (@(name "description")
+               (content ,(index-short-description index))))
+       ,(if (not (index-atom-feed-uri index))
+         `()
+         `(link (@(rel "alternate")
+                  (type "application/atom+xml")
+                  (href ,(index-atom-feed-uri index)))))
+       ,@(map render-style (index-styles index)))
+     (body
+       (h1 (@(class title)) ,(index-title index))
+       (section (@(class description)) ,(index-long-description index))
+       ,@(map render-post (index-posts index))
+       ,@(map render-script (index-scripts index)))))
+
+(define (render index)
+  (display "<!DOCTYPE html>")
+  (sxml->xml (render-index index)))