new file mode 100644

@@ -0,0 +1,2 @@

+.*.sw[a-z]

+*~

@@ -14,6 +14,7 @@

   :components ((:file "package")

                (:file "alimenta")  

                (:file "atom")  

+               (:file "rss")  

                (:file "fetching")

                (:file "discovery")))

@@ -1,30 +1,107 @@

 ;;;; alimenta.lisp

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

-

 (in-package #:alimenta)

-;;; "alimenta" goes here. Hacks and glory await!

-(defun detect-feed-type (xml-dom)

-  (let ((root-node-name (make-keyword (string-upcase

-                                        ($ (inline xml-dom) (children)

-                                           (map #'tag-name) (node))))))

-    (setf type

-          (case root-node-name

-            ((:feed) :atom)

-            (t root-node-name)))))

+(defclass feed () 

+  ((title :initarg :title :initform nil)

+   (link :initarg :link :initform nil)

+   (items :initarg :items :initform nil)

+   (description :initarg :description :initform nil)

+   (feed-link :initarg :feed-link :initform nil)

+   (doc :initarg :doc :initform nil)

+   (source-type :initarg :source-type :initform nil)))

+

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

+

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

 (defgeneric push-item (feed item)

   (:documentation "Adds an item to the feed"))

-(defgeneric make-item (xml-dom type))

+(defgeneric make-item (xml-dom doc-type)

+  (:documentation "Given an xml document, return an item"))

 (defgeneric parse-feed (feed))

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

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

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

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

+  (declare (ignore r))

+  (let ((result (call-next-method feed feed-type)))

+    (with-slots (items) feed

+      (loop for item in items

+            do (%generate-xml item feed-type :partial result)))

+    result))

+

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

+  (:documentation "Given an xml-document, return a feed object"))

+(defmethod %to-feed :around ((xml-dom plump:node) doc-type &key feed-link)

+  "This wraps the particular methods so that _they_ don't have to implement item fetching.

+   NIL passed to the type activates auto-detection"

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

+    (with-slots (doc source-type) it

+      (setf doc xml-dom

+            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 (setf link) (value self))

+(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 print-object ((object feed) stream)

+  (print-unreadable-object (object stream :type t :identity t)

+    (with-slots (title link) object

+      (format stream "title: ~s link: ~s"

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

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

+

+(defmethod print-object ((object item) stream)

+  (print-unreadable-object (object stream :type t :identity t)

+    (with-slots (title link date) object

+      (format stream "title: ~s link: ~s date:~s"

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

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

+              (aif date it "<no date>")))))

+

+

+(defun detect-feed-type (xml-dom)

+  (let ((root-node-name (make-keyword (string-upcase

+                                        ($ (inline xml-dom) (children)

+                                           (map #'tag-name) (node))))))

+    (setf type

+          (case root-node-name

+            ((:feed) :atom)

+            (t root-node-name)))))

+

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

   (%generate-xml feed feed-type))

@@ -37,8 +114,6 @@

     (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

@@ -46,18 +121,6 @@

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

           finally (return items)))) 

-(defmethod %to-feed :around (xml-dom doc-type &key feed-link)

-  "This wraps the particular methods so that _they_ don't have to implement item fetching.

-   NIL passed to the type activates auto-detection"

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

-    (with-slots (doc source-type) it

-      (setf doc xml-dom

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

 (defgeneric feed-to-json (feed))

@@ -82,15 +145,6 @@

      </body>

      </html>"))

-(defclass feed ()

-  ((title :initarg :title :initform nil)

-   (link :initarg :link :initform nil)

-   (items :initarg :items :initform nil)

-   (description :initarg :description :initform nil)

-   (feed-link :initarg :feed-link :initform nil)

-   (doc :initarg :doc :initform nil)

-   (source-type :initarg :source-type :initform nil)))

-

 (defun make-feed (&key title link items feed-link description)

   (make-instance 'feed :title title :link link :items items :feed-link feed-link :description description))

@@ -105,135 +159,10 @@

     (push-item feed it)

     (values feed it)))

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

-  (declare (ignore r))

-  (let ((result (call-next-method feed feed-type)))

-    (with-slots (items) feed

-      (loop for item in items

-            do (%generate-xml item feed-type :partial result)))

-    result))

-

-(defmethod shorten-link (link)

+(defun shorten-link (link)

   (let ((link (cl-ppcre:regex-replace "^https?:" link "")))

     (subseq link 0 (min 30 (length link)))))

-(defmethod print-object ((object feed) stream)

-  (print-unreadable-object (object stream :type t :identity t)

-    (with-slots (title link) object

-      (format stream "title: ~s link: ~s"

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

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

-

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

-         (channel (plump-dom:make-element feed-root "channel")))

-    ($ (inline feed-root)

-       (attr "version" "2.0")

-       (attr "xmlns:content" "http://purl.org/rss/1.0/modules/content/")

-       (attr "xmlns:atom" "http://www.w3.org/2005/Atom"))

-    (with-slots (title link feed-link description) feed

-      ($ (inline (make-element channel "title"))

-         (text title))

-      ($ (inline (make-element channel "link"))

-         (text link))

-      (awhen description

-        ($ (inline (make-element channel "description"))

-         (text it)))

-      ($ (inline (make-element channel "atom:link"))

-         (attr "rel" "self")

-         (attr "type" "application/rss+xml")

-         (attr "href" link)))

-    xml-root))

-

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

-      (with-slots (title id date link content) item

-        ($ (inline (make-element item-root "title")) (text title)) 

-        ($ (inline (make-element item-root "link")) (text link)) 

-        (plump-dom:set-attribute

-          ($ (inline (make-element item-root "guid")) (text id) (node))

-          "isPermaLink"

-          "false") 

-        ($ (inline (make-element item-root "pubDate")) (text date)) 

-        ($ (inline (make-element item-root "description")) (text content))))))

-

-(defmethod print-object ((object item) stream)

-  (print-unreadable-object (object stream :type t :identity t)

-    (with-slots (title link date) object

-      (format stream "title: ~s link: ~s date:~s"

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

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

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

-

-;{{{ RSS feed handling

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

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

-         (item-link ($ "> link" (text) (node)))

-         (item-date ($ "> pubDate" (text) (node)))

-         (item-guid ($ "> guid" (text) (node)))

-         (item-description ($ "> description" (text) (node)))

-         (item-content-encoded ($ "> content::encoded" (text) (node)))

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

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

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

-    (make-instance 'item

-                   :content content   

-                   :date item-date

-                   :doc xml-dom

-                   :id item-guid

-                   :link item-link

-                   :title item-title)))

-

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

-  ; TODO: store feed-link

-  (lquery:initialize xml-dom)

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

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

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

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

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

-;}}} 

-

-; {{{ ATOM feed handling

-

-

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

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

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

@@ -18,12 +18,13 @@

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

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

+   (logo       :initarg :logo                            :initform nil)

+   (updated    :initarg :updated                         :initform nil)

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

 (defclass atom-item (alimenta:item)

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

@@ -64,7 +65,7 @@

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

     (make-instance 'atom-item

                    :content content

-                   :date item-date

+                   :date (local-time:parse-timestring item-date)

                    :id item-guid

                    :author item-author

                    :author-uri item-author-uri

@@ -90,6 +91,7 @@

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

@@ -102,6 +104,7 @@

         :icon doc-icon

         :logo doc-logo

         :link doc-link

+        :updated doc-updated

         :id doc-id

         :feed-link doc-feed-link

         :subtitle doc-subtitle

@@ -134,7 +137,7 @@

                     (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

+        (with-slots (title id updated link feed-link description) feed

           ($ (inline (make-element feed-root "title")) (text title)

              (inline (make-element feed-root "link"))

@@ -145,6 +148,7 @@

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

              ))))))

@@ -161,7 +165,9 @@

              (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 "content")) (text content)

+             (inline (make-element item-root "updated")) (text date) (node)

+             ))))))

 (defconstants-really

@@ -6,6 +6,9 @@

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

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

+(defpackage #:alimenta.rss

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

+

 (defpackage #:alimenta.atom

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

new file mode 100644

@@ -0,0 +1,73 @@

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

+

+(in-package :alimenta.rss)

+

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

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

+

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

+  ($ (inline xml-dom) "channel > item"))

+

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

+  (prog1 partial

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

+      (with-slots (title id date link content) item

+        ($ (inline (make-element item-root "title")) (text title)) 

+        ($ (inline (make-element item-root "link")) (text link)) 

+        (plump-dom:set-attribute

+          ($ (inline (make-element item-root "guid")) (text id) (node))

+          "isPermaLink"

+          "false") 

+        ($ (inline (make-element item-root "pubDate")) (text date)) 

+        ($ (inline (make-element item-root "description")) (text content))))))

+

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

+  (declare (ignore r))

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

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

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

+    ($ (inline feed-root)

+       (attr "version" "2.0")

+       (attr "xmlns:content" "http://purl.org/rss/1.0/modules/content/")

+       (attr "xmlns:atom" "http://www.w3.org/2005/Atom"))

+    (with-slots (title link feed-link description) feed

+      ($ (inline (make-element channel "title"))

+         (text title))

+      ($ (inline (make-element channel "link"))

+         (text link))

+      (awhen description

+        ($ (inline (make-element channel "description"))

+           (text it)))

+      ($ (inline (make-element channel "atom:link"))

+         (attr "rel" "self")

+         (attr "type" "application/rss+xml")

+         (attr "href" link)))

+    xml-root))

+

+(defmethod make-item (xml-dom (type (eql :rss)))

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

+         (item-link ($ "> link" (text) (node)))

+         (item-date ($ "> pubDate" (text) (node)))

+         (item-guid ($ "> guid" (text) (node)))

+         (item-description ($ "> description" (text) (node)))

+         (item-content-encoded ($ "> content::encoded" (text) (node)))

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

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

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

+    (make-instance 'item

+                   :content content   

+                   :date item-date

+                   :doc xml-dom

+                   :id item-guid

+                   :link item-link

+                   :title item-title)))

+

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

+  ; TODO: store feed-link

+  (lquery:initialize xml-dom)

+  (let ((doc-title ($ "channel > title" (text) (node)))

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

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

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

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

+

@@ -4,20 +4,6 @@

 (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

     `(*

@@ -45,6 +31,20 @@

        )

     ))

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

+

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

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

     (spinneret:with-html-string