publish.lisp 16.9 KB
Newer Older
1
;;
2
;; Copyright 2002-2011 Genworks International
3 4 5 6 7 8 9 10
;;
;; 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.
11
;;
12 13 14 15
;; 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.
16
;;
17 18 19
;; 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/>.
20
;;
21 22 23 24 25 26 27



(in-package :gwl)

(defparameter *bug* nil)

Dave Cooper's avatar
Dave Cooper committed
28 29 30 31 32
(defparameter *remote-hash-lock* (bt:make-lock "remote-hash-lock"))
(defparameter *remote-proxy-lock* (bt:make-lock "remote-proxy-lock"))
(defparameter *remote-evaluate-lock* (bt:make-lock "remote-evaluate-lock"))
(defparameter *remote-fetch-input-lock* (bt:make-lock "remote-fetch-input-lock"))

33 34
(defparameter *request-server-ipaddr* nil)

35
(defmethod decode-plist-from-url ((syntax (eql :lisp)) argstring)
36
  (base64-decode-list argstring))
37

38 39 40 41 42 43
(defmethod decode-plist-from-url ((syntax (eql :json)) string)
  (let* ((argstring (base64-decode-safe string))
         (yason-string (read-safe-string argstring))
         (plist (yason:parse yason-string :object-key-fn #'make-keyword :object-as :plist)))
    (unstringify-plist plist)))

44 45
(defparameter *remote-syntax* nil)

46

47 48 49 50 51 52 53 54
(defun remote-function-handler (handler &key (encode t)) ;;&optional lock
  #'(lambda (req ent)
      (progn ;; bt:with-lock-held (lock)
        (let* ((socket (request-socket req))
               (*request-server-ipaddr* (socket:ipaddr-to-dotted (socket:local-host socket)))
               (*ipaddr* (socket:ipaddr-to-dotted (socket:remote-host socket)))
               (query (request-query req))
               (args (rest (assoc "args" query :test #'string-equal)))
55 56 57
               (syntax-string (rest (assoc "syntax" query :test #'string-equal)))
               (*remote-syntax* (if syntax-string (read-safe-string syntax-string) :json))
               (args-list (decode-plist-from-url *remote-syntax* args)))
58 59
	  (when (eql excl:*current-case-mode* :case-sensitive-lower)
		(setq args-list (downcase-plist args-list)))
60 61 62 63 64 65 66 67 68
          (glisp:with-heuristic-case-mode ()
            (with-http-response (req ent)
              (with-http-body (req ent)
                (let ((value (funcall handler args-list)))
                  (if encode
                      (let ((encoded-value (base64-encode-safe (format nil "~s" (encode-for-http value)))))
                        (html (format *html-stream* "~a" encoded-value)))
                      (html (format *html-stream* "~s" value)))))))))))

69 70 71 72 73 74 75 76 77 78 79

(defun igetf (plist key)
    (or (getf plist key)
	(getf plist (make-keyword (string-upcase key)))))

(defun normalize-case (string)
  (print-variables string)
  #-allegro string
  #+allegro (if (eql excl:*current-case-mode* :case-sensitive-lower)
		(string-downcase string) string))

80 81
(defun publish-dgdl-funcs (server)
  
82 83
  (publish-file :path "/favicon.ico"
                :server server
84
                :file (format nil "~a"
85 86
			      (if glisp:*genworks-source-home*
				  (merge-pathnames "gwl/static/gwl/images/favicon.ico" glisp:*gendl-source-home*)
87
				  (merge-pathnames "static/gwl/images/favicon.ico" glisp:*gdl-home*))))
88

89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
  



  (publish :path "/fetch-remote-input"
	   :server server
	   :function
           (remote-function-handler
            #'(lambda (args-list)
                ;;
                ;; FLAG -- consider a warning if package not found
                ;;
                (let ((*package* (or (find-package (igetf args-list :package)) *package*)))
                  (let* ((object (the-object (gethash (let ((id (igetf args-list :remote-id)))
							#+allegro (when (eql excl:*current-case-mode* :case-sensitive-lower)
								    (setq id (make-keyword (string-downcase id))))
							(print-variables id)
							id)
						      *remote-objects-hash*)
                                             (follow-root-path (igetf args-list :remote-root-path))))

                         (part-name (make-keyword (normalize-case (igetf args-list :part-name))))
111

112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145
                         (index (igetf args-list :index))

                         (child (if index
                                    (the-object object ((evaluate part-name) index))
                                    (the-object object (evaluate part-name))))

                         (message (igetf args-list :message))
                         (gdl::*notify-cons* (decode-from-http (igetf args-list :notify-cons)))

                         (args (igetf args-list :args)))
                    (if object (multiple-value-bind (value error)
                                   (ignore-errors
                                     (apply (symbol-function (glisp:intern (normalize-case message) :gdl-inputs))
                                            object (glisp:intern (normalize-case part-name) :gdl-acc) child args))
                                 (if (typep error 'error)
                                     (let ((error-string
                                            (glisp:replace-regexp
                                             (format nil "~a" error) "\\n" " ")))
                                       (cond ((or (search "could not handle"
                                                          error-string)
                                                  #+nil
                                                  (search "which is the root"
                                                          error-string)
                                                  (search "instances could handle"
                                                          error-string))
                                              'gdl-rule:%not-handled%)
                                             (t (when *debug?*
                                                  (format t "Throwing error on fetch-input server because gwl::*debug?* is set to non-nil~%")
                                                  (error error))
                                                (list :error (format nil "~a" error)))))
                                     value))
                        (list :error :no-such-object (igetf args-list :remote-id))))))))

  
146

147
  #+nil
148 149 150
  (publish :path "/fetch-remote-input"
	   :server server
	   :function
151 152 153 154 155 156 157 158 159 160 161
           (remote-function-handler
            #'(lambda (args-list)
                ;;
                ;; FLAG -- consider a warning if package not found
                ;;
                (let ((*package* (or (find-package (getf args-list :package)) *package*)))
                  (let* ((object (the-object (gethash (getf args-list :remote-id) *remote-objects-hash*)
                                             (follow-root-path (getf args-list :remote-root-path))))

                         (part-name (getf args-list :part-name))

162
                         (index (getf args-list :index))
163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193

                         (child (if index
                                    (the-object object ((evaluate part-name) index))
                                    (the-object object (evaluate part-name))))

                         (message (getf args-list :message))
                         (gdl::*notify-cons* (decode-from-http (getf args-list :notify-cons)))

                         (args (getf args-list :args)))
                    (if object (multiple-value-bind (value error)
                                   (ignore-errors
                                     (apply (symbol-function (glisp:intern message :gdl-inputs))
                                            object (glisp:intern part-name :gdl-acc) child args))
                                 (if (typep error 'error)
                                     (let ((error-string
                                            (glisp:replace-regexp
                                             (format nil "~a" error) "\\n" " ")))
                                       (cond ((or (search "could not handle"
                                                          error-string)
                                                  #+nil
                                                  (search "which is the root"
                                                          error-string)
                                                  (search "instances could handle"
                                                          error-string))
                                              'gdl-rule:%not-handled%)
                                             (t (when *debug?*
                                                  (format t "Throwing error on fetch-input server because gwl::*debug?* is set to non-nil~%")
                                                  (error error))
                                                (list :error (format nil "~a" error)))))
                                     value))
                        (list :error :no-such-object (getf args-list :remote-id))))))))
194 195 196 197 198


  (publish :path "/unbind-slots"
	   :server server
	   :function
199 200 201 202 203 204 205 206 207 208 209
           (remote-function-handler
            #'(lambda (args-list)
                (let ((object (let ((root (the-object (gethash (getf args-list :remote-id)
                                                               *remote-objects-hash*))))
                                (when root (the-object root (follow-root-path
                                                             (getf args-list :remote-root-path))))))
                      (slot (getf args-list :slot)))

                  (when object (gdl::unbind-dependent-slots object slot))

                  nil))))
210 211 212 213


  (publish :path "/send-remote-message"
	   :server server
214
	   :function (remote-function-handler 'send-remote-message))
215 216 217 218 219



  (publish :path "/send-remote-output"
	   :server server
220 221 222 223 224 225 226 227 228 229 230 231 232 233
	   :function
           (remote-function-handler
            #'(lambda (args-list)
                (let ((*package* (or (find-package (getf args-list :package)) *package*)))
                  (let ((object (the-object (gethash (getf args-list :remote-id) *remote-objects-hash*)
                                            (follow-root-path (getf args-list :remote-root-path))))
                        (*%format%* (apply #'make-instance (getf (getf args-list :format) :type)
                                           (decode-from-http (rest (rest (getf args-list :format))))))
                        (message (getf args-list :message))
                        (args (getf args-list :args)))
                    (with-output-to-string (*stream*)
                      (apply (glisp:intern message :gdl-output)
                             *%format%* object  t ;; flag pick up skin
                             args)))))))
234 235 236 237 238 239 240 241

  ;;
  ;; FLAG -- return proper error when requested object type does not exist
  ;; or make-object fails for any other reason.
  ;;
  (publish :path "/make-remote-object"
	   :server server
	   :function
242 243 244 245 246 247 248 249 250 251 252 253 254 255 256
           (remote-function-handler
            #'(lambda (args-list)
                (when *debug?*
                  (format t "~%In make-remote-object response func:~%")
                  (print-variables args-list))

                (let ((*package* (or (find-package (getf args-list :package)) *package*))
                      (name (getf args-list :name))
                      (index (getf args-list :index))
                      (rest-args (remove-plist-keys args-list
                                                    (list :parent-form :current-id  :name :index
                                                          :type :package :host :port)))
                      (current-id (getf args-list :current-id))
                      (parent-form (getf args-list :parent-form)))

257 258 259 260
                  (setf parent-form
                        (multiple-value-bind (type plist) (destructure-object-from-http parent-form)
                          (setf (getf plist :host) *ipaddr*)
                          (construct-object-for-http type plist)))
261 262 263 264 265 266 267 268 269 270 271 272 273 274

                  (when current-id
                    (let ((removed? (remhash current-id *remote-objects-hash*)))
                      (when removed?
                        (format t "~&~%Removed stale remote object with ID ~s.~%~%" current-id))))
                  (let ((object (make-object (read-safe-string (getf args-list :type))

                                             :type (read-safe-string (getf args-list :type))))
                        (new-id (make-keyword (make-new-instance-id))))

                    (the-object object (set-slot! :%name% name :warn-on-non-toplevel? nil))
                    (the-object object (set-slot! :remote-id new-id :remember? nil :warn-on-non-toplevel? nil))
                    (the-object object (set-slot! :%index% index :warn-on-non-toplevel? nil))
                    (setf (slot-value object 'gdl-acc::%parent%)
275
                          (list (decode-from-http parent-form) nil t))
276 277
                    (setf (gethash new-id *remote-objects-hash*) object)
                    (format t "~&~%Created new remote object with ID ~s and arglist:
278
~s~%~%"
279 280
                            new-id rest-args)
                    new-id)))
281 282 283 284 285 286 287
            :encode nil))

  (publish :path "/delete-remote-object"
	   :server server
	   :function
           (remote-function-handler
            #'(lambda (args-list)
Dave Cooper's avatar
Dave Cooper committed
288
                (let* ((current-id (getf args-list :current-id))
289 290 291 292 293 294 295 296
                       (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))
                         :ok)
                        (t :unknown-id))))
            :encode nil))
)
297

298
(pushnew 'publish-dgdl-funcs *publishers*)
299

300 301 302 303 304
(defun send-remote-message (args-list)
  (when *debug?*
    (format t "~%In send-remote-message-object response func:~%")
    (print-variables args-list *ipaddr* *request-server-ipaddr*))

305
  
306 307 308 309 310 311 312 313
  (let ((*package* (or (find-package (getf args-list :package)) *package*)))
    (let ((object (when (gethash (getf args-list :remote-id) *remote-objects-hash*)
                    (the-object (gethash (getf args-list :remote-id) *remote-objects-hash*)
                                (follow-root-path (getf args-list :remote-root-path)))))
          (message (getf args-list :message))
          (gdl::*notify-cons* (decode-from-http (getf args-list :notify-cons)))
          (args (getf args-list :args)))

314 315
      (when *debug?* (print-variables args))
      
316 317 318 319 320 321 322 323 324 325 326 327 328
      (if object (multiple-value-bind (value error)
                     (progn ;; bt:with-lock-held (*remote-evaluate-lock*)
                       (ignore-errors (if args
                                          (the-object object ((evaluate message)
                                                              (:apply args)))
                                          (the-object object (evaluate message)))))

                   (if (typep error 'error)
                       (progn
                         (when *debug?* (error error))
                         (list :error (format nil "~a" error)))
                       value))
          (list :error :no-such-object (getf args-list :remote-id))))))
329

Dave Cooper's avatar
Dave Cooper committed
330 331


332 333 334
;;;
;;; FLAG -- Should  *remote-proxies-hash* be a weak-on-value hash table?
;;;
335 336
(defmethod evaluate-object ((category (eql :remote-gdl-instance)) args)
  (let ((hash-key (list (getf args :id) (getf args :root-path))))
337
    (progn ;; bt:with-lock-held (*remote-proxy-lock*)
Dave Cooper's avatar
Dave Cooper committed
338 339 340 341
      (or (gethash hash-key gwl::*remote-proxies-hash* )
	  (progn
	    (format t "~%~%~s Not found in hash - creating fresh ~%~%" (getf args :id))
	    (setf (gethash hash-key *remote-proxies-hash*)
342 343
                  ;; Note that this avoids the usual request to create a new target on the remote
                  ;; by specifying the :remote-id arg explicitly.
Dave Cooper's avatar
Dave Cooper committed
344 345 346 347 348 349 350 351 352 353
		  (gdl::make-object-internal 'remote-object
					     :%parent% (list nil nil t)
					     :%index% (list (getf args :index) nil t)
					     :remote-id (list (getf args :id) nil t)
					     :host (list (or *ipaddr* (getf args :host)) nil t)
					     :port (list (getf args :port) nil t)
					     :remote-root-path (list (getf args :root-path) nil t)
					     :remote-type (list (multiple-value-bind (result error)
								    (ignore-errors (read-from-string (getf args :type)))
								  (if (typep error 'error) :unknown result)) nil t))))))))
354

355 356 357 358 359


(defun clear-dgdl ()
  (clrhash *remote-proxies-hash*)
  (clrhash *remote-objects-hash*))