@@ -11,10 +11,13 @@

                #:anaphora

                #:chronicity

                #:fwoar.lisputils

+               #:split-sequence

                #:drakma)

   :serial t

   :components ((:file "package")

                (:file "alimenta")  

+               (:file "data-class")

+               (:file "date-handling")

                (:file "atom")  

                (:file "rss")  

                (:file "fetching")

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

 (defclass feed () 

   ((title :initarg :title :initform nil)

    (link :initarg :link :initform nil)

-   (items :initarg :items :initform nil)

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

    (description :initarg :description :initform nil)

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

    (doc :initarg :doc :initform nil)

@@ -19,7 +19,7 @@

    (date :initarg :date :initform nil)

    (link :initarg :link :initform nil)

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

-   (content :initarg :content :initform nil)

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

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

 (defclass complex-value () ())

@@ -6,17 +6,11 @@

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

@@ -26,16 +20,22 @@

    (updated    :initarg :updated                         :initform nil)

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

+(defclass alimenta::link ()

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

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

+

 (defclass atom-item (alimenta:item)

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

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

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

@@ -28,20 +28,56 @@

               `(setf ,name (when it (,transform it)))

               `(setf ,name it)))))))

-(defgeneric all-slots (self format))

+(defgeneric %all-slots (self format))

+(defun all-slots (self &optional format)

+  (%all-slots self format))

+

+(defgeneric slot-tags (self))

+

+(defun process-slots-for-data-class (slots)

+  (mapcar

+    (fw.lu::destructuring-lambda ((slot tag . rest))

+      (let ((tag (etypecase tag

+                   (symbol (string-downcase tag))

+                   (string tag))))

+        (list* slot (make-keyword slot) tag rest)))

+    (fw.lu:ensure-mapping slots)))

+

