@@ -4,18 +4,24 @@

   :description "A little library to discover, fetch, parse and generate RSS feeds"

   :author "Fiddlerwoaroof <fiddlerwoaroof@howit.is>"

   :license "MIT"

-  :depends-on (#:plump

-               #:lquery

-               #:should-test

-               #:alexandria

-               #:serapeum

+  :depends-on (#:alexandria

                #:anaphora

                #:chronicity

+               #:drakma

+               #:for

                #:fwoar.lisputils

-               #:split-sequence

-               #:drakma)

+               #:lquery

+               #:plump

+               #:serapeum

+               #:should-test

+               #:spinneret

+               #:split-sequence)

   :serial t

   :components ((:file "package")

+               (:file "collections")

+               (:file "collections-for")

+               #+sbcl (:file "collections-sbcl-iterators")

+

                (:file "alimenta")  

                (:file "data-class")

                (:file "date-handling")

@@ -3,31 +3,64 @@

 (in-package #:alimenta)

+(defclass feed-entity ()

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

+   (link :initarg :link :initform nil :accessor link)

+   (doc :initarg :doc :initform nil :accessor doc)))

+

+(defgeneric belongs-to (feed-entity)

+  (:documentation "Returns the person responsible for this feed item"))

+

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

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

+(defgeneric render (object renderer)

+  (:documentation "Given a lisp object representing a feed, return it rendered

+                   to the specified format"))

+

+(defgeneric render-feed (feed renderer)

+  (:documentation "Render the container for the feed's items. Return an object

+                   to which the items can be added via add-rendered-item"))

+

+(defgeneric render-item (item renderer)

+  (:documentation "Render an item to be added to a feed. Return an object that

+                   can be added to the container by add-rendered-item"))

+

+(defgeneric add-rendered-item (item-representation feed-representation renderer)

+  (:documentation "Add the rendered item to the rendered feed"))

+

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

   (:documentation "Given a lisp object representing a feed, return an xml

                    document"))

-(defclass feed () 

-  ((description :initarg :description :initform nil :accessor description)

-   (doc :initarg :doc :initform nil :accessor doc)

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

-   (items :initarg :items :initform nil :accessor items)

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

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

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

-

-(defclass item ()

+(defclass item (feed-entity)

   ((author :initarg :author :initform nil :accessor author)

    (content :initarg :content :initform nil :accessor content)

    (date :initarg :date :initform nil :accessor date)

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

    (id :initarg :id :initform nil :accessor id)

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

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

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

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

+

+(collection-class:define-collection (feed item) (feed-entity) 

+  ((description :initarg :description :initform nil :accessor description)

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

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

+

+(defmethod render ((feed feed) renderer)

+  (let ((doc (render-feed feed renderer)))

+    (for:for ((item over feed))

+      (add-rendered-item (render-item item renderer) doc renderer))))

+

+(defmethod (setf feed-link) ((value string) (feed feed))

+  (setf (slot-value feed 'feed-link)

+        (puri:parse-uri value)))

+

+(defmethod initialize-instance :after ((feed feed) &key feed-link)

+  (when feed-link

+    (setf (feed-link feed) (puri:parse-uri feed-link))))

+

+(defmethod belongs-to ((item item))

+  (author item))

 (defclass complex-value () ())

@@ -56,11 +89,10 @@

   (:report (lambda (condition stream)

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

-

 (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

+    (with-accessors ((items items)) feed

       (loop for item in items

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

     result))

@@ -72,10 +104,10 @@

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

+    (setf

+      (items it)

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

@@ -144,7 +176,7 @@

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

-;  (with-slots (items) feed

+;  (with-accessors ((items items)) feed

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

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

 ;          finally (return items)))) 

@@ -173,17 +205,17 @@

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

 (defmethod push-item ((feed feed) (item item))

-  (push item (slot-value feed 'items)))

+  (push item

+        (items feed)))

 (deftest push-item ()

   (let ((feed (make-instance 'feed))

         (item (make-instance 'item)))

-    (with-slots (items) feed

+    (with-accessors ((items items)) feed

       ;(should signal error (push-item feed 2))

       (should be eql item

               (progn

                 (push-item feed item)

                 (car items))))))

-

 ;; vim: set foldmethod=marker:

@@ -2,30 +2,30 @@

 (in-package :alimenta.atom)

 (defclass atom-category ()

-  ((term :initarg :term :initform nil)

-   (label :initarg :label :initform nil)

-   (scheme :initarg :scheme :initform nil)))

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

+   (label :initarg :label :initform nil :accessor label)

+   (scheme :initarg :scheme :initform nil :accessor 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)))

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

-   (id         :initarg :id                              :initform nil)

-   (icon       :initarg :icon                            :initform nil)

-   (categories :initarg :categories :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)))

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

+   (id         :initarg :id                              :initform nil :accessor id)

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

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

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

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

@@ -136,19 +136,20 @@

   (let ((feed-root (or ($1 (inline partial) "feed")

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

     (prog1 feed-root

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

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

-             )))))

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

@@ -157,7 +158,8 @@

                   (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

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

new file mode 100644

@@ -0,0 +1,13 @@

+(defmethod for:has-more ((iterator collection-iterator))

+  (not (null (for:object iterator))))

+

+(defmethod for:next ((iterator collection-iterator))

+  (let ((collection-items (for:object iterator)))

+    (prog1 (car collection-items)

+      (setf (for:object iterator)

+            (cdr collection-items)))))

+

+(defmethod for:make-iterator ((collection collection) &key)

+  (make-instance 'collection-iterator :object collection))

+

+

new file mode 100644

@@ -0,0 +1,28 @@

+(in-package :collection-class)

+

+(defmethod sb-sequence:length ((sequence collection))

+  (length (items sequence)))

+

+(defmethod sb-sequence:elt ((sequence collection) index)

+  (elt (items sequence) index))

+

+(defmethod (setf sb-sequence:elt) (new-value (sequence collection) index)

+  (setf (elt (items sequence) index) new-value))

+

+(defmethod sb-sequence:adjust-sequence ((sequence collection) length &key initial-element initial-contents)

+  (let ((result (duplicate-collection sequence)))

+    (when (or initial-element initial-contents)

+      (setf (items result)

+            (sb-sequence:adjust-sequence (items result) length

+                                         :initial-element initial-element

+                                         :initial-contents initial-contents)))

+    result))

+

+(defmethod sb-sequence:make-sequence-like ((sequence collection) length &key initial-element initial-contents)

+  (let ((result (duplicate-collection sequence)))

+    (setf (items result)

+          (sb-sequence:make-sequence-like (items result) length

+                                          :initial-element initial-element

+                                          :initial-contents initial-contents))

+    result))

+

new file mode 100644

@@ -0,0 +1,68 @@

+(in-package :collection-class)

+

+(defclass collection (standard-object sequence)

+  ())

+

+(define-condition value-error ()

+  ((value :initarg :value :accessor value)))

+

+(defgeneric push-item (collection item)

+  (:documentation "Push item onto the beginning of the collection"))

+

+(defgeneric items (collection)

+  (:documentation "Get the items from a collection"))

+

+(defgeneric duplicate-collection (collection))

+

+(defgeneric copy-instance (object &rest initargs &key &allow-other-keys)

+  (:documentation "Makes and returns a shallow copy of OBJECT.

+

+                   An uninitialized object of the same class as OBJECT is allocated by

+                   calling ALLOCATE-INSTANCE.  For all slots returned by

+                   CLASS-SLOTS, the returned object has the

+                   same slot values and slot-unbound status as OBJECT.

+

+                   REINITIALIZE-INSTANCE is called to update the copy with INITARGS.")

+  (:method ((object standard-object) &rest initargs &key &allow-other-keys)

+   (let* ((class (class-of object))

+          (copy (allocate-instance class)))

+     (dolist (slot-name (mapcar #'sb-mop:slot-definition-name (sb-mop:class-slots class)))

+       (when (slot-boundp object slot-name)

+         (setf (slot-value copy slot-name)

+               (slot-value object slot-name))))

+     (apply #'reinitialize-instance copy initargs))))

+

+

+; TODO: actually use item-class...

+; TODO: finish initform handling.  Have to figure out how to make initform work with push-item

+(defmacro define-collection ((name item-class &key (initform '(list))) (&rest supers) &body ((&rest slots) &rest other-stuff))

+  (with-gensyms (item-slot-sym)

+    `(progn (defclass ,name (,@supers collection)

+              ((,item-slot-sym :initform ,initform :accessor items)

+               ,@slots)

+              ,@other-stuff)

+            (defmethod duplicate-collection ((collection ,name))

+              (let ((result (copy-instance collection)))

+                (setf (items result)

+                      (copy-seq (items result)))

+                result))

+            (defmethod push-item ((collection ,name) (item ,item-class))

+              (push item (items collection))))))

+

+(defclass collection-iterator (for:iterator)

+  ())

+

+(defmethod initialize-instance :after ((iterator collection-iterator) &key object)

+  (setf (for:object iterator)

+        (items object)))

+

+(defmethod random-item ((collection collection) &optional (random-state *random-state*))

+  (let* ((length (length (items collection)))

+         (selected-index (random length random-state)))

+    (elt (items collection)

+         selected-index)))

+

+(defmethod nth-item ((collection collection) (index integer))

+  (if (>= index 0)

+    (elt (items collection) index)

+    (error 'value-error :value index)))

@@ -9,9 +9,22 @@

                     drakma:*text-content-types*)))

      ,@body))

+(defvar *user-agent* "alimenta/0.0")

+

+(defun call-with-user-agent (user-agent cb &rest args)

+  (let ((*user-agent* user-agent))

+    (apply cb args)))

+

+(defun let-bind-special-var-macro-body (var value body)

+  `(let ((,var ,value))

+     ,@body))

+

+(defmacro with-user-agent ((user-agent) &body body)

+  (let-bind-special-var-macro-body '*user-agent* user-agent body))

+

 (defun fetch-doc-from-url (url)

   (setup-libraries-for-feeds 

-    (plump:parse (drakma:http-request url))))

+    (plump:parse (drakma:http-request url :user-agent *user-agent*))))

 (define-condition fetch-error () ())

 (define-condition feed-ambiguous (fetch-error) ((choices :initarg :choices :initform nil)))

@@ -26,7 +39,7 @@

 (defun fetch-feed-from-url (url &key type)

   (setup-libraries-for-feeds

-    (let* ((feeds (alimenta.discover:discover-feed (drakma:http-request url)))

+    (let* ((feeds (alimenta.discover:discover-feed (drakma:http-request url :user-agent *user-agent*)))

            (feeds (if type (remove-if-not (lambda (x) (eql type (car x))) feeds) feeds)))

       (if (not feeds) (no-feed url)

         (fetch-doc-from-url

@@ -1,5 +1,9 @@

 ;;;; package.lisp

+(defpackage #:collection-class

+  (:use #:cl #:alexandria #:serapeum)

+  (:export collection value-error push-item define-collection random-item nth-item items))

+

 (defpackage #:data-class

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

   (:export #:define-data-class))

@@ -8,11 +12,16 @@

   (:use #:cl #:alexandria #:serapeum #:fw.lu #:should-test))

 (defpackage #:alimenta

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

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

   (:export #:to-feed #:generate-xml #:feed #:title #:link #:items #:feed-link

            #:doc #:source-type #:id #:date #:content #:item #:description

            #:%generate-xml #:%to-feed #:get-items #:make-item #:complex-value

-           #:primary-value))

+           #:primary-value #:render #:author))

+

+(defpackage #:alimenta.html

+  (:use #:cl #:should-test #:lquery #:alexandria #:anaphora #:alimenta #:data-class

+        #:fwoar.lisputils)

+  (:export #:html-renderer))

 (defpackage #:alimenta.rss

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

@@ -48,30 +48,72 @@

             (slot-value self 'category)

             (slot-value self 'domain))))

+(defmacro check ((test &body body))

+  `(let ((val (progn ,@body)))

+     (when (,test val)

+       val)))

+

+(defun all-alpha (str)

+  (check-type str string)

+  (loop for char across str

+        always (alpha-char-p char)))

+

+

+(defun extract-date-timezone (date-str)

+  (declare (optimize (debug 3)))

+  (let ((tz-inited nil))

+    (flet ((init-tz ()

+             (unless tz-inited

+               (local-time:reread-timezone-repository)

+               (setf tz-inited t))))

+

+      (macrolet ((ensure-tz-inited (&body body)

+                   `(progn (init-tz)

+                           ,@body)))

+        (let* ((last-space (position #\space date-str :from-end t))

+               (tz-name (check (all-alpha (subseq date-str (1+ last-space)))))

+               (timestamp-raw (if tz-name

+                                (subseq date-str 0 last-space)

+                                date-str)))

+          (values (if tz-name

+                    (ensure-tz-inited

+                      (local-time:find-timezone-by-location-name

+                        (string-upcase tz-name)))

+                    local-time:+utc-zone+)

+                  timestamp-raw))))))

+

 (defun get-date (str)

   (declare (optimize (debug 3)))

   (handler-case

     (local-time:parse-timestring str)

     (local-time::invalid-timestring (c) (declare (ignore c))

-      (multiple-value-bind (res groups) (cl-ppcre:scan-to-strings "(.*)\s*([+-][0-9]{2,4})\s?$" str)

-        (let ((local-time:*default-timezone* local-time:+utc-zone+))

-          (let* ((timestamp (string-trim " " (if res (elt groups 0) str)))

-                 (hour-offset (if res (parse-integer (elt groups 1) :end 3) 0)) 

-                 (minute-offset (if (and res (> (length (elt groups 1)) 3))

-                                  (* (signum hour-offset) (parse-integer (elt groups 1) :start 3))

-                                  0)))

-            (loop

-              (restart-case (return

-                              (let-each (:be *)

-                                (chronicity:parse timestamp)

-                                (local-time:timestamp- * minute-offset :minute)

-                                (local-time:timestamp- * hour-offset   :hour)))       

-                (pop-token () (setf timestamp

-                                    (subseq timestamp

-                                            0

-                                            (position #\space timestamp

-                                                      :from-end t))))))))))))

-

+      (multiple-value-bind (local-time:*default-timezone* timestamp-raw) (extract-date-timezone str)

+        (multiple-value-bind (res groups) (cl-ppcre:scan-to-strings "(.*)\s*([+-][0-9]{2,4})\s?$" timestamp-raw)

+          (let ((ts (if res (elt groups 0) timestamp-raw))

+                (tz-offset (if res (elt groups 1) "0000")))

+            (let* ((timestamp (string-trim " " ts))

+                   ; Handle numeric timzones like -0430 or +0320

+                   (hour-offset (parse-integer tz-offset :end 3))

+                   (minute-offset (if (> (length tz-offset) 3)

+                                    (* (signum hour-offset)

+                                       (parse-integer tz-offset :start 3))

+                                    0)))

+

+              (loop

+                (restart-case (return

+                                (let-each (:be *)

+                                  (chronicity:parse timestamp)

+                                  (local-time:timestamp- * minute-offset :minute)

+                                  (local-time:timestamp- * hour-offset   :hour)))       

+                  (pop-token () (setf timestamp

+                                      (subseq timestamp

+                                              0

+                                              (position #\space timestamp

+                                                        :from-end t)))))))))))))

+

+(defun pop-token ()

+  (when-let ((restart (find-restart 'pop-token)))

+    (invoke-restart restart)))

 (defmethod primary-value ((self rss-image))

   (slot-value self 'url))

@@ -180,7 +222,7 @@

            (doc-link (get-channel-element "channel > link"))

            (doc-description (get-channel-element "channel > description"))

            (doc-feed-link (or feed-link

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

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

       (make-instance 'rss-feed

         :title doc-title

         :link doc-link