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 - ((#<) "&lt;") - ((#>) "&gt;") - ((#&) "&amp;") - ((#') "&apos;") - ((#") "&quot;") - (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)))