src/components/crud.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (defmethod/cc read-instance ((self component) instance)
   4   "View an existing instance"
   5   (call 'crud-viewer :instance instance))
   6
   7 (defmethod/cc update-instance ((self component) instance)
   8   "Edit an instance, possibly a newly created one"
   9   (call 'crud-editor :instance instance))
  10
  11 (defmethod/cc create-instance ((self component) class &rest initargs)
  12   "Create a new instance and edit it."
  13   (update-instance self (apply #'make-instance class initargs)))
  14
  15 (defun %delete-instance-and-return-nil (instance)
  16   "returns nil on success"
  17   (handler-case (clsql:delete-instance-records instance)
  18     (error (x)
  19       (return-from %delete-instance-and-return-nil x)))
  20   nil)
  21
  22 (defun display-as-string (instance)
  23   (with-output-to-string (s)
  24     (yaclml:with-yaclml-stream s
  25       (display (make-instance 'component) instance
  26                :layers '(+ as-string)))))
  27
  28 (defmethod/cc delete-instance ((self component) instance)
  29   (when  (call 'option-dialog
  30                :message (format nil "Really Delete ~A" (display-as-string instance))
  31                :options '((t "Yes, really delete it,")
  32                           (nil "No, i'll hold on to this one.")))
  33     (let ((delete-failed (%delete-instance-and-return-nil instance)))
  34       (if (not delete-failed)
  35           (answer t)
  36           (progn
  37             (call 'info-message :message delete-failed)
  38             (answer t))))))
  39
  40
  41 (defmethod breadcrumb-name (component)
  42   (string-downcase (string  (class-name (class-of component)))))
  43
  44 (defun render-breadcrumb (self)
  45   (<:p :class "breadcrumb"
  46        (let ((count 0)
  47              (trail-length 3))
  48          (labels ((find-call-stack-for-crumbs (component list-of-parents)
  49                     (cond ((and (not (null component))
  50                                 (> trail-length count))
  51                            (incf count)
  52                            (find-call-stack-for-crumbs
  53                             (when (slot-boundp component 'ucw::calling-component)
  54                               (slot-value component 'ucw::calling-component))
  55                             (cons component list-of-parents)))
  56                           (t
  57                            list-of-parents))))
  58            (loop
  59               :for c
  60               :on (find-call-stack-for-crumbs self nil)
  61               :do (let ((c c))
  62                     (<:as-html " / ")
  63                     (if (cdr c)
  64                         (<ucw:a
  65                          :action (answer-component (second c) nil)
  66                          (<:as-html (breadcrumb-name (first c))))
  67                         (<:as-html (breadcrumb-name (first c))))))))))
  68
  69 (defcomponent crud ()
  70  ((instance :accessor instance :initarg :instance :initform nil))
  71   (:documentation "The base class for all standard crud components"))
  72
  73 (defmethod render ((self crud))
  74   "Just to show off more of LOL, we'll use its display mechanism for UCW components.
  75
  76 DISPLAY takes two required arguments,
  77 COMPONENT : The component to display FROM (not neccesarily 'in')
  78 OBJECT : The 'thing' we want to display... in this case it's the component,
  79
  80 DISPLAY also takes keyword arguments that modify the DESCRIPTION at run time.
  81
  82 By default, the display method iterates through the ATTRIBUTES
  83 of the DESCRIPTION of the OBJECT. This will hopfully become clear.
  84
  85 In this case, we are displaying the component from itself.
  86 "
  87
  88   (display self self))
  89
  90 (defun class-name-of (instance)
  91   (class-name (class-of instance)))
  92
  93 ;;;; We'll use this in a string attribute to display the title.
  94 (defgeneric find-title (crud)
  95   (:method (crud)
  96     (if (instance crud)
  97         (format nil "An instance of ~A" (class-name-of (instance crud)))
  98         "Welcome to Crud 1.0")))
  99
 100 ;;;; ** We define an attribute for the menu
 101 ;;;; DEFATTRIBUTE is like defclass for attributes.
 102 (defattribute crud-menu ()
 103   ()
 104   (:default-properties
 105       :show-back-p t)
 106   (:documentation
 107    "A Custom menu attribute"))
 108
 109 (defdisplay :wrapping ((menu crud-menu) object (component component))
 110  "Set up the menu with an optional back button
 111
 112 In a DEFDISPLAY form, the variable SELF is bound to the component we are displaying.
 113 This allows it to work with UCW's CALL and ANSWER, and saves some typing as well.
 114 One can also provide a name (or a specializer) for the component as the third parameter
 115 in the defdisplay argument list, (as i did above) but this is optional.
 116
 117 DEFDISPLAY is really just a few macros around DISPLAY-USING-DESCRIPTION,
 118 which does the real work. Macroexpand if you're interested."
 119   (<:ul
 120    (when (show-back-p menu)
 121      (<:li (<ucw:a :action (answer nil)
 122                    (<:as-html "Go Back"))))
 123    (call-next-method)))
 124
 125 (defdisplay ((menu crud-menu) object)
 126   "Do nothing beyond the defalt for our standard menu
 127
 128 note the omitted COMPONENT argument. sugar is all."
 129   t)
 130
 131 ;;;; create a new layer for some customisations.
 132 (deflayer crud)
 133
 134 ;;;; we don't really _have_ to do this in our own layer,
 135 ;;;; but it does give us the ability to turn the behaviour off.
 136 (defdisplay :in-layer crud
 137             :wrap-around ((attribute standard-attribute) (object crud))
 138   "Around every attribute of a CRUD instance, i'd like to wrap a div."
 139   (<:div
 140    :class (format nil "crud-~A" (string-downcase
 141                                  (string (attribute-name attribute))))
 142    (call-next-method)))
 143
 144 ;;;; A description contains attributes.
 145 ;;;; ATTRIBUTES are the various pieces that come together to make a display
 146 ;;;; In this case, we define parts of the 'page'.
 147
 148 (defdescription crud ()
 149   (;; use a generic function for the title attribute
 150    (title
 151     ;; attributes have types.
 152     ;; inspect LOL::FIND-ATTRIBUTE-CLASS-FOR-TYPE for a list.
 153     :type 'string
 154     ;; almost all attributes have a getter and/or setter function
 155     ;; which is passed the object being displayed.
 156     ;; You can also use :SLOT-NAME
 157     ;; see ATTRIBUTE-VALUE for details.
 158     :getter #'find-title)
 159
 160    ;; our breadcrumb function renders itself,
 161    ;; and does not return a value.
 162    (breadcrumb
 163     ;; the FUNCTION type calls a function
 164     ;; again, passing the object.
 165     :type 'function
 166     :function #'render-breadcrumb
 167     ;; We need to specify IDENTITY here,
 168     ;; as the default :GETTER calls
 169     ;; SLOT-VALUE on the name of the attribute.
 170     :getter #'identity)
 171    ;; So we don't need a getter in INSTANCE.
 172    (instance
 173    ;; the DISPLAY type calls DISPLAY
 174    ;; passing the component and the object
 175    ;; along with any arguments specified using the
 176    ;; :DISPLAY property
 177     :type 'display
 178     :display '(:layers (+ show-attribute-labels)))
 179    ;; this is our menu, a custom attribute
 180    (menu
 181     :type 'crud-menu))
 182   (;; now we create a LINE in the default layer.
 183    ;; LINES describe how an object is displayed
 184    ;; when that layer is active.
 185    :in-layer
 186    t
 187    :attributes '(breadcrumb title menu instance)
 188    :layers '(- show-attribute-labels + crud)))
 189
 190
 191 ;;;; That's the basic outline of our app, now we fill in the blanks.
 192
 193 ;;;; ** Viewer
 194 (defcomponent crud-viewer (crud)
 195   ()
 196   (:documentation "A component for viewing objects"))
 197
 198 (defdisplay ((menu crud-menu) (crud crud-viewer))
 199   "Allow the user to edit and delete the object"
 200   (<:li (<ucw:a :action (delete-instance crud (instance crud))
 201                 (<:as-html "DELETE this object.")))
 202   (<:li (<ucw:a :action (update-instance crud (instance crud))
 203                 (<:as-html "EDIT this object."))))
 204
 205 ;;;; ** Editor
 206 ;;;; (use the same component for creating and editing,
 207 ;;;; with a little magic to make it all work.
 208 (defcomponent crud-editor (crud validation-mixin)
 209   ())
 210
 211 (defmethod/cc ensure-instance ((self crud-editor))
 212   "This one does a little magic, see SYNC-INSTANCE"
 213   (meta-model::sync-instance (instance self)))
 214
 215 (defmethod find-title ((crud crud-editor))
 216   (<:as-html "Editing a "
 217              (class-name (class-of (instance crud)))
 218              " ")
 219     (unless (meta-model:persistentp (instance crud))
 220     (<:as-html "(new)")))
 221
 222 (defattribute crud-editor-attribute (display-attribute)
 223   ()
 224   (:type-name crud-editor))
 225
 226 (defdisplay :around ((ed crud-editor-attribute) object)
 227  (with-active-layers (editor show-attribute-labels wrap-form)
 228    (call-next-method)))
 229
 230
 231 (defdescription crud-editor ()
 232   ((instance :type 'crud-editor))
 233   (:in-layer
 234    t
 235    :default-attributes
 236    `((instance
 237       :display
 238       (:form-buttons
 239       ((:value ,(if (meta-model:persistentp (instance self))
 240                      "Save"
 241                      "Create")
 242          :action ,(action (self object)
 243                     (ensure-instance self)
 244                     (answer (instance self))))
 245          (:value
 246           "Cancel"
 247           :action
 248           ,(action (self object)
 249             (setf (instance self) nil)
 250             (answer nil)))))))))
 251
 252 ;;;; ** Summary
 253 (defcomponent crud-summary (crud)
 254   ((class :accessor db-class :initarg :class)
 255    (limit :accessor row-limit :initform 25)
 256    (offset :accessor row-offset :initform 0)))
 257
 258 (defmethod find-title ((crud crud-summary))
 259   (format nil "Viewing Summary of ~A" (db-class crud)))
 260
 261 (defun find-some (class limit offset)
 262   (clsql:select class :limit limit  :offset offset :flatp t))
 263
 264 (defmethod find-summary ((crud crud-summary))
 265   (find-some (db-class crud)
 266              (row-limit crud)
 267              (row-offset crud)))
 268
 269 (defdescription crud-summary ()
 270   ()
 271   (:in-layer t
 272    ;;; here we show :default-attributes
 273    ;;; the attributes themselves can vary by layer
 274    ;;; the same syntax is supported in an :ATTRIBUTES form
 275    ;;; but that also specifies which attributes to display
 276    :default-attributes
 277    `((instance
 278       :getter ,#'find-summary
 279       :display
 280       (:layers (+ one-line)
 281        :list-item
 282         (:layers (+ lol::wrap-link + lol::show-attribute-labels)
 283          :link-action ,(action (self obj)
 284                         (call 'crud-viewer :instance obj))))))))
 285
 286 (defdisplay ((menu crud-menu) (object crud-summary))
 287    (<:li (<ucw:a
 288           :action (create-instance object (db-class object))
 289           (<:as-html "(Create New " (db-class object) ")"))))
 290
 291 (defmethod/cc call-crud-summary ((self component) class)
 292   (call 'crud-summary :class class))
 293
 294
 295 (defcomponent crud-database (crud)
 296   ())
 297
 298 (defdescription crud-database ()
 299   ((instructions
 300     :type 'string
 301     :getter (constantly "View Object Summary: "))
 302    (instance
 303     :type 'display
 304     :getter #'(lambda (obj)
 305                 (declare (ignore obj))
 306                 (meta-model::list-base-classes :clsql))
 307     :display `(:layers (+ one-line)
 308                        :list-item
 309                        (:layers (+ lol::wrap-link )
 310                         :link-action ,(action (self class)
 311                                        (call-crud-summary self class))))))
 312   (:in-layer
 313    t
 314    :attributes '(title menu instructions instance)))