@@ -12,6 +12,8 @@

 (ql:quickload :ubiquitous)

 (ql:quickload :iterate)

 (ql:quickload :jonathan)

+(ql:quickload :cl-actors)

+(ql:quickload :simple-tasks)

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

@@ -19,10 +21,11 @@

 (push (cons "application" "rss+xml") drakma:*text-content-types*)

 (push (cons "text" "rss+xml") drakma:*text-content-types*)

+;(load "utils.lisp")

 (load "rss.lisp")

 (defpackage :whitespace

-  (:use #:cl #:whitespace.utils #:whitespace.rss #:whitespace.tables))

+  (:use #:cl #:whitespace.utils #:whitespace.feeds.rss #:whitespace.tables))

 (in-package plump-dom)

@@ -58,6 +61,15 @@

     (defparameter *feeds* (map 'vector (lambda (x) (make-rss-feed x)) docs))))

 (defparameter *db-connection-info* (ubiquitous:value 'db 'connection 'info))

+(defmacro with-whitespace-db (&body body)

+  `(postmodern:with-connection *db-connection-info*

+     ,@body))

+(defmacro wc (&body body)

+  `(with-whitespace-db ,@body))

+

+(defmacro with-xml-tags (&body body)

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

+     ,@body))

 (defmacro def-markup (name (&rest args) &body body)

   `(defmacro ,name ,args

@@ -302,6 +314,7 @@

                    `((:or (:and .link-header :hover) (.link.closed (:and .link-header :hover)))

                      :background-color ,(colors:colorscheme-hover-highlight *colorscheme*)))))

+        (declare (ignorable main-right-margin)) ; TODO: use this!!!

         `(200 (:content-type "text/css") ,ss)))))

 (cl-oid-connect:def-route ("/theme/dark.css" (params) :app *app*)

@@ -348,4 +361,31 @@

     (stop))

   (start))

+(defun update-feed (url)

+  (wc

+    (postmodern:with-transaction ()

+      (upsert-feed (make-rss-feed (with-xml-tags (plump:parse (drakma:http-request url))))))))

+

+(defun update-all-feeds ()

+  (wc

+    (let ((urls (postmodern:query (:select 'fetch-url :from 'rss-feed-store))))

+      (mapcar (lambda (x) (apply #'update-feed x)) urls))))

+

+(defun minutes (minutes) (* minutes 60))

+

+(let (update-thread stop)

+  (defun start-update-thread ()

+    (setf update-thread

+          (bordeaux-threads:make-thread

+            (lambda ()

+              (loop

+                (update-all-feeds)

+                (sleep (ubiquitous:value 'update-frequency))

+                (when stop

+                  (return-from nil nil))))

+            :name "Whitespace Update Thread")))

+  (defun stop-update-thread ()

+    (setf stop t)

+    (setf update-thread nil)))

+

 ; vim: foldmethod=marker foldmarker=(,) foldminlines=3 :

@@ -1,27 +1,60 @@

 (in-package :cl-user)

+(use-package :lquery)

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

+(define-lquery-list-function where-attr (els attr &key is)

+  (remove-if-not (lambda (y) (string= (plump:attribute y attr) is))

+                 els))

+

+(define-lquery-list-function tag-name (nodes &rest tags)

+  "Manipulate elements on the basis of their tag-name.  With no arguments,

+   return their names else return the corresponding tags."

+  (if (null tags)

+    (map 'vector #'plump:tag-name nodes)

+    (apply #'vector

+           (loop for node across nodes

+                 if (find (plump:tag-name node) tags :test #'string=)

+                 collect node))))

+

+

+

 (load "tables.lisp")

-(defpackage :whitespace.rss

+(defpackage :whitespace.feeds.autodiscovery

   (:use #:cl #:alexandria #:postmodern #:lquery #:cl-syntax #:cl-annot.syntax #:cl-annot.class

         #:whitespace.tables #:iterate #:whitespace.utils)

   (:import-from anaphora it))

+(in-package #:whitespace.feeds.autodiscovery)

+

+(defun discover-feeds (doc)

+  "Given a plump DOM element, discover any feeds in the document using the link tags.

+   Returns a vector "

+  (coerce

+    (lquery:$ (inline doc)

+            "link"

+            (where-attr "rel" :is "alternate")

+            (combine (attr "href")

+                     (attr "type")))

+    'list))

+(export 'discover-feeds)

+

+(defpackage :whitespace.feeds.opml

+  (:use #:cl #:alexandria #:postmodern #:lquery #:cl-syntax #:cl-annot.syntax #:cl-annot.class

+        #:whitespace.tables #:iterate #:whitespace.utils)

+  (:import-from anaphora it))

+(in-package #:whitespace.feeds.opml)

-(in-package :whitespace.rss)

-(cl-annot.syntax:enable-annot-syntax)

-(lquery:define-lquery-list-function tag-name (nodes &rest tags)

-  "Manipulate elements on the basis of their tag-name.

-   With no arguments, return their names else return

-   the corresponding tags."

-  (if (null tags)

-    (map 'vector #'plump:tag-name nodes)

-    (apply #'vector

-           (loop for node across nodes

-                 if (find (plump:tag-name node) tags :test #'string=)

-                 collect node))))

+(in-package :cl-user)

+(defpackage :whitespace.feeds.rss

+  (:use #:cl #:alexandria #:postmodern #:lquery #:cl-syntax #:cl-annot.syntax #:cl-annot.class

+        #:whitespace.tables #:iterate #:whitespace.utils #:whitespace.feeds.autodiscovery)

+  (:import-from anaphora it))

+

+

+(in-package :whitespace.feeds.rss)

+(cl-annot.syntax:enable-annot-syntax)

 @export

 (defmacro get-elements (feed &optional (filter nil))

@@ -39,12 +72,6 @@

 (defmacro extract-text (selector &optional (default ""))

   `(or (lquery:$ ,selector (text) (node)) ,default))

-(defmacro defserializer ((specializes) &body slots)

-  (with-gensyms (obj o-t p-t)

-    `(defmethod serialize ((,obj ,specializes) &optional (,o-t #'identity) (,p-t #'%default-pair-transform))

-      (transform-result (,o-t ,p-t)

-        (slots-to-pairs ,obj ,slots)))))

-

 @export

 (defmacro xml-text-bind (syms &body body)

   "Bind the symbols passed in the second arg to the text of the matching

@@ -84,7 +111,7 @@

    (source :accessor rss-item-source  :initarg :source)))

 @export

-(defun make-rss-item (item)

+(defun make-rss-item (item fallback-date)

   (lquery:initialize item)

   (flet ((dehtml (h) (plump:text (plump:parse h)))

          (get-category-names (it) ;;; TODO: simplify this---Ask Shinmera on IRC

@@ -100,16 +127,18 @@

            (description-raw (normalize-html

                               (default-when description-element (emptyp description-element)

-                                (extract-text "description"))))

-

-           (description-munged (dehtml description-raw))

-           (category (get-category-names (lquery:$ "category"))))

+                                (extract-text "description")))))

            ;(enclosure) --- TODO: implement comment / enclosure handling

-      (xml-text-bind (title link guid pub-date source comments)

+      (xml-text-bind (title link guid pubdate source comments)

+        (when (string= pubdate "")

+          (setf pubdate fallback-date))

         (make-instance-from-symbols 'rss-item

-                                    item title link description-raw (description description-munged)

-                                    category guid pub-date source comments)))))

+                                    item title link

+                                    description-raw

+                                    (description (dehtml description-raw))

+                                    (category (get-category-names (lquery:$ "category")))

+                                    guid (pub-date pubdate) source comments)))))

       ;(setf (rss-item-enclosure result) enclosure)      -- TODO: comment/enclosure . . .

@@ -120,20 +149,17 @@

          (fetch-url (lquery:$ "channel" (children) (tag-name "atom:link") (filter "[rel=self]") (attr :href) (node)))

          (link (lquery:$ "channel > link" (text) (node)))

          (link (if (string= link "") (lquery:$ "channel" (children) (tag-name "atom:link") (attr :href) (node)) link))

-         (items (lquery:$ "item")))

+         (items (lquery:$ "item"))

+         (last-build (or (lquery:$ "lastBuildDate" (text) (node)) ""))

+         (pub-date (default-when last-build (string= last-build "")

+                     (lquery:$ "pubDate" (text) (node))))

+         (fallback-date (if (string= pub-date "") "2015-01-01 0:0:0+00" pub-date)))

+    (format t "fallback-date: ~a~%" fallback-date)

     (xml-text-bind (title description)

       (make-instance-from-symbols 'rss-feed

                                   feed title link description channel fetch-url

                                   (items (iterate (for it in-sequence items)

-                                                  (collecting (make-rss-item it))))))))

-

-@export

-(defgeneric serialize (cls &optional output-transform pair-transform))

-

-

-(defmethod serialize ((obj sequence) &optional (o-t #'identity) (p-t #'%default-pair-transform))

-  (iterate (for item in-sequence obj)

-           (collect (serialize item o-t p-t))))

+                                                  (collecting (make-rss-item it fallback-date))))))))

 ; These are the interface I'm planning to remove as duplicate

 (defserializer (rss-feed)

@@ -144,13 +170,6 @@

 (defserializer (rss-item)

   title link (description description-raw :bind-from description-raw) guid pub-date source)

-; this is the interface to be used

-(defserializer (rss_feed_store)

-  title link description fetch-url)

-

-(defserializer (rss_item_store)

-  title link description fetch-url)

-

 (defmethod jonathan:%to-json ((obj rss-feed))

   (jonathan:%to-json (serialize obj #'alexandria:alist-hash-table #'%json-pair-transform)))

@@ -164,63 +183,22 @@

                  (caar it))))

        ,@body)))

-(defgeneric get-dao-for (obj &optional link)

-  ; NOTE: this won't make dao objects for the _items_ when called on the feed!

-  ; also NOTE: this _prefers_ the passed object

-  (:method ((obj rss-feed) &optional linked-objects)

-   (declare (ignore linked-objects))

-   (with-slots (title link description fetch-url) obj

-     (get-id-for-object (rss_feed_store link) link

-       (make-instance-from-symbols 'rss_feed_store id title link description fetch-url (fetch-defaults t))) ))

-

-  (:method ((obj rss-item) &optional feed)

-   (with-slots (title link description-raw guid pub-date source) obj

-     (get-id-for-object (rss_item_store guid) guid

-       (let ((result (make-instance-from-symbols 'rss_item_store title link (description description-raw)

-                                   guid pub-date source feed (fetch-defaults t))))

-         (unless (null id)

-           (setf (ris-id result) id))

-         result)))))

-

-(define-condition blarg () ((text :initarg text)))

-@export

-(defun get-feed-from-dao (rss-feed)

-  (let ((feed-dao (get-dao-for rss-feed)))

-    (list feed-dao

-          ;(error 'blarg :text (format t "~a~%" rss-feed))

-          (with-slots (items) rss-feed

-            (iterate (for item in items)

-                     (collect (get-dao-for item (slot-value feed-dao 'id))))))))

-

-

-@export

-(defun upsert-feed (rss-feed)

-  (postmodern:ensure-transaction

-    (destructuring-bind (feed items) (get-feed-from-dao rss-feed)

-      (postmodern:upsert-dao feed)

-      (mapcar #'postmodern:upsert-dao items))))

-

-@export

-(defun store-item-dao (serialized-rss-item link)

-  (apply #'postmodern:make-dao

-         (list* 'rss_item_store :feed link

-                (iterate (for (k . v) in-sequence serialized-rss-item)

-                         (appending (list k v))))))

-

-@export

-(defun store-feed-dao (serialized-rss-feed &optional link)

-  (declare (ignore link))

-  (let* ((items nil)

-         (rss_feed (apply #'postmodern:make-dao

-                          (cons 'rss_feed_store

-                                (iterate (for (k . v) in-sequence serialized-rss-feed)

-                                         (if (eql k :items)

-                                           (setf items v)

-                                           (appending (list k v))))))))

-    (iterate (for item in items)

-             (store-item-dao (serialize item)

-                             (slot-value rss_feed 'id)))

-    rss_feed))

+; NOTE: this won't make dao objects for the _items_ when called on the feed!

+; also NOTE: this _prefers_ the passed object

+(defmethod get-dao-for ((obj rss-feed) &optional linked-objects)

+ (declare (ignore linked-objects))

+ (with-slots (title link description fetch-url) obj

+   (get-id-for-object (rss_feed_store link) link

+     (make-instance-from-symbols 'rss_feed_store id title link description fetch-url (fetch-defaults t))) ))

+

+(defmethod get-dao-for ((obj rss-item) &optional feed)

+ (with-slots (title link description-raw guid pub-date source) obj

+   (get-id-for-object (rss_item_store guid) guid

+     (let ((result (make-instance-from-symbols 'rss_item_store title link (description description-raw)

+                                 guid pub-date source feed (fetch-defaults t))))

+       (unless (null id)

+         (setf (ris-id result) id))

+       result))))

 (defun get-and-possibly-store-feed (rss-feed)

   "Given an rss-feed, return the db's feed-id, persisting it if it doesn't already exist."

@@ -259,7 +237,10 @@

 @export

 (defun deserialize-items (feed-id)

   (let ((items (postmodern:query-dao 'rss_item_store

-                                     (:select :* :from 'rss_item_store :where (:= :feed feed-id)))))

+                                     (:order-by

+                                       (:select :* :from 'rss_item_store

+                                        :where (:= :feed feed-id))

+                                       (:desc 'pub-date)))))

     (loop for item in items collect (deserialize-item item))))

 @export

@@ -281,15 +262,21 @@

                                    :where (:= 'reader_user.foreign_id (user-foreign-id user-info))))))

       (apply #'vector (loop for feed in feeds collect (deserialize-feed feed))))))

+(export

+  (defun get-feed-from-dao (rss-feed)

+    (let ((feed-dao (get-dao-for rss-feed)))

+      (list feed-dao

+            (with-slots (items) rss-feed

+              (iterate (for item in items)

+                       (collect (get-dao-for item (slot-value feed-dao 'id)))))))))

+

 @export

-(defun normalize-html (html)

-  (let ((plump-parser:*tag-dispatchers* plump:*html-tags*))

-    (with-output-to-string (ss)

-      (map 'vector

-           (lambda (x) (plump:serialize (plump:parse (plump:text x)) ss))

-           html)

-      ss)))

+(defun upsert-feed (rss-feed)

+  (postmodern:ensure-transaction

+    (destructuring-bind (feed items) (get-feed-from-dao rss-feed)

+      (postmodern:upsert-dao feed)

+      (mapcar #'postmodern:upsert-dao items))))

 ; \o/

@@ -1,6 +1,6 @@

 (in-package :cl-user)

 (defpackage :whitespace.tables

-  (:use #:cl #:alexandria #:postmodern #:annot.class))

+  (:use #:cl #:alexandria #:postmodern #:annot.class #:iterate #:whitespace.utils))

 (in-package :whitespace.tables)

 (cl-annot.syntax:enable-annot-syntax)

@@ -74,6 +74,59 @@

   (!foreign "reader_user" "uid" "id" :on-delete :cascade :on-update :cascade)

   (!unique '(uid feedid)))

+

+@export

+(defgeneric get-dao-for (obj &optional link)

+  (:documentation "Take an object an return the equivalent dao object. Use link to specify a single

+                   foreign key relationship---this probably should be generalized further"))

+

+@export

+(defgeneric serialize (cls &optional output-transform pair-transform))

+

+@export

+(defmacro defserializer ((specializes) &body slots)

+  (with-gensyms (obj o-t p-t)

+    `(defmethod serialize ((,obj ,specializes) &optional (,o-t #'identity) (,p-t #'%default-pair-transform))

+      (transform-result (,o-t ,p-t)

+        (slots-to-pairs ,obj ,slots)))))

+

+(defmethod serialize ((obj sequence) &optional (o-t #'identity) (p-t #'%default-pair-transform))

+  (iterate (for item in-sequence obj)

+           (collect (serialize item o-t p-t))))

+

+; this is the interface to be used

+(defserializer (rss_feed_store)

+  title link description fetch-url)

+

+(defserializer (rss_item_store)

+  title link description fetch-url)

+

+@export

+(defun store-item-dao (serialized-rss-item link)

+  (pomo:ensure-transaction

+    (apply #'postmodern:make-dao

+           (list* 'rss_item_store :feed link

+                  (iterate (for (k . v) in-sequence serialized-rss-item)

+                           (appending (list k v)))))))

+

+@export

+(defun store-feed-dao (serialized-rss-feed &optional link)

+  (declare (ignore link))

+  (pomo:ensure-transaction

+    (let* ((items nil)

+           (rss_feed (apply #'postmodern:make-dao

+                            (cons 'rss_feed_store

+                                  (iterate (for (k . v) in-sequence serialized-rss-feed)

+                                           (if (eql k :items)

+                                             (setf items v)

+                                             (appending (list k v))))))))

+      (iterate (for item in items)

+               (handler-case (pomo:with-savepoint store-item

+                               (store-item-dao (serialize item) (slot-value rss_feed 'id)))

+                 (cl-postgres-error:unique-violation ())))

+      rss_feed)))

+

+

 #|

 (with-connection whitespace::*db-connection-info* 

@@ -66,4 +66,12 @@

          ,(make-pairs slots)))))

 (export 'slots-to-pairs)

+(defun normalize-html (html)

+  (let ((plump-parser:*tag-dispatchers* plump:*html-tags*))

+    (with-output-to-string (ss)

+      (prog1 ss

+        (map 'vector

+           (lambda (x) (plump:serialize (plump:parse (plump:text x)) ss))

+           html)))))

+(export 'normalize-html)