ajax.lisp 10.4 KB
Newer Older
1
;;
2
;; Copyright 2002-2011 Genworks International 
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;; 
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file.  If not, see
;; <http://www.gnu.org/licenses/>.
;; 

(in-package :gwl)

24
(defparameter *ajax-snap-restore?* nil)
25

26
27
(defparameter *self* nil)

Dave Cooper's avatar
Dave Cooper committed
28
(defun quick-save (self &key (snap-folder (glisp:snap-folder)))
29
30
31
32
33
34
35
  (when *ajax-snap-restore?*
    (let ((snap-file 
	   (merge-pathnames 
	    (make-pathname :name (format nil "~a" (the instance-id))
			   :type "snap") snap-folder)))
      (with-error-handling ()
	(the (write-snapshot :filename snap-file))))))
36
37
38


(defun restore-from-snap (iid)
39
40
41
42
43
44
45
46
47
48
49
50
  (when *ajax-snap-restore?*
    (let ((new-self
	   (let ((snap-file 
		  (merge-pathnames 
		   (make-pathname :name (format nil "~a" iid) 
				  :type "snap") (glisp:snap-folder))))
	     (when (probe-file snap-file)
	       (with-error-handling ()
		 (read-snapshot :filename snap-file
				:keys-to-ignore (list :time-last-touched 
						      :time-instantiated 
						      :expires-at)))))))
51
        
52
53
54
55
56
57
      (when new-self
	(setf (gethash (make-keyword (the-object new-self instance-id)) *instance-hash-table*)
	      (list new-self nil))
	(when (typep new-self 'session-control-mixin) (the-object new-self set-expires-at))
	(the-object new-self set-instantiation-time!)
	(the-object new-self set-time-last-touched!)
58
          
59
60
	(format t "~%~%*************** Session ~a Restarted! ***************~%~%" 
		(the-object new-self instance-id))
61
	  
62
	(the-object new-self custom-snap-restore!)
63
	  
64
	)
65
    
66
67
68
69
70
      ;;
      ;; FLAG for testing only. 
      ;; return error object instead of just throwing an error here. 
      ;;
      (unless new-self (error "Restoring of session ~a was not possible.~%" iid))
71

72
      new-self)))
73

74
(defparameter *new-debug?* nil)
75

76
77
78
(defun gdlAjax (req ent)

  (let* ((query-plist (gwl::assoc-list-to-plist (request-query req)))
79
80
81
82
         (plist (progn ;;(when *debug?* (print-variables query-plist))
		  (when *new-debug?* (print-variables query-plist))
		  (read-safe-string 
		   (base64-decode-safe (coerce (getf query-plist :|args|) 'string)))))
83
         (fields 
84
          (progn (when *new-debug?* (print-variables plist))
85
86
                 (let ((encoded-fields
                        (read-safe-string 
87
                         (base64-decode-safe (coerce (getf query-plist :|fields|) 
88
89
90
91
                                                     'string)))))
                   (mapcan 
                    #'(lambda(key value)
                        (list key 
Dave Cooper's avatar
Dave Cooper committed
92
93
                              (if (or (glisp:match-regexp "^radio-" (string-downcase (format nil "~a" key)))
                                      (glisp:match-regexp "-checkedp$" (string-downcase (format nil "~a" key))))
94
                                  value
95
				  (base64-decode-safe value))))
96
97
                    (plist-keys encoded-fields)
                    (plist-values encoded-fields)))))
98
99
         (raw-fields (getf query-plist :|raw-fields|))
         (iid (getf plist :|iid|))
100

Dave Cooper's avatar
Dave Cooper committed
101
         (self (first (gethash (make-keyword-sensitive iid) gwl:*instance-hash-table*)))
102
103
104

	 (self (or self (restore-from-snap iid)))

105
	 (plist-raw plist)
106
         (plist (decode-from-ajax plist self))
107
         (bashee (getf plist :|bashee|))
108
         (respondent (progn (when *debug?* (print-variables plist))
109
110
                            (or (getf plist :|respondent|) bashee)))
         (function (getf plist :|function|))
111
112
	 (js-vals (let ((jsvals (getf query-plist :|jsvals|)))
		    (when jsvals (read-from-string jsvals))))
113
         (arguments (getf plist :|arguments|)))
114
    
115

116
117

    (setq *self* self)
118
119
120
121
    
    (when *debug?*
      (let ((bashee-root (the-object bashee root-path))
            (respondent-root (the-object respondent root-path)))
122
123
        (print-variables plist-raw plist raw-fields bashee-root respondent-root fields function)
	))
124
125

    
126
    (let ((*clicked-x* (let ((string (getf query-plist :|x|)))
127
                         (when string (ignore-errors (parse-integer string)))))
128
          (*clicked-y* (let ((string (getf query-plist :|y|)))
129
130
                         (when string (ignore-errors (parse-integer string)))))

131
132
133
	  (js-to-eval-previi (mapcar #'(lambda(section)
					   (the-object section js-to-eval))
				       (the-object respondent html-sections))))
134
      
135
136
137
138
139
140
      (let ((f-e-p (make-object 'form-element-processor 
                                :bashee bashee 
                                :query-plist (merge-plist-duplicates fields))))
        
        (the-object f-e-p  validate-and-set!)
        (when *debug?* (setq *f-e-p* f-e-p)))
141
      
142
      (when js-vals (the-object bashee (set-js-vals! js-vals)))
143
144
145
146
147
148
149
150
151
152
153
154
155
156
      
      (when function 
        (with-error-handling (:timeout *ajax-timeout*) 
          (the-object bashee ((evaluate function) (:apply arguments)))))

      (when (and respondent (the-object respondent root) 
                 (typep (the-object respondent root) 'session-control-mixin))
        (the-object respondent root (set-expires-at)))
      
      (when (and respondent (the-object respondent root) 
                 (the-object respondent root (set-time-last-touched!))))
      
      (when (and respondent (the-object respondent root) 
                 (the-object respondent root (set-remote-host! req))))
157
      
158
159
      (quick-save self)

160
      (respond-with-new-html-sections req ent respondent
161
				      :js-to-eval-previi js-to-eval-previi))))
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177


(publish :path "/gdlAjax" :function 'gdlAjax)


(defun wrap-cdata (string)
  (string-append "<![CDATA[" string "]]>"))


(defun respond-with-nothing (req ent)
  (with-http-response (req ent :content-type "text/xml")
    (with-http-body (req ent)
      (with-html-output(*html-stream* nil)
        ))))


178
179
180
181
(defun respond-with-new-html-sections (req ent respondent &key js-to-eval-previi)
  (the-object (make-object 'ajax-response :req req :ent ent :respondent respondent :js-to-eval-previi js-to-eval-previi)
	      respond!))

Dave Cooper's avatar
Dave Cooper committed
182
183
184
185
186
(defparameter *current-status* nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setq *current-status* *compile-dependency-tracking?*)
  (setq *compile-dependency-tracking?* nil))

187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
(define-object ajax-response ()

  :input-slots (req ent respondent (js-to-eval-previi nil))

  :computed-slots 
  ((security-ok? (the respondent root do-security-check))
   (replace-lists (mapsend (the html-sections) :replace-list))
   (html-section-objects (the respondent html-sections))
   (mismatch? (< (length (the js-to-eval-previi)) (length (the replace-lists)))))

  :objects
  ((html-sections :type 'html-replacement-section
		  :sequence (:size (length (the html-section-objects)))
		  :js-to-eval-previous (nth (the-child index) (the js-to-eval-previi))
		  :section (nth (the-child index) (the html-section-objects))))
202
  
203
204
205
  :functions
  ((respond! 
    ()
206
207
208

    (when *debug?* (print-messages replace-lists))

209
210
211
212
213
214
215
216
217
218
219
220
221
222
    (when (the mismatch?)
      (warn "the js-to-eval-previous is not the same length as html-section-objects in ~s~%" 
	    (the respondent)))
    (with-http-response ((the req) (the ent) :content-type "text/xml")
      (with-http-body ((the req) (the ent))
	(with-html-output (*html-stream* nil)
	  (:document
	     (mapc #'(lambda(replace-pair js-to-eval-status)
		       (declare (ignore js-to-eval-status)) ;; this can play into the flag
		       (destructuring-bind (&key dom-id inner-html js-to-eval) replace-pair
			 (let ((js-to-eval? (and js-to-eval (not (string-equal js-to-eval "")))))
			   (when (or inner-html js-to-eval?)
			     (htm
			      (:html-section (:|replaceId| (str dom-id))
223
224
					     (:|newHTML| (str (if inner-html
								  (wrap-cdata (if (the security-ok?) inner-html
225
										  (with-cl-who-string ()
226
227
228
										    (:i "Security Error")))) "")))
					     (:|jsToEval| (str (if (and js-to-eval? (the security-ok?))
								   (wrap-cdata js-to-eval) "")))))))))
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
		   (the replace-lists) (the js-to-eval-previi)))))))))


(define-object html-replacement-section ()
  :input-slots (section js-to-eval-previous)
  :computed-slots ((status (the section (slot-status :inner-html)))
		   (js-status (the section (slot-status :js-to-eval)))
		   (stale? (or (eql (the status) :unbound)
			       (eql (the js-status) :unbound)))

		   (dom-id (the section dom-id))

		   (inner-html (when (eql (the status) :unbound)
				 (let ((timeout? nil))
				   (multiple-value-bind (value error backtrace)
				       (ignore-errors-with-backtrace (the section inner-html))
				     (cond ((typep error 'error)
					    (with-cl-who-string () 
					      (:i (esc (format nil "!! This section threw error: ~a !!" 
							       error)))
					      (:pre (esc backtrace))))
					   (timeout?
					    (with-cl-who-string ()
					      (:i (fmt "!! This section timed out after ~a seconds.
You can reload to get previous state" *ajax-timeout*))
					      (:pre (esc backtrace))))
					   (t value))))))

		   (js-to-eval (multiple-value-bind (value error)
				   (ignore-errors (the section js-to-eval))
				 (if (typep error 'error)
				     (with-cl-who-string ()
				       (:i (fmt "alert('This section threw error: ~a !!');" error)))
				     (if (equalp value :parse) "parseme" value))))


		   (replace-list (when (the stale?)
				   (list :dom-id (the dom-id)
					 :inner-html (the inner-html)
					 :js-to-eval (the js-to-eval))))))
		   
Dave Cooper's avatar
Dave Cooper committed
270
271
272
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setq *compile-dependency-tracking?* *current-status*))

273
274

#+nil
275
276
277
(defun remove-html-sections (sections string)
  (remove-substrings string (mapsend sections :main-div)))

278
#+nil
279
280
281
282
(defun remove-substrings (string substrings)
  (let ((result string))
    (dolist (substring substrings result)
      (setq result (replace-substring result substring "")))))
283
284
285
286