12319 drewc (define-attributes (policy) (policy-type-code code-select :category 3 :label "Policy Type") (agent-id ajax-fkey :label "Agent") (company-id lol::ajax-foreign-key :label "Company") (insured-id lol::ajax-foreign-key :label "Insured") (policy-number t :label "Policy Number") (effective-date t :label "Effective ") (expiry-date t :label "Expires") (deductible t :label "Deductible $") (:viewer maxwell-viewer :attributes (policy-number effective-date expiry-date policy-type-code agent-id company-id deductable) :global-properties (:editablep nil) :editablep nil) (:editor maxwell-object-presentation :attributes (policy-number effective-date expiry-date policy-type-code agent-id company-id deductable) :global-properties (:editablep t) :editablep t) (:one-line mewa:mewa-one-line-presentation :attributes (policy-number effective-date expiry-date policy-type-code) :global-properties (:editablep nil) :editablep nil)) 3337633172 None 3 Andrzej Skrzyd³o <table style="border: 1px solid #666666;" align="center" cellpadding="0" cellspacing="0"> <tr><td style="padding: 8px; font-weight: bold; text-align: center; background-color: #EEEEEE;"> <form method="get" action="http://usseek.com/system/search.cgi"> Search <select name="mode"> <option value="internet" selected="1">the web</option> <option value="images" >images</option> </select> for <input type="text" name="string" value="" style="width: 250px;"> in: <select name="language"> <option value="lang_de">German</option> <option value="lang_da">Danish</option> <option value="lang_en" selected>English</option> <option value="lang_es">Spanish</option> <option value="lang_fr">French</option> <option value="lang_it">Italian</option> <option value="lang_no">Norwegian</option> <option value="lang_sv">Swedish</option> <option value="lang_cs">Czech</option> <option value="lang_nl">Dutch</option> <option value="lang_pl">Polish</option> <option value="lang_ru">Russian</option> <option value="lang_fi">Finnish</option> </select> <input type="submit" value="Search"> </form> </td></tr> </table> 3342332630 None 2 drewc ;;;; * Utilities (defmethod reorder-list ((list list) new-order) (loop for n in new-order collect (nth n list))) (defun find-all-subclasses (class) (loop for class in (mopp:class-direct-subclasses class) collect class into classes finally (return (nconc classes (loop for class in classes nconc (find-all-subclasses class)))))) ;;;; * Content Store ;;;; For the sake of keeping it simple, ;;;; we are going to store all the content in a single EQUAL hash-table. ;;;; this is somewhat naive, but will do for now. (defclass content-store () ((store :accessor store :initform (make-hash-table :test #'equalp)) (place :accessor place :initform "content-store"))) (defvar *content* (make-instance 'content-store)) (defmethod find-content ((store content-store) name) (gethash name (store store))) (defmethod (setf find-content) (content (store content-store) name) (setf (gethash name (store store)) content)) (defmethod save-content ((store content-store)) (cl-store:store store (place store))) (defmethod restore-content ((store content-store)) (cl-store:restore (place store))) (defun content (name) (find-content *content* name)) (defun (setf content) (value name) (setf (find-content *content* name) value)) (defun store-content () (save-content *content*)) ;;;; ;;;; ** Content Items ;;;; TODO: I'm missing a DEFCLASS/META macro and it shows. (defclass content () ((name :accessor name :initarg :name :initform nil)) (:documentation "The superclass of all content items")) (defmethod initialize-instance :around ((self content) &rest initargs) (let ((content (content (getf initargs :name)))) (cond (content (setf content (apply #'reinitialize-instance content initargs))) (t (setf content (call-next-method)))) (setf (content (name content)) content) content)) (defclass simple-content (content) ((title :accessor title :initarg :title :initform "") (show-title-p :accessor show-title-p :initarg :show-title-p :initform t) (body :accessor body :initarg :body :initform ""))) (lol:define-meta-model simple-content () ((title :type string) (body :type string) (name :type string) (show-title-p :type boolean))) (lol:set-default-attributes 'simple-content) (defclass content-container (content) ((contents :accessor contents :initarg :contents) (title :accessor title :initarg :title :initform nil))) (lol:define-meta-model content-container () ((contents :type string))) (lol:set-default-attributes 'content-container) ;;;; the lack of inheritance in the meta model shows here. ;;;; perhaps the next iteration should include that feature. (defclass faq-container (content-container) ((show-title-p :accessor show-title-p :initarg :show-title-p :initform t))) (lol:define-meta-model faq-container () ((contents :type string) (title :type string) (show-title-p :type boolean))) (lol:set-default-attributes 'faq-container) (defclass faq-item (simple-content) ()) (lol:define-meta-model faq-item () ((title :type string) (body :type string) (name :type string) (show-title-p :type boolean))) (lol:set-default-attributes 'faq-item) (lol:define-attributes (simple-content faq-item) (body mewa::text) (show-title-p mewa::mewa-boolean) (:one-line t :attributes (title)) (:viewer content-viewer) (:editor content-editor :attributes (name title show-title-p (body :type dojo-editor)))) (lol:define-attributes (content-container faq-container) (:viewer content-list-presentation) (:listing sortable-list-editor) (:one-line t :attributes (title))) (lol:define-attributes (faq-container) (:viewer faq-presentation)) (lol:define-attributes (faq-item) (:viewer faq-item-presentation)) ;;;; ** Restore Content on Startup : ;;;; *** This should perhaps be moved to start.lisp (let ((content (restore-content *content*))) (if content (setf *content* content))) (defcomponent content-presentation (lol::mewa-viewer) ()) (defmethod editablep ((self content-presentation)) (get-session-value :editablep)) (defmethod lol:present ((self content-presentation)) (<:div :class "content" (when (show-title-p (lol:instance self)) (<:h2 (lol:present-slot-view self 'title))) (lol:present-slot-view self 'body) (when (editablep self) (<ucw:a :action (lol:call-view ((lol:instance self) :editor)) (<:as-html "edit"))))) (defcomponent sign-up-now-mixin (dojo-component) () (:default-initargs :requires '("dojo.event.*"))) (defaction check-postal-code ((self component) postal-code) (call 'info-message :message "Feature not yet implemented")) (defmethod render-on :wrapping ((res response) (self sign-up-now-mixin)) (call-next-method) (let (postal-code) (<ucw:form :action (check-postal-code self postal-code) (<:div :class "sign-up-now" (<:h2 (<:as-html "Sign Up Now")) (<ucw:text :accessor postal-code :value "Enter Postal Code" :id "postal-code") (<ucw:script `(dojo.event.connect dojo "loaded" (lambda () (setf po (document.get-element-by-id "postal-code")) (dojo.event.connect po "onfocus" (lambda () (setf (slot-value po value) ""))) (dojo.event.connect po "onkeypress" (submit-on-enter po))))))))) (defcomponent charity-list-mixin () ()) (defmethod render-on :wrapping ((res response) (self charity-list-mixin)) (call-next-method) (<:div :id "charity-list-footer" (<:img :src "images/charities.jpg") (<ucw:a :action (view-charites)))) (defcomponent content-viewer (content-presentation sign-up-now-mixin charity-list-mixin) ()) (defcomponent content-editor (content-presentation) () (:default-initargs :global-properties '(:editablep t))) (defmethod lol:present ((self content-editor)) (<:div :style "border:1px solid black" (<ucw:form :action (refresh-component self) (<:as-html "Content Info: ") (<:p (<:as-html "name :") (lol:present-slot-view self 'name)) (<:p (<:as-html "title :") (lol:present-slot-view self 'title)) (<:as-html "Show Title when Displaying?") (lol:present-slot-view self 'show-title-p) (<ucw:submit :value "Save Info" :action (refresh-component self)))) (lol:present-slot-view self 'body) (when (editablep self) (<ucw:a :action (lol:call-view ((lol:instance self) :editor)) (<:as-html "edit")))) (defcomponent content-list-presentation (content-presentation) ((presentation :accessor presentation :initarg :presentation :initform :one-line))) ;;;; ** list viewer (defmethod contents ((self content-list-presentation )) (contents (lol:instance self))) (defaction edit-list ((self content-list-presentation)) (let ((saved (lol:call-view ((contents self) 'content-list-editor)))) (when saved (setf (contents (lol::instance self)) saved)))) (defmethod lol:present ((self content-list-presentation)) (<:ul (arnesi:dolist* (n (contents self)) (<:li (<ucw:a :action (display-content self n) (lol:present-view (n :one-line)))))) (when (editablep self) (<ucw:a :action (edit-list self) (<:as-html "edit" )))) (defaction display-content ((self content-list-presentation) content) (lol:call-view (content :viewer (call-from self)))) (defmethod call-from ((self content-presentation)) "Where to call from when displaying the content body" (content-area (ucw::parent self))) (defcomponent content-finder (content-list-presentation) ()) (defmethod find-content-types () (find-all-subclasses (find-class 'content))) (defmethod render-on ((res response) (self content-finder)) (<:h2 (<:as-html "Find Content")) (<:as-html "to add new content : ") (<ucw:form :action (refresh-component self) (<:ul (let ((type (find-class 'content)) (name "") (title "")) (<:li (<:as-html "Select a type :") (<ucw:select :accessor type (arnesi:dolist* (class (find-content-types)) (<ucw:option :value class (<:as-html (class-name class)))))) (<:li (<:as-html "give it a name :") (<ucw:input :accessor name)) (<:li (<:as-html "give it a Title :") (<ucw:input :accessor title)) (<:li (<ucw:button :action (lol:call-view ((make-instance type :name name :title title) :editor)) (<:as-html "Add Content")))))) (loop for value being the hash-values of (store *content*) using (hash-key key) do (let ((key key) (value value)) (<:div :style "border-bottom:1px solid black" (<:as-html "Name : " (name value)) (<:br) (<ucw:a :action (answer value) (<:as-html (title value))))))) (defcomponent content-list-editor (sortable-list-editor content-presentation) ()) (defaction add-item ((self content-list-editor)) (let ((c (call-component (call-from self) (make-instance 'content-finder)))) (when c (setf (mewa::instances self) (cons c (mewa::instances self)))))) (defcomponent faq-presentation-mixin () ()) (defmethod lol:present :around ((self faq-presentation-mixin)) (<:h2 (<:as-html "F.A.Q")) (<:h3 (<:as-html "Answers to some common questions about Sunrise Organics")) (<:div :class "faq" (call-next-method))) (defcomponent faq-presentation (content-list-presentation sign-up-now-mixin charity-list-mixin faq-presentation-mixin) ()) (defcomponent faq-item-presentation (content-viewer charity-list-mixin faq-presentation-mixin) ()) (defmethod lol:present :around ((self faq-item-presentation)) (call-next-method) (<ucw:a :class "back-link" :action (lol:call-view ((content "FAQ"))) (<:as-html "Return to Faq"))) 3339532387 None 1 drewc (in-package :maxwell-web-gui) ;;;; * A simple User component ;;;; ** The database tables . ;;;; Postgresql is the only way to go. ;;;; (actually, LoL will work with any lisp data type, ;;;; but one has to set up the meta-model manually) ;;;; the only flaw is that "user" is a ;;;; reserverd word in sql, and the generator ;;;; is not very smart. ;;;; you'll want to remove the #+(or) if you plan ;;;; to create the tables in lisp. #+ (or) (clsql:execute-command " DROP TABLE app_user; CREATE TABLE app_user ( app_user_id SERIAL PRIMARY KEY, username TEXT, password TEXT, person_id INTEGER REFERENCES person(person_id) );") #+(or) (clsql:execute-command " CREATE TABLE app_resource ( app_resource_id SERIAL PRIMARY KEY, description TEXT, code TEXT );") #+ (or) (clsql:execute-command " CREATE TABLE app_user_app_resource ( app_user_app_resource_id SERIAL PRIMARY KEY, app_user_id INTEGER REFERENCES app_user(app_user_id), app_resource_id INTEGER REFERENCES app_resource(app_resource_id) );") ;;;; This is a macro that seta up a meta-model, ;;;; a clsql view-class and sets ;;;; the default mewa attributes. ;;;; when developing at the REPL, you can use ;;;; it to redefine your view classes. ;;;; When compiling an app, it is better to use ;;;; LOL:DEFINE-VIEWS-FOR-DATABASE ;;;; (lol:define-view-for-table "app_user") ;;;; (lol:define-view-for-table "app_user_app_resource") (define-attributes (app-user) (person-id ajax-fkey) (username t :label "User Name") (:one-line mewa-one-line-presentation :attributes (username person-id) :global-properties (:editablep nil)) (:creator maxwell-editor :attributes ((username :label "Please enter a User Name. This is the name this person will use to login.") (password :label "Enter a password for this user.") (person-id :label "Select the person or company associated with this login.")))) ;;;; ** User Resource Component. (define-attributes (app-user-app-resource) (app-resource-id ajax-fkey) (:editor t :attributes ((app-user-id :editablep nil :label "User") (app-resource-id :label "Select a Resource"))) (:one-line t :attributes ((app-resource-id :editablep nil)))) #+(or) (mapcar #'meta-model:sync-instance (mapcar #'(lambda (init-args) (apply #'make-instance 'app-resource init-args)) '((:description "User Manager" :code "USER") (:description "Recent Changes" :code "RECENT")))) ;;;; Fist thing we need is to add some users. (defaction create-user ((c component)) (let ((new-user (make-instance 'app-user))) (lol:call-view (new-user :creator)))) ;;;; We'd like to be able to view them as well. (defaction view-user ((c component) user) (lol:call-view (user :viewer))) (defun list-users () (clsql:select 'app-user :flatp t)) (defcomponent user-manager () ()) (defmethod render-on ((res response) (self user-manager)) (<:h2 (<:as-html "User Manager")) (<ucw:a :action (create-user self) (<:as-html "Create User")) (<:h3 (<:as-html "All Users :")) (<:ul (arnesi:dolist* (u (list-users)) (<:li (<ucw:a :action (view-user self u) (lol:present-view (u :one-line))))))) 3339181029 None