+(deftest process-slots-for-data-class ()

+  (let ((tc-1 '(a))

+        (tc-2 '((a b)))

+        (tc-3 '((a "b")))

+        (tc-4 '((a b c)))

+        (tc-5 '((a "b" c)))

+        (tc-6 '((a "bC")))

+        (tc-7 '((a "bC" d))))

+    (should be equal '((a :a "a")) (process-slots-for-data-class tc-1))

+    (should be equal '((a :a "b")) (process-slots-for-data-class tc-2))

+    (should be equal '((a :a "b")) (process-slots-for-data-class tc-3))

+    (should be equal '((a :a "b" c)) (process-slots-for-data-class tc-4))

+    (should be equal '((a :a "b" c)) (process-slots-for-data-class tc-5))

+    (should be equal '((a :a "bC")) (process-slots-for-data-class tc-6))

+    (should be equal '((a :a "bC" d)) (process-slots-for-data-class tc-7))))

 (defmacro define-data-class (name (doc-slot root-el) (&rest superclasses) &body slots)

-  `(progn

-     (defclass ,name ,superclasses

-       ,(loop for (slot) in (fw.lu:ensure-mapping slots)

-              collect `(,slot :initarg ,(make-keyword slot) :accessor ,slot)))

-     ,@(loop for (slot tag-name . rest) in (fw.lu:ensure-mapping slots)

-             collect `(lazy-load-slot ,name ,doc-slot ,root-el ,slot ,tag-name ,@rest))

-     (defmethod all-slots ((self ,name) format)

-       (pairlis (list ,@(mapcar (fw.lu::alambda (make-keyword (car it)))

-                                (fw.lu:ensure-mapping slots)))

-                (list ,@(loop for (slot) in (fw.lu:ensure-mapping slots)

-                              collect `(,slot self)))))))

+  (declare (optimize (debug 3)))

+  (flet ((make-slot-spec (slot slot-keyword)

+           `(,slot :initarg ,slot-keyword :accessor ,slot)))

+    (let ((slots (process-slots-for-data-class slots)))

+      `(progn

+         (defclass ,name ,superclasses

+           ((slot-tags :allocation :class :initform

+                       ',(loop for (_ slot-keyword tag) in slots

+                               collect (cons slot-keyword tag)))

+            ,@(mapcar (fw.lu::destructuring-lambda ((slot slot-keyword . r))

+                        (declare (ignore r))

+                        (make-slot-spec slot slot-keyword))

+                      slots)))

+         ,@(loop for (slot _ tag-name . rest) in slots

+                 collect `(lazy-load-slot ,name ,doc-slot ,root-el ,slot ,tag-name ,@rest))

+         (defmethod %all-slots ((self ,name) format)

+           (pairlis (list ,@(mapcar (fw.lu::alambda (cadr it)) slots))

+                    (list ,@(loop for (slot) in slots collect `(,slot self)))))))))

@@ -1,11 +1,16 @@

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

 (in-package :alimenta.pull-feed)

+(defmacro setup-libraries-for-feeds (&body body)

+  `(let ((plump:*tag-dispatchers* plump:*xml-tags*)

+         (drakma:*text-content-types* 

+           (pairlis '("application" "application")

+                    '("atom+xml"    "rss+xml")

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

+     ,@body))

+

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

-  (let ((plump:*tag-dispatchers* plump:*xml-tags*)

-        (drakma:*text-content-types* (concatenate 'list

-                                                  '(("application" . "atom+xml") ("application" . "rss+xml"))

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

+  (setup-libraries-for-feeds 

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

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

@@ -20,21 +25,27 @@

   (cerror "Skip this feed" 'no-feed :url url))

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

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

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

-    (format t "~a << type" type)

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

-      (fetch-doc-from-url

-        (cdar 

-          (restart-case

-            (if (cdr feeds) (feed-ambiguous feeds) feeds)

-            (take-first-feed nil

-                             :report (lambda (s) (format s "Take the first feed"))

-                             feeds)

-            (take-nth-feed (n)

-                           :report (lambda (s) (format s "Take the nth feed"))

-                           (list (elt feeds n)))

-            (select-feed (selector)

-                         :report (lambda (s) (format s "Provide a function to select the right feed"))

-                         (find-if selector feeds))))))))

+  (setup-libraries-for-feeds

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

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

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

+        (fetch-doc-from-url

+          (cdar 

+            (restart-case

+              (if (cdr feeds) (feed-ambiguous feeds) feeds)

+              (take-first-feed nil

+                               :report (lambda (s) (format s "Take the first feed"))

+                               feeds)

+              (take-nth-feed (n)

+                             :report (lambda (s) (format s "Take the nth feed"))

+                             (list (elt feeds n)))

+              (select-feed (selector)

+                           :report (lambda (s) (format s "Provide a function to select the right feed"))

+                           (find-if selector feeds)))))))))

+(defun pull-feed (url &key detect type)

+  (to-feed

+    (if detect

+      (fetch-feed-from-url url)

+      (fetch-doc-from-url url)) 

+    :type type))

@@ -6,16 +6,18 @@

 (defpackage #:alimenta

   (: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 #:description #:%generate-xml #:%to-feed #:%get-items #:make-item #:complex-value

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

 (defpackage #:alimenta.rss

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

-  (:export #:language #:copyright #:managing-editor #:webmaster #:publication-date #:last-build-date

-           #:categories #:generator #:docs #:cloud #:ttl #:image #:rating #:text-input #:skip-hours

-           #:skip-days #:rss-feed #:rss-item))

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

+        #:fwoar.lisputils)

+  (:export #:language #:copyright #:managing-editor #:webmaster

+           #:publication-date #:last-build-date #:categories #:generator #:docs

+           #:cloud #:ttl #:image #:rating #:text-input #:skip-hours #:skip-days

+           #:rss-feed #:rss-item))

 (defpackage #:alimenta.atom

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

@@ -26,7 +28,8 @@

 (defpackage #:alimenta.pull-feed 

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

-  (:export #:pull-feed #:fetch-doc-from-url)) 

+  (:export #:pull-feed #:fetch-doc-from-url #:fetch-feed-from-url

+           #:fetch-error #:feed-ambiguous #:no-feed)) 

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

   (asdf:load-system :alimenta)

@@ -1,20 +1,5 @@

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

-

 (in-package :alimenta.rss)

-(defun get-date (str)

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

-                  

-            (local-time:timestamp- (local-time:timestamp- (chronicity:parse timestamp) minute-offset :minute)

-                                   hour-offset :hour)))))))

 (defclass rss-image ()

@@ -25,44 +10,10 @@

    (height :initarg :height :initform nil)

    (description :initarg :description :initform nil)))

-(defmethod print-object ((self rss-image) stream)

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

-    (format stream "~a" (slot-value self 'url))))

-

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

-  (slot-value self 'url))

-

-(defun make-image (url title &optional link width height description)

-  (let ((link (or link url)))

-    (make-instance 'rss-image

-                   :url url

-                   :title title

-                   :link link

-                   :width width

-                   :height height

-                   :description description)))

-

 (defclass rss-category ()

   ((category :initarg :category :initform nil)

    (domain :initarg :domain :initform nil)))

-(defmethod print-object ((self rss-category) stream)

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

-    (format stream "~a~@[ ~a~]"

-            (slot-value self 'category)

-            (slot-value self 'domain))))

-

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

-  (slot-value self 'category))

-

-(defun make-category (category &optional domain)

- (make-instance 'rss-category :category category :domain domain))

-

-(defun get-categories (doc tag)

-  ($ (inline doc) tag

-     (combine (text) (attr "domain"))

-     (map-apply #'make-category)))

-

 (define-data-class rss-feed (doc "channel") (feed)

   language copyright webmaster

   generator docs cloud ttl rating

@@ -87,6 +38,57 @@

   (categories "category" :value (get-categories doc "> category"))

   source comments enclosure )

+(defmethod print-object ((self rss-image) stream)

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

+    (format stream "~a" (slot-value self 'url))))

+

+(defmethod print-object ((self rss-category) stream)

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

+    (format stream "~a~@[ ~a~]"

+            (slot-value self 'category)

+            (slot-value self 'domain))))

+

+(defun get-date (str)

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

+            (let-each (:be *)

+              (chronicity:parse timestamp)

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

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

+

+

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

+  (slot-value self 'url))

+

+(defun make-image (url title &optional link width height description)

+  (let ((link (or link url)))

+    (make-instance 'rss-image

+                   :url url

+                   :title title

+                   :link link

+                   :width width

+                   :height height

+                   :description description)))

+

+(defmethod primary-value ((self rss-category))

+  (slot-value self 'category))

+

+(defun make-category (category &optional domain)

+ (make-instance 'rss-category :category category :domain domain))

+

+(defun get-categories (doc tag)

+  ($ (inline doc) tag

+     (combine (text) (attr "domain"))

+     (map-apply #'make-category)))

+

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

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

@@ -102,10 +104,7 @@

           (plump-dom:set-attribute

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

             "isPermaLink"

-            "false") 

-          ))

-

-      )))

+            "false"))))))

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

   (declare (ignore r))