Author: hhubner Date: 2006-03-05 09:04:26 -0500 (Sun, 05 Mar 2006) New Revision: 1889 Modified: branches/xml-class-rework/bknr/src/data/object.lisp branches/xml-class-rework/bknr/src/utils/package.lisp branches/xml-class-rework/bknr/src/utils/utils.lisp branches/xml-class-rework/bknr/src/web/authorizer.lisp Log: Attempt to handle uploads which are over the size limit better (not finished) Add scale-bytes function to pretty-print a file's size. Change delete-object so that it can be called within transaction code. Modified: branches/xml-class-rework/bknr/src/data/object.lisp =================================================================== --- branches/xml-class-rework/bknr/src/data/object.lisp 2006-03-05 14:02:00 UTC (rev 1888) +++ branches/xml-class-rework/bknr/src/data/object.lisp 2006-03-05 14:04:26 UTC (rev 1889) @@ -560,17 +560,21 @@ (destroy-object (store-object-with-id id))) (defun delete-object (object) - (execute (make-instance 'transaction :function-symbol 'tx-delete-object - :timestamp (get-universal-time) - :args (list (store-object-id object))))) + (if (in-transaction-p) + (destroy-object object) + (execute (make-instance 'transaction :function-symbol 'tx-delete-object + :timestamp (get-universal-time) + :args (list (store-object-id object)))))) (defun tx-delete-objects (&rest object-ids) (mapc #'(lambda (id) (destroy-object (store-object-with-id id))) object-ids)) (defun delete-objects (&rest objects) - (execute (make-instance 'transaction :function-symbol 'tx-delete-objects - :timestamp (get-universal-time) - :args (mapcar #'store-object-id objects)))) + (if (in-transaction-p) + (mapc #'destroy-object objects) + (execute (make-instance 'transaction :function-symbol 'tx-delete-objects + :timestamp (get-universal-time) + :args (mapcar #'store-object-id objects))))) (deftransaction change-slot-values (object &rest slots-and-values) (when object Modified: branches/xml-class-rework/bknr/src/utils/package.lisp =================================================================== --- branches/xml-class-rework/bknr/src/utils/package.lisp 2006-03-05 14:02:00 UTC (rev 1888) +++ branches/xml-class-rework/bknr/src/utils/package.lisp 2006-03-05 14:04:26 UTC (rev 1889) @@ -14,6 +14,9 @@ #+(not allegro) (:shadowing-import-from :acl-compat.mp process-kill process-wait) (:export #:define-bknr-class + + ;; byte size formatting + #:scale-bytes ;; date format #:format-date-time Modified: branches/xml-class-rework/bknr/src/utils/utils.lisp =================================================================== --- branches/xml-class-rework/bknr/src/utils/utils.lisp 2006-03-05 14:02:00 UTC (rev 1888) +++ branches/xml-class-rework/bknr/src/utils/utils.lisp 2006-03-05 14:04:26 UTC (rev 1889) @@ -536,3 +536,17 @@ (apply #'append subclasses (mapcar #'collect-subclasses subclasses))))) (mapcar #'class-name (remove-duplicates (collect-subclasses (if (symbolp class) (find-class class) class)))))) + +(defun scale-bytes (byte-count) + (cond + ((> byte-count (* 1024 1024 1024 1024)) + (format nil "~3,1F TB" (/ byte-count (* 1024 1024 1024 1024)))) + ((> byte-count (* 1024 1024 1024)) + (format nil "~3,1F GB" (/ byte-count (* 1024 1024 1024)))) + ((> byte-count (* 1024 1024)) + (format nil "~3,1F MB" (/ byte-count (* 1024 1024)))) + ((> byte-count 1024) + (format nil "~3,1F KB" (/ byte-count 1024))) + (t + (format nil "~A" byte-count)))) + \ No newline at end of file Modified: branches/xml-class-rework/bknr/src/web/authorizer.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/authorizer.lisp 2006-03-05 14:02:00 UTC (rev 1888) +++ branches/xml-class-rework/bknr/src/web/authorizer.lisp 2006-03-05 14:04:26 UTC (rev 1889) @@ -71,17 +71,26 @@ (defmethod authorize ((authorizer bknr-authorizer) (req http-request) ent) - ;; first check session cookie or bknr-sessionid parameter. the - ;; session cookie is set in the with-bknr-http-response macro to - ;; follow aserve's documented protocol for setting cookies - (let ((session (or (session-from-request-parameters authorizer req) - (session-from-request req) - (make-anonymous-session req)))) - (when session - (bknr-session-touch session) - (change-class req 'bknr-request :session session) - (return-from authorize t))) + (format t "; trying to authorize request~%") + ;; Catch any errors that occur during request body processing + (handler-case + ;; first check session cookie or bknr-sessionid parameter. the + ;; session cookie is set in the with-bknr-http-response macro to + ;; follow aserve's documented protocol for setting cookies + (let ((session (or (session-from-request-parameters authorizer req) + (session-from-request req) + (make-anonymous-session req)))) + (when session + (bknr-session-touch session) + (change-class req 'bknr-request :session session) + (format t "; request authorized~%") + (return-from authorize t))) + (error (e) + (format t "; Caught error ~A during request processing~%" e) + (http-error req *response-bad-request* (princ-to-string e)))) + + (format t "; request NOT authorized~%") ;; unauthorized, come up with 401 response to the web browser (redirect "/login" req) :deny)