;;
;; 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)
(define-object remote-object (vanilla-remote)
:no-vanilla-mixin? t
:input-slots (remote-type (input-parameters nil) host port
(remote-root-path nil)
(remote-id (read-safe-string
(let* ((current-id (the previous-id))
(encoded-args (gwl:base64-encode-list
(encode-plist-args
(append (list :current-id current-id)
(the remote-object-args))))))
(let ((new-id
(read-safe-string (net.aserve.client:do-http-request
(format nil "http://~a:~a/make-remote-object?args=~a"
(the host) (the port) encoded-args)))))
(the (set-slot! :previous-id new-id :remember? nil :warn-on-non-toplevel? nil))
new-id))) :settable))
:computed-slots
((remote-object-args (append (list :type (format nil "~a::~a"
(package-name (symbol-package (the remote-type)) )
(symbol-name (the remote-type)))
:package *package*
:host (the host)
:name (the %name%)
:index (the index)
:parent-form (the parent-form)
:port (the port))
(the input-parameters)))
(parent-form (encode-for-http (the parent)))
(local-remote-id nil :settable)
(previous-id nil :settable))
:functions
((fetch-input
(message part-name child &rest args)
;;
;; FLAG -- *notify-cons* is going to be broken now... have to unmarshal/marshal from hash table.
;; hold off on doing this until we switch to an Abstract Associative Map.
;;
(let ((encoded-args (gwl:base64-encode-list (encode-plist-args (list :message (make-keyword message)
:part-name (make-keyword part-name)
:child (encode-for-http child)
:notify-cons (encode-for-http gdl::*notify-cons*)
:args args
:remote-id (the remote-id)
:remote-root-path (the remote-root-path)
:package *package*)))))
(multiple-value-bind
(result length)
(base64-decode-list
(net.aserve.client:do-http-request (format nil "http://~a:~a/fetch-remote-input?args=~a"
(the host) (the port) encoded-args)))
(declare (ignore length))
(if (listp result)
(if (keywordp (first result))
(evaluate-object (first result) (rest result))
(mapcar #'(lambda(item)
(evaluate-object (first item) (rest item))) result))
result))))
(unbind-remote-slot
(slot)
(let ((encoded-args (gwl:base64-encode-list
(encode-plist-args (list :slot slot
:remote-id (the remote-id)
:remote-root-path (the remote-root-path))))))
(multiple-value-bind
(result length)
(read-safe-string
(base64-decode-safe
(net.aserve.client:do-http-request (format nil "http://~a:~a/unbind-slots?args=~a"
(the host) (the port) encoded-args))))
(declare (ignore length))
(decode-from-http result))))
(send
(message &rest args)
(let ((encoded-args (gwl:base64-encode-list (encode-plist-args (list :message (make-keyword message)
:notify-cons (encode-for-http gdl::*notify-cons*)
:args args
:remote-id (the remote-id)
:remote-root-path (the remote-root-path)
:package *package*)))))
(multiple-value-bind
(result length)
(read-safe-string
(base64-decode-safe
(net.aserve.client:do-http-request (format nil "http://~a:~a/send-remote-message?args=~a"
(the host) (the port) encoded-args))))
(declare (ignore length))
;;
;; FLAG -- pass result through generic function to sanitize
;;
(let ((result (decode-from-http result)))
(cond ((and (consp result) (eql (first result) :error)
(eql (second result) :no-such-object))
(progn
(warn "~&Remote object returned error, creating a new one...~%")
(the (set-slot! :remote-id nil :warn-on-non-toplevel? nil))
(the (restore-slot-default! :remote-id))
(the (send (:apply (cons message args))))))
((and (consp result) (eql (first result) :error))
(format *error-output* "~&~%Remote object threw error:~%~%")
(error (format nil (second result))))
(t result))))))
(send-output
(message format &rest args)
(let ((encoded-args (gwl:base64-encode-list (encode-plist-args (list :message (make-keyword message)
:format format
:args args
:remote-id (the remote-id)
:remote-root-path (the remote-root-path)
:package *package*)))))
(multiple-value-bind
(result length)
(read-safe-string
(base64-decode-safe
(net.aserve.client:do-http-request (format nil "http://~a:~a/send-remote-output?args=~a"
(the host) (the port) encoded-args))))
(declare (ignore length))
(write-string result *stream*))))))
(defmethod decode-from-http ((item t)) item)
(defmethod decode-from-http ((list list))
(when list
(cond ((keywordp (first list)) (evaluate-object (first list) (rest list)))
(t (cons (decode-from-http (first list)) (decode-from-http (rest list)))))))
(defun encode-plist-args (plist)
(when plist
(cons (first plist)
(cons (encode-for-http (second plist)) (encode-plist-args (rest (rest plist)))))))
(defmethod encode-for-http ((item t)) item)
(defmethod encode-for-http ((item pathname))
(format nil "~a" item))
(defmethod encode-for-http ((item package))
(package-name item))
(defmethod encode-for-http ((item list))
(when item
(cons (encode-for-http (first item))
(encode-for-http (rest item)))))
(defmethod encode-for-http ((item base-format))
(let ((slots-plist (mapcan #'(lambda(slot-definition)
(let ((name (glisp:slot-definition-name slot-definition)))
(list (make-keyword name)
(encode-for-http (slot-value item name)))))
(glisp:class-slots (class-of item)))))
(append (list :type (class-name (class-of item))) slots-plist)))
;;
;; FLAG -- replace item with self and get rid of the-object
;;
(defmethod encode-for-http ((item gdl-remote))
(let ((id (or (the-object item root local-remote-id)
(let ((new-id (make-keyword (make-new-instance-id))))
(setf (gethash new-id *remote-objects-hash*) (the-object item root))
(the-object item root (set-slot! :local-remote-id new-id :remember? nil :warn-on-non-toplevel? nil))
new-id))))
(encode-object-for-http item id)))
(defmethod encode-for-http ((item gdl::gdl-basis))
(let ((id (or (the-object item root remote-id)
(let ((new-id (make-keyword (make-new-instance-id))))
(setf (gethash new-id *remote-objects-hash*) (the-object item root))
(the-object item root (set-slot! :remote-id new-id :remember? nil :warn-on-non-toplevel? nil))
new-id))))
(encode-object-for-http item id)))
(defun encode-object-for-http (item id)
(list :remote-gdl-instance
:id id
:index (the-object item index)
:type (format nil "~s" (the-object item type))
:root-path (the-object item root-path)
:host :unknown
:port (glisp:local-port
(slot-value (symbol-value (read-from-string "net.aserve:*wserver*"))
(read-from-string "net.aserve::socket")))))
(defmethod print-object ((object remote-object) stream)
(format stream "#, a.k.a. " (the-object object remote-type))
(call-next-method))