[bknr-cvs] r2180 - in trunk/bknr/src: . data indices sysclasses utils web xml-impex
bknr at bknr.net
bknr at bknr.net
Thu Oct 4 07:41:40 UTC 2007
Author: hhubner
Date: 2007-10-04 03:41:40 -0400 (Thu, 04 Oct 2007)
New Revision: 2180
Modified:
trunk/bknr/src/bknr-impex.asd
trunk/bknr/src/bknr-utils.asd
trunk/bknr/src/bknr.asd
trunk/bknr/src/data/object.lisp
trunk/bknr/src/data/package.lisp
trunk/bknr/src/data/txn.lisp
trunk/bknr/src/indices/package.lisp
trunk/bknr/src/packages.lisp
trunk/bknr/src/sysclasses/user.lisp
trunk/bknr/src/utils/acl-mp-compat.lisp
trunk/bknr/src/utils/package.lisp
trunk/bknr/src/utils/utils.lisp
trunk/bknr/src/utils/xml.lisp
trunk/bknr/src/web/user-handlers.lisp
trunk/bknr/src/web/user-tags.lisp
trunk/bknr/src/web/web-visitor.lisp
trunk/bknr/src/xml-impex/package.lisp
Log:
Merge back changes that I committed to the bos branch recently. This includes
the SBCL compatibility fixes as well as the CXML fix from Kamen.
Modified: trunk/bknr/src/bknr-impex.asd
===================================================================
--- trunk/bknr/src/bknr-impex.asd 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/bknr-impex.asd 2007-10-04 07:41:40 UTC (rev 2180)
@@ -21,7 +21,7 @@
:description "BKNR XML import/export"
:long-description ""
- :depends-on (:cl-interpol :cxml :bknr-utils :bknr-indices)
+ :depends-on (:cl-interpol :cxml :bknr-utils :bknr-xml :bknr-indices)
:components ((:module "xml-impex"
:components
Modified: trunk/bknr/src/bknr-utils.asd
===================================================================
--- trunk/bknr/src/bknr-utils.asd 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/bknr-utils.asd 2007-10-04 07:41:40 UTC (rev 2180)
@@ -17,7 +17,6 @@
:description "baikonour - launchpad for lisp satellites"
:depends-on (:cl-interpol :cl-ppcre
- :cxml
:md5
#+(not allegro)
:acl-compat
@@ -37,7 +36,6 @@
(:file "base64" :depends-on ("utils"))
(:file "capability" :depends-on ("utils"))
(:file "make-fdf-file" :depends-on ("utils"))
- (:file "xml" :depends-on ("utils"))
(:file "date-calc")
(:file "acl-mp-compat" :depends-on ("package"))))))
Modified: trunk/bknr/src/bknr.asd
===================================================================
--- trunk/bknr/src/bknr.asd 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/bknr.asd 2007-10-04 07:41:40 UTC (rev 2180)
@@ -28,6 +28,7 @@
:cxml
:unit-test
:bknr-utils
+ :bknr-xml
:puri
;:stem
;:mime
Modified: trunk/bknr/src/data/object.lisp
===================================================================
--- trunk/bknr/src/data/object.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/data/object.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -607,6 +607,34 @@
:timestamp (get-universal-time)
:args (mapcar #'store-object-id objects)))))
+(defgeneric cascade-delete-p (object referencing-object)
+ (:documentation "return non-nil if the REFERENCING-OBJECT should be deleted when the OBJECT is deleted"))
+
+(defmethod cascade-delete-p (object referencing-object)
+ nil)
+
+(defun partition-list (list predicate)
+ "Return two list values, the first containing all elements from LIST
+that satisfy PREDICATE, the second those that don't"
+ (let (do dont)
+ (dolist (element list)
+ (if (funcall predicate element)
+ (push element do)
+ (push element dont)))
+ (values do dont)))
+
+(defun cascading-delete-object (object)
+ "Delete the OBJECT and all objects that reference it and that are eligible to cascading deletes, as indicated by
+the result of calling CASCADE-DELETE-P. Generate error if there are references to the objects that are not eligible
+to cascading deletes."
+ (multiple-value-bind (cascading-delete-refs
+ remaining-refs)
+ (partition-list (find-refs object) #'cascade-delete-p)
+ (when remaining-refs
+ (error "Cannot delete object ~A because there are references to this object in the system, please consult a system administrator!"
+ object))
+ (apply #'delete-objects object cascading-delete-refs)))
+
(deftransaction change-slot-values (object &rest slots-and-values)
(when object
(loop for (slot value) on slots-and-values by #'cddr
@@ -655,4 +683,17 @@
(deftransaction store-object-set-keywords (object slot keywords)
(setf (slot-value object slot) keywords))
+(defmethod find-refs ((object store-object))
+ "Find references to the given OBJECT in all store-objects, traversing both single valued and list valued slots."
+ (remove-if-not
+ (lambda (candidate)
+ (find-if (lambda (slotd)
+ (and (slot-boundp candidate (slot-definition-name slotd))
+ (let ((slot-value (slot-value candidate (slot-definition-name slotd))))
+ (or (eq object slot-value)
+ (and (listp slot-value)
+ (find object slot-value))))))
+ (class-slots (class-of candidate))))
+ (class-instances 'store-object)))
+
(pushnew :mop-store cl:*features*)
Modified: trunk/bknr/src/data/package.lisp
===================================================================
--- trunk/bknr/src/data/package.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/data/package.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -52,6 +52,8 @@
#:delete-object
#:delete-objects
+ #:cascade-delete-p
+ #:cascading-delete-object
#:initialize-persistent-instance
#:initialize-transient-instance
@@ -108,4 +110,6 @@
#:store-blob-root-tempdir
#:store-object-subsystem
- #:blob-subsystem))
+ #:blob-subsystem
+
+ #:find-refs))
Modified: trunk/bknr/src/data/txn.lisp
===================================================================
--- trunk/bknr/src/data/txn.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/data/txn.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -43,11 +43,11 @@
()
(:default-initargs :guard (let ((lock (make-process-lock)))
(lambda (thunk)
- (mp-with-lock-held (lock)
+ (mp-with-recursive-lock-held (lock)
(funcall thunk))))
:log-guard (let ((lock (make-process-lock)))
(lambda (thunk)
- (mp-with-lock-held (lock)
+ (mp-with-recursive-lock-held (lock)
(funcall thunk)))))
(:documentation
"Store in which every transaction and operation is protected by a giant lock."))
Modified: trunk/bknr/src/indices/package.lisp
===================================================================
--- trunk/bknr/src/indices/package.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/indices/package.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -6,7 +6,6 @@
#+cmu :ext
#+sbcl :sb-ext
:cl-user
- :cxml
:bknr.utils
:bknr.skip-list
#+allegro :aclmop
Modified: trunk/bknr/src/packages.lisp
===================================================================
--- trunk/bknr/src/packages.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/packages.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -26,7 +26,7 @@
#:start-cron))
(defpackage :bknr.rss
- (:use :cl :cl-user :cl-ppcre :bknr.utils :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml)
+ (: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*
@@ -130,6 +130,7 @@
#:user-flags
#:user-preferences
#:user-subscriptions
+ #:user-editable-p
;; Export slot names so that derived classes can overload
;; slots (e.g. to add XML impex attributes)
@@ -152,6 +153,7 @@
#:user-add-flags
#:user-remove-flags
#:all-user-flags
+ #:define-user-flag
#:user-reachable-by-mail-p
#:user-mail-error-p
@@ -163,6 +165,7 @@
#:all-users
#:get-flag-users
#:make-user
+ #:delete-user
#:set-user-password
#:set-user-last-login
@@ -189,6 +192,7 @@
:bknr.indices
:bknr.impex
:bknr.utils
+ :bknr.xml
:bknr.events
:bknr.user)
(:shadowing-import-from :cl-interpol #:quote-meta-chars)
Modified: trunk/bknr/src/sysclasses/user.lisp
===================================================================
--- trunk/bknr/src/sysclasses/user.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/sysclasses/user.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -13,8 +13,7 @@
:index-values all-users)
(flags :update :initform nil
:index-type hash-list-index
- :index-reader get-flag-users
- :index-keys all-user-flags)
+ :index-reader get-flag-users)
(email :update :initform ""
:documentation "Email Address, must be unique")
@@ -30,6 +29,15 @@
(defconstant +salt-length+ 8)
+(defgeneric user-editable-p (user)
+ (:documentation "Return non-nil if the given user can be edited through the administration interface. The USER class
+is frequently subclassed to implement special user accounts that are self-registered and that cannot be edited through
+the standard user administration interface. It would be better if the ``real'' system users would live in a seperate base
+class that would be editable and have the USER class be non-editable."))
+
+(defmethod user-editable-p ((user user))
+ t)
+
(defun make-salt ()
(coerce (loop
for i from 1 upto +salt-length+
@@ -91,6 +99,14 @@
(defmethod user-has-flag ((user user) flag)
(find flag (user-flags user)))
+(defvar *user-flags* '(:admin))
+
+(defun define-user-flag (keyword)
+ (pushnew keyword *user-flags*))
+
+(defun all-user-flags ()
+ (copy-list *user-flags*))
+
(defmethod verify-password ((user user) password)
(when password
(let ((upw (user-password user)))
@@ -149,6 +165,14 @@
(set-user-password user password))
user))
+(defmethod cascade-delete-p ((user user) (event event))
+ t)
+
+(defmethod delete-user ((user user))
+ (when (eq user (find-user "anonymous"))
+ (error "Can't delete system user ``anonymous''"))
+ (cascading-delete-object user))
+
(deftransaction set-user-full-name (user full-name)
(setf (user-full-name user) full-name))
@@ -215,4 +239,4 @@
(defmethod as-xml ((event message-event))
(generate-event-xml event
:from (message-event-from-name event)
- :text (message-event-text event)))
\ No newline at end of file
+ :text (message-event-text event)))
Modified: trunk/bknr/src/utils/acl-mp-compat.lisp
===================================================================
--- trunk/bknr/src/utils/acl-mp-compat.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/utils/acl-mp-compat.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -18,3 +18,14 @@
#+cmu
`(mp:with-lock-held (,lock)
, at body))
+
+(defmacro mp-with-recursive-lock-held ((lock) &rest body)
+ #+allegro
+ `(mp:with-process-lock (,lock)
+ , at body)
+ #+sbcl
+ `(sb-thread:with-recursive-lock (,lock)
+ , at body)
+ #+cmu
+ `(mp:with-lock-held (,lock)
+ , at body))
Modified: trunk/bknr/src/utils/package.lisp
===================================================================
--- trunk/bknr/src/utils/package.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/utils/package.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -4,7 +4,6 @@
(:use :cl
:cl-ppcre
:cl-interpol
- :cxml-xmls
:md5
#+cmu :extensions
; #+sbcl :sb-ext
@@ -122,15 +121,6 @@
#:string-beginning-with-p
#:string-delimited-by-p
- ;; xml
- #:node-children-nodes
- #:find-child
- #:find-children
- #:node-string-body
- #:node-attribute
- #:node-child-string-body
- #:node-to-html
-
;; crypt-md5
#:crypt-md5
#:verify-md5-password
@@ -147,6 +137,10 @@
;; mp compatibility
#:mp-make-lock
#:mp-with-lock-held
+ #:mp-with-recursive-lock-held
;; class utils
- #:class-subclasses))
+ #:class-subclasses
+
+ ;; norvig
+ #:find-all))
Modified: trunk/bknr/src/utils/utils.lisp
===================================================================
--- trunk/bknr/src/utils/utils.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/utils/utils.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -545,4 +545,15 @@
(format nil "~3,1F KB" (/ byte-count 1024)))
(t
(format nil "~A" byte-count))))
-
\ No newline at end of file
+
+;;; from norvig
+(defun find-all (item sequence &rest keyword-args
+ &key (test #'eql) test-not &allow-other-keys)
+ "Find all those elements of sequence that match item,
+ according to the keywords. Doesn't alter sequence."
+ (if test-not
+ (apply #'remove item sequence
+ :test-not (complement test-not) keyword-args)
+ (apply #'remove item sequence
+ :test (complement test) keyword-args)))
+
Modified: trunk/bknr/src/utils/xml.lisp
===================================================================
--- trunk/bknr/src/utils/xml.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/utils/xml.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -1,63 +0,0 @@
-(in-package :bknr.utils)
-
-(defun node-children-nodes (xml)
- (remove-if-not #'consp (node-children xml)))
-
-(defun find-child (xml node-name)
- (let ((children (node-children-nodes xml)))
- (find node-name children :test #'string-equal :key #'node-name)))
-
-(defun find-children (xml node-name)
- (let ((children (node-children-nodes xml)))
- (find-all node-name children :test #'string-equal :key #'node-name)))
-
-(defun node-string-body (xml)
- (let ((children (remove-if #'consp (node-children xml))))
- (if (every #'stringp children)
- (apply #'concatenate 'string children)
- (error "Some children are not strings"))))
-
-(defun node-attribute (xml attribute-name)
- (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal)))
-
-(defun node-child-string-body (xml node-name)
- (let ((child (find-child xml node-name)))
- (if (and child (consp child))
- (node-string-body child)
- nil)))
-
-(defun node-to-html (node &optional (stream *standard-output*))
- (when (stringp node)
- (write-string node)
- (return-from node-to-html))
- (write-char #\< stream)
- (when (node-ns node)
- (write-string (node-ns node) stream)
- (write-char #\: stream))
- (write-string (node-name node) stream)
- (loop for (key value) in (node-attrs node)
- do (write-char #\Space stream)
- (write-string key stream)
- (write-char #\= stream)
- (write-char #\" stream)
- (write-string value stream)
- (write-char #\" stream))
- (if (node-children node)
- (progn
- (write-char #\> stream)
- (write-char #\Newline stream)
- (dolist (child (node-children node))
- (node-to-html child stream))
- (write-char #\< stream)
- (write-char #\/ stream)
- (when (node-ns node)
- (write-string (node-ns node) stream)
- (write-char #\: stream))
- (write-string (node-name node) stream)
- (write-char #\> stream)
- (write-char #\Newline stream))
- (progn (write-char #\Space stream)
- (write-char #\/ stream)
- (write-char #\> stream)
- (write-char #\Newline stream))))
-
Modified: trunk/bknr/src/web/user-handlers.lisp
===================================================================
--- trunk/bknr/src/web/user-handlers.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/web/user-handlers.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -59,13 +59,21 @@
(defmethod handle-object-form ((handler user-handler) action (user (eql nil)) req)
(with-bknr-page (req :title "Manage users")
- #+(or)
- (:ul (loop for user in (remove :registered (all-users) :key #'user-flags :test #'member)
- do (html (:li ((:a :href (object-url user))
- (:princ-safe (user-login user)))))))
- ((:form :method "POST")
- (:h2 "Search for user")
- "Login: " ((:input :type "text" :name "login" :size "20")) (submit-button "search" "search"))
+ ((:table :border "1")
+ (:tr (:th "Login")
+ (:th "Real name")
+ (:th "Privileges")
+ (:th "Last login"))
+ (dolist (user (sort (remove-if-not #'user-editable-p (all-users))
+ #'string-lessp :key #'user-login))
+ (html (:tr (:td ((:a :href (object-url user))
+ (:princ-safe (user-login user))))
+ (:td (:princ-safe (user-full-name user)))
+ (:td (:princ-safe (format nil "~{~A~^, ~}" (user-flags user))))
+ (:td (:princ-safe (if (and (user-last-login user)
+ (plusp (user-last-login user)))
+ (format-date-time (user-last-login user))
+ "<never logged in>")))))))
(:h2 "Create new user")
(user-form)))
@@ -90,25 +98,27 @@
(when password
(set-user-password user password))
(change-slot-values user 'email email 'full-name full-name)))
+
+ (when (admin-p (bknr-request-user req))
+ (let* ((all-flags (all-user-flags))
+ (set-flags (keywords-from-query-param-list (query-param-list req "flags")))
+ (unset-flags (set-difference all-flags set-flags)))
+ (user-add-flags user set-flags)
+ (user-remove-flags user unset-flags)))
+
(call-next-method))
+(define-condition unauthorized-error (simple-error)
+ ()
+ (:report "You are not authorized to perform this operation"))
+
(defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user req)
+ (unless (admin-p (bknr-request-user req))
+ (error 'unauthorized-error))
(when user
- (delete-object user))
+ (delete-user user))
(redirect "/user" req))
-(defmethod handle-object-form ((handler user-handler) (action (eql :add-flags)) user req)
- (when user
- (let ((flags (keywords-from-query-param-list (query-param-list req "keyword"))))
- (user-add-flags user flags)))
- (call-next-method))
-
-(defmethod handle-object-form ((handler user-handler) (action (eql :remove-flags)) user req)
- (when user
- (let ((flags (keywords-from-query-param-list (query-param-list req "keyword"))))
- (user-remove-flags user flags)))
- (call-next-method))
-
(defmethod handle-object-form ((handler user-handler) (action (eql :create)) user req)
(with-query-params (req login email full-name password password-repeat)
(if (and password
@@ -116,14 +126,14 @@
(error "please enter the same password twice")
(if login
(let* ((flags (keywords-from-query-param-list (query-param-list req "keyword")))
- (user (make-object 'user :login login
- :email email
- :full-name full-name
- :password password
- :flags flags)))
+ (user (make-user login
+ :email email
+ :full-name full-name
+ :password password
+ :flags flags)))
(redirect (edit-object-url user) req))
(error "please enter a login")))))
(define-bknr-webserver-module user
("/user" user-handler)
- ("/logout" logout-handler))
\ No newline at end of file
+ ("/logout" logout-handler))
Modified: trunk/bknr/src/web/user-tags.lisp
===================================================================
--- trunk/bknr/src/web/user-tags.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/web/user-tags.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -2,20 +2,15 @@
(enable-interpol-syntax)
-(define-bknr-tag user-flag-choose-dialog (&key (size "4") (name "keyword") (create nil))
- (let ((size (or (parse-integer size :junk-allowed t) 1)))
- (loop for i from 1 to size
- do (html ((:div :class "keyword-choose")
- (when (> size 1)
- (html (:princ-safe i) ". "))
- (select-box name
- (loop for flag in
- (sort (all-user-flags) #'string<)
- collect (list (string-downcase flag) flag)))
- (when create
- (html ((:input :type "text" :length "20" :name name)))))))))
+(define-bknr-tag user-flag-choose-dialog (&key enabled)
+ (dolist (flag (sort (all-user-flags) #'string<))
+ (html
+ ((:div :class "user-flag-choose")
+ (if (find flag enabled)
+ (html ((:input :type "checkbox" :name "flags" :value flag :checked "checked")))
+ (html ((:input :type "checkbox" :name "flags" :value flag))))
+ (:princ-safe flag)))))
-
(define-bknr-tag user-form (&key user-id)
(let ((user (when user-id
(store-object-with-id (if (numberp user-id)
@@ -36,11 +31,7 @@
(:td (html (text-field "email" :value (user-email user)))))
(when (admin-p *user*)
(html (:tr (:td "flags")
- (:td (dolist (flag (user-flags user))
- (html (:princ-safe flag) " "))))
- (:tr (:td "new flags")
- (:td (user-flag-choose-dialog :create t
- :size "2")))))
+ (:td (user-flag-choose-dialog :enabled (user-flags user))))))
(:tr (:td "new password")
(:td ((:input :type "password" :name "password" :size "8"))))
(:tr (:td "repeat new password")
@@ -48,9 +39,7 @@
(:tr ((:td :colspan "2")
(submit-button "save" "save")
(when (admin-p *user*)
- (submit-button "add-flags" "add flags")
- (submit-button "remove-flags" "remove flags")
- (submit-button "delete" "delete")))))))
+ (submit-button "delete" "delete" :confirm "Really delete this user account? The operation cannot be undone.")))))))
(html ((:form :method "post")
(:table
(:tr (:td "login")
@@ -60,7 +49,7 @@
(:tr (:td "email")
(:td ((:input :type "text" :name "email" :size "40"))))
(:tr (:td "flags")
- (:td (user-flag-choose-dialog :create t :size "2")))
+ (:td (user-flag-choose-dialog)))
(:tr (:td "password")
(:td ((:input :type "password" :name "password" :size "8"))))
(:tr (:td "repeat password")
Modified: trunk/bknr/src/web/web-visitor.lisp
===================================================================
--- trunk/bknr/src/web/web-visitor.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/web/web-visitor.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -16,12 +16,15 @@
(host-ip-address (web-visitor-event-host event))))
(defmethod print-object ((event web-visitor-event) stream)
- (format stream "#<~a at ~a user ~a from ~a [~a]>"
- (class-of event) (format-date-time (event-time event))
- (when (web-visitor-event-user event)
- (user-login (web-visitor-event-user event)))
- (host-name (web-visitor-event-host event))
- (host-ip-address (web-visitor-event-host event)))
+ (print-unreadable-object (event stream :type t :identity t)
+ (format stream "at ~A user ~A"
+ (format-date-time (event-time event))
+ (and (web-visitor-event-user event)
+ (user-login (web-visitor-event-user event))))
+ (when (web-visitor-event-host event)
+ (format stream " from ~a [~a]"
+ (host-name (web-visitor-event-host event))
+ (host-ip-address (web-visitor-event-host event))))))
event)
#+(or)
Modified: trunk/bknr/src/xml-impex/package.lisp
===================================================================
--- trunk/bknr/src/xml-impex/package.lisp 2007-10-04 07:23:42 UTC (rev 2179)
+++ trunk/bknr/src/xml-impex/package.lisp 2007-10-04 07:41:40 UTC (rev 2180)
@@ -13,6 +13,7 @@
#+sbcl
:sb-pcl
:bknr.utils
+ :bknr.xml
:bknr.indices)
(:export #:xml-class
More information about the Bknr-cvs
mailing list