bknr-cvs

bknr-cvs@common-lisp.net

1964 discussions

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/session.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3710 Author: hans URL: http://bknr.net/trac/changeset/3710 Start session outside of lock scope in order to avoid recursive locking. U trunk/thirdparty/hunchentoot/session.lisp Modified: trunk/thirdparty/hunchentoot/session.lisp =================================================================== --- trunk/thirdparty/hunchentoot/session.lisp 2008-07-31 12:00:25 UTC (rev 3709) +++ trunk/thirdparty/hunchentoot/session.lisp 2008-07-31 15:57:09 UTC (rev 3710) @@ -148,16 +148,16 @@ there's no session for the current request." (with-rebinding (symbol) (with-unique-names (place %session) - `(with-lock-held (*session-data-lock*) - (let* ((,%session (or ,session (start-session))) - (,place (assoc ,symbol (session-data ,%session) :test #'eq))) - (cond - (,place - (setf (cdr ,place) ,new-value)) - (t - (push (cons ,symbol ,new-value) - (slot-value ,%session 'session-data)) - ,new-value))))))) + `(let ((,%session (or ,session (start-session)))) + (with-lock-held (*session-data-lock*) + (let* ((,place (assoc ,symbol (session-data ,%session) :test #'eq))) + (cond + (,place + (setf (cdr ,place) ,new-value)) + (t + (push (cons ,symbol ,new-value) + (slot-value ,%session 'session-data)) + ,new-value)))))))) (defun delete-session-value (symbol &optional (session *session*)) "Removes the value associated with SYMBOL from the current session

1 0

