Paste number 5833: UCW code for Re: Looking for bored Lisper with GUI chops.

Paste number 5833: UCW code for Re: Looking for bored Lisper with GUI chops.
Pasted by: drewc
3 years, 2 months ago
#lisp | Context in IRC logs
Paste contents:
Raw Source | XML | Display As
(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))))
)
)


This paste has no annotations.

Colorize as:
Show Line Numbers

Ads absolutely not by Google

Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.