(declaim (optimize (debug 3) (safety 3) (speed 0)))
(in-package :alimenta.atom)
(defclass atom-category ()
((term :initarg :term :initform nil :accessor term)
(label :initarg :label :initform nil :accessor label)
(scheme :initarg :scheme :initform nil :accessor scheme)))
(defmethod print-object ((o atom-category) s)
(format s "#.(~s ~s ~s ~s)" 'make-category (term o) (label o) (scheme o)))
(defclass atom-person ()
((name :initarg :name :type (or null string) :initform nil :accessor name)
(uri :initarg :uri :type (or null string) :initform nil :accessor uri )
(email :initarg :email :type (or null string) :initform nil :accessor email)))
(defclass atom-feed (alimenta:feed)
((subtitle :initarg :subtitle :initform nil :accessor subtitle)
(id :initarg :id :initform nil :accessor id)
(links :initarg :links :initform nil :accessor links)
(icon :initarg :icon :initform nil :accessor icon)
(categories :initarg :categories :type (or null list) :initform nil :accessor categories)
(logo :initarg :logo :initform nil :accessor logo)
(updated :initarg :updated :initform nil :accessor updated)
(authors :initarg :authors :type (or null list) :initform nil :accessor authors)))
(defclass alimenta::link ()
((alimenta::relation :initarg :rel)
(alimenta::target :initarg :target)))
(defclass atom-item (alimenta:item)
((author-uri :initarg :author-uri :initform nil :accessor author-uri)
(categories :initarg :categories :type (or null list) :initform nil :accessor categories)))
(defun make-category (term &optional label scheme)
(make-instance 'atom-category :term term :label label :scheme scheme))
(defun make-person (name &optional uri email)
(make-instance 'atom-person :name name :uri uri :email email))
(defmethod alimenta::get-items (xml-dom (feed-type (eql :atom)))
($ (inline xml-dom) "feed > entry"))
(defun get-link (xml)
"This only handles alternate links"
(let ((links ($ (inline xml) "> link[rel=alternate]" (combine (attr :type) (attr :href)))))
(map 'list
(lambda (x)
(destructuring-bind (type href) x
(setf (alimenta::link (make-keyword (string-upcase type)))
(cons type href))))
links)))
(defmethod make-item (xml-dom (type (eql :atom)))
(let* ((lquery:*lquery-master-document* xml-dom)
(item-title ($ "> title" (text) (node)))
(links ($ "> link" (combine (attr "rel") (attr "href"))))
(sel-links (cadr (find-if (lambda (x) (aif (car x) (equal it "alternate") t))
links)))
(item-link (or sel-links (cdr (when (> (length links) 0) (elt links 0)))))
(item-date (or ($ "> updated" (text) (node))
($ "> published" (text) (node)))) ;; Which should be default?
(item-guid ($ "> id" (text) (node)))
(item-description ($ "> summary" (text) (node)))
(item-content ($ "> content" (text) (node)))
(item-author ($ "> author > name" (text) (node)))
(item-author-uri ($ "> author > uri" (text) (node)))
(item-categories ($ (inline xml-dom) "> category"
(combine (attr "term") (attr "label") (attr "scheme"))
(map-apply #'make-category)))
(*tag-dispatchers* *html-tags*)
(content (with-output-to-string (s)
(awhen (or item-content item-description) (serialize (parse it) s)))))
(make-instance 'atom-item
:doc xml-dom
:content content
:date (local-time:parse-timestring item-date)
:description item-description
:id item-guid
:author item-author
:author-uri item-author-uri
:link item-link
:categories (coerce item-categories 'list)
:title item-title)))
(defun get-authors (xml-dom)
(let ((authors ($ (inline xml-dom) "feed > author")))
(loop for author across authors
collect (make-person
($ (inline author) "> name" (text) (node))
($ (inline author) "> uri" (text) (node))
($ (inline author) "> email" (text) (node))))))
(defmethod alimenta::-to-feed (xml-dom (type (eql :atom)) &key feed-link)
(declare (ignore type))
(flet ((get-feed-elem (selector) ($ (inline xml-dom) selector (text) (node)))
(get-feed-elem-attr (selector attr) ($ (inline xml-dom) selector (attr attr) (node))))
(let ((doc-title (get-feed-elem "feed > title"))
(doc-subtitle (get-feed-elem "feed > subtitle"))
(doc-summary (get-feed-elem "feed > summary"))
(doc-icon (get-feed-elem "feed > icon"))
(doc-logo (get-feed-elem "feed > logo"))
(doc-id (get-feed-elem "feed > id"))
(doc-updated (awhen (get-feed-elem "feed > updated")
(local-time:parse-timestring it)))
(doc-link (or (get-feed-elem-attr "feed > link[rel=alternate]" "href")
(get-feed-elem-attr "feed > link:not([rel=self])" "href")
(get-feed-elem-attr "feed > link[rel=self]" "href")
feed-link))
(doc-links (coerce ($ (inline xml-dom)
"feed > link"
(combine (attr "rel")
(attr "href")))
'list))
(doc-feed-link (or feed-link
(get-feed-elem-attr "feed > link[rel=self]" "href")))
(doc-categories ($ (inline xml-dom) "feed > category"
(combine (attr "term") (attr "label") (attr "scheme"))
(map-apply #'make-category)))
(doc-authors (get-authors xml-dom)))
(make-instance 'atom-feed
:title doc-title
:description doc-summary
:icon doc-icon
:logo doc-logo
:link doc-link
:links doc-links
:updated doc-updated
:id doc-id
:feed-link doc-feed-link
:subtitle doc-subtitle
:categories (coerce doc-categories 'list)
:authors doc-authors
))))
;}}}
(defmacro defconstants (&body constants)
(list*
'progn
(loop for (name value &optional doc) in constants
collect `(defconstant ,name ,value ,@(when doc (list doc))))))
(defvar *defconstants-really-verbose* nil)
#+sbcl (defmacro defconstants-really (&body constants)
"auto-invoke the continue restart . . ."
`(handler-bind ((sb-ext:defconstant-uneql
(lambda (c)
(when *defconstants-really-verbose*
(format t "~&Changing definition of ~s from ~s to ~s~%"
(sb-ext:defconstant-uneql-name c)
(sb-ext:defconstant-uneql-old-value c)
(sb-ext:defconstant-uneql-new-value c)))
(continue c))))
(defconstants ,@constants)))
#-sbcl (defmacro defconstants-really (&body constants)
`(defconstants ,@constants))
(defmethod generate-xml ((feed feed) (feed-type (eql :atom)) &key partial)
(let ((feed-root (or ($1 (inline partial) "feed")
(plump:make-element (plump:make-root) "feed"))))
(prog1 feed-root
(with-accessors ((title title) (id id) (updated updated) (link link)
(feed-link feed-link) (description description)) feed
($ (inline (make-element feed-root "title")) (text title)
(inline (make-element feed-root "link"))
(attr "href" feed-link) (attr "rel" "self")
(inline (make-element feed-root "link"))
(attr "href" link) (attr "rel" "alternate") (attr "type" "text/html")
(inline (make-element feed-root "id")) (text id) (node)
(inline (make-element feed-root "summary")) (text description) (node)
(inline (make-element feed-root "updated")) (text updated) (node)
)))))
(defmethod generate-xml ((item item) (feed-type (eql :atom)) &key partial)
(let ((parent (if (string-equal (tag-name partial) "feed")
partial
(plump:make-element (plump:make-root) "feed"))))
(prog1 parent
(let ((item-root (make-element parent "entry")))
(with-accessors ((title title) (id id) (date date) (link link)
(content content) (author author) (author-uri author-uri)) item
($ (inline (make-element item-root "title")) (text title)
(inline (make-element item-root "link")) (attr "href" link)
(inline (make-element item-root "id")) (text id) (node)
(inline (make-element item-root "pubDate")) (text date)
(inline (make-element item-root "author"))
(append ($ (inline (make-element item-root "name")) (text author)))
(append ($ (inline (make-element item-root "uri")) (text author-uri)))
(inline (make-element item-root "content")) (text content)
(inline (make-element item-root "updated")) (text date) (node)
))))))
(defconstants-really
(+title+ "The Title")
(+author+ "Joe Q Public")
(+author-uri+ "http://example.com/joeq")
(+content+ "Teh Content")
(+id+ "t3_43tjwv")
(+link+ "http://example.com/something")
(+published+ "2016-02-02T09:41:27+00:00")
(+entry1+
(format nil
"<entry>
<author>
<name>~A</name>
<uri>~A</uri>
</author>
<category term='programming' label='/r/programming'/>
<content type='html'>~A</content>
<id>~a</id>
<link href='~a'/>
<published>~a</published>
<title>~a</title>
</entry>"
+author+ +author-uri+ +content+ +id+ +link+
+published+ +title+))
(+feed-category-term+ "testing")
(+feed-category-label+ "/r/testing")
(+feed-id+ "The Feed")
(+feed-icon+ "http://example.com/feed.png")
(+feed-logo+ "http://example.com/logo.png")
(+feed-link-website+ "http://example.com")
(+feed-link-self+ "http://example.com/atom.xml")
(+feed-subtitle+ "The SubTitle")
(+feed-title+ "The Title")
(+feed-author-name+ "The Author")
(+feed-author-uri+ "http://example.com/theauthor")
(+feed-description+ "The description")
(+feed1+
(format nil
"<feed>
<title>~a</title>
<subtitle>~a</subtitle>
<icon>~a</icon>
<category term=\"~a\" label=\"~a\"/>
<link rel=\"alternate\" href=\"~a\" type=\"text/html\" />
<link rel=\"self\" href=\"~a\" />
<logo>~a</logo>
<summary>~a</summary>
<author><name>~a</name><uri>~a</uri></author>
<author><name>~a</name><uri>~a</uri></author>
<id>~a</id>
</feed>"
+feed-title+
+feed-subtitle+
+feed-icon+
+feed-category-term+ +feed-category-label+
+feed-link-website+
+feed-link-self+
+feed-logo+
+feed-description+
+feed-author-name+ +feed-author-uri+
+feed-author-name+ +feed-author-uri+
+feed-id+
)))
(defun true (x) (not (null x)))
(defun get-node-text (xml-doc selector)
($ (inline xml-doc) selector (text) (node)))
(deftest to-feed ()
(let ((xml (parse +feed1+)))
(symbol-macrolet ((feed (alimenta::-to-feed xml :atom)))
(should be equal +feed-title+ (slot-value feed 'alimenta:title))
(should be equal +feed-link-website+ (slot-value feed 'alimenta:link))
(should be equal +feed-link-self+ (slot-value feed 'alimenta:feed-link))
(should be equal +feed-description+ (slot-value feed 'description))
(should be equal +feed-id+ (slot-value feed 'id))
(should be equal +feed-subtitle+ (slot-value feed 'subtitle))
(should be equal +feed-icon+ (slot-value feed 'icon))
(should be equal +feed-logo+ (slot-value feed 'logo))
(should be equal +feed-category-term+
(slot-value
(elt
(slot-value feed 'categories)
0)
'term))
(should be equal +feed-category-label+
(slot-value
(elt
(slot-value feed 'categories)
0)
'label))
(should be equal +feed-author-name+
(slot-value
(elt (slot-value feed 'authors) 0)
'name))
(should be equal +feed-author-uri+
(slot-value
(elt (slot-value feed 'authors) 0)
'uri))
;(should be equal +feed-title+ (slot-value feed 'alimenta:title))
;(should be equal +feed-title+ (slot-value feed 'alimenta:title))
;(should be equal +feed-title+ (slot-value feed 'alimenta:title))
)
)
)
(deftest make-item ()
(let ((xml (lquery:$ (inline (plump:parse +entry1+)) "entry" (node))))
(symbol-macrolet ((item (alimenta::make-item xml :atom)))
(should be true item)
(should be equal +link+ (slot-value item 'alimenta:link))
(should be equal +content+ (slot-value item 'alimenta:content))
(should be equal +author+ (slot-value item 'alimenta::author))
(should be equal +author-uri+ (slot-value item 'author-uri))
(should be equal +id+ (slot-value item 'alimenta:id)))))
(defparameter *tmp* nil)
(deftest generate-xml ()
(let* ((xml ($ (inline (parse +entry1+)) "entry" (node)))
(item (alimenta::make-item xml :atom)))
(symbol-macrolet ((generated-xml (alimenta::generate-xml item :atom)))
(should be equal +title+
($ (inline generated-xml) "entry > title" (text) (node)))
(should be equal +author+
($ (inline generated-xml) "entry > author > name" (text) (node)))
(should be equal +author-uri+
($ (inline generated-xml) "entry > author > uri" (text) (node)))
(should be equal +id+
($ (inline generated-xml) "entry > id" (text) (node)))
(should be equal +content+
($ (inline generated-xml) "entry > content" (text) (node)))
(should be equal +link+
($ (inline generated-xml) "entry > link" (attr "href") (node)))
;; TODO: deal with dates . . .
)))
(defun do-test (&optional (test nil))
(let ((st:*test-output* *debug-io*))
(multiple-value-bind (result hm? errors) (st:test :test test)
(format t
"~&Returns: ~a~%Error:~%~{~a~^~%~}~%Failures-vals:~%~{~a~^ ~}~%"
result
errors
hm?
))))