[bknr-cvs] r1968 - in branches/xml-class-rework/bknr/src: . rss web
bknr at bknr.net
bknr at bknr.net
Sat Jul 22 11:29:40 UTC 2006
Author: hhubner
Date: 2006-07-22 07:29:38 -0400 (Sat, 22 Jul 2006)
New Revision: 1968
Added:
branches/xml-class-rework/bknr/src/rss/test.lisp
Modified:
branches/xml-class-rework/bknr/src/bknr.asd
branches/xml-class-rework/bknr/src/packages.lisp
branches/xml-class-rework/bknr/src/rss/rss.lisp
branches/xml-class-rework/bknr/src/web/handlers.lisp
branches/xml-class-rework/bknr/src/web/web-utils.lisp
Log:
fix smaller upload problems
rewrote rss module, still needs debugging to make it work with gmail
Modified: branches/xml-class-rework/bknr/src/bknr.asd
===================================================================
--- branches/xml-class-rework/bknr/src/bknr.asd 2006-07-16 17:49:02 UTC (rev 1967)
+++ branches/xml-class-rework/bknr/src/bknr.asd 2006-07-22 11:29:38 UTC (rev 1968)
@@ -34,6 +34,7 @@
:klammerscript
:bknr-datastore
:bknr-data-impex
+ :kmrcl
#+(not allegro)
:acl-compat)
Modified: branches/xml-class-rework/bknr/src/packages.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/packages.lisp 2006-07-16 17:49:02 UTC (rev 1967)
+++ branches/xml-class-rework/bknr/src/packages.lisp 2006-07-22 11:29:38 UTC (rev 1968)
@@ -26,7 +26,7 @@
#:start-cron))
(defpackage :bknr.rss
- (:use :cl :cl-user :cl-ppcre :bknr.utils :puri :cxml-xmls)
+ (:use :cl :cl-user :cl-ppcre :bknr.utils :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml)
(:export #:xml-escape
#:*img-src-scanner*
#:*a-href-scanner*
@@ -37,14 +37,9 @@
#:rss-to-xml
#:merge-feeds
- ;; feed
- #:rss-feed
- #:rss-feed-channel
- #:rss-feed-image
- #:rss-feed-items
-
;; channel
#:rss-channel
+ #:rss-channel-cleanup
#:rss-channel-about
#:rss-channel-title
#:rss-channel-link
@@ -52,6 +47,7 @@
#:rss-channel-image
#:rss-channel-textinput
#:rss-channel-items
+ #:rss-channel-xml
;; image
#:rss-image
@@ -62,13 +58,16 @@
;; item
#:rss-item
- #:rss-item-about
+ #:rss-item-channel
#:rss-item-title
#:rss-item-link
- #:rss-item-desc
- #:rss-item-creator
- #:rss-item-date
- #:rss-item-orig-feed
+ #:rss-item-description
+ #:rss-item-author
+ #:rss-item-category
+ #:rss-item-comments
+ #:rss-item-enclosure
+ #:rss-item-guid
+ #:rss-item-source
;; textinput
#:rss-textinput
@@ -251,6 +250,12 @@
#:navi-button
#:with-bknr-http-response
+ #:upload
+ #:upload-name
+ #:upload-pathname
+ #:upload-size
+ #:upload-content-type
+
#:bknr-url-path
;; templates
Modified: branches/xml-class-rework/bknr/src/rss/rss.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-07-16 17:49:02 UTC (rev 1967)
+++ branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-07-22 11:29:38 UTC (rev 1968)
@@ -1,168 +1,134 @@
(in-package :bknr.rss)
-(defconstant +rdf-ns+ "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
-(defconstant +rss-ns+ "http://purl.org/rss/1.0/")
-(defconstant +dc-ns+ "http://purl.org/dc/elements/1.1/")
-(defconstant +content-ns+ "http://purl.org/rss/1.0/modules/content/")
+;; RSS 2.0 Generation Package
-(defgeneric rss-to-xml (rss-element))
+;; This package aids in the automatic generation of RSS channels.
-(defun xml-escape (xml-string)
- (apply #'concatenate 'string
- (loop for c across xml-string
- collect (case c
- ((#\<) "<")
- ((#\>) ">")
- ((#\&) "&")
- ((#\') "'")
- ((#\") """)
- (t (string c))))))
+;; Class rss-channel models one rss channel. Items are added to a
+;; channel by deriving other persistent classes from the (mixin) class
+;; rss-item. When an object of such a derived class is created, it is
+;; automatically added to its RSS channel. Likewise, it is
+;; automatically deleted from the channel when it is deleted.
+;; The channel that an item is put into is defined by the generic
+;; function rss-item-channel which needs to be specialized for each
+;; item class. The default method of this generic function specifies
+;; nil as channel, which results in the creation of a warning message
+;; when an object of this class is created.
-(defun rss10-content (content)
- `(("description") NIL ,content))
+;; The rss-item-channel method may return the channel either as a
+;; string or as a channel object.
-(defun rss10-tzd (zone)
- (if (> zone 0)
- (format nil "+~2,'0D" zone)
- (format nil "-~2,'0D" (- zone))))
+;; Subclasses of rss-item should provide methods for some of the
+;; generic functions (rss-item-channel rss-item-title rss-item-link
+;; rss-item-description rss-item-author rss-item-category
+;; rss-item-comments rss-item-enclosure rss-item-guid
+;; rss-item-source). These functions are called when the RSS file for
+;; the channel is generated and provide the
-(defun rss10-date (date)
- (multiple-value-bind (second minute hour date month year day daylight zone)
- (decode-universal-time date)
- (declare (ignore day daylight))
- (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~a:00"
- year month date hour minute second
- (rss10-tzd zone))))
+;; One rss-item can only be in one channel.
-(defclass rss-feed ()
- ((channel :initarg :channel :accessor rss-feed-channel :initform nil)
- (image :initform nil :initarg :image :accessor rss-feed-image)
- (items :initarg :items :accessor rss-feed-items :initform nil)))
+;;; Paul Graham, On Lisp, p191
+(defmacro aif (test-form then-form &optional else-form)
+ `(let ((it ,test-form))
+ (if it ,then-form ,else-form)))
-(defmethod rss-feed-items-with-title ((feed rss-feed))
- (let ((feed-title (rss-channel-title (rss-feed-channel feed))))
- (mapcar #'(lambda (item)
- (with-slots (title about link desc creator date) item
- (make-instance 'rss-item
- :title (format nil "~a - ~a"
- feed-title title)
- :about about
- :orig-feed feed
- :link link
- :desc desc
- :creator creator
- :date date)))
- (rss-feed-items feed))))
+(define-persistent-class rss-channel ()
+ ((name :update
+ :index-type string-unique-index
+ :index-reader find-rss-channel)
+ (title :update)
+ (link :update)
+ (description :update)
+ (last-update :update :initform (get-universal-time))
+ (max-item-age :update :initform (* 7 3600))
+ (items :update :initform nil)))
-(defun merge-feeds (title url desc feeds)
- (let ((items (subseq (sort (apply #'append (mapcar #'rss-feed-items-with-title feeds))
- #'> :key #'rss-item-date)
- 0 30)))
- (make-instance 'rss-feed
- :channel (make-instance 'rss-channel :title title
- :link url
- :desc desc
- :items (mapcar #'rss-item-link items))
- :items items)))
+(defun render-mandatory-element (channel element)
+ (with-element (string-downcase (symbol-name element))
+ (text (aif (and (slot-boundp channel element)
+ (slot-value channel element))
+ it
+ (format nil "(channel ~(~A~) not defined)" element)))))
-(defmethod rss-to-xml ((feed rss-feed))
- (make-node :name "rdf:RDF"
- :ns +rss-ns+
- :attrs `(("xmlns:rdf" ,+rdf-ns+)
- ("xmlns:dc" ,+dc-ns+))
- :children (append (list (rss-to-xml (rss-feed-channel feed)))
- (if (rss-feed-image feed)
- (list (rss-to-xml (rss-feed-image feed)))
- nil)
- (mapcar #'rss-to-xml (rss-feed-items feed)))))
+(defmethod rss-channel-xml ((channel rss-channel) stream)
+ (with-xml-output (make-character-stream-sink stream)
+ (with-element "rss"
+ (attribute "version" "2.0")
+ (with-element "channel"
+ (dolist (slot '(title description link))
+ (render-mandatory-element channel slot))
+ (dolist (item (rss-channel-items channel))
+ (rss-item-xml item))))))
-(defclass rss-channel ()
- ((about :initarg :about :accessor rss-channel-about :initform nil)
- (title :initarg :title :accessor rss-channel-title :initform nil)
- (link :initarg :link :accessor rss-channel-link :initform nil)
- (desc :initarg :desc :accessor rss-channel-desc :initform nil)
- (image :initform nil :initarg :image :accessor rss-channel-image)
- (textinput :initform nil :initarg :textinput :accessor rss-channel-textinput)
- (items :initform nil :initarg :items :accessor rss-channel-items)))
+(defmethod rss-channel-items ((channel rss-channel))
+ "Return all non-expired items in channel."
+ (let ((expiry-time (- (get-universal-time) (rss-channel-max-item-age channel))))
+ (remove-if (lambda (item) (< (rss-item-pub-date item) expiry-time)) (slot-value channel 'items))))
-(defmethod rss-to-xml ((chan rss-channel))
- `(("channel")
- (("rdf:about" ,(or (rss-channel-about chan) "nothing")))
- ,@(remove nil
- `((("title") NIL ,(rss-channel-title chan))
- (("link" ) NIL ,(rss-channel-link chan))
- ,(when (rss-channel-desc chan)
- `(("description") NIL ,(rss-channel-desc chan)))
- ,(when (rss-channel-image chan)
- `(("image")
- (("rdf:resource" ,(rss-image-url (rss-channel-image chan))))))
- ,(when (rss-channel-items chan)
- `(("items")
- NIL
- ("rdf:Seq" NIL
- ,@(mapcar #'(lambda (item)
- `("rdf:li" (("rdf:resource"
- ,(if (typep item 'rss-item)
- (rss-item-link item)
- item)))))
- (rss-channel-items chan)))))
- ,(when (rss-channel-textinput chan)
- `(("textinput")
- (("rdf:resource" . ,(rss-textinput-link
- (rss-channel-textinput chan))))))))))
+(deftransaction rss-channel-cleanup (channel)
+ "Remove expired items from the items list. Can be used to reduce
+the memory footprint of very high volume channels."
+ (setf (slot-value channel 'items) (rss-channel-items channel)))
-(defclass rss-image ()
- ((about :initarg :about :accessor rss-image-about :initform nil)
- (title :initarg :title :accessor rss-image-title :initform nil)
- (url :initarg :url :accessor rss-image-url :initform nil)
- (link :initarg :link :accessor rss-image-link :initform nil)))
+;; Internal helper functions to find a channel
-(defmethod rss-to-xml ((image rss-image))
- `(("image")
- (("rdf:about" ,(or (rss-image-about image) "nothing")))
- (("title") NIL ,(rss-image-title image))
- (("link" ) NIL ,(rss-image-link image))
- (("url" ) NIL ,(rss-image-url image))))
+(defmethod remove-item ((channel rss-channel) (item rss-item))
+ "Remove item from channel. May only be called within transaction context."
+ (setf (slot-value channel 'items) (remove item (rss-channel-items channel))))
-(defclass rss-item ()
- ((about :initarg :about :accessor rss-item-about :initform nil)
- (title :initarg :title :accessor rss-item-title)
- (link :initarg :link :accessor rss-item-link)
- (desc :initform nil :initarg :desc :accessor rss-item-desc)
- (creator :initarg :creator :accessor rss-item-creator :initform nil)
- (date :initarg :date :accessor rss-item-date :initform 0)
- (orig-feed :initarg :orig-feed :accessor rss-item-orig-feed :initform nil)))
+(defmethod remove-item ((channel string) (item rss-item))
+ (aif (find-rss-channel channel)
+ (remove-item it item)))
-(defmethod rss-to-xml ((item rss-item))
- `(("item")
- (("rdf:about" ,(or (rss-item-about item) "nothing")))
- ,@(remove
- nil
- `((("title") NIL ,(rss-item-title item))
- (("link" ) NIL ,(rss-item-link item))
- ,(when (rss-item-desc item)
- (rss10-content (rss-item-desc item)))
- ,(when (rss-item-creator item)
- `("dc:creator"
- NIL
- ,(rss-item-creator item)))
- ,(when (rss-item-date item)
- `("dc:date"
- NIL
- ,(rss10-date (rss-item-date item))))))))
+(defmethod remove-item ((channel (eql nil)) (item rss-item))
+ (warn "no RSS channel defined for item ~A" item))
-(defclass rss-textinput ()
- ((about :initarg :about :accessor rss-textinput-about :initform nil)
- (title :initarg :title :accessor rss-textinput-title)
- (desc :initarg :desc :accessor rss-textinput-desc)
- (link :initarg :link :accessor rss-textinput-link)
- (name :initarg :name :accessor rss-textinput-name)))
+(defmethod add-item ((channel rss-channel) (item rss-item))
+ "Add item to channel. May only be called within transaction context."
+ (setf (slot-value channel 'items) (cons item (rss-channel-items channel))))
-(defmethod rss-to-xml ((textinput rss-textinput))
- `(("textinput")
- (("rdf:about" ,(or (rss-textinput-about textinput) "nothing")))
- (("title") NIL ,(rss-textinput-title textinput))
- (("link" ) NIL ,(rss-textinput-link textinput))
- (("name" ) NIL ,(rss-textinput-name textinput))
- (("description") NIL ,(rss-textinput-desc textinput))))
+(defmethod add-item ((channel string) (item rss-item))
+ (aif (find-rss-channel channel)
+ (add-item it item)
+ (warn "can't find RSS channel ~A to add newly created item ~A to" channel item)))
+
+(defmethod add-item ((channel (eql nil)) (item rss-item))
+ (warn "no RSS channel defined for item ~A" item))
+
+;; Mixin for items
+
+(define-persistent-class rss-item ()
+ ((pub-date :read)))
+
+(defmethod initialize-persistent-instance :after ((rss-item rss-item))
+ (setf (slot-value rss-item 'pub-date) (get-universal-time))
+ (add-item (rss-item-channel rss-item) rss-item))
+
+(defmethod destroy-object :before ((rss-item rss-item))
+ (remove-item (rss-item-channel rss-item) rss-item))
+
+(defmethod rss-item-channel ((rss-item rss-item)))
+(defmethod rss-item-title ((rss-item rss-item)))
+(defmethod rss-item-link ((rss-item rss-item)))
+(defmethod rss-item-description ((rss-item rss-item)))
+(defmethod rss-item-author ((rss-item rss-item)))
+(defmethod rss-item-category ((rss-item rss-item)))
+(defmethod rss-item-comments ((rss-item rss-item)))
+(defmethod rss-item-enclosure ((rss-item rss-item)))
+(defmethod rss-item-guid ((rss-item rss-item)))
+(defmethod rss-item-source ((rss-item rss-item)))
+
+(defun item-slot-element (item slot-name)
+ (let ((accessor (kmrcl:concat-symbol 'rss-item- slot-name)))
+ (aif (funcall accessor item)
+ (with-element (string-downcase (symbol-name slot-name))
+ (text it)))))
+
+(defmethod rss-item-xml ((item rss-item))
+ (with-element "item"
+ (dolist (slot '(title link description author category comments enclosure guid source))
+ (item-slot-element item slot))
+ (with-element "pubDate"
+ (text (format-date-time (rss-item-pub-date item) :mail-style t)))))
+
Added: branches/xml-class-rework/bknr/src/rss/test.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/rss/test.lisp 2006-07-16 17:49:02 UTC (rev 1967)
+++ branches/xml-class-rework/bknr/src/rss/test.lisp 2006-07-22 11:29:38 UTC (rev 1968)
@@ -0,0 +1,15 @@
+(make-package :bknr.rss.test)
+(in-package :bknr.rss.test)
+(use-package :bknr.rss)
+(use-package :bknr.datastore)
+
+(define-persistent-class test-item (rss-item)
+ ())
+
+(defmethod rss-item-channel ((item test-item))
+ "blub")
+
+(defmethod rss-item-author ((item test-item))
+ "Hans Hübner")
+
+(open-store "/tmp/datastore/")
\ No newline at end of file
Modified: branches/xml-class-rework/bknr/src/web/handlers.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-07-16 17:49:02 UTC (rev 1967)
+++ branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-07-22 11:29:38 UTC (rev 1968)
@@ -237,7 +237,7 @@
(error e))))
(handle handler req)))
(handler-case
- (mapcar #'delete-file (mapcar #'cdr (getf (request-reply-plist req) 'uploaded-files)))
+ (mapcar #'delete-file (mapcar #'cdr (request-uploaded-files req)))
(error (e)
(warn "error ~A ignored while deleting uploaded files" e)))))
Modified: branches/xml-class-rework/bknr/src/web/web-utils.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/web/web-utils.lisp 2006-07-16 17:49:02 UTC (rev 1967)
+++ branches/xml-class-rework/bknr/src/web/web-utils.lisp 2006-07-22 11:29:38 UTC (rev 1968)
@@ -2,6 +2,8 @@
(enable-interpol-syntax)
+(defstruct upload name pathname content-type)
+
(defgeneric object-url (obj))
(defgeneric edit-object-url (obj))
(defgeneric html-link (obj))
@@ -31,7 +33,6 @@
(loop
(multiple-value-bind (kind part-name file-name content-type)
(parse-multipart-header (get-multipart-header request))
- (declare (ignore content-type))
(case kind
(:eof (return))
(:data (push (cons part-name (get-all-multipart-data request)) parameters))
@@ -53,7 +54,8 @@
:if-exists :error
:element-type '(unsigned-byte 8))
(write-sequence contents temporary-file))
- (push (cons part-name uploaded-file-name) uploaded-files))))))
+ (push (make-upload :name part-name :pathname uploaded-file-name
+ :content-type content-type) uploaded-files))))))
(t
(get-all-multipart-data request :limit *upload-file-size-limit*)))))
(when file-size-limit-reached
@@ -91,10 +93,15 @@
(parse-request-body request :uploads t)
(setf (getf (request-reply-plist request) 'body-parsed) t)))
-(defun request-uploaded-files (request)
- "Return a list of conses (NAME . PATHNAME) which contains files uploaded by the user"
+(defun request-uploaded-files (request &key all-info)
+ "Return a list of conses (NAME . PATHNAME) which contains files uploaded by the user.
+If :all-info is non-nil, the full upload file information is returned as a list"
(get-parameters-from-body request)
- (getf (request-reply-plist request) 'uploaded-files))
+ (if all-info
+ (getf (request-reply-plist request) 'uploaded-files)
+ (mapcar (lambda (upload) (cons (upload-name upload)
+ (upload-pathname upload)))
+ (getf (request-reply-plist request) 'uploaded-files))))
(defun request-uploaded-file (request parameter-name)
(cdr (find parameter-name (request-uploaded-files request) :test #'equal :key #'car)))
More information about the Bknr-cvs
mailing list