summaryrefslogtreecommitdiff
path: root/src/atom.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/atom.scm')
-rw-r--r--src/atom.scm219
1 files changed, 0 insertions, 219 deletions
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 <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)))

© ElenQ Technology