ajax.lisp 9.42 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
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
;;
;; FLAG -- Undocumented. This will change.
;;
(defvar *snap-folder* 
  (or (probe-file (merge-pathnames "snaps/" "sys:"))
      (ensure-directories-exist (merge-pathnames "snaps/" (glisp:temporary-folder)))))

(defun restore-from-snap (iid)
  (let ((new-self
	 (let ((snap-file 
		(merge-pathnames 
		 (make-pathname :name (format nil "~a" iid) 
				:type "snap") *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)))))))
        
    (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!)
          
          ;;(evaluate-relevant-slots new-self)
          (format t "~%~%*************** Session ~a Restarted! ***************~%~%" (the-object new-self instance-id))
          (the-object new-self tree-manager restore-design-state!))
    
    ;;
    ;; 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))

    new-self))



65
66
67
68
69
(defun gdlAjax (req ent)

  (let* ((query-plist (gwl::assoc-list-to-plist (request-query req)))
         (plist (progn (when *debug?* (print-variables query-plist))
                       (read-safe-string 
70
                        (base64-decode-safe (coerce (getf query-plist :|args|) 'string)))))
71
72
73
74
         (fields 
          (progn (when *debug?* (print-variables plist))
                 (let ((encoded-fields
                        (read-safe-string 
75
                         (base64-decode-safe (coerce (getf query-plist :|fields|) 
76
77
78
79
80
81
82
                                                     'string)))))
                   (mapcan 
                    #'(lambda(key value)
                        (list key 
                              (if (or (glisp:match-regexp "^radio-" (format nil "~a" key))
                                      (glisp:match-regexp "-checkedp$" (format nil "~a" key)))
                                  value
83
				  (base64-decode-safe value))))
84
85
                    (plist-keys encoded-fields)
                    (plist-values encoded-fields)))))
86
87
         (raw-fields (getf query-plist :|raw-fields|))
         (iid (getf plist :|iid|))
88
         (self (first (gethash (make-keyword iid) gwl:*instance-hash-table*)))
89
90
91
92
93
94
95
96
97
	 
	 ;;
	 ;; Restore from snapshot if exists.
	 ;;
	 (self (or self (restore-from-snap iid)))
	 ;;
	 ;; FLAG If not exists, we don't handle that yet. 
	 ;;

98
         (plist (decode-from-ajax plist self))
99
         (bashee (getf plist :|bashee|))
100
         (respondent (progn (when *debug?* (print-variables plist))
101
102
103
                            (or (getf plist :|respondent|) bashee)))
         (function (getf plist :|function|))
         (arguments (getf plist :|arguments|)))
104
    
105

106
107
108
109
    
    (when *debug?*
      (let ((bashee-root (the-object bashee root-path))
            (respondent-root (the-object respondent root-path)))
Dave Cooper's avatar
Dave Cooper committed
110
        (print-variables raw-fields bashee-root respondent-root fields function)))
111
112

    
113
    (let ((*clicked-x* (let ((string (getf query-plist :|x|)))
114
                         (when string (ignore-errors (parse-integer string)))))
115
          (*clicked-y* (let ((string (getf query-plist :|y|)))
116
                         (when string (ignore-errors (parse-integer string))))))
117
      
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
      (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)))

      
      (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))))
139
140
141
      
      (quick-save self)
      
142
143
144
145
146
      (respond-with-new-html-sections req ent respondent))))


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

147
148
149
150
151
152
(defun quick-save (self &key (snap-folder *snap-folder*))
  (let ((snap-file 
	 (merge-pathnames 
	  (make-pathname :name (format nil "~a" (the instance-id))
			 :type "snap") snap-folder)))
    (the (write-snapshot :filename snap-file))))
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171


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


(defun respond-with-new-html-sections (req ent self ;;current-body-sans-sections
                                       )
  
  (let ((security-ok? (the root do-security-check)))
    (let (replace-list)
      (dolist (section (the html-sections) (reverse replace-list))
172
        (let ((status (the-object section (slot-status :inner-html)))
173
174
              (js-status (the-object section (slot-status :js-to-eval))))
        
175
          (when *debug?* (print-variables (the-object section root-path) status js-status))
176
177
178
179
180
181
182
        
          (when (or (eql status :unbound)
                    (eql js-status :unbound))
            (push (list (the-object section dom-id)
                        (let ((timeout? nil))
                          (multiple-value-bind (string error backtrace)
                              (ignore-errors-with-backtrace
183
                                (the-object section inner-html))
184
185
186
187
188
189
190
191
192
193
194
195
196
                            (cond ((typep error 'error)
                                   (with-output-to-string(ss)
                                     (with-html-output(ss)
                                       (:i (esc (format nil "!! This section threw error: ~a !!" 
                                                error)))
                                       (:pre (esc backtrace)))))
                                  (timeout?
                                   (with-output-to-string(ss)
                                     (with-html-output(ss)
                                       (:i (fmt "!! This section timed out after ~a seconds.
You can reload to get previous state" *ajax-timeout*))
                                       (:pre (esc backtrace)))))
                                  (t string))))
197
198
199
200
201
202
203
204
205
206
207
			(if t ;;(eql js-status :unbound)
			    (multiple-value-bind (string error)
				(ignore-errors (the-object section js-to-eval))
			      (if (typep error 'error)
				  (with-output-to-string(ss)
				    (with-html-output(ss)
				      (:i (fmt "alert('This section threw error: ~a !!');" error))))
				  (or string (the-object section js-always-to-eval) "")))
			    ""))
                  replace-list)))

208
	(when *debug?* (print-variables (the-object section js-always-to-eval))))
209
210


211
212
213
214
215
216
217
218
219
220
221
222
223
      (when *debug?* (print-variables replace-list))
        
    
      (with-http-response (req ent :content-type "text/xml")
        (with-http-body (req ent)
          (with-html-output(*html-stream* nil)
            (:document
             (dolist (replace-pair replace-list)
               (htm
                (:html-section (:|replaceId| (str (first replace-pair)))
                               (:|newHTML| (str (wrap-cdata (if security-ok?
                                                                (second replace-pair)
                                                              "<i>Security Error</i>"))))
224
225
226
227
                               (:|jsToEval| (when (third replace-pair)
					      (str (wrap-cdata (if security-ok?
								   (third replace-pair)
								   "")))))))))))))))
228
229
230
231
232
233
234
235
236

(defun remove-html-sections (sections string)
  (remove-substrings string (mapsend sections :main-div)))


(defun remove-substrings (string substrings)
  (let ((result string))
    (dolist (substring substrings result)
      (setq result (replace-substring result substring "")))))
237
238
239
240