@@ -13,6 +13,7 @@

   :serial t

   :components ((:file "package")

                (:file "alimenta")  

+               (:file "atom")  

                (:file "fetching")

                (:file "discovery")))

@@ -24,19 +24,11 @@

 (defgeneric %to-feed (doc type &key feed-link))

-(defgeneric get-items (feed doc type)

-  (:documentation

-    "Get items for a feed. Specialize a symbol on type, to get items from a new sort of feed"))

-

 (defgeneric %generate-xml (feed feed-type &key partial))

 (defun generate-xml (feed &key (feed-type :rss))

   (%generate-xml feed feed-type))

-(defmethod %generate-xml :around (feed feed-type &key partial)

-  (call-next-method feed feed-type :partial partial))

-

-

 (defun to-feed (doc &key type feed-link)

   "Makes an instance of feed from the given document.  Specialize %to-feed with

    an equal-specializer on type with an appropriate symbol to implement a new

@@ -45,9 +37,12 @@

     (setf type (detect-feed-type doc)))

   (%to-feed doc type :feed-link feed-link))

+(defgeneric %get-items (xml feed-type)

+  (:method (xml-dom (feed-type (eql :rss))) ($ (inline xml-dom) "channel > item")))

+

 (defun get-items (feed xml-dom &key type)

   (with-slots (items) feed

-    (loop for item across ($ (inline xml-dom) "channel > item")

+    (loop for item across (%get-items xml-dom type)

           do (push (make-item xml-dom type) items)

           finally (return items)))) 

@@ -57,8 +52,11 @@

   (aprog1 (call-next-method xml-dom doc-type :feed-link feed-link)

     (with-slots (doc source-type) it

       (setf doc xml-dom

-            source-type feed-link))

-    (get-items it xml-dom :type doc-type)))

+            source-type doc-type))

+    (with-slots (items) it

+      (setf

+        items (loop for item across (%get-items xml-dom doc-type)

+                    collect (make-item item doc-type))))))

 (defgeneric feed-to-rss (feed))

 (defgeneric feed-to-atom (feed))

@@ -126,7 +124,9 @@

               (aif title (shorten-link it) "<untitled>")

               (aif link (shorten-link it) "<no link>")))))

