Author: hhubner Date: Sun Feb 17 14:25:56 2008 New Revision: 2522
Removed: branches/trunk-reorg/bknr/web/src/rss/parse-atom.lisp branches/trunk-reorg/bknr/web/src/rss/parse-rss091.lisp branches/trunk-reorg/bknr/web/src/rss/parse-rss10.lisp branches/trunk-reorg/bknr/web/src/rss/parse-rss20.lisp branches/trunk-reorg/bknr/web/src/rss/parse-xml.lisp branches/trunk-reorg/bknr/web/src/rss/test.lisp Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp branches/trunk-reorg/bknr/web/src/images/image.lisp branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/rss/rss.lisp branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/menu.lisp branches/trunk-reorg/bknr/web/src/web/site.lisp branches/trunk-reorg/bknr/web/src/web/tags.lisp branches/trunk-reorg/bknr/web/src/web/template-handler.lisp branches/trunk-reorg/bknr/web/src/web/web-macros.lisp Log: Docstrings.
Cleaning up: The old RSS parsing code is now gone, as it was not used and did not work any more.
HANDLER-MATCHES renamed to HANDLER-MATCHES-P
Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd ============================================================================== --- branches/trunk-reorg/bknr/web/src/bknr-web.asd (original) +++ branches/trunk-reorg/bknr/web/src/bknr-web.asd Sun Feb 17 14:25:56 2008 @@ -49,16 +49,7 @@ :depends-on ("hyperspec"))) :depends-on ("packages"))
- (:module "rss" :components ((:file "rss") - (:file "parse-xml") - (:file "parse-rss10" - :depends-on ("parse-xml" "rss")) - (:file "parse-rss091" - :depends-on ("parse-xml" "rss")) - (:file "parse-atom" - :depends-on ("parse-xml" "rss")) - (:file "parse-rss20" - :depends-on ("parse-xml" "rss"))) + (:module "rss" :components ((:file "rss")) :depends-on ("packages"))
(:module "web" :components ((:file "site")
Modified: branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp Sun Feb 17 14:25:56 2008 @@ -10,12 +10,13 @@ (setf (header-out :cache-control) (format nil "max-age=~A" max-age))) (unless (zerop date) (setf (header-out :last-modified) (rfc-1123-date date))) - (with-http-body () + (let ((stream (send-headers))) + (setf (flex:flexi-stream-element-type stream) 'flex:octet) (setf (save-alpha-p :image image) t) (if (member image-format '(:jpg :jpeg)) - (write-image-to-stream *html-stream* image-format :image image :quality quality) - (write-image-to-stream *html-stream* image-format :image image)) - (finish-output *html-stream*)))) + (write-image-to-stream stream image-format :image image :quality quality) + (write-image-to-stream stream image-format :image image)) + (finish-output stream))))
(defmethod store-image-xml-info ((image store-image)) (cxml:with-element "image" @@ -52,9 +53,6 @@ (defmethod object-list-handler-title ((handler image-page-handler) object) "bknr images")
-(defmethod object-list-handler-rss-link ((handler image-page-handler) object) - "/image-rss") - (defmethod object-list-handler-get-objects ((handler image-page-handler) object) (all-store-images))
@@ -65,7 +63,6 @@ (defmethod handle-object ((handler image-page-handler) images) (let ((results (make-keyword-results (object-list-handler-get-objects handler images)))) (with-bknr-page (:title (object-list-handler-title handler images)) - (cmslink (object-list-handler-rss-link handler images) "rss") (image-page results))))
(defclass upload-image-handler (form-handler) @@ -114,10 +111,6 @@ (defmethod object-list-handler-title ((handler image-keyword-handler) keyword) (format nil "bknr keyword images: ~a" keyword))
-(defmethod object-list-handler-rss-link ((handler image-keyword-handler) keyword) - (format nil "/keyword-rss/~A" - (string-downcase (symbol-name keyword)))) - (defclass image-union-handler (image-page-handler keywords-handler) ())
@@ -127,9 +120,6 @@ (defmethod object-list-handler-title ((handler image-union-handler) keywords) (format nil "bknr union images: ~a" keywords))
-(defmethod object-list-handler-rss-link ((handler image-union-handler) keywords) - (format nil "/union-rss/~A" (parse-url))) - (defclass image-intersection-handler (image-page-handler keywords-handler) ())
@@ -139,43 +129,6 @@ (defmethod object-list-handler-title ((handler image-intersection-handler) keywords) (format nil "bknr intersection images: ~a" keywords))
-(defmethod object-list-handler-rss-link ((handler image-intersection-handler) keywords) - (format nil "/intersection-rss/~A" (parse-url))) - -;;; rss image feeds -#| -(defclass rss-image-handler (object-rss-handler image-page-handler) - ()) - -(defmethod create-object-rss-feed ((handler rss-image-handler) object) - (let* ((url (website-url (page-handler-site handler))) - (image-items (mapcar #'(lambda (image) - (store-image-to-rss-item image :url url)) - (subseq (sort (object-list-handler-get-objects handler object) - #'> :key #'blob-timestamp) - 0 20)))) - (if image-items - (make-instance 'rss-feed - :channel (make-instance - 'rss-channel - :about (render-uri url nil) - :title (object-list-handler-title handler object) - :link (render-uri url nil) - :items (mapcar #'rss-item-link image-items)) - :items image-items) - (make-instance 'rss-feed :channel (make-instance 'rss-channel - :about "no such keyword" - :title "no such keyword"))))) - -(defclass rss-image-keyword-handler (rss-image-handler image-keyword-handler) - ()) - -(defclass rss-image-union-handler (rss-image-handler image-union-handler) - ()) - -(defclass rss-image-intersection-handler (rss-image-handler image-intersection-handler) - ()) -|#
(defclass xml-image-browser-handler (image-handler xml-object-handler) ()) @@ -203,12 +156,6 @@ ("/image-keyword" image-keyword-handler) ("/image-union" image-union-handler) ("/image-intersection" image-intersection-handler) - #| - ("/rss-image" rss-image-handler) - ("/rss-image-keyword" rss-image-keyword-handler) - ("/rss-image-union" rss-image-union-handler) - ("/rss-image-intersection" rss-image-intersection-handler) - |# ("/image" imageproc-handler) ("/image-import" image-import-handler) ("/session-image" session-image-handler)
Modified: branches/trunk-reorg/bknr/web/src/images/image.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image.lisp Sun Feb 17 14:25:56 2008 @@ -103,26 +103,6 @@ (store-image-with-name image-id))) (keyword (store-image-with-name (string-downcase (symbol-name image-id))))))
-(defmethod store-image-to-rss-item ((image store-image) &key (url (parse-uri ""))) - (let ((image-url (render-uri (merge-uris (parse-uri (format nil "/image/~a" - (store-object-id image))) - url) nil)) - (browse-url (render-uri (merge-uris (parse-uri (format nil "/browse-image/~A" - (store-object-id image))) - url) nil)) ) - (make-instance 'rss-item - :about browse-url - :title (store-image-name image) - :link browse-url - :desc (with-output-to-string (s) - (html-stream s ((:a :href image-url) - ((:img :src - (concatenate 'string - image-url - "/thumbnail,,320,200") - :align "left"))))) - :date (blob-timestamp image)))) - ;;; import (defun import-image (pathname &key name user keywords directory (keywords-from-dir t) (class-name 'store-image) initargs) "Create blob from given file"
Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp Sun Feb 17 14:25:56 2008 @@ -34,9 +34,7 @@ (when (and (true-color-p working-image) (not (true-color-p input-image))) (true-color-to-palette :dither t :image working-image :colors-wanted 256)) - (let ((stream (send-headers))) - (setf (flex:flexi-stream-element-type stream) 'flex:octet) - (write-image-to-stream stream (image-type-keyword image) :image working-image)) + (emit-image-to-browser working-image (image-type-keyword image)) (unless (eq working-image input-image) (destroy-image working-image)))))
Modified: branches/trunk-reorg/bknr/web/src/packages.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/packages.lisp (original) +++ branches/trunk-reorg/bknr/web/src/packages.lisp Sun Feb 17 14:25:56 2008 @@ -20,17 +20,8 @@
(defpackage :bknr.rss (:use :cl :cl-user :cl-ppcre :bknr.utils :bknr.xml :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) - (:export #:xml-escape - #:*img-src-scanner* - #:*a-href-scanner* - #:*link-href-scanner* - #:replace-relative-links - #:make-absolute-url - - #:rss-to-xml - #:merge-feeds + (:export ;; channel
- ;; channel #:rss-channel #:find-rss-channel #:make-rss-channel @@ -44,13 +35,6 @@ #:rss-channel-items #:rss-channel-xml
- ;; image - #:rss-image - #:rss-image-about - #:rss-image-title - #:rss-image-url - #:rss-image-link - ;; item #:rss-item #:rss-item-channel @@ -65,22 +49,7 @@ #:rss-item-enclosure #:rss-item-guid #:rss-item-source - #:rss-item-encoded-content - - ;; textinput - #:rss-textinput - #:rss-textinput-about - #:rss-textinput-title - #:rss-textinput-desc - #:rss-textinput-link - #:rss-textinput-name - - #:parse-rss091-feed - #:parse-rss10-feed - #:parse-rss20-feed - #:parse-atom-feed - - #:*base-url*)) + #:rss-item-encoded-content))
(defpackage :bknr.events (:use :cl @@ -292,13 +261,12 @@ #:website-session-info #:website-base-href #:website-make-path - #:website-rss-feed-url #:host #:publish-site #:publish-handler #:unpublish
- #:handler-matches + #:handler-matches-p #:handle-object #:handle-object-form #:handle-form @@ -357,7 +325,6 @@ #:object-list-handler #:object-list-handler-get-objects #:object-list-handler-title - #:object-list-handler-rss-link #:object-list-handler-show-object-xml #:object-date-list-handler #:object-date-list-handler-grouped-objects
Modified: branches/trunk-reorg/bknr/web/src/rss/rss.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/rss.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/rss.lisp Sun Feb 17 14:25:56 2008 @@ -4,33 +4,7 @@
;; This package aids in the automatic generation of RSS channels.
-;; 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. - -;; The rss-item-channel method may return the channel either as a -;; string or as a channel object. - -;; 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 - -;; One rss-item can only be in one channel. - -;; The channel object has more required elements than the standard -;; specifies in order to make the generated feed documents more widely -;; accepted. +;; See the documentation to class RSS-CHANNEL for an overview.
;;; Paul Graham, On Lisp, p191 (defmacro aif (test-form then-form &optional else-form) @@ -48,17 +22,46 @@ (description :update) (last-update :update :initform (get-universal-time)) (max-item-age :update :initform (* 4 7 3600)) - (items :update :initform nil))) + (items :update :initform nil)) + (:documentation "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. + +The RSS-ITEM-CHANNEL method may return the channel either as a string +or as a channel object. + +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 content in the RSS items. + +One RSS-ITEM can only be in one channel, which is a restriction that +may eventually be removed. + +The channel object has more required elements than specified by the +standard in order to make the generated feed documents more widely +accepted."))
(defmethod prepare-for-snapshot ((channel rss-channel)) + "When snapshotting, remove items from CHANNEL that are destroyed." (setf (rss-channel-items channel) (remove-if #'object-destroyed-p (rss-channel-items channel))))
;; Mixin for items
(define-persistent-class rss-item () - ()) - -(defgeneric rss-item-pub-date (item)) + () + (:documentation "Mixin class for RSS items. See documentation for +class RSS-CHANNEL for an overview."))
(defun make-rss-channel (name title description link &rest args) (apply #'make-object 'rss-channel :name name :title title :description description :link link args)) @@ -85,42 +88,41 @@ (rss-channel-items channel))) (rss-item-xml item))))))
-(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) (or (object-destroyed-p item) - (< (rss-item-pub-date item) expiry-time))) - (slot-value channel 'items)))) +(defgeneric rss-channel-items (channel) + (:documentation "Return all non-expired items in channel.") + (:method ((channel rss-channel)) + (let ((expiry-time (- (get-universal-time) (rss-channel-max-item-age channel)))) + (remove-if (lambda (item) (or (object-destroyed-p item) + (< (rss-item-pub-date item) expiry-time))) + (slot-value channel 'items)))))
(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)))
-;; Internal helper functions to find a channel - -(defmethod remove-item ((channel rss-channel) item) - "Remove item from channel. May only be called within transaction context." - (setf (slot-value channel 'items) (remove item (rss-channel-items channel)))) - -(defmethod remove-item ((channel string) item) - (aif (find-rss-channel channel) - (remove-item it item))) - -(defmethod remove-item ((channel (eql nil)) item) - (warn "no RSS channel defined for item ~A" item)) - -(defmethod add-item ((channel rss-channel) item) - "Add item to channel. May only be called within transaction context." - (setf (slot-value channel 'items) (cons item (rss-channel-items channel)))) - -(defmethod add-item ((channel string) 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) - (warn "no RSS channel defined for item ~A" item)) +(defgeneric remove-item (channel item) + (:documentation "Remove ITEM from CHANNEL. May only be called +within transaction context.") + (:method ((channel rss-channel) item) + (setf (slot-value channel 'items) (remove item (rss-channel-items channel)))) + (:method ((channel string) item) + (aif (find-rss-channel channel) + (remove-item it item))) + (:method ((channel (eql nil)) item) + (warn "no RSS channel defined for item ~A" item))) + +(defgeneric add-item (channel item) + (:documentation "Add ITEM to CHANNEL. May only be called within +transaction context.") + (:method ((channel rss-channel) item) + (setf (slot-value channel 'items) (cons item (rss-channel-items channel)))) + (:method ((channel string) 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))) + (:method ((channel (eql nil)) item) + (warn "no RSS channel defined for item ~A" item)))
(defmethod initialize-persistent-instance :after ((rss-item rss-item)) (add-item (rss-item-channel rss-item) rss-item)) @@ -129,12 +131,14 @@ (remove-item (rss-item-channel rss-item) rss-item))
(defun item-slot-element (item slot-name) + "Cheapo helper function to map from a pseudo slot name to an accessor." (let ((accessor (find-symbol (format nil "RSS-ITEM-~A" slot-name) (find-package :bknr.rss)))) (aif (funcall accessor item) (with-element (string-downcase (symbol-name slot-name)) (text it)))))
(defun rss-item-xml (item) + "Generate RSS XML for ITEM using CXML's unparse functionality." (with-element "item" (dolist (slot '(title link author category comments enclosure source)) (item-slot-element item slot)) @@ -154,27 +158,41 @@ ;; All items present on an RSS stream can implement the access ;; methods below.
-(defmethod rss-item-published (item) - t) +(defgeneric rss-item-pub-date (item) + (:documentation "The default implementation for the publication date +delivers the current system date/time as publication date.") + (:method (item) + (warn "no rss-item-pub-date defined for class ~A, using current date/time" (class-of item)) + (get-universal-time)))
-(defmethod rss-item-pub-date (item) - "The default implementation for the publication date delivers the -current system date/time as publication date." - (warn "no rss-item-pub-date defined for class ~A, using current date/time" (class-of item)) - (get-universal-time)) - -(defmethod rss-item-channel (item)) -(defmethod rss-item-title (item)) -(defmethod rss-item-link (item)) -(defmethod rss-item-description (item)) -(defmethod rss-item-author (item)) -(defmethod rss-item-category (item)) -(defmethod rss-item-comments (item)) -(defmethod rss-item-enclosure (item)) -(defmethod rss-item-guid (item)) -(defmethod rss-item-source (item)) -(defgeneric rss-item-encoded-content (item) - (:documentation "Return the content for ITEM in encoded (usually HTML) form as string.") +(defgeneric rss-item-published (item) + (:documentation "Return non-nil if the ITEM is published. +Non-published items are not put into generated XML by +RSS-CHANNEL-XML.") (:method (item) - (declare (ignore item)) - nil)) + t)) + +(defmacro define-rss-item-field (field-name + &key + (documentation (format nil "Return the ~(~A~) of the ITEM as a string" field-name)) + mandatory) + `(defgeneric ,(intern (format nil "RSS-ITEM-~A" field-name)) (item) + (:documentation ,(format nil "~A~@[ (optional)~]" + documentation (not mandatory))) + ,@(unless mandatory + '((:method (item) nil))))) + +(define-rss-item-field channel + :documentation "Return the channel that the ITEM is published in." + :mandatory t) +(define-rss-item-field title) +(define-rss-item-field link) +(define-rss-item-field description) +(define-rss-item-field author) +(define-rss-item-field category) +(define-rss-item-field comments) +(define-rss-item-field enclosure) +(define-rss-item-field guid) +(define-rss-item-field source) +(define-rss-item-field encoded-content + :documentation "Return the content for ITEM in encoded (usually HTML) form as string.")
Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Sun Feb 17 14:25:56 2008 @@ -503,13 +503,13 @@
(defgeneric object-date-list-handler-grouped-objects (handler object))
-(defmethod object-date-list-handler-date ((handler object-date-list-handler) - object) - (with-query-params (date) - (get-daytime (if date - (or (parse-integer date :junk-allowed t) - (get-universal-time)) - (get-universal-time))))) +(defgeneric object-date-list-handler-date (handler object) + (:method ((handler object-date-list-handler) object) + (with-query-params (date) + (get-daytime (if date + (or (parse-integer date :junk-allowed t) + (get-universal-time)) + (get-universal-time))))))
(defclass admin-only-handler () ())
Modified: branches/trunk-reorg/bknr/web/src/web/menu.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/menu.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/menu.lisp Sun Feb 17 14:25:56 2008 @@ -44,6 +44,7 @@ (let* ((menu (bknr.impex:parse-xml-file #+cmu (ext:unix-namestring (merge-pathnames config *default-pathname-defaults*)) #+sbcl (sb-int:unix-namestring (merge-pathnames config *default-pathname-defaults*)) + #-(or cmu sbcl) (namestring (probe-file (merge-pathnames config *default-pathname-defaults*))) *menu-def-classes*))) (html ((:div :class container-class)
Modified: branches/trunk-reorg/bknr/web/src/web/site.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/site.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/site.lisp Sun Feb 17 14:25:56 2008 @@ -5,6 +5,6 @@ (defparameter *thumbnail-max-width* 108) (defparameter *thumbnail-max-height* 54)
-;; default billboard to show on home page -(defparameter *default-billboard* "main") +(defparameter *default-billboard* "main" + "default billboard to show on home page")
Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/tags.lisp Sun Feb 17 14:25:56 2008 @@ -61,6 +61,7 @@ (html ((:input :type "checkbox" :name name) (:princ-safe value)))))
(define-bknr-tag date-field (name &key date (show-time t)) + "Generate a date entry widget using HTML <select> elements." (unless date (setf date (get-universal-time))) (multiple-value-bind (sec min hour day month year)
Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp Sun Feb 17 14:25:56 2008 @@ -300,7 +300,7 @@ (defmacro with-error-handlers ((handler) &body body) `(invoke-with-error-handlers (lambda () ,@body) ,handler))
-(defmethod handler-matches ((handler template-handler)) +(defmethod handler-matches-p ((handler template-handler)) (handler-case (find-template-pathname handler (script-name)) (template-not-found (c)
Modified: branches/trunk-reorg/bknr/web/src/web/web-macros.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-macros.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-macros.lisp Sun Feb 17 14:25:56 2008 @@ -80,6 +80,8 @@ :value ,(or variable ""))))
(defmacro html-warn (&rest warning) + "Generate a warning on the console and write the warning into the +currently generated XHTML output as a comment." `(progn (html (:princ-safe (format nil "<!-- ~a -->~%" (format nil ,@warning)))) (warn ,@warning)))