From a1ed7b9f9954618e2ed4e14dd2dd3215ba7afd7d Mon Sep 17 00:00:00 2001 From: Ekaitz Zarraga Date: Tue, 7 Oct 2025 15:15:58 +0200 Subject: API: move `src` to `ss` --- README.md | 8 +- src/as.scm | 16 ---- src/as/atom.scm | 10 --- src/as/html.scm | 9 --- src/as/media-list.scm | 9 --- src/atom.scm | 219 -------------------------------------------------- src/dates.scm | 44 ---------- src/html.scm | 214 ------------------------------------------------ src/media-list.scm | 14 ---- src/mime-types.scm | 155 ----------------------------------- ss/as.scm | 16 ++++ ss/as/atom.scm | 10 +++ ss/as/html.scm | 9 +++ ss/as/media-list.scm | 9 +++ ss/atom.scm | 219 ++++++++++++++++++++++++++++++++++++++++++++++++++ ss/dates.scm | 44 ++++++++++ ss/html.scm | 214 ++++++++++++++++++++++++++++++++++++++++++++++++ ss/media-list.scm | 14 ++++ ss/mime-types.scm | 155 +++++++++++++++++++++++++++++++++++ tests/atom.scm | 4 +- tests/html.scm | 4 +- 21 files changed, 698 insertions(+), 698 deletions(-) delete mode 100644 src/as.scm delete mode 100644 src/as/atom.scm delete mode 100644 src/as/html.scm delete mode 100644 src/as/media-list.scm delete mode 100644 src/atom.scm delete mode 100644 src/dates.scm delete mode 100644 src/html.scm delete mode 100644 src/media-list.scm delete mode 100644 src/mime-types.scm create mode 100644 ss/as.scm create mode 100644 ss/as/atom.scm create mode 100644 ss/as/html.scm create mode 100644 ss/as/media-list.scm create mode 100644 ss/atom.scm create mode 100644 ss/dates.scm create mode 100644 ss/html.scm create mode 100644 ss/media-list.scm create mode 100644 ss/mime-types.scm diff --git a/README.md b/README.md index 32d46a3..b1a9f33 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ It doesn't control errors for the moment so be careful with what you do. ## Usage -`(src atom)` and `(src html)` are libraries you can use independently as in +`(ss atom)` and `(ss html)` are libraries you can use independently as in `tests/`, but the magic comes when you read the basic Format (see below) as a generic generator. @@ -14,9 +14,9 @@ The following script shows one way to do it: ``` scm (define-module (scripts create) - #:use-module ((src atom) #:prefix atom:) - #:use-module ((src html) #:prefix html:) - #:use-module (src as)) + #:use-module ((ss atom) #:prefix atom:) + #:use-module ((ss html) #:prefix html:) + #:use-module (ss as)) (define root (canonicalize-path (cadr (command-line)))) diff --git a/src/as.scm b/src/as.scm deleted file mode 100644 index d309b8a..0000000 --- a/src/as.scm +++ /dev/null @@ -1,16 +0,0 @@ -(define-module (src 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 `(src as ,what))) diff --git a/src/as/atom.scm b/src/as/atom.scm deleted file mode 100644 index 092393c..0000000 --- a/src/as/atom.scm +++ /dev/null @@ -1,10 +0,0 @@ -(define-module (src as atom) - #:use-module ((src atom) #:prefix atom:) - #:use-module (src dates) - #:declarative? #f) - -(define main atom:feed) -(define post atom:entry) -(define person atom:person) -(define media atom:media) - diff --git a/src/as/html.scm b/src/as/html.scm deleted file mode 100644 index 8d2a6e8..0000000 --- a/src/as/html.scm +++ /dev/null @@ -1,9 +0,0 @@ -(define-module (src as html) - #:use-module (src dates) - #:use-module ((src html) #:prefix html:) - #:declarative? #f) - -(define main html:index) -(define post html:post) -(define person html:person) -(define media html:media) diff --git a/src/as/media-list.scm b/src/as/media-list.scm deleted file mode 100644 index ca29507..0000000 --- a/src/as/media-list.scm +++ /dev/null @@ -1,9 +0,0 @@ -(define-module (src as media-list) - #:use-module (src dates) - #:use-module ((src 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/src/atom.scm b/src/atom.scm deleted file mode 100644 index ba4ff3d..0000000 --- a/src/atom.scm +++ /dev/null @@ -1,219 +0,0 @@ -(define-module (src atom) - #:use-module (src mime-types) - #:use-module (src 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 - (%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 - (%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 - (%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 - (%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 "") - (sxml->xml (render-feed feed))) diff --git a/src/dates.scm b/src/dates.scm deleted file mode 100644 index a70aa01..0000000 --- a/src/dates.scm +++ /dev/null @@ -1,44 +0,0 @@ -(define-module (src 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/src/html.scm b/src/html.scm deleted file mode 100644 index e957683..0000000 --- a/src/html.scm +++ /dev/null @@ -1,214 +0,0 @@ -(define-module (src html) - #:use-module (src dates) - #:use-module (srfi srfi-9) - #:use-module (sxml simple) - #:use-module (src 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 - (%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 - (%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 - (%make-media type uri path) - media? - (type media-type) - (uri media-uri) - (path media-path)) - -(define-record-type - (%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 "") - (sxml->xml (render-index index))) diff --git a/src/media-list.scm b/src/media-list.scm deleted file mode 100644 index 115ae0a..0000000 --- a/src/media-list.scm +++ /dev/null @@ -1,14 +0,0 @@ -(define-module (src 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/src/mime-types.scm b/src/mime-types.scm deleted file mode 100644 index 20dd228..0000000 --- a/src/mime-types.scm +++ /dev/null @@ -1,155 +0,0 @@ -(define-module (src 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"))) 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 + (%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 + (%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 + (%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 + (%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 "") + (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 + (%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 + (%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 + (%make-media type uri path) + media? + (type media-type) + (uri media-uri) + (path media-path)) + +(define-record-type + (%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 "") + (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"))) diff --git a/tests/atom.scm b/tests/atom.scm index c6cd268..bdf78c6 100644 --- a/tests/atom.scm +++ b/tests/atom.scm @@ -1,7 +1,7 @@ (define-module (tests atom) - #:use-module (src dates) + #:use-module (ss dates) #:use-module (srfi srfi-64) - #:use-module ((src atom) #:prefix atom:)) + #:use-module ((ss atom) #:prefix atom:)) (test-begin "Atom feed") diff --git a/tests/html.scm b/tests/html.scm index 805ab17..974b2f1 100644 --- a/tests/html.scm +++ b/tests/html.scm @@ -1,7 +1,7 @@ (define-module (tests html) - #:use-module (src dates) + #:use-module (ss dates) #:use-module (srfi srfi-64) - #:use-module ((src html) #:prefix html:)) + #:use-module ((ss html) #:prefix html:)) (test-begin "HTML index page") -- cgit v1.2.3