[bknr-cvs] r1889 - in branches/xml-class-rework/bknr/src: data utils web

[bknr at bknr.net]

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)