[bknr-cvs] ksprotte changed trunk/bknr/web/src/web/web-utils.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3709 Author: ksprotte URL: http://bknr.net/trac/changeset/3709 use (upload-content-type upload) als in method bknr.images:import-image upload U trunk/bknr/web/src/web/web-utils.lisp Modified: trunk/bknr/web/src/web/web-utils.lisp =================================================================== --- trunk/bknr/web/src/web/web-utils.lisp 2008-07-31 09:36:07 UTC (rev 3708) +++ trunk/bknr/web/src/web/web-utils.lisp 2008-07-31 12:00:25 UTC (rev 3709) @@ -46,7 +46,7 @@ (defmethod bknr.images:import-image ((upload upload) &rest args &key &allow-other-keys) (apply #'bknr.images:import-image (upload-pathname upload) :name (pathname-name (upload-original-filename upload)) - :type (make-keyword-from-string (pathname-type (upload-original-filename upload))) args)) + :type (image-type-symbol (upload-content-type upload)) args)) (defun all-request-params () "Return all non-empty request parameters - This includes all parameters encoded in the URL as

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3708 Author: ksprotte URL: http://bknr.net/trac/changeset/3708 poi image shifting works again U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-31 09:02:18 UTC (rev 3707) +++ trunk/projects/bos/m2/poi.lisp 2008-07-31 09:36:07 UTC (rev 3708) @@ -148,12 +148,12 @@ ;;; Exchanges (nth index (poi-sat-images poi)) with ;;; (nth (1+ index) (poi-sat-images poi)). (deftransaction poi-sat-images-exchange-neighbours (poi index) - (check-type index (integer 0 4)) + (check-type index (mod 6)) (multiple-value-bind (images positions) (poi-images poi) (declare (ignore images)) (let ((media-index-a (nth index positions)) - (media-index-b (nth (1+ index) positions))) + (media-index-b (nth (mod (1+ index) 6) positions))) (rotatef (nth media-index-a (poi-media poi)) (nth media-index-b (poi-media poi)))))) Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 09:02:18 UTC (rev 3707) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 09:36:07 UTC (rev 3708) @@ -52,21 +52,14 @@ (defmethod handle-object-form ((handler edit-poi-handler) action (poi poi)) - (with-query-params (language shift shift-by) + (with-query-params (language shift shift-id) (unless language (setq language (request-language))) (when shift - ;; change image order - (setq shift (find-store-object (parse-integer shift))) - (setq shift-by (parse-integer shift-by)) - (let* ((new-images (poi-sat-images poi)) - (old-position (position shift new-images)) - (tmp (nth old-position new-images))) - (assert (and (< -1 old-position (length new-images)) - (< -1 (+ shift-by old-position) (length new-images)))) - (setf (nth old-position new-images) (nth (+ shift-by old-position) new-images)) - (setf (nth (+ shift-by old-position) new-images) tmp) - (with-transaction ("setf poi-sat-images") - (setf (poi-sat-images poi) new-images)))) + (let ((shift (parse-integer shift)) + (shift-id (parse-integer shift-id))) + ;; only if this exchange has not already happened + (when (= shift-id (store-object-id (nth shift (poi-sat-images poi)))) + (poi-sat-images-exchange-neighbours poi shift)))) (with-bos-cms-page (:title "Edit POI") (content-language-chooser) (unless (poi-complete poi language) @@ -110,20 +103,20 @@ ((:table) (:tr (loop for image in (poi-sat-images poi) - for index from 1 by 1 + for index upfrom 0 do (html (:td ((:a :href (format nil "/edit-poi-image/~a?poi=~A" (store-object-id image) (store-object-id poi))) ((:img :border "0" :src (format nil "/image/~a/thumbnail,,55,55" (store-object-id image))))) :br - (if (eql index 1) + (if (zerop index) (html ((:img :src "/images/trans.gif" :width "16"))) - (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=-1" - (store-object-id poi) - (store-object-id image))) + (html ((:a :href (format nil "/edit-poi/~A?shift=~D&shift-id=~D" + (store-object-id poi) (1- index) + (store-object-id (nth (1- index) (poi-sat-images poi))))) ((:img :border "0" :src "/images/pfeil-l.gif"))))) ((:img :src "/images/trans.gif" :width "23")) (unless (eql index (length (poi-sat-images poi))) - (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=1" - (store-object-id poi) + (html ((:a :href (format nil "/edit-poi/~A?shift=~D&shift-id=~D" + (store-object-id poi) index (store-object-id image))) ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) (unless (eql 6 (length (poi-sat-images poi)))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/poi-handlers.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3707 Author: ksprotte URL: http://bknr.net/trac/changeset/3707 refactored web/poi-handlers.lisp U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 08:54:27 UTC (rev 3706) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 09:02:18 UTC (rev 3707) @@ -2,6 +2,7 @@ (enable-interpol-syntax) +;;; make-poi-handler (defclass make-poi-handler (page-handler) ()) @@ -19,6 +20,7 @@ (t (redirect (edit-object-url (make-poi name))))))) +;;; edit-poi-handler (defclass edit-poi-handler (editor-only-handler edit-object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi)) @@ -283,8 +285,7 @@ (html (:h2 "POI has been deleted") "The POI has been deleted"))) -;; edit-poi-image - +;;; edit-poi-image-handler (defclass edit-poi-image-handler (editor-only-handler edit-object-handler) () (:default-initargs :object-class 'poi-image)) @@ -375,6 +376,7 @@ (:h2 "The POI image has been deleted") "You may " (cmslink (edit-object-url poi) "continue editing the POI")))) +;;; poi-javascript-handler (defclass poi-javascript-handler (page-handler) ()) @@ -403,6 +405,7 @@ (:princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (:princ (format nil "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js last-paid-contracts))))))))) +;;; poi-image-handler (defclass poi-image-handler (object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi)) @@ -422,6 +425,7 @@ imageproc-arguments)) (error "image index ~a out of bounds for poi ~a" image-index poi))))) +;;; poi-movie-handler (defclass poi-movie-handler (admin-only-handler object-handler) () (:default-initargs :object-class 'poi-movie)) @@ -439,6 +443,7 @@ :allowFullScreen "true" :width "425" :height "344"))))) +;;; poi-xml-handler (defun write-poi-xml (poi language) "Writes the poi xml format for one specific language. This is used to generate the POI microsite using XSLT (client side)." @@ -492,6 +497,21 @@ (with-media ("movie" "Video") (with-element "url" (text (poi-movie-url movie)))))))))) +(defclass poi-xml-handler (object-handler) + () + (:default-initargs :object-class 'poi :query-function #'find-poi)) + + +(defmethod handle-object ((handler poi-xml-handler) poi) + (let ((timestamp (store-object-last-change poi 1))) + (hunchentoot:handle-if-modified-since timestamp) + (setf (hunchentoot:header-out :last-modified) + (hunchentoot:rfc-1123-date timestamp)) + (with-query-params ((lang "en")) + (with-xml-response (:xsl-stylesheet-name "/static/poi.xsl") + (write-poi-xml poi lang))))) + +;;; poi-kml-handler (defun poi-description-google-earth (poi language &key (image-width 120)) (labels ((website-path (path &rest args) (format nil "http://~a~a" (website-host) @@ -590,8 +610,6 @@ (text " | copyright"))))))))) (error (c) (error "while generating poi-description-google-earth for ~s:~%~a" poi c))))) - - (defun write-poi-kml (poi language) (with-element "Placemark" (with-element "name" (text (or (slot-string poi 'title language nil) @@ -603,20 +621,6 @@ (with-element "coordinates" (text (format nil "~{~,20F,~}0" (poi-center-lon-lat poi))))))) -(defclass poi-xml-handler (object-handler) - () - (:default-initargs :object-class 'poi :query-function #'find-poi)) - - -(defmethod handle-object ((handler poi-xml-handler) poi) - (let ((timestamp (store-object-last-change poi 1))) - (hunchentoot:handle-if-modified-since timestamp) - (setf (hunchentoot:header-out :last-modified) - (hunchentoot:rfc-1123-date timestamp)) - (with-query-params ((lang "en")) - (with-xml-response (:xsl-stylesheet-name "/static/poi.xsl") - (write-poi-xml poi lang))))) - (defclass poi-kml-handler (object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi)) @@ -629,6 +633,7 @@ (with-element "kml" (write-poi-kml poi lang)))))) +;;; poi-kml-all-handler (defclass poi-kml-all-handler (page-handler) ())

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3706 Author: ksprotte URL: http://bknr.net/trac/changeset/3706 added reader poi-sat-images and transaction poi-sat-images-exchange-neighbours for edit-poi handler U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-31 08:21:43 UTC (rev 3705) +++ trunk/projects/bos/m2/packages.lisp 2008-07-31 08:54:27 UTC (rev 3706) @@ -229,6 +229,8 @@ #:poi-center-y #:poi-center-lon-lat #:poi-images + #:poi-sat-images + #:poi-sat-images-exchange-neighbours #:poi-airals #:poi-panoramas #:poi-movies Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-31 08:21:43 UTC (rev 3705) +++ trunk/projects/bos/m2/poi.lisp 2008-07-31 08:54:27 UTC (rev 3706) @@ -117,16 +117,46 @@ (defun poi-center-lon-lat (poi) (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ (poi-center-x poi)) (- +nw-utm-y+ (poi-center-y poi)) +utm-zone+ t)) +;;; POI media are stored in one list - for convenience we provide +;;; accessors by type. POI-IMAGES e.g. returns a list of all +;;; POI-IMAGES in the same order as they appear in the media list. The +;;; second value is a list of corresponding positions in that list. (macrolet ((define-poi-medium-reader (name) (let ((type (find-symbol (subseq (symbol-name name) 0 (1- (length (symbol-name name))))))) (assert type) `(defun ,name (poi) - (remove-if-not (lambda (medium) (typep medium ',type)) (poi-media poi)))))) + ;; this surely could be optimized + (let ((media-of-type (remove-if-not (lambda (medium) (typep medium ',type)) (poi-media poi)))) + (values media-of-type + (mapcar (lambda (medium) (position medium (poi-media poi))) media-of-type))))))) (define-poi-medium-reader poi-images) (define-poi-medium-reader poi-airals) (define-poi-medium-reader poi-panoramas) (define-poi-medium-reader poi-movies)) +(defun poi-sat-images (poi) + "We use the 6 last (oldest) images of POI as images for the + satellite application." + (multiple-value-bind (images positions) + (poi-images poi) + (let* ((length (length images)) + (start (max 0 (- length 6)))) + (values (subseq images start length) + (subseq positions start length))))) + +;;; Provides for the shifting of images in the edit-poi handler. +;;; Exchanges (nth index (poi-sat-images poi)) with +;;; (nth (1+ index) (poi-sat-images poi)). +(deftransaction poi-sat-images-exchange-neighbours (poi index) + (check-type index (integer 0 4)) + (multiple-value-bind (images positions) + (poi-images poi) + (declare (ignore images)) + (let ((media-index-a (nth index positions)) + (media-index-b (nth (1+ index) positions))) + (rotatef (nth media-index-a (poi-media poi)) + (nth media-index-b (poi-media poi)))))) + (defun make-poi-javascript (language) "Erzeugt das POI-Javascript für das Infosystem" (with-output-to-string (*standard-output*) @@ -155,8 +185,8 @@ (escape-nl (slot-string poi 'description language)) (poi-center-x poi) (poi-center-y poi) - (length (poi-images poi))) - (format t "poi.thumbnail = ~D;~%" (length (poi-images poi))) + (length (poi-sat-images poi))) + (format t "poi.thumbnail = ~D;~%" (length (poi-sat-images poi))) (when (poi-airals poi) (format t "poi.luftbild = ~D;~%" (store-object-id (first (poi-airals poi))))) @@ -168,7 +198,7 @@ for javascript-name in '("imageueberschrift" "imageuntertitel" "imagetext") for slot-values = (mapcar (lambda (image) (escape-nl (slot-string image slot-name language))) - (poi-images poi)) + (poi-sat-images poi)) when slot-values do (format t "poi.~A = [ ~{~S~^, ~} ];~%" javascript-name slot-values)) (format t "pois.push(poi);~%")) Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 08:21:43 UTC (rev 3705) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 08:54:27 UTC (rev 3706) @@ -56,15 +56,15 @@ ;; change image order (setq shift (find-store-object (parse-integer shift))) (setq shift-by (parse-integer shift-by)) - (let* ((new-images (poi-images poi)) + (let* ((new-images (poi-sat-images poi)) (old-position (position shift new-images)) (tmp (nth old-position new-images))) (assert (and (< -1 old-position (length new-images)) (< -1 (+ shift-by old-position) (length new-images)))) (setf (nth old-position new-images) (nth (+ shift-by old-position) new-images)) (setf (nth (+ shift-by old-position) new-images) tmp) - (with-transaction ("setf poi-images") - (setf (poi-images poi) new-images)))) + (with-transaction ("setf poi-sat-images") + (setf (poi-sat-images poi) new-images)))) (with-bos-cms-page (:title "Edit POI") (content-language-chooser) (unless (poi-complete poi language) @@ -107,24 +107,24 @@ (:td ((:table) (:tr - (loop for image in (poi-images poi) + (loop for image in (poi-sat-images poi) for index from 1 by 1 do (html (:td ((:a :href (format nil "/edit-poi-image/~a?poi=~A" (store-object-id image) (store-object-id poi))) ((:img :border "0" :src (format nil "/image/~a/thumbnail,,55,55" (store-object-id image))))) - :br - (if (eql index 1) - (html ((:img :src "/images/trans.gif" :width "16"))) - (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=-1" - (store-object-id poi) - (store-object-id image))) - ((:img :border "0" :src "/images/pfeil-l.gif"))))) - ((:img :src "/images/trans.gif" :width "23")) - (unless (eql index (length (poi-images poi))) - (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=1" - (store-object-id poi) - (store-object-id image))) - ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) - (unless (eql 6 (length (poi-images poi))) + :br + (if (eql index 1) + (html ((:img :src "/images/trans.gif" :width "16"))) + (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=-1" + (store-object-id poi) + (store-object-id image))) + ((:img :border "0" :src "/images/pfeil-l.gif"))))) + ((:img :src "/images/trans.gif" :width "23")) + (unless (eql index (length (poi-sat-images poi))) + (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=1" + (store-object-id poi) + (store-object-id image))) + ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) + (unless (eql 6 (length (poi-sat-images poi))) (html :br (cmslink (format nil "edit-poi-image/?poi=~A" (store-object-id poi)) "[new]"))))) @@ -342,8 +342,8 @@ (:td ((:img :src (format nil "/image/~A" (store-object-id poi-image)))))) (:tr (:td "upload new image") (:td ((:input :type "file" :name "image-file")) - :br - (submit-button "upload" "upload"))) + :br + (submit-button "upload" "upload"))) (:tr (:td "title") (:td (text-field "title" :value (slot-string poi-image 'title language)))) @@ -416,9 +416,9 @@ (declare (ignore poi-name)) (let ((image-index (1- (parse-integer image-index-string)))) (if (and (not (minusp image-index)) - (< image-index (length (poi-images poi)))) + (< image-index (length (poi-sat-images poi)))) (redirect (format nil "/image/~D~@[~{/~a~}~]" - (store-object-id (nth image-index (poi-images poi))) + (store-object-id (nth image-index (poi-sat-images poi))) imageproc-arguments)) (error "image index ~a out of bounds for poi ~a" image-index poi))))) @@ -436,8 +436,8 @@ ((:param :name "movie" :value (poi-movie-url poi-movie))) ((:param :name "allowFullScreen" :value "true")) ((:embed :src (poi-movie-url poi-movie) :type "application/x-shockwave-flash" - :allowFullScreen "true" - :width "425" :height "344"))))) + :allowFullScreen "true" + :width "425" :height "344"))))) (defun write-poi-xml (poi language) "Writes the poi xml format for one specific language. This is used @@ -467,7 +467,7 @@ (subtitle poi-subtitle) (description poi-description) (airals poi-airals) - (images poi-images) + (images poi-sat-images) (panoramas poi-panoramas) (movies poi-movies)) poi (with-element "poi" @@ -564,7 +564,7 @@ (with-element "br"))) (with-element "table" (with-element "tbody" - (let ((images (poi-images poi))) + (let ((images (poi-sat-images poi))) (images-2trs (subseq images 0 (min 3 (length images)))) (when (> (length images) 3) (images-2trs (subseq images 3 (min 6 (length images))))))))))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/web-utils.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3705 Author: ksprotte URL: http://bknr.net/trac/changeset/3705 fixed content-language-chooser to keep other GET parameters U trunk/projects/bos/web/web-utils.lisp Modified: trunk/projects/bos/web/web-utils.lisp =================================================================== --- trunk/projects/bos/web/web-utils.lisp 2008-07-31 08:02:37 UTC (rev 3704) +++ trunk/projects/bos/web/web-utils.lisp 2008-07-31 08:21:43 UTC (rev 3705) @@ -37,15 +37,23 @@ (defun language-name (language-short-name) (cadr (assoc language-short-name (website-languages) :test #'equal))) -(defun content-language-chooser () - "Note that in the current implementation other GET parameters than - language will be lost (not appended to script-name)." +(defun content-language-chooser () (html ((:p :class "languages") "Content languages: " (loop for (language-symbol language-name) in (website-languages) - do (labels ((show-language-link () - (html (cmslink (format nil "~A?language=~A" (hunchentoot:script-name*) language-symbol) + do (labels ((show-language-link () + (html (cmslink (with-output-to-string (out) + (write-string (hunchentoot:script-name*) out) + ;; write language param and remaining get params + (write-string "?language=" out) + (write-string language-symbol out) + (dolist (get-param (remove "language" (hunchentoot:get-parameters*) :key #'first :test #'equal)) + (destructuring-bind (key . value) get-param + (write-string "&" out) + (write-string key out) + (write-string "=" out) + (write-string value out)))) (:princ-safe language-name))))) (if (equal (request-language) language-symbol) (html "[" (show-language-link) "]")

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/poi-handlers.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3704 Author: ksprotte URL: http://bknr.net/trac/changeset/3704 replaced fixed host createrainforest.org by (website-host) for poi xml U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 07:44:11 UTC (rev 3703) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 08:02:37 UTC (rev 3704) @@ -457,8 +457,8 @@ (attribute "title" (slot-string image 'title language)) (attribute "subtitle" (slot-string image 'subtitle language)) (with-element "description" (text (slot-string image 'description language)))) - (with-element "url" (text (format nil "http://createrainforest.org/image/~D" - (store-object-id image)))) + (with-element "url" (text (format nil "http://~A/image/~D" + (website-host) (store-object-id image)))) (with-element "width" (text (princ-to-string (store-image-width image)))) (with-element "height" (text (princ-to-string (store-image-height image))))))) (with-accessors ((id store-object-id)

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/handlers.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3703 Author: hans URL: http://bknr.net/trac/changeset/3703 STREAM->OUTPUT-STREAM to avoid package lock errors U trunk/projects/quickhoney/src/handlers.lisp Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-07-31 06:18:02 UTC (rev 3702) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-07-31 07:44:11 UTC (rev 3703) @@ -433,18 +433,18 @@ (defvar *json-output*) (defclass json-output-stream () - ((stream :reader stream - :initarg :stream) + ((output-stream :reader output-stream + :initarg :output-stream) (stack :accessor stack :initform nil))) (defun next-aggregate-element () (if (car (stack *json-output*)) - (princ #\, (stream *json-output*)) + (princ #\, (output-stream *json-output*)) (setf (car (stack *json-output*)) t))) (defmacro with-json-output ((stream) &body body) - `(let ((*json-output* (make-instance 'json-output-stream :stream ,stream))) + `(let ((*json-output* (make-instance 'json-output-stream :output-stream ,stream))) ,@body)) (defmacro with-json-output-to-string (() &body body) @@ -456,12 +456,12 @@ `(progn (when (stack *json-output*) (next-aggregate-element)) - (princ ,begin-char (stream *json-output*)) + (princ ,begin-char (output-stream *json-output*)) (push nil (stack *json-output*)) (prog1 (progn ,@body) (pop (stack *json-output*)) - (princ ,end-char (stream *json-output*))))) + (princ ,end-char (output-stream *json-output*))))) (defmacro with-json-array (() &body body) `(with-json-aggregate (#\[ #\]) @@ -473,13 +473,13 @@ (defun encode-array-element (object) (next-aggregate-element) - (json:encode-json object (stream *json-output*))) + (json:encode-json object (output-stream *json-output*))) (defun encode-object-element (key value) (next-aggregate-element) - (json:encode-json key (stream *json-output*)) - (princ #\: (stream *json-output*)) - (json:encode-json value (stream *json-output*))) + (json:encode-json key (output-stream *json-output*)) + (princ #\: (output-stream *json-output*)) + (json:encode-json value (output-stream *json-output*))) (defmethod handle-object ((handler news-json-handler) (channel rss-channel)) (with-http-response (:content-type "application/json")

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3702 Author: hans URL: http://bknr.net/trac/changeset/3702 Add streaming JSON encoding infrastructure and handler for news. U trunk/bknr/web/src/rss/rss.lisp U trunk/projects/quickhoney/src/handlers.lisp Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-07-30 21:06:43 UTC (rev 3701) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-31 06:18:02 UTC (rev 3702) @@ -117,6 +117,12 @@ (when days-string (parse-integer days-string))))) +(defun month-from-query-parameter () + (when (boundp 'hunchentoot:*request*) + (let ((month-string (bknr.web:query-param "month"))) + (when month-string + (mapcar #'parse-integer (cl-ppcre:split "([-/]|(?<=..))" month-string :limit 2)))))) + (defun rss-channel-archive (channel) "Return the channel archive consisting of lists of lists ((MONTH YEAR) ITEM...)" (group-on (rss-channel-items channel) @@ -129,18 +135,21 @@ (defgeneric rss-channel-items (channel &key) (:documentation "Return all non-expired items in channel.") - (:method ((channel rss-channel) &key days month) - (cond - (month - (cdr (find month (rss-channel-archive channel) :test #'equal))) - (t - (let* ((days (or days - (days-from-query-parameter) - (rss-channel-max-item-age channel))) - (expiry-time (- (get-universal-time) (* 60 60 25 days)))) - (remove-if (lambda (item) (or (object-destroyed-p item) - (< (rss-item-pub-date item) expiry-time))) - (slot-value channel 'items))))))) + (:method ((channel rss-channel) &key days month count) + (unless month + (setf month (month-from-query-parameter))) + (unless days + (setf days (or (days-from-query-parameter) + (rss-channel-max-item-age channel)))) + (let ((items (if month + (cdr (find month (rss-channel-archive channel) :test #'equal)) + (let ((expiry-time (- (get-universal-time) (* 60 60 24 days)))) + (remove-if (lambda (item) (or (object-destroyed-p item) + (< (rss-item-pub-date item) expiry-time))) + (slot-value channel 'items)))))) + (if count + (subseq items 0 (min count (length items))) + items)))) (defgeneric rss-channel-archived-months (channel) (:documentation "Return a list of lists (MONTH YEAR) for which the Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-07-30 21:06:43 UTC (rev 3701) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-07-31 06:18:02 UTC (rev 3702) @@ -432,49 +432,61 @@ (defvar *json-output*) +(defclass json-output-stream () + ((stream :reader stream + :initarg :stream) + (stack :accessor stack + :initform nil))) + +(defun next-aggregate-element () + (if (car (stack *json-output*)) + (princ #\, (stream *json-output*)) + (setf (car (stack *json-output*)) t))) + (defmacro with-json-output ((stream) &body body) - `(let ((*json-output* ,stream)) + `(let ((*json-output* (make-instance 'json-output-stream :stream ,stream))) ,@body)) (defmacro with-json-output-to-string (() &body body) - `(with-output-to-string (*json-output*) - ,@body)) + `(with-output-to-string (s) + (with-json-output (s) + ,@body))) +(defmacro with-json-aggregate ((begin-char end-char) &body body) + `(progn + (when (stack *json-output*) + (next-aggregate-element)) + (princ ,begin-char (stream *json-output*)) + (push nil (stack *json-output*)) + (prog1 + (progn ,@body) + (pop (stack *json-output*)) + (princ ,end-char (stream *json-output*))))) + (defmacro with-json-array (() &body body) - (with-gensyms (need-comma) - `(let (,need-comma) - (princ #\[ *json-output*) - (prog1 - (labels ((encode-array-element (value) - (if ,need-comma - (princ #\, *json-output*) - (setf ,need-comma t)) - (json:encode-json value *json-output*))) - ,@body) - (princ #\] *json-output*))))) + `(with-json-aggregate (#\[ #\]) + ,@body)) (defmacro with-json-object (() &body body) - (with-gensyms (need-comma) - `(let (,need-comma) - (princ #\{ *json-output*) - (prog1 - (labels ((encode-object-member (key value) - (when value - (if ,need-comma - (princ #\, *json-output*) - (setf ,need-comma t)) - (json:encode-json key *json-output*) - (princ #\, *json-output*) - (json:encode-json value *json-output*)))) - ,@body) - (princ #\} *json-output*))))) + `(with-json-aggregate (#\{ #\}) + ,@body)) +(defun encode-array-element (object) + (next-aggregate-element) + (json:encode-json object (stream *json-output*))) + +(defun encode-object-element (key value) + (next-aggregate-element) + (json:encode-json key (stream *json-output*)) + (princ #\: (stream *json-output*)) + (json:encode-json value (stream *json-output*))) + (defmethod handle-object ((handler news-json-handler) (channel rss-channel)) (with-http-response (:content-type "application/json") (with-json-output-to-string () (with-json-array () (dolist (item (rss-channel-items channel)) (with-json-object () - (encode-object-member "pubDate" (format-date-time (rss-item-pub-date item) :vms-style t)) - (encode-object-member "title" (rss-item-title item)) - (encode-object-member "description" (rss-item-description item)))))))) \ No newline at end of file + (encode-object-element "pubDate" (format-date-time (rss-item-pub-date item) :vms-style t)) + (encode-object-element "title" (rss-item-title item)) + (encode-object-element "description" (rss-item-description item))))))))

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3701 Author: hans URL: http://bknr.net/trac/changeset/3701 Work on JSON handler for news. U trunk/projects/quickhoney/src/handlers.lisp U trunk/projects/quickhoney/src/image.lisp A trunk/projects/quickhoney/src/news.lisp U trunk/projects/quickhoney/src/quickhoney.asd U trunk/projects/quickhoney/src/webserver.lisp Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-07-30 15:30:19 UTC (rev 3700) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-07-30 21:06:43 UTC (rev 3701) @@ -313,7 +313,8 @@ ((:script :type "text/javascript" :language "JavaScript") "function done() { window.opener.do_query(); window.close(); }")) (:body - (:p "Image " (:princ-safe (store-image-name image)) " with " (:princ-safe (hash-table-count color-table)) " colors uploaded") + (:p "Image " (:princ-safe (store-image-name image)) " with " + (:princ-safe (hash-table-count color-table)) " colors uploaded") (:p ((:img :src (format nil "/image/~D" (store-object-id image)) :width (round (* ratio width)) :height (round (* ratio height))))) (:p ((:a :href "javascript:done()") "ok"))))))))))) @@ -424,3 +425,56 @@ (:p "Error during upload:") (:p (:princ-safe (apply #'format nil (simple-condition-format-control e) (simple-condition-format-arguments e)))) (:p ((:a :href "javascript:window.close()") "ok")))))))))))) + +(defclass news-json-handler (object-handler) + () + (:default-initargs :object-class 'rss-channel :query-function #'find-rss-channel)) + +(defvar *json-output*) + +(defmacro with-json-output ((stream) &body body) + `(let ((*json-output* ,stream)) + ,@body)) + +(defmacro with-json-output-to-string (() &body body) + `(with-output-to-string (*json-output*) + ,@body)) + +(defmacro with-json-array (() &body body) + (with-gensyms (need-comma) + `(let (,need-comma) + (princ #\[ *json-output*) + (prog1 + (labels ((encode-array-element (value) + (if ,need-comma + (princ #\, *json-output*) + (setf ,need-comma t)) + (json:encode-json value *json-output*))) + ,@body) + (princ #\] *json-output*))))) + +(defmacro with-json-object (() &body body) + (with-gensyms (need-comma) + `(let (,need-comma) + (princ #\{ *json-output*) + (prog1 + (labels ((encode-object-member (key value) + (when value + (if ,need-comma + (princ #\, *json-output*) + (setf ,need-comma t)) + (json:encode-json key *json-output*) + (princ #\, *json-output*) + (json:encode-json value *json-output*)))) + ,@body) + (princ #\} *json-output*))))) + +(defmethod handle-object ((handler news-json-handler) (channel rss-channel)) + (with-http-response (:content-type "application/json") + (with-json-output-to-string () + (with-json-array () + (dolist (item (rss-channel-items channel)) + (with-json-object () + (encode-object-member "pubDate" (format-date-time (rss-item-pub-date item) :vms-style t)) + (encode-object-member "title" (rss-item-title item)) + (encode-object-member "description" (rss-item-description item)))))))) \ No newline at end of file Modified: trunk/projects/quickhoney/src/image.lisp =================================================================== --- trunk/projects/quickhoney/src/image.lisp 2008-07-30 15:30:19 UTC (rev 3700) +++ trunk/projects/quickhoney/src/image.lisp 2008-07-30 21:06:43 UTC (rev 3701) @@ -8,32 +8,6 @@ (spider-keywords :update :initform nil) (products :update :initform nil))) -(defmethod rss-item-pub-date ((item quickhoney-image)) - (blob-timestamp item)) - -(defmethod quickhoney-image-explicit ((image quickhoney-image)) - (member :explicit (store-image-keywords image))) - -(defmethod rss-item-encoded-content ((image quickhoney-image)) - (let* ((category (first (intersection (store-image-keywords image) '(:vector :pixel)))) - (is-vector (eq category :vector))) - (with-output-to-string (s) - (html-stream - s - ((:div :class (format nil "newsentry news_~(~A~)" category)) - ((:img :src (format nil "http://~A/image/~A/cutout-button,,~A,98,4" - (website-host) - (store-object-id image) - (if is-vector "00ccff" "ff00ff"))) - (:div - (:h1 (:princ (store-image-name image))) - (:princ (format nil "~A by ~A | " - (format-date-time (blob-timestamp image)) - (if is-vector "Peter" "Nana"))) - ((:a :href (make-image-link image)) "permalink"))))) - (when (quickhoney-image-client image) - (html-stream s :br "Client: " (:princ (quickhoney-image-client image))))))) - (defvar *last-image-upload-timestamp* 0) (defmethod initialize-transient-instance :after ((image quickhoney-image)) @@ -48,21 +22,6 @@ (store-object-remove-keywords image 'bknr.web::keywords '(:import))) (get-keywords-intersection-store-images '(:import)))) -(defmethod rss-item-channel ((item quickhoney-image)) - "quickhoney") - -(defmethod rss-item-title ((image quickhoney-image)) - (store-image-name image)) - -(defmethod rss-item-description ((image quickhoney-image)) - (format nil "~A~@[ (Client: ~A)~]" (store-image-name image) (quickhoney-image-client image))) - -(defmethod rss-item-link ((image quickhoney-image)) - (make-image-link image)) - -(defmethod rss-item-guid ((image quickhoney-image)) - (make-image-link image)) - (defmethod quickhoney-image-category ((image quickhoney-image)) (first (intersection (store-image-keywords image) '(:pixel :vector :news :contact)))) @@ -81,27 +40,3 @@ (defmethod destroy-object :before ((image quickhoney-animation-image)) (delete-object (quickhoney-animation-image-animation image))) -(define-persistent-class quickhoney-news-item (quickhoney-image) - ((title :update) - (text :update))) - -(defmethod quickhoney-image-spider-keywords ((item quickhoney-news-item)) - (quickhoney-news-item-title item)) - -(defmethod rss-item-title ((item quickhoney-news-item)) - (quickhoney-news-item-title item)) - -(defmethod rss-item-encoded-content ((item quickhoney-news-item)) - (concatenate 'string - (call-next-method) - (quickhoney-news-item-text item))) - -(defclass quickhoney-rss-channel (rss-channel) - () - (:metaclass persistent-class)) - -(defmethod rss-channel-items ((channel quickhoney-rss-channel) &key) - (remove-if (lambda (item) - (and (typep item 'quickhoney-image) - (quickhoney-image-explicit item))) - (call-next-method))) \ No newline at end of file Added: trunk/projects/quickhoney/src/news.lisp =================================================================== --- trunk/projects/quickhoney/src/news.lisp (rev 0) +++ trunk/projects/quickhoney/src/news.lisp 2008-07-30 21:06:43 UTC (rev 3701) @@ -0,0 +1,68 @@ +(in-package :quickhoney) + +(defmethod rss-item-pub-date ((item quickhoney-image)) + (blob-timestamp item)) + +(defmethod quickhoney-image-explicit ((image quickhoney-image)) + (member :explicit (store-image-keywords image))) + +(defmethod rss-item-encoded-content ((image quickhoney-image)) + (let* ((category (first (intersection (store-image-keywords image) '(:vector :pixel)))) + (is-vector (eq category :vector))) + (with-output-to-string (s) + (html-stream + s + ((:div :class (format nil "newsentry news_~(~A~)" category)) + ((:img :src (format nil "http://~A/image/~A/cutout-button,,~A,98,4" + (website-host) + (store-object-id image) + (if is-vector "00ccff" "ff00ff"))) + (:div + (:h1 (:princ (store-image-name image))) + (:princ (format nil "~A by ~A | " + (format-date-time (blob-timestamp image)) + (if is-vector "Peter" "Nana"))) + ((:a :href (make-image-link image)) "permalink"))))) + (when (quickhoney-image-client image) + (html-stream s :br "Client: " (:princ (quickhoney-image-client image))))))) + +(defmethod rss-item-channel ((item quickhoney-image)) + "quickhoney") + +(defmethod rss-item-title ((image quickhoney-image)) + (store-image-name image)) + +(defmethod rss-item-description ((image quickhoney-image)) + (format nil "~A~@[ (Client: ~A)~]" (store-image-name image) (quickhoney-image-client image))) + +(defmethod rss-item-link ((image quickhoney-image)) + (make-image-link image)) + +(defmethod rss-item-guid ((image quickhoney-image)) + (make-image-link image)) + +(define-persistent-class quickhoney-news-item (quickhoney-image) + ((title :update) + (text :update))) + +(defmethod quickhoney-image-spider-keywords ((item quickhoney-news-item)) + (quickhoney-news-item-title item)) + +(defmethod rss-item-title ((item quickhoney-news-item)) + (quickhoney-news-item-title item)) + +(defmethod rss-item-encoded-content ((item quickhoney-news-item)) + (concatenate 'string + (call-next-method) + (quickhoney-news-item-text item))) + +(defclass quickhoney-rss-channel (rss-channel) + () + (:metaclass persistent-class)) + +(defmethod rss-channel-items ((channel quickhoney-rss-channel) &key) + (remove-if (lambda (item) + (and (typep item 'quickhoney-image) + (quickhoney-image-explicit item))) + (call-next-method))) + Modified: trunk/projects/quickhoney/src/quickhoney.asd =================================================================== --- trunk/projects/quickhoney/src/quickhoney.asd 2008-07-30 15:30:19 UTC (rev 3700) +++ trunk/projects/quickhoney/src/quickhoney.asd 2008-07-30 21:06:43 UTC (rev 3701) @@ -29,6 +29,7 @@ :components ((:file "packages") (:file "config" :depends-on ("packages")) (:file "image" :depends-on ("config")) + (:file "news" :depends-on ("image")) (:file "layout" :depends-on ("config")) (:file "imageproc" :depends-on ("config")) (:file "handlers" :depends-on ("layout" "config" "image")) Modified: trunk/projects/quickhoney/src/webserver.lisp =================================================================== --- trunk/projects/quickhoney/src/webserver.lisp 2008-07-30 15:30:19 UTC (rev 3700) +++ trunk/projects/quickhoney/src/webserver.lisp 2008-07-30 21:06:43 UTC (rev 3701) @@ -33,6 +33,7 @@ ("/admin" admin-handler) ("/upload-news" upload-news-handler) ("/digg-image" digg-image-handler) + ("/news-json" news-json-handler) ("/" template-handler :default-template "frontpage" :destination ,(namestring (merge-pathnames "templates/" *website-directory*))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs