(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
            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* (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   '())
               #:allow-other-keys)
  (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 unix-date)
                       (updated unix-date)
                       (authors '())
                       (summary-html '())
                       (content-html '())
                       (categories '())
                       (contributors '())
                       (media '())
                 #:allow-other-keys)
  (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   "")
                      #: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 (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)))