Commit 8b198685 authored by Dave Cooper's avatar Dave Cooper

Merge branch 'devo' of gitlab.common-lisp.net:gendl/gendl into devo

parents cd799515 af38fd75
......@@ -140,7 +140,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:cyclic-nth
#:decode-for-http
#:defaulting
#:defcompanion
;;#:defcompanion
#:define-color-set
#:define-colored-icon
#:define-format
......@@ -154,8 +154,8 @@ If you are interested in this effort we would love to hear from you at open-sour
#:define-skin
#:define-view
#:definition-tree
#:defpart
#:defwriter
;;#:defpart
;;#:defwriter
#:distribute
#:distribute-dir
#:div
......@@ -190,7 +190,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:keywordize-plist
#:lastcar
#:least
#:let-streams
;;#:let-streams
#:list-elements
#:list-hash
#:list-of-numbers
......@@ -284,6 +284,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:version-sequence
#:with-error-handling
#:with-format
#:with-writer
#:with-format-slots
#:with-oracle
#:with-version
......
......@@ -35,6 +35,12 @@
(defmethod decode-plist-from-url ((syntax (eql :lisp)) argstring)
(base64-decode-list argstring))
(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)))
(defparameter *remote-syntax* nil)
(defun remote-function-handler (handler &key (encode t)) ;;&optional lock
......@@ -57,6 +63,17 @@
(html (format *html-stream* "~a" encoded-value)))
(html (format *html-stream* "~s" value)))))))))))
(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))
(defun publish-dgdl-funcs (server)
(publish-file :path "/favicon.ico"
......@@ -66,8 +83,65 @@
(merge-pathnames "gwl/static/gwl/images/favicon.ico" glisp:*gendl-source-home*)
(merge-pathnames "static/gwl/images/favicon.ico" glisp:*gdl-home*))))
(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))))
(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))))))))
#+nil
(publish :path "/fetch-remote-input"
:server server
:function
......
......@@ -27,12 +27,62 @@
(defparameter *make-object-plist* nil)
(defparameter *fetch-plist* nil)
(defvar *preferred-remote-syntax* :lisp)
(defvar *preferred-remote-syntax* :lisp) ;; or :json
(defmethod encode-plist-for-url ((syntax (eql :lisp)) encoded-plist)
(let ((*print-case* :downcase))
(base64-encode-list encoded-plist)))
(defun upcase-plist (plist)
(mapcan #'(lambda(key value)
(list (make-keyword (string-upcase key))
(cond ((keywordp value) (make-keyword (string-upcase value)))
((symbolp value)
(cond ((null value) nil)
(t (string-upcase
(string
(intern (string value)
(symbol-package value)))))))
((consp value) (upcase-plist value))
((stringp value) value)
(t value))))
(plist-keys plist) (plist-values plist)))
(defmethod encode-plist-for-url ((syntax (eql :json)) plist)
(let ((yason-string (with-output-to-string (s)
(yason:encode (yasonify plist) s))))
(base64-encode-safe (format nil "~s" yason-string))))
(defun yasonify (value)
(cond ((or (null value) (eql value t) (numberp value) (stringp value)) value)
((vectorp value) (map 'vector #'yasonify value))
((atom value) (let ((*print-readably* t)) (format nil "~s" value)))
((and (keywordp (car value)) (evenp (length value)))
(loop with hash = (make-hash-table :test 'equal)
for (key val) on value by #'cddr
do (setf (gethash (symbol-name key) hash) (yasonify val))
finally (print-hash hash) (return hash)))
(t (mapcar #'yasonify value))))
#+nil
(defun yasonify (value)
(cond ((or (null value) (eql value t) (numberp value) (stringp value)) value)
((vectorp value) (map 'vector #'yasonify value))
((atom value) (let ((*print-readably* t)) (format nil "~s" value)))
((and (keywordp (car value)) (evenp (length value)))
(loop with hash = (make-hash-table :test 'equal)
for (key val) on value by #'cddr
do (setf (gethash (symbol-name key) hash) (yasonify val))
finally (return hash)))
(t (mapcar #'yasonify value))))
(defun register-remote-object (obj)
(declare (ignore obj))
#+ccl (ccl:terminate-when-unreachable obj)
......@@ -228,6 +278,9 @@
;; with mlisp slave.
;;
(let ((*print-case* :downcase))
#+allegro
(when (eql excl:*current-case-mode* :case-sensitive-lower)
(setq plist (upcase-plist plist)))
(when plist
(cons (first plist)
(cons (encode-for-http (second plist)) (encode-plist-args (rest (rest plist))))))))
......
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