Commit 1080076f authored by Dave Cooper's avatar Dave Cooper

Added experimental restoring of timed-out or missing sessions to gwlAjax.

parent 7cb0960d
......@@ -9,8 +9,8 @@
:depends-on (:gwl-graphics
:tasty
:robot
:yadd)
:components ((:file "source/try")))
:yadd))
......
......@@ -279,7 +279,7 @@
(let ((command
(format nil "\"~a\" -q -sDEVICE=~a \"-sOutputFile=~a\" -dTextAlphaBits=~a -dGraphicsAlphaBits=~a -dSAFER -dBATCH -dNOPAUSE \"~a\""
(format nil "\"~a\" -q -sDEVICE=~a \"-sOutputFile=~a\" -dTextAlphaBits=~a -dGraphicsAlphaBits=~a -dSAFER -dBATCH -dNOPAUSE \"~a\""
*gs-path* "jpeg" temp-jpeg *gs-text-alpha-bits*
*gs-graphics-alpha-bits* temp-pdf)))
(glisp:run-gs command))
......
......@@ -73,8 +73,11 @@
(defun run-gs (command)
"Shell out a ghostscript command and handle errors."
(let ((result
#+(and mswindows allegro) (excl:run-shell-command command :show-window :hide)
#-(and mswindows allegro) (run-program command :output (make-broadcast-stream))))
;;#+(and mswindows allegro) (excl:run-shell-command command :show-window :hide)
;;#-(and mswindows allegro) (run-program command :output (make-broadcast-stream))
(run-program command :output (make-broadcast-stream))
))
(unless (zerop result) (error "Ghostscript threw error"))))
(defun run-program (command &key output ignore-error-status force-shell
......
......@@ -22,6 +22,47 @@
(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)))
......@@ -46,6 +87,15 @@
(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))
......@@ -87,12 +137,20 @@
(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)
......@@ -181,17 +239,3 @@ You can reload to get previous state" *ajax-timeout*))
#+nil
(defun ajaxJSON (req ent)
(format t "At 1~%")
(let ((query-plist (gwl::assoc-list-to-plist (request-query req))))
(print-variables query-plist))
(respond-with-nothing req ent))
#+nil
(publish :path "/ajaxJSON" :function 'ajaxJSON)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment