summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/atom.scm180
-rw-r--r--src/dates.scm11
-rw-r--r--src/mime-types.scm59
3 files changed, 250 insertions, 0 deletions
diff --git a/src/atom.scm b/src/atom.scm
new file mode 100644
index 0000000..9f71f00
--- /dev/null
+++ b/src/atom.scm
@@ -0,0 +1,180 @@
+(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 (srfi srfi-19)
+ #:use-module (sxml simple)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
+ #:export (feed
+ append-feed-entry!
+ entry
+ person
+ media
+ 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 zero-date (string/ISO->date "1970-01-01"))
+(define (newest a b) (if (time>? (date->time-utc a) (date->time-utc b)) a b))
+(define (find-newest dates) (reduce newest zero-date dates))
+
+(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 "")
+ (entries '()))
+ (let* ((f (make-feed uri
+ title
+ subtitle
+ uri
+ (find-newest (map entry-updated entries))
+ '()))
+ (append-entry! (partial append-feed-entry! f)))
+ (for-each append-entry! entries)
+ f))
+
+
+(define* (entry #:key (title "")
+ (id #f)
+ (published zero-date)
+ (updated zero-date)
+ (authors '())
+ (summary-html '())
+ (content-html '())
+ (categories '())
+ (contributors '())
+ (media '()))
+ (define (id-from-title title)
+ (string-map (lambda (c)
+ (if (char-set-contains? char-set:letter 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 ""))
+ (make-person name email uri))
+
+
+(define* (media path #:key (title "")
+ (uri ""))
+ (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 (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)) ,(entry-summary ent))
+ (content (@(type html)) ,(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/src/dates.scm b/src/dates.scm
new file mode 100644
index 0000000..0e9a075
--- /dev/null
+++ b/src/dates.scm
@@ -0,0 +1,11 @@
+(define-module (src dates)
+ #:use-module (srfi srfi-19)
+ #:export (string/ISO->date
+ date->string/RFC3339))
+
+(define (string/ISO->date string)
+ (string->date string "~Y-~m-~d"))
+
+(define (date->string/RFC3339 date)
+ (date->string date "~4"))
+
diff --git a/src/mime-types.scm b/src/mime-types.scm
new file mode 100644
index 0000000..c199406
--- /dev/null
+++ b/src/mime-types.scm
@@ -0,0 +1,59 @@
+(define-module (src mime-types)
+ #:export (mime-types))
+
+(define mime-types
+ '(("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")
+ ("ogv" . "video/ogv")
+ ("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")
+ ("avi" . "video/x-msvideo")
+ ("movie" . "video/x-sgi-movie")))
+