Improve API and add tests

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