-(defmethod %generate-xml ((feed feed) (feed-type (eql :rss)) &rest r)

+(defclass rss-feed (feed) ())

+

+(defmethod %generate-xml ((feed rss-feed) (feed-type (eql :rss)) &rest r)

   (declare (ignore r))

   (let* ((xml-root (plump:make-root))

          (feed-root (plump:make-element xml-root "rss"))

@@ -152,11 +152,35 @@

 (defclass item ()

   ((title :initarg :title :initform nil)

    (id :initarg :id :initform nil)

+   (author :initarg :author :initform nil)

    (date :initarg :date :initform nil)

    (link :initarg :link :initform nil)

+   (links :initform (make-hash-table :test #'equalp))

    (content :initarg :content :initform nil)

    (doc :initarg :doc :initform nil)))

+(defgeneric (setf link) (value self))

+

+(define-condition duplicate-link-type (error)

+  ((old :reader duplicate-link-type-old :initarg :old)

+   (new :reader duplicate-link-type-new :initarg :new))

+  (:report (lambda (condition stream)

+             (format stream "Item already has link ~s" (duplicate-link-type-old condition)))))

+

+(defmethod (setf link) ((value cons) (self item))

+  (with-slots (links) self

+    (destructuring-bind (type . href) value

+      (when (consp href)

+        (if (null (cdr href))

+          (setf href (car href))

+          (error 'type-error "too many arguments")))

+      (let ((type-keyword (make-keyword (string-upcase type))))

+        (when (slot-boundp self 'links)

+          (multiple-value-bind (old-link old-link-p) (gethash type-keyword links) 

+            (when old-link-p

+              (cerror "Replace Link ~a:~a with ~a:~a" 'duplicate-link-type :old old-link :new href))))

+        (setf (gethash type-keyword links) href)))))

+

 (defmethod %generate-xml ((item item) (feed-type (eql :rss)) &key partial)

   (prog1 partial

     (let ((item-root (make-element ($ (inline partial) "channel" (node)) "item")))

@@ -204,39 +228,12 @@

         (doc-link ($ "channel > link" (text) (node)))

         (doc-feed-link (or feed-link

                            ($ "feed > atom::link[rel=self]" (first) (attr "href") (node)))))

-    (make-instance 'feed :title doc-title :link doc-link :feed-link doc-feed-link)))

+    (make-instance 'rss-feed :title doc-title :link doc-link :feed-link doc-feed-link)))

 ;}}} 

 ; {{{ ATOM feed handling

-(defmethod make-item (xml-dom (type (eql :atom)))

-  (let* ((item-title ($ "> title" (text) (node)))

-         (item-link ($ "> link[rel=alternate]" (attr "href") (first) (node)))

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

-         (*tag-dispatchers* *html-tags*) 

-         (content (with-output-to-string (s)

-                    (serialize (parse (or item-content item-description)) s))))

-    (make-instance 'item

-                   :content content   

-                   :date item-date 

-                   :id item-guid 

-                   :link item-link 

-                   :title item-title)))

-(defmethod %to-feed (xml-dom (type (eql :atom)) &key feed-link)

-  (declare (ignore type) (ignorable feed-link))

-  ; TODO: store feed-link

-  (lquery:initialize xml-dom)

-  (let ((doc-title ($ "feed > title" (text) (node)))

-        (doc-link ($ "feed > link[rel=alternate]" (first) (attr "href") (node)))

-        (doc-feed-link (or feed-link

-                           ($ "feed > link[rel=self]" (first) (attr "href") (node)))))

-    (make-instance 'feed :title doc-title :link doc-link :feed-link doc-feed-link)))

-;}}}

-  

+

 (defun rdf-to-feed (xml-dom))

 (defun json-to-feed (json-object))

 (defun html5-to-feed (html-dom))

new file mode 100644

@@ -0,0 +1,317 @@

+(declaim (optimize (debug 3) (safety 3) (speed 0)))

+(in-package :alimenta.atom)

+

+(defclass atom-category ()

+  ((term :initarg :term :initform nil)

+   (label :initarg :label :initform nil)

+   (scheme :initarg :scheme :initform nil)))

+

+(defun make-category (term &optional label scheme)

+  (make-instance 'atom-category :term term :label label :scheme scheme))

+

+(defclass atom-person ()

+  ((name  :initarg :name  :type (or null string) :initform nil)

+   (uri   :initarg :uri   :type (or null string) :initform nil)

+   (email :initarg :email :type (or null string) :initform nil)))

+

+(defun make-person (name &optional uri email)

+  (make-instance 'atom-person :name name :uri uri :email email))

+

+(defclass atom-feed (alimenta:feed)

+  ((subtitle   :initarg :subtitle                                 :initform nil)

+   (id         :initarg :id                                       :initform nil)

+   (icon       :initarg :icon                                     :initform nil)

+   (categories :initarg :categories :type (or null list) :initform nil)

+   (logo       :initarg :logo                                     :initform nil)

+   (authors    :initarg :authors    :type (or null list)   :initform nil)))

+

+(defclass atom-item (alimenta:item)

+  ((author-uri :initarg :author-uri :initform nil)))

+

+(defmethod alimenta::%get-items (xml-dom (feed-type (eql :atom)))

+  ($ (inline xml-dom) "feed > entry"))

+

+(defclass alimenta::link ()

+  ((alimenta::relation :initarg :rel)

+   (alimenta::target   :initarg :target)))

+

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

+         (*tag-dispatchers* *html-tags*)

+         (content (with-output-to-string (s)

+                    (awhen (or item-content item-description) (serialize  (parse it) s)))))

+    (make-instance 'atom-item

+                   :content content

+                   :date item-date

+                   :id item-guid

+                   :author item-author

+                   :author-uri item-author-uri

+                   :link item-link

+                   :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 %to-feed (xml-dom (type (eql :atom)) &key feed-link)

+  (declare (ignore type) (ignorable feed-link))

+  ; TODO: store feed-link

+  (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-link (get-feed-elem-attr "feed > link[rel=alternate]" "href"))

+          (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

+        :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 ,doc))))

+

+(defvar *defconstants-really-verbose* nil)

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

+

+(defmethod %generate-xml ((feed feed) (feed-type (eql :atom)) &key partial)

+  (let ((parent (or ($ (inline partial) "feed" (node))

+                    (plump:make-element (plump:make-root) "feed"))))

+    (prog1 parent

+      (let ((feed-root (make-element parent "feed")))

+        (with-slots (title id link feed-link 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)

+             ))))))

+

+

+(defmethod %generate-xml ((item item) (feed-type (eql :atom)) &key partial)

+  (let ((parent (or ($ (inline partial) "feed" (node))

+                    (plump:make-element (plump:make-root) "feed"))))

+    (prog1 parent

+      (let ((item-root (make-element parent "entry")))

+        (with-slots (title id date link content (author alimenta::author) 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)))))))

+

+

+(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?

+              ))))

@@ -4,7 +4,10 @@

   (:use #:cl #:should-test #:lquery #:plump #:alexandria #:anaphora)

   (:export #:to-feed #:generate-xml

            #:feed #:title #:link #:items #:feed-link #:doc #:source-type #:id #:date #:content

-           #:item))

+           #:item #:description #:%generate-xml #:%to-feed #:%get-items #:make-item))

+

+(defpackage #:alimenta.atom

+  (:use #:cl #:should-test #:lquery #:plump #:alexandria #:anaphora #:alimenta))

 (defpackage #:alimenta.discover

   (:use #:cl #:alimenta #:alexandria #:anaphora #:lquery)

@@ -18,3 +21,17 @@

   (asdf:load-system :alimenta)

   (st:test :package :alimenta)

   t)

+

+(defpackage #:alimenta.test-runner

+  (:use #:cl #:alimenta #:alimenta.atom #:alimenta.discover #:alimenta.pull-feed))

+

+(in-package :alimenta.test-runner)

+

+(defclass xunit-test (asdf:test-op) ())

+

+(defmethod asdf:perform ((o asdf:test-op) (s (eql (asdf:find-system :alimenta))))

+  (asdf:load-system :alimenta)

+  (or (st:test :package :alimenta)

+      (st:test :package :alimenta.atom)

+      (st:test :package :alimenta.discover)

+      (st:test :package :alimenta.pull-feed)))

new file mode 100644

@@ -0,0 +1,72 @@

+(ql:quickload :clack)

+(ql:quickload :ningle )

+(ql:quickload :araneus)

+(ql:quickload :spinneret)

+(ql:quickload :lass)

+

+(defmethod araneus:view ((name (eql 'root)) (item alimenta:item))

+  (with-slots ((title alimenta:title) (link alimenta:link)) item

+    (spinneret:with-html 

+      (:article

+        (:div.title title)

+        (:a.link :href link link)))))

+

+(defmethod araneus:view ((name (eql 'root)) (feed alimenta:feed))

+  (with-slots ((title alimenta:title) (link alimenta:link)) feed

+    (spinneret:with-html

+      (:header

+        (:h1.feed-title title)

+        (:a.feed-link link)))))

+

+(defun get-css ()

+  (lass:compile-and-write

+    `(*

+       :padding "0px"

+       :margin "0px")

+    `(body

+       :box-sizing "border-box"

+       :font-family sans-serif

+       )

+

+    `(header

+       :border-bottom "thin solid black"

+       :width "100%"

+       :text-align center

+       :margin-bottom "2em"

+       :padding "1em")

+

+    `(article

+       :padding "1em"

+       :border "4px double #888"

+       :display "inline-block"

+       :width "30%"

+       :overflow "hidden"

+       :min-height "4em"

+       )

+    ))

+

+(defmethod araneus:view :around ((name (eql 'root)) (feed alimenta:feed))

+  (with-slots ((title alimenta:title) (items alimenta::items)) feed

+    (spinneret:with-html-string

+      (:html

+        (:head (:title title))

+        (:style

+          :type "text/css"

+          (get-css))

+        (:body

+          (:main

+            (call-next-method)

+            (loop for item in items

+                  do (araneus:view 'root item))))))))

+

+(araneus:define-controller root (params)

+  (let* ((url "https://reddit.com/r/programming.rss")

+         (feed (alimenta.pull-feed::fetch-doc-from-url url)))

+    (alimenta:to-feed feed :type :atom :feed-link url)))

+

+(defvar *app* (make-instance 'ningle:<app>))

+

+(araneus:defroutes *app*

+  (("/") (araneus:as-route 'root)))

+

+(defvar *handler* (clack:clackup *app* :port 4939))