ajax.lisp 11.1 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 63 64 65 66 67 68

	;;
	;; Force it to set html-sections.
	;;
	;; But, have to do the one at root-path as well if root-path is not nil. 
	;;
	(the-object new-self main-sheet-body)
	
69
	(the-object new-self custom-snap-restore!)
70
	  
71
	)
72
    
73 74 75 76 77
      ;;
      ;; 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))
78

79
      new-self)))
80

81
(defparameter *new-debug?* nil)
82

83 84 85
(defun gdlAjax (req ent)

  (let* ((query-plist (gwl::assoc-list-to-plist (request-query req)))
86 87 88 89
         (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)))))
90
         (fields 
91
          (progn (when *new-debug?* (print-variables plist))
92 93
                 (let ((encoded-fields
                        (read-safe-string 
94
                         (base64-decode-safe (coerce (getf query-plist :|fields|) 
95 96 97 98
                                                     'string)))))
                   (mapcan 
                    #'(lambda(key value)
                        (list key 
Dave Cooper's avatar
Dave Cooper committed
99 100
                              (if (or (glisp:match-regexp "^radio-" (string-downcase (format nil "~a" key)))
                                      (glisp:match-regexp "-checkedp$" (string-downcase (format nil "~a" key))))
101
                                  value
102
				  (base64-decode-safe value))))
103 104
                    (plist-keys encoded-fields)
                    (plist-values encoded-fields)))))
105 106
         (raw-fields (getf query-plist :|raw-fields|))
         (iid (getf plist :|iid|))
107

108
         (self (first (gethash (make-keyword-sensitive iid) gwl:*instance-hash-table*)))
109 110 111

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

112
	 (plist-raw plist)
113
         (plist (decode-from-ajax plist self))
114
         (bashee (getf plist :|bashee|))
115
         (respondent (progn (when *debug?* (print-variables plist))
116 117
                            (or (getf plist :|respondent|) bashee)))
         (function (getf plist :|function|))
118 119
	 (js-vals (let ((jsvals (getf query-plist :|jsvals|)))
		    (when jsvals (read-from-string jsvals))))
120
         (arguments (getf plist :|arguments|)))
121
    
122

123 124

    (setq *self* self)
125 126 127 128
    
    (when *debug?*
      (let ((bashee-root (the-object bashee root-path))
            (respondent-root (the-object respondent root-path)))
129 130
        (print-variables plist-raw plist raw-fields bashee-root respondent-root fields function)
	))
131 132

    
133
    (let ((*clicked-x* (let ((string (getf query-plist :|x|)))
134
                         (when string (ignore-errors (parse-integer string)))))
135
          (*clicked-y* (let ((string (getf query-plist :|y|)))
136 137
                         (when string (ignore-errors (parse-integer string)))))

138 139 140
	  (js-to-eval-previi (mapcar #'(lambda(section)
					   (the-object section js-to-eval))
				       (the-object respondent html-sections))))
141
      
142 143 144 145 146 147
      (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)))
148
      
149
      (when js-vals (the-object bashee (set-js-vals! js-vals)))
150 151 152 153 154 155 156 157 158 159 160 161 162 163
      
      (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))))
164
      
165 166
      (quick-save self)

167
      (respond-with-new-html-sections req ent respondent
168
				      :js-to-eval-previi js-to-eval-previi))))
169 170


171 172 173 174 175 176 177 178 179

(defun publish-gdlajax (server)
  (publish :path "/gdlAjax" :function 'gdlAjax :server server))


(pushnew 'publish-gdlajax *publishers*)
	     

#+nil
180 181 182 183
(defun publish-gdlajax ()
  (with-all-servers (server)
    (publish :path "/gdlAjax" :function 'gdlAjax :server server)))

184
;;(publish-gdlajax)
185 186 187 188 189

;;
;; FLAG -- remove this defunct version. 
;;
;; (publish :path "/gdlAjax" :function 'gdlAjax)
190 191 192 193 194 195 196 197 198 199 200 201 202


(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)
        ))))


203 204 205 206
(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!))

207 208 209 210 211
(defparameter *current-status* nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setq *current-status* *compile-dependency-tracking?*)
  (setq *compile-dependency-tracking?* nil))

212 213 214 215 216 217 218 219 220 221 222 223 224 225 226
(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))))
227
  
228 229 230
  :functions
  ((respond! 
    ()
231 232 233

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

234 235 236 237 238 239 240 241 242 243 244 245 246 247
    (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))
248 249
					     (:|newHTML| (str (if inner-html
								  (wrap-cdata (if (the security-ok?) inner-html
250
										  (with-cl-who-string ()
251 252 253
										    (:i "Security Error")))) "")))
					     (:|jsToEval| (str (if (and js-to-eval? (the security-ok?))
								   (wrap-cdata js-to-eval) "")))))))))
254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289
		   (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))))


290 291 292 293 294 295 296 297 298
		   (replace-list
		    (progn

		      (when *debug?* (print-variables (the stale?) (the section root-path)))
		      
		      (when (the stale?)
			(list :dom-id (the dom-id)
			      :inner-html (the inner-html)
			      :js-to-eval (the js-to-eval)))))))
299
		   
300 301 302
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setq *compile-dependency-tracking?* *current-status*))

303 304

#+nil
305 306 307
(defun remove-html-sections (sections string)
  (remove-substrings string (mapsend sections :main-div)))

308
#+nil
309 310 311 312
(defun remove-substrings (string substrings)
  (let ((result string))
    (dolist (substring substrings result)
      (setq result (replace-substring result substring "")))))
313 314 315 316