Commit 7373e32e authored by Gail Zacharias's avatar Gail Zacharias
Browse files

Add remote object deletion protocol from agile

parent 13e28d61
......@@ -197,7 +197,22 @@
new-id rest-args)
:encode nil)))
:encode nil))
(publish :path "/delete-remote-object"
:server server
#'(lambda (args-list)
(let* ((current-id (getf :current-id args-list))
(object (gethash current-id *remote-objects-hash*)))
(cond (object
(remhash current-id *remote-objects-hash*)
(the-object object (set-slot! :remote-id nil :remember? nil :warn-on-non-toplevel? nil))
(t :unknown-id))))
:encode nil))
(pushnew 'publish-dgdl-funcs *publishers*)
......@@ -230,9 +245,9 @@
;;; FLAG -- Should *remote-proxies-hash* be a weak-on-value hash table?
(defmethod evaluate-object ((category (eql :remote-gdl-instance)) args)
(let ((hash-key (list (getf args :id) (getf args :root-path))))
(progn ;; bt:with-lock-held (*remote-proxy-lock*)
......@@ -240,6 +255,8 @@
(format t "~%~%~s Not found in hash - creating fresh ~%~%" (getf args :id))
(setf (gethash hash-key *remote-proxies-hash*)
;; Note that this avoids the usual request to create a new target on the remote
;; by specifying the :remote-id arg explicitly.
(gdl::make-object-internal 'remote-object
:%parent% (list nil nil t)
:%index% (list (getf args :index) nil t)
......@@ -31,6 +31,23 @@
(let ((*print-case* :downcase))
(base64-encode-list encoded-plist)))
(defun register-remote-object (obj)
(declare (ignore obj))
#+ccl (ccl:terminate-when-unreachable obj)
(defun do-remote-execute (request host port plist &key (decode t))
(let* ((encoded-plist (encode-plist-args plist))
(argstring (encode-plist-for-url encoded-plist))
(result (net.aserve.client:do-http-request
(format nil "http://~a:~a/~a?args=~a"
host port
request argstring))))
(if decode
(decode-from-http (read-safe-string (base64-decode-safe result)))
(read-safe-string result))))
(define-object remote-object (vanilla-remote)
:no-vanilla-mixin? t
......@@ -53,6 +70,7 @@
(let ((new-id (the (remote-execute "make-remote-object" plist :decode nil))))
(the (set-slot! :previous-id new-id :remember? nil :warn-on-non-toplevel? nil))
(register-remote-object self)
new-id))) :settable))
......@@ -83,16 +101,8 @@
(request plist &key (decode t))
(let* ((encoded-plist (encode-plist-args plist))
(argstring (encode-plist-for-url encoded-plist))
(result (net.aserve.client:do-http-request
(format nil "http://~a:~a/~a?args=~a"
(the host) (the port)
request argstring))))
(if decode
(decode-from-http (read-safe-string (base64-decode-safe result)))
(read-safe-string result))))
(do-remote-execute request (the host) (the port) plist :decode decode))
(message part-name child &rest args)
......@@ -160,6 +170,45 @@
(let ((result (the (remote-execute "send-remote-output" plist))))
(write-string result *stream*))))))
;; FLAG -- promote this to a generic glisp finalizer scheme
(defparameter *remotes-to-purge* nil)
(defparameter *remotes-to-purge-lock* (bt:make-lock))
(defmethod ccl:terminate ((object remote-object))
(let ((data (list (the-object object host)
(the-object object port)
(the-object object remote-id))))
(bt:with-lock-held (*remotes-to-purge-lock*)
(push data *remotes-to-purge*))))
(defun terminate-remotes ()
(let ((remote (bt:with-lock-held (*remotes-to-purge-lock*)
(pop *remotes-to-purge*))))
(unless remote (return))
(host port id) remote
(let ((result
(do-remote-execute "delete-remote-object" host port
(list :current-id (make-keyword id))
:decode nil)))
(unless (string-equal result "ok")
(warn "Terminate of ~a returned ~a.~%" id result)))))))
(defun launch-terminator ()
(bt:make-thread #'(lambda()
(do () ()
(sleep 5)
:name "remote terminator, wakes every 5 seconds and cleans up stale remotes."))
(defun decode-from-http (item)
(if (consp item)
(multiple-value-bind (object-type initargs) (destructure-object-from-http item)
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