5833 drewc (defpackage :cl-bloglines (:use :cl :it.bese.ucw :it.bese.ucw-user)) (in-package :cl-bloglines) (require 'xmls) (require 'aserve) (setf ucw::*debug-on-error* t) (defparameter *rpc-url* "http://rpc.bloglines.com/") (defun do-bloglines-request (username password &key (feed nil) (update 0)) "Does a listsubs, or a getitems if FEED is non-nil. Set UPDATE to 1 to mark a feed read" (let ((args `(:basic-authorization ,(cons username password))) (url (concatenate 'string *rpc-url* (if feed "getitems" "listsubs")))) (when feed (setf args (append `(:query (("s" . ,feed) ("n" . ,update))) args))) (apply #'net.aserve.client:do-http-request url args))) ;;;some xmls utilities functions (defun assoc-value (key alist) (cadr (assoc key alist :test #'equalp))) (defun get-by-name (name node) (let ((n (find-if #'(lambda (x) (equalp (car x) name)) (xmls:node-children node)))) (if (atom (third n)) (values (third n) (second n)) n))) (defun get-all-by-name (name node) (remove nil (mapcar #'(lambda (x) (when (equalp (car x) name) x)) (xmls:node-children node)))) (defapplication cl-bloglines (:url-prefix "/bl/")) ;;;; define the window component (defclass bl-window (simple-window-component) ((body :initarg :body :accessor body :component bl-login)) (:default-initargs :title "CL-Bloglines" :stylesheet "stylesheet.css") (:metaclass standard-component-class)) (defentry-point "index.ucw" (:application cl-bloglines) () (call 'bl-window)) (defmethod render-on ((res response) (win bl-window)) (<:h1 (<:as-html "CL-Bloglines RSS Reader")) (render-on res (body win))) ;;; a base class for all UI objects. (defclass bl-class () ((feeds :accessor feeds :initarg :feeds :initform "") (items :accessor items :initarg :items :initform nil) (current-feed :accessor current-feed :initarg :current-feed :initform nil) (current-item :accessor current-item :initarg :current-item :initform nil) (auth :accessor auth :initarg :auth :initform nil)) (:metaclass standard-component-class)) (defmethod get-feeds ((bl bl-class)) "Returns the XML text in outline format and sets (feeds self). nil on errors" (multiple-value-bind (feeds result) (do-bloglines-request (car (auth bl)) (cdr (auth bl))) (when (equal 200 result) (setf (feeds bl) feeds)))) (defmethod get-items ((bl bl-class)) "Returns the RSS XML for the current feed" (multiple-value-bind (items result) (do-bloglines-request (car (auth bl)) (cdr (auth bl)) :feed (current-feed bl)) (if (equal 200 result) (setf (items bl) items) (setf (items bl) nil)))) (defmethod extract-feeds ((bl bl-class)) "Extracts the feed outine from the xml. returns an xmls node" (cddr (third (fourth (xmls:parse (feeds bl)))))) (defmethod extract-items ((bl bl-class)) "extracts the rss items from the XML. Returns an xmls node" (caddr (xmls:parse (items bl)))) (defaction select-item ((bl bl-class) item) "Makes item the current item" (setf (current-item bl) item)) (defaction select-feed ((bl bl-class) feed) "Makes feed the current feed" (setf (current-feed bl) feed)) (defclass bl-login (login bl-class) () (:metaclass standard-component-class) (:documentation "Gets the username and password and retrieves the feed")) (defmethod check-credentials ((login bl-login)) (setf (auth login) (cons (login.username login) (login.password login))) (get-feeds login)) ;;;this has to be ini the ucw package. possibly a bug in ucw. (defaction it.bese.ucw::login-successful ((login bl-login)) (call 'rss-reader :feeds (feeds login) :auth (auth login))) (defclass feeds-pane (widget-component bl-class) ((feeds-outline :accessor feeds-outline)) (:metaclass standard-component-class) (:documentation "a UI class to hold the list of feeds")) (defmethod render-on ((res response) (f feeds-pane)) (<:h3 (<:as-html "Subscriptions")) (dolist (x (feeds-outline f)) (let ((id (assoc-value "BloglinesSubId" (second x))) (title (assoc-value "title" (second x))) (unread (assoc-value "BloglinesUnread" (second x)))) (<:div (<ucw:a :action (select-feed f id) (if (equalp "0" unread) (<:as-html title) (<:as-html (format nil "~A (~A)" title unread)))))))) (defclass items-pane (widget-component bl-class) () (:metaclass standard-component-class) (:documentation "A UI pane to hold the Titles of the RSS feed")) (defmethod render-on ((res response) (ip items-pane)) (<:h3 (<:a :href (get-by-name "link" (items ip)) (<:as-html (get-by-name "title" (items ip))))) (dolist (item (get-all-by-name "item" (items ip))) (<:div :class "item" (<ucw:a :action (select-item ip item) (<:as-html (get-by-name "title" item)))))) (defclass body-pane (widget-component bl-class) () (:metaclass standard-component-class) (:documentation "a UI pane to hold the bdy of the blog post")) (defmethod render-on ((res response) (b body-pane)) (<:h3 (<:as-html (get-by-name "title" (current-item b)))) (<:a :href (get-by-name "link" (current-item b)) (<:as-html "(link)")) (<:div :class "content" (<:as-is (get-by-name "description" (current-item b))))) (defclass rss-reader (widget-component bl-class) ((feeds-pane :accessor feeds-pane :component feeds-pane) (items-pane :accessor items-pane :component items-pane) (body-pane :accessor body-pane :component body-pane)) (:metaclass standard-component-class) (:documentation "the RSS reader application itself")) (defmethod render-on :before ((res response) (rss rss-reader)) "Propogates the state of the current-feed/item throughout the application Also gets the current RSS Feed if needed" (with-slots (current-feed current-item feeds-pane items-pane body-pane) rss ;set the current-feed/item (setf current-feed (current-feed feeds-pane) current-item (current-item items-pane)) (setf (current-item body-pane) current-item) ;update if current-feed has changed. (when (not (equal current-feed (current-feed items-pane))) (get-items rss) (setf (current-feed items-pane) current-feed (items items-pane) (extract-items rss))))) (defmethod shared-initialize :after ((rss rss-reader) foo &rest bar) "Sets up the initial feed pane" (declare (ignore foo bar)) (setf (feeds-outline (feeds-pane rss)) (extract-feeds rss))) (defmethod render-on ((res response) (rss rss-reader)) (<:table :width "100%" :style "{border:1px solid black}" (<:tr (<:td :rowspan 2 :valign "top" :width "20%" :style "{border-right : 1px solid black}" (render-on res (feeds-pane rss))) (<:td (render-on res (items-pane rss)))) (<:tr (<:td (<:hr)(render-on res (body-pane rss)))))) 3317511768 #lisp