API: move `src` to `ss`

1 files changed, 219 insertions, 0 deletions

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 <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)))