(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 (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 (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 (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 (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 "" port) (sxml->xml (render-feed feed)) port)