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) ,@body)) + +(defmacro mp-with-recursive-lock-held ((lock) &rest body) + #+allegro + `(mp:with-process-lock (,lock) + ,@body) + #+sbcl + `(sb-thread:with-recursive-lock (,lock) + ,@body) + #+cmu + `(mp:with-lock-held (,lock) + ,@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