src/components/ajax.lisp

   1 (in-package :lisp-on-lines)
   2
   3 ;;;; for when there is nothing left to display.
   4 (defcomponent empty-page (window-component)
   5   ())
   6
   7 (defmethod render-on ((res response) (self empty-page))
   8   "didnt find a thing")
   9
  10 (defcomponent auto-complete ()
  11   ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
  12    (output-id :accessor output-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
  13    (client-value
  14     :accessor client-value
  15     :initform ""
  16     :documentation "The string the user has, so far, insterted.")
  17    (index
  18     :accessor index
  19     :initform nil
  20     :documentation "The index (for use with NTH) in list-of-values of the item selected via Ajax")
  21    (list-of-values
  22     :accessor list-of-values
  23     :initform '()
  24     :documentation "The list generated by values-generator")
  25    (values-generator :accessor values-generator :initarg :values-generator
  26                      :documentation "Function which, when passed the auto-complete component, returns a list of objects.")
  27    (value
  28     :accessor value
  29     :initform nil
  30     :documentation  "The lisp value of the object selecting in the drop down")
  31    (as-value :accessor as-value :initarg :as-value
  32              :documentation "Function which, when passed a value, returns the string to put in the text box.")
  33    (render-it :accessor render-it :initarg :render
  34            :documentation "Function which, when passed the component and one of the values render it (the value).")
  35    (input-size :accessor input-size :initarg :input-size :initform 20)
  36    (submit-on-select-p
  37     :accessor submit-on-select-p
  38     :initarg :submit-on-select-p
  39     :initform t)
  40    (output-component-name :accessor output-component-name :initarg :output-comonent-name :initform 'auto-complete-output)))
  41
  42 (defmethod js-on-complete ((l auto-complete))
  43   `(lambda (transport)
  44     (setf (slot-value (document.get-element-by-id ,(output-id l))
  45            'inner-h-t-m-l)
  46      transport.response-text)))
  47
  48 (defmacro make-action-url (component action)
  49   "
  50 There has got to be something like this buried in UCW somewhere,
  51 but here's what i use."
  52   `(ucw::print-uri-to-string
  53     (compute-url ,component
  54      :action-id (ucw::make-new-action (ucw::context.current-frame *context*)
  55                  (lambda ()
  56                    (arnesi:with-call/cc
  57                      ,action))))))
  58
  59 (defun generate-ajax-request (js-url &optional js-options)
  60   `(new
  61     (*Ajax.*Request
  62      ,js-url
  63      ,js-options)))
  64
  65 (defmacro with-ajax-request (js-url &rest js-options)
  66   `(generate-ajax-request-for-url
  67     ,js-url
  68     ,@js-options))
  69
  70 (defmacro with-ajax-action ((component) &body action)
  71   `(generate-ajax-request
  72     (make-action-url ,component (progn ,@action))))
  73
  74
  75 (defun make-auto-complete-url (input-id)
  76   "creates a url that calls the auto-complete entry-point for INPUT-ID."
  77   (format nil "auto-complete.ucw?&auto-complete-id=~A&~A=~A"
  78           input-id  "session"
  79           (ucw::session.id (ucw::context.session ucw::*context*))))
  80
  81 (defaction on-submit ((l auto-complete))
  82   ())
  83
  84 (defmethod js-on-select ((l auto-complete))
  85   "the javascript that is called when an item is selected"
  86   (when (submit-on-select-p l)
  87     `(progn
  88       (set-action-parameter ,(register-action
  89                               (lambda ()
  90                                   (arnesi:with-call/cc
  91                                     (on-submit l)))))
  92       (submit-form))))
  93
  94
  95 (defmethod render ( (l auto-complete))
  96   ;; session-values are stored in an eql hash table.
  97   (let ((input-key (intern (input-id l))))
  98     ;; We are storing the input components in the session,
  99     ;; keyed on the string that we also use as the id for
 100     ;; the input field.
 101
 102     (unless (get-session-value input-key)
 103       (setf (get-session-value input-key) l))
 104
 105     ;; A hidden field to hold the index number selected via javascript
 106     (<ucw:text :accessor (client-value l)
 107                :id (input-id l) :size (input-size l))
 108     (<:div :id (output-id l) :class "auto-complete" (<:as-html " ")))
 109   (let* ((a (make-symbol (format nil "~A-autocompleter" (input-id l))))
 110          (f (make-symbol (format nil "~A.select-entry-function"a))))
 111     (<ucw:script
 112      `(setf ,a
 113        (new
 114         (*Ajax.*Autocompleter
 115          ,(input-id l) ,(output-id l)
 116          ,(make-auto-complete-url (input-id l))
 117          (create
 118           :param-name "value"))))
 119      `(setf ,f (slot-value ,a 'select-entry))
 120      `(setf (slot-value ,a 'select-entry)
 121        (lambda ()
 122          (,f)
 123          ,(generate-ajax-request
 124            (make-auto-complete-url (input-id l))
 125            `(create
 126              :parameters (+ "&index=" (slot-value ,a 'index))
 127              :method "post"
 128              :on-complete (lambda (res)
 129                             ,(js-on-select l)))))))))
 130
 131
 132 ;;;; * auto-complete-ouput
 133
 134
 135 (defcomponent auto-complete-output (window-component)
 136   ((auto-complete :initarg :auto-complete :accessor auto-complete)))
 137
 138 (defmethod render ((output auto-complete-output))
 139   (let ((auto-complete (auto-complete output)))
 140     (setf (list-of-values auto-complete)
 141           (funcall (values-generator auto-complete) (client-value auto-complete)))
 142     (<:ul
 143      :class "auto-complete-list"
 144      (arnesi:dolist* (value (list-of-values auto-complete))
 145        (<:li
 146         :class "auto-complete-list-item"
 147         (funcall (render-it auto-complete) value))))
 148     (answer-component output t)))
 149
 150 (defcomponent fkey-auto-complete (auto-complete)
 151   ())
 152
 153 (defmethod js-on-select ((self fkey-auto-complete))
 154   (with-ajax-action (self)
 155     (mewa::sync-foreign-instance (ucw::parent self) (value self))))
 156
 157 (defslot-presentation ajax-foreign-key-slot-presentation (mewa::foreign-key-slot-presentation)
 158   ((original-value :accessor original-value :initform nil)
 159    (search-slots :accessor search-slots :initarg :search-slots :initform nil)
 160    (live-search
 161      :accessor live-search
 162      :component fkey-auto-complete))
 163   (:type-name ajax-foreign-key))
 164
 165
 166 (defmethod shared-initialize :after ((slot ajax-foreign-key-slot-presentation) slots &rest args)
 167   (let* ((l (live-search slot))
 168          (slot-name (slot-name slot))
 169          (instance (instance (ucw::parent slot)))
 170          (foreign-instance (explode-foreign-key instance slot-name))
 171          (class-name (class-name
 172                       (class-of foreign-instance))))
 173     ;; If no search-slots than use the any slots of type string
 174     (unless (search-slots slot)
 175       (setf (search-slots slot) (find-slots-of-type foreign-instance)))
 176
 177     (setf (lisp-on-lines::values-generator l)
 178           (lambda (input)
 179             (word-search class-name
 180                          (search-slots slot)  input)))
 181
 182     (setf (lisp-on-lines::render-it l)
 183           (lambda (val)
 184             (<ucw:render-component
 185              :component (make-presentation val :type :one-line))))))
 186
 187 (defaction revert-foreign-slot ((slot ajax-foreign-key-slot-presentation))
 188   (setf (lol::value (live-search slot)) nil)
 189   (when (original-value slot)
 190   (mewa::sync-foreign-instance slot (original-value slot))))
 191
 192 (defmethod present-slot :around ((slot ajax-foreign-key-slot-presentation) instance)
 193
 194   (let ((foreign-instance
 195          (if (lol::value (live-search slot))
 196              (lol::value (live-search slot))
 197              (setf (original-value slot)
 198                    (when (presentation-slot-value slot instance)
 199                      (meta-model:explode-foreign-key instance (slot-name slot)))))))
 200
 201     (flet ((render-s () (when foreign-instance (call-next-method))))
 202       (if (slot-boundp slot 'ucw::place)
 203           (cond
 204             ((editablep slot)
 205              (when  foreign-instance
 206                (setf (client-value (live-search slot))
 207                      (with-output-to-string (s)
 208                        (yaclml:with-yaclml-stream s
 209                          (present (make-presentation foreign-instance
 210                                                      :type :one-line))))))
 211
 212              (<ucw:render-component :component (live-search slot))
 213              #+ (or) (<ucw:submit :action (revert-foreign-slot slot)
 214                           :value "Undo")
 215                               (<ucw:submit :action  (mewa::search-records slot instance) :value "find" :style "display:inline"))
 216             ((mewa::linkedp slot)
 217              (<ucw:a :action (mewa::view-instance slot foreign-instance)
 218                      (render-s)))
 219             (t
 220              (render-s)))
 221           ;; presentation is used only for rendering
 222           (render-s)))))