;;
;; Copyright 2002-2011 Genworks International
;;
;; 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
;; .
;;
(in-package :gwl)
;;
;; 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))
(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
(base64-decode-safe (coerce (getf query-plist :|args|) 'string)))))
(fields
(progn (when *debug?* (print-variables plist))
(let ((encoded-fields
(read-safe-string
(base64-decode-safe (coerce (getf query-plist :|fields|)
'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
(base64-decode-safe value))))
(plist-keys encoded-fields)
(plist-values encoded-fields)))))
(raw-fields (getf query-plist :|raw-fields|))
(iid (getf plist :|iid|))
(self (first (gethash (make-keyword iid) gwl:*instance-hash-table*)))
;;
;; Restore from snapshot if exists.
;;
(self (or self (restore-from-snap iid)))
;;
;; FLAG If not exists, we don't handle that yet.
;;
(plist (decode-from-ajax plist self))
(bashee (getf plist :|bashee|))
(respondent (progn (when *debug?* (print-variables plist))
(or (getf plist :|respondent|) bashee)))
(function (getf plist :|function|))
(arguments (getf plist :|arguments|)))
(when *debug?*
(let ((bashee-root (the-object bashee root-path))
(respondent-root (the-object respondent root-path)))
(print-variables raw-fields bashee-root respondent-root fields function)))
(let ((*clicked-x* (let ((string (getf query-plist :|x|)))
(when string (ignore-errors (parse-integer string)))))
(*clicked-y* (let ((string (getf query-plist :|y|)))
(when string (ignore-errors (parse-integer string))))))
(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))))
(quick-save self)
(respond-with-new-html-sections req ent respondent))))
(publish :path "/gdlAjax" :function 'gdlAjax)
(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))))
(defun wrap-cdata (string)
(string-append ""))
(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))
(let ((status (the-object section (slot-status :inner-html)))
(js-status (the-object section (slot-status :js-to-eval))))
(when *debug?* (print-variables (the-object section root-path) status js-status))
(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
(the-object section inner-html))
(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))))
(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)))
(when *debug?* (print-variables (the-object section js-always-to-eval))))
(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)
"Security Error"))))
(:|jsToEval| (when (third replace-pair)
(str (wrap-cdata (if security-ok?
(third replace-pair)
"")))))))))))))))
(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 "")))))