diff options
| -rw-r--r-- | atom.scm | 238 | ||||
| -rw-r--r-- | example.scm | 22 | ||||
| -rw-r--r-- | src/atom.scm | 180 | ||||
| -rw-r--r-- | src/dates.scm | 11 | ||||
| -rw-r--r-- | src/mime-types.scm | 59 | ||||
| -rw-r--r-- | tests/example.scm | 30 |
6 files changed, 280 insertions, 260 deletions
diff --git a/atom.scm b/atom.scm deleted file mode 100644 index 148a5cb..0000000 --- a/atom.scm +++ /dev/null @@ -1,238 +0,0 @@ -(define-module (atom) - #: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 - entry - person - media - render)) - -; ATOM Explanation: http://www.atomenabled.org/developers/syndication/ -; ATOM Validator: https://validator.w3.org/feed/check.cgi - -(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"))) - -;; Entities -(define-record-type <feed> - (make-feed id title subtitle uri date entries) - feed? - (id feed-id) - (title feed-title) - (subtitle feed-subtitle) - (uri feed-uri) - (date feed-date set-feed-date!) - (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 (date->string/RFC3339 date) - (date->string date "~4")) -(define (entry-published entry) - (date->string/RFC3339 (_entry-published entry))) -(define (entry-updated entry) - (date->string/RFC3339 (_entry-updated entry))) -(define (string->date/ISO string) - (string->date string "~Y-~m-~d")) - -(define-record-type <media> - (make-media title type length uri path contents) - media? - (title media-title) - (type media-type) - (length media-length) - (uri media-uri) - (path media-path) - (contents media-contents)) - -(define-record-type <person> - (make-person name email uri) - person? - (name person-name) - (email person-email) - (uri person-uri)) - -(define zero-date (string->date/ISO "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* (feed #:key (title "") - (subtitle "") - (uri "") - (entries '())) - (make-feed uri - title - subtitle - uri - (find-newest (map entry-updated entries)) - entries)) - -(define* (register-entry! feed entry) - (let ((entries (feed-entries feed))) - (set-entry-id! entry (string-append - (feed-uri feed) "/" - (number->string (length entries)))) ;; TODO: is this enough - (set-feed-entries! feed (append entries (list entry)))) - (set-feed-date! feed (find-newest (map entry-updated - (feed-entries feed))))) - - -(define* (entry feed #:key (title "") - (published "1970-01-01") - (updated "1970-01-01") - (authors '()) - (summary-html '()) - (content-html '()) - (categories '()) - (contributors '()) - (media '())) - - (register-entry! feed - (make-entry #f - title - (string->date/ISO published) - (find-newest (map string->date/ISO - (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 - contents))) - -;; 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 ,(entry-published ent)) - (updated ,(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 ,(feed-date fe)) - (subtitle ,(feed-subtitle fe)) - ,@(map render-entry (feed-entries fe)))) - -(define* (render feed #:optional (port (current-output-port))) - (display "<?xml version=\"1.0\" encoding=\"utf-8\"?>" port) - (sxml->xml (render-feed feed)) port) diff --git a/example.scm b/example.scm deleted file mode 100644 index 0bb7255..0000000 --- a/example.scm +++ /dev/null @@ -1,22 +0,0 @@ -(define-module (content) - #:use-module ((atom) #:prefix atom:)) - -(define me (atom:person "Ekaitz" - #:email "ekaitz@elenq.tech" - #:uri "https://elenq.tech")) - -(define feed (atom:feed #:title "Mi feed" - #:subtitle "Este es mi feed" - #:uri "https://thoughts.elenq.tech")) - -(atom:entry feed - #:title "first entry" - #:published "2023-03-01" - #:authors (list me) - #:summary-html '(p "Este es el resumen") - #:content-html '(p "Este es el contenido") - #:categories (list "una" "dos" "tres") - #:media (list (atom:media "../HOLA.webm" #:title "01" - #:uri ""))) - -(atom:render feed) 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"))) + diff --git a/tests/example.scm b/tests/example.scm new file mode 100644 index 0000000..5d47ef6 --- /dev/null +++ b/tests/example.scm @@ -0,0 +1,30 @@ +(define-module (tests atom) + #:use-module (src dates) + #:use-module (srfi srfi-64) + #:use-module ((src atom) #:prefix atom:)) + +(test-begin "Atom feed") + +(define me (atom:person "Ekaitz" + #:email "ekaitz@elenq.tech" + #:uri "https://elenq.tech")) + +(define feed + (atom:feed #:title "Mi feed" + #:subtitle "Este es mi feed" + #:uri "https://feed.elenq.tech" + #:entries (list + (atom:entry #:title "first entry" + #:published (string/ISO->date "2023-03-01") + #:authors (list me) + #:summary-html '(p "Este es el resumen") + #:content-html '(p "Este es el contenido") + #:categories (list "una" "dos" "tres") + #:media (list))))) + ;; TODO: Test media (reads file) + +(let ((atom-feed (with-output-to-string (lambda () (atom:render feed))))) + (test-assert (string=? atom-feed + "<?xml version=\"1.0\" encoding=\"utf-8\"?><feed xmlns=\"http://www.w3.org/2005/Atom\"><id>https://feed.elenq.tech</id><title>Mi feed</title><link href=\"https://feed.elenq.tech\" rel=\"self\" /><updated>2023-03-01T00:00:00+0100</updated><subtitle>Este es mi feed</subtitle><entry><id>https://feed.elenq.tech/first-entry</id><title>first entry</title><published>2023-03-01T00:00:00+0100</published><updated>2023-03-01T00:00:00+0100</updated><author><name>Ekaitz</name><uri>https://elenq.tech</uri><email>ekaitz@elenq.tech</email></author><summary type=\"html\"><p>Este es el resumen</p></summary><content type=\"html\"><p>Este es el contenido</p></content><category term=\"una\" /><category term=\"dos\" /><category term=\"tres\" /></entry></feed>"))) + +(test-end "Atom feed") |