API: move `src` to `ss`

9 files changed, 690 insertions, 0 deletions

diff --git a/ss/as.scm b/ss/as.scm
new file mode 100644
index 0000000..6af0ff4
--- /dev/null
+++ b/ss/as.scm
@@ -0,0 +1,16 @@
+(define-module (ss as)
+  #:export (as)
+  #:declarative? #f)
+
+(define (call-in-module thunk module)
+  (let* ((curmod (current-module))
+         (_ (set-current-module (resolve-module module)))
+         (v (thunk))
+         (_ (set-current-module curmod)))
+    v))
+
+(define (load-in-module path module-name)
+  (call-in-module (lambda () (load path)) module-name))
+
+(define (as what file)
+  (load-in-module file `(ss as ,what)))
diff --git a/ss/as/atom.scm b/ss/as/atom.scm
new file mode 100644
index 0000000..c089974
--- /dev/null
+++ b/ss/as/atom.scm
@@ -0,0 +1,10 @@
+(define-module (ss as atom)
+  #:use-module ((ss atom) #:prefix atom:)
+  #:use-module (ss dates)
+  #:declarative? #f)
+
+(define main atom:feed)
+(define post atom:entry)
+(define person atom:person)
+(define media atom:media)
+
diff --git a/ss/as/html.scm b/ss/as/html.scm
new file mode 100644
index 0000000..743a77c
--- /dev/null
+++ b/ss/as/html.scm
@@ -0,0 +1,9 @@
+(define-module (ss as html)
+  #:use-module (ss dates)
+  #:use-module ((ss html) #:prefix html:)
+  #:declarative? #f)
+
+(define main html:index)
+(define post html:post)
+(define person html:person)
+(define media html:media)
diff --git a/ss/as/media-list.scm b/ss/as/media-list.scm
new file mode 100644
index 0000000..ca07829
--- /dev/null
+++ b/ss/as/media-list.scm
@@ -0,0 +1,9 @@
+(define-module (ss as media-list)
+  #:use-module (ss dates)
+  #:use-module ((ss media-list) #:prefix media-list:)
+  #:declarative? #f)
+
+(define main media-list:media-list)
+(define post media-list:ignore)
+(define person media-list:ignore)
+(define media media-list:add-to-list)
diff --git a/ss/atom.scm b/ss/atom.scm
new file mode 100644
index 0000000..37cec5a
--- /dev/null
+++ b/ss/atom.scm
@@ -0,0 +1,219 @@
+(define-module (ss atom)
+  #:use-module (ss mime-types)
+  #:use-module (ss dates)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (sxml simple)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (rnrs bytevectors)
+  #:export (feed
+            feed?
+            feed-id
+            feed-title
+            feed-subtitle
+            feed-uri
+            feed-updated
+            feed-entries
+            append-feed-entry!
+
+            entry
+            entry?
+            entry-id
+            entry-title
+            entry-published
+            entry-updated
+            entry-authors
+            entry-summary
+            entry-content
+            entry-categories
+            entry-contributors
+            entry-media
+
+            person
+            person?
+            person-name
+            person-email
+            person-uri
+
+            media
+            media?
+            media-title
+            media-type
+            media-length
+            media-uri
+            media-path
+
+            render))
+
+; ATOM Explanation: http://www.atomenabled.org/developers/syndication/
+; ATOM Validator:   https://validator.w3.org/feed/check.cgi
+
+;; Entities
+(define-record-type <feed>
+  (%make-feed id title subtitle uri updated entries)
+  feed?
+  (id feed-id)
+  (title feed-title)
+  (subtitle feed-subtitle)
+  (uri feed-uri)
+  (updated feed-updated set-feed-updated!)
+  (entries feed-entries set-feed-entries!))
+
+(define-record-type <entry>
+  (%make-entry id title published updated authors summary content categories contributors media)
+  entry?
+  (id entry-id set-entry-id!)
+  (title entry-title)
+  (published entry-published)
+  (updated entry-updated)
+  (authors entry-authors)
+  (summary entry-summary)
+  (content entry-content)
+  (categories entry-categories)
+  (contributors entry-contributors)
+  (media entry-media))
+
+(define-record-type <media>
+  (%make-media title type length uri path)
+  media?
+  (title media-title)
+  (type media-type)
+  (length media-length)
+  (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* (append-feed-entry! feed entry)
+         (let ((entries (feed-entries feed)))
+           (set-entry-id!     entry (string-append
+                                      (feed-uri feed) "/"
+                                      (entry-id entry))) ;; TODO: is this enough
+           (set-feed-entries! feed (append entries (list entry))))
+           (set-feed-updated! feed (find-newest (map entry-updated
+                                                     (feed-entries feed)))))
+
+(define* (feed #:key (title              "")
+                     (subtitle           "")
+                     (uri                "")
+                     (atom-feed-location "")
+                     (posts             '())
+               #:allow-other-keys)
+  (let* ((f (%make-feed uri
+                        title
+                        subtitle
+                        (string-append uri atom-feed-location)
+                        (find-newest (map entry-updated posts))
+                        '()))
+         (append-entry! (partial append-feed-entry! f)))
+    (for-each append-entry!
+              (sort posts (lambda (a b)
+                            (date>? (entry-published a) (entry-published b)))))
+    f))
+
+
+(define* (entry  #:key (title "")
+                       (id #f)
+                       (published unix-date)
+                       (updated unix-date)
+                       (authors '())
+                       (summary-html '())
+                       (content-html '())
+                       (categories '())
+                       (contributors '())
+                       (media '())
+                 #:allow-other-keys)
+  (define valid (char-set-intersection char-set:ascii char-set:letter))
+  (define (id-from-title title)
+    (string-map (lambda (c)
+                  (if (char-set-contains? valid c) c #\-))
+                title))
+
+  (%make-entry (or id (id-from-title title))
+               title
+               published
+               (find-newest (list published updated))
+               authors
+               summary-html
+               content-html
+               categories
+               contributors
+               media))
+
+(define* (person name #:key (email "")
+                            (uri   "")
+                      #:allow-other-keys)
+  (%make-person name email uri))
+
+
+(define* (media path #:key (title "")
+                           (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"))))
+  (let ((contents (call-with-input-file path get-bytevector-all #:binary #t)))
+    (%make-media title
+                 (type path)
+                 (bytevector-length contents)
+                 uri
+                 path)))
+
+;; Rendering
+(define (render-person tag person)
+  `(,tag
+     (name  ,(person-name person))
+     (uri   ,(or (person-uri person) ""))
+     (email ,(or (person-email person) ""))))
+
+(define (partial  f . set)
+  (lambda (. args) (apply f (append set args))))
+(define render-author      (partial render-person 'author))
+(define render-contributor (partial render-person 'contributor))
+
+(define (render-media med)
+  `(link (@(rel enclosure)
+           (href ,(media-uri med))
+           (type ,(media-type med))
+           (title ,(media-title med))
+           (length ,(media-length med)))))
+
+(define (render-category cat)
+  `(category (@(term ,cat))))
+
+(define (sxml->string/rendered content)
+  (call-with-output-string
+    (lambda (p) (sxml->xml content p))))
+
+(define (render-entry ent)
+  `(entry
+     (id                      ,(entry-id ent))
+     (title                   ,(entry-title ent))
+     (published               ,(date->string/RFC3339 (entry-published ent)))
+     (updated                 ,(date->string/RFC3339 (entry-updated ent)))
+     ,@(map render-author      (entry-authors ent))
+     (summary (@(type html))  ,(sxml->string/rendered (entry-summary ent)))
+     (content (@(type html))  ,(sxml->string/rendered (entry-content ent)))
+     ,@(map render-category    (entry-categories ent))
+     ,@(map render-contributor (entry-contributors ent))
+     ,@(map render-media       (entry-media ent))))
+
+(define (render-feed fe)
+  `(feed (@(xmlns "http://www.w3.org/2005/Atom"))
+     (id ,(feed-id fe))
+     (title ,(feed-title fe))
+     (link (@(href ,(feed-uri fe))
+             (rel "self")))
+     (updated ,(date->string/RFC3339 (feed-updated fe)))
+     (subtitle ,(feed-subtitle fe))
+     ,@(map render-entry (feed-entries fe))))
+
+(define (render feed)
+  (display "<?xml version=\"1.0\" encoding=\"utf-8\"?>")
+  (sxml->xml (render-feed feed)))
diff --git a/ss/dates.scm b/ss/dates.scm
new file mode 100644
index 0000000..58a1ec6
--- /dev/null
+++ b/ss/dates.scm
@@ -0,0 +1,44 @@
+(define-module (ss dates)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:export (string/ISO->date
+            date->string/RFC3339
+            unix-date
+            newest
+            find-newest
+            date>?))
+
+(define (string/ISO->date string)
+  (string->date string "~Y-~m-~d"))
+
+(define (date->string/RFC3339 date)
+  (call-with-output-string
+    (lambda (p)
+      (let* ((offset           (abs (date-zone-offset date)))
+             (rem-h-seconds    (modulo offset (* 60 60)))
+             (offset-hours     (floor (/ (- offset rem-h-seconds) 60 60)))
+             (rem-m-seconds    (modulo rem-h-seconds 60))
+             (offset-minutes   (floor (/ (- rem-h-seconds rem-m-seconds) 60))))
+       (format
+         p
+         "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d~:[Z~;~c~2,'0d:~2,'0d~]"
+         (date-year date)
+         (date-month date)
+         (date-day date)
+         (date-hour date)
+         (date-minute date)
+         (date-second date)
+         (not (= 0 (date-zone-offset date)))
+         (if (< 0 (date-zone-offset date)) #\+ #\-)
+         offset-hours
+         offset-minutes)))))
+
+(define unix-date (string/ISO->date "1970-01-01"))
+
+(define (newest a b) (if (time>? (date->time-utc a) (date->time-utc b)) a b))
+
+(define (date>? a b)
+  (time>? (date->time-utc a) (date->time-utc b)))
+
+(define (find-newest dates) (reduce newest unix-date dates))
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)))
diff --git a/ss/media-list.scm b/ss/media-list.scm
new file mode 100644
index 0000000..8e49e9b
--- /dev/null
+++ b/ss/media-list.scm
@@ -0,0 +1,14 @@
+(define-module (ss media-list)
+  #:use-module (ice-9 format)
+  #:export (ignore
+            media-list
+            add-to-list))
+
+(define %media '())
+
+(define (ignore . rest) #f)
+
+(define* (add-to-list path #:key (uri  "") #:allow-other-keys)
+ (set! %media (append! %media (list (cons path uri)))))
+
+(define (media-list . rest) %media)
diff --git a/ss/mime-types.scm b/ss/mime-types.scm
new file mode 100644
index 0000000..f6f1f3c
--- /dev/null
+++ b/ss/mime-types.scm
@@ -0,0 +1,155 @@
+(define-module (ss mime-types)
+      #:export (mime-types))
+
+(define mime-types
+  '(("js"         . "application/javascript")
+    ("mjs"        . "application/javascript")
+    ("json"       . "application/json")
+    ("webmanifest". "application/manifest+json")
+    ("doc"        . "application/msword")
+    ("dot"        . "application/msword")
+    ("wiz"        . "application/msword")
+    ("nq"         . "application/n-quads")
+    ("nt"         . "application/n-triples")
+    ("bin"        . "application/octet-stream")
+    ("a"          . "application/octet-stream")
+    ("dll"        . "application/octet-stream")
+    ("exe"        . "application/octet-stream")
+    ("o"          . "application/octet-stream")
+    ("obj"        . "application/octet-stream")
+    ("so"         . "application/octet-stream")
+    ("oda"        . "application/oda")
+    ("pdf"        . "application/pdf")
+    ("p7c"        . "application/pkcs7-mime")
+    ("ps"         . "application/postscript")
+    ("ai"         . "application/postscript")
+    ("eps"        . "application/postscript")
+    ("trig"       . "application/trig")
+    ("m3u"        . "application/vnd.apple.mpegurl")
+    ("m3u8"       . "application/vnd.apple.mpegurl")
+    ("xls"        . "application/vnd.ms-excel")
+    ("xlb"        . "application/vnd.ms-excel")
+    ("ppt"        . "application/vnd.ms-powerpoint")
+    ("pot"        . "application/vnd.ms-powerpoint")
+    ("ppa"        . "application/vnd.ms-powerpoint")
+    ("pps"        . "application/vnd.ms-powerpoint")
+    ("pwz"        . "application/vnd.ms-powerpoint")
+    ("wasm"       . "application/wasm")
+    ("bcpio"      . "application/x-bcpio")
+    ("cpio"       . "application/x-cpio")
+    ("csh"        . "application/x-csh")
+    ("dvi"        . "application/x-dvi")
+    ("gtar"       . "application/x-gtar")
+    ("hdf"        . "application/x-hdf")
+    ("h5"         . "application/x-hdf5")
+    ("latex"      . "application/x-latex")
+    ("mif"        . "application/x-mif")
+    ("cdf"        . "application/x-netcdf")
+    ("nc"         . "application/x-netcdf")
+    ("p12"        . "application/x-pkcs12")
+    ("pfx"        . "application/x-pkcs12")
+    ("ram"        . "application/x-pn-realaudio")
+    ("pyc"        . "application/x-python-code")
+    ("pyo"        . "application/x-python-code")
+    ("sh"         . "application/x-sh")
+    ("shar"       . "application/x-shar")
+    ("swf"        . "application/x-shockwave-flash")
+    ("sv4cpio"    . "application/x-sv4cpio")
+    ("sv4crc"     . "application/x-sv4crc")
+    ("tar"        . "application/x-tar")
+    ("tcl"        . "application/x-tcl")
+    ("tex"        . "application/x-tex")
+    ("texi"       . "application/x-texinfo")
+    ("texinfo"    . "application/x-texinfo")
+    ("roff"       . "application/x-troff")
+    ("t"          . "application/x-troff")
+    ("tr"         . "application/x-troff")
+    ("man"        . "application/x-troff-man")
+    ("me"         . "application/x-troff-me")
+    ("ms"         . "application/x-troff-ms")
+    ("ustar"      . "application/x-ustar")
+    ("src"        . "application/x-wais-source")
+    ("xsl"        . "application/xml")
+    ("rdf"        . "application/xml")
+    ("wsdl"       . "application/xml")
+    ("xpdl"       . "application/xml")
+    ("zip"        . "application/zip")
+    ("3gp"        . "audio/3gpp")
+    ("3gpp"       . "audio/3gpp")
+    ("3g2"        . "audio/3gpp2")
+    ("3gpp2"      . "audio/3gpp2")
+    ("aac"        . "audio/aac")
+    ("adts"       . "audio/aac")
+    ("loas"       . "audio/aac")
+    ("ass"        . "audio/aac")
+    ("au"         . "audio/basic")
+    ("snd"        . "audio/basic")
+    ("mp3"        . "audio/mpeg")
+    ("mp2"        . "audio/mpeg")
+    ("opus"       . "audio/opus")
+    ("oga"        . "audio/ogg")
+    ("aif"        . "audio/x-aiff")
+    ("aifc"       . "audio/x-aiff")
+    ("aiff"       . "audio/x-aiff")
+    ("ra"         . "audio/x-pn-realaudio")
+    ("wav"        . "audio/x-wav")
+    ("avif"       . "image/avif")
+    ("bmp"        . "image/bmp")
+    ("gif"        . "image/gif")
+    ("ief"        . "image/ief")
+    ("jpg"        . "image/jpeg")
+    ("jpe"        . "image/jpeg")
+    ("jpeg"       . "image/jpeg")
+    ("heic"       . "image/heic")
+    ("heif"       . "image/heif")
+    ("png"        . "image/png")
+    ("svg"        . "image/svg+xml")
+    ("tiff"       . "image/tiff")
+    ("tif"        . "image/tiff")
+    ("ico"        . "image/vnd.microsoft.icon")
+    ("ras"        . "image/x-cmu-raster")
+    ("pnm"        . "image/x-portable-anymap")
+    ("pbm"        . "image/x-portable-bitmap")
+    ("pgm"        . "image/x-portable-graymap")
+    ("ppm"        . "image/x-portable-pixmap")
+    ("rgb"        . "image/x-rgb")
+    ("xbm"        . "image/x-xbitmap")
+    ("xpm"        . "image/x-xpixmap")
+    ("xwd"        . "image/x-xwindowdump")
+    ("eml"        . "message/rfc822")
+    ("mht"        . "message/rfc822")
+    ("mhtml"      . "message/rfc822")
+    ("nws"        . "message/rfc822")
+    ("css"        . "text/css")
+    ("csv"        . "text/csv")
+    ("html"       . "text/html")
+    ("htm"        . "text/html")
+    ("n3"         . "text/n3")
+    ("txt"        . "text/plain")
+    ("bat"        . "text/plain")
+    ("c"          . "text/plain")
+    ("h"          . "text/plain")
+    ("ksh"        . "text/plain")
+    ("pl"         . "text/plain")
+    ("srt"        . "text/plain")
+    ("rtx"        . "text/richtext")
+    ("tsv"        . "text/tab-separated-values")
+    ("vtt"        . "text/vtt")
+    ("py"         . "text/x-python")
+    ("etx"        . "text/x-setext")
+    ("sgm"        . "text/x-sgml")
+    ("sgml"       . "text/x-sgml")
+    ("vcf"        . "text/x-vcard")
+    ("xml"        . "text/xml")
+    ("mp4"        . "video/mp4")
+    ("mpeg"       . "video/mpeg")
+    ("m1v"        . "video/mpeg")
+    ("mpa"        . "video/mpeg")
+    ("mpe"        . "video/mpeg")
+    ("mpg"        . "video/mpeg")
+    ("mov"        . "video/quicktime")
+    ("qt"         . "video/quicktime")
+    ("webm"       . "video/webm")
+    ("ogv"        . "video/ogg")
+    ("avi"        . "video/x-msvideo")
+    ("movie"      . "video/x-sgi-movie")))