Support receiving script results.

clog-connection.lisp

@@ -11,6 +11,7 @@
 ;; Exports - clog-connection
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+
 (mgl-pax:define-package :clog-connection
   (:documentation "The Common List Omnificent GUI - Connection")
   (:use #:cl #:mgl-pax))
@@ -22,31 +23,41 @@
 
   "CLOG connections"
   
-  (message        function)
-  (execute-script function)
+  (execute  function)
+  (query    function)
   (validp   function)
   (cclose   function)
   (shutdown function)
   (cwrite   function)
   (cwriteln function))
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Implemetation - clog-connection
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
 ;;;;;;;;;;;;;
-;; message ;;
+;; execute ;;
 ;;;;;;;;;;;;;
 
-(defun message (connection-id message)
-  "Send MESSAGE to CONNECTION-ID."
+(defun execute (connection-id message)
+  "Execute SCRIPT on CONNECTION-ID, disregard return value."
   (let ((con (clog::get-connection connection-id)))
     (when con
       (websocket-driver:send con message))))
 
-;;;;;;;;;;;;;;;;;;;;
-;; execute-script ;;
-;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;
+;; query ;;
+;;;;;;;;;;;
 
-(defun execute-script (connection-id script)
-  "Execute SCRIPT on CONNECTION-ID, disregard return value."
-  (message connection-id script))
+(defun query (connection-id script)
+  "Execute SCRIPT on CONNECTION-ID, return value."
+  (let ((uid (clog::generate-connection-id)))
+    (clog::store-query uid nil)
+    (execute connection-id
+	     (format nil "ws.send (\"~A:\"+eval(\"~A\"));" uid script))
+    (clog::wait-for-answer uid)))
 
 ;;;;;;;;;;;;
 ;; validp ;;
@@ -65,7 +76,7 @@
 (defun cclose (connection-id)
   "Close connection to CONNECTION-ID. The boot file may try to reistablish
  connectivity."
-  (execute-script connection-id "ws.close()"))
+  (execute connection-id "ws.close()"))
 
 ;;;;;;;;;;;;;;
 ;; shutdown ;;
@@ -74,7 +85,7 @@
 (defun shutdown (connection-id)
   "Shutdown connection to CONNECTION-ID. The boot file may not try to
 reistablish connectivity."
-  (execute-script connection-id "Shutdown_ws(event.reason='user')"))
+  (execute connection-id "Shutdown_ws(event.reason='user')"))
 
 ;;;;;;;;;;;;
 ;; cwrite ;;
@@ -82,7 +93,7 @@ reistablish connectivity."
 
 (defun cwrite (connection-id text)
   "Write TEXT raw to document object of CONNECTION-ID with out new line."
-  (message connection-id (format nil "document.write('~A');" text)))
+  (execute connection-id (format nil "document.write('~A');" text)))
 
 ;;;;;;;;;;;;;;
 ;; cwriteln ;;
@@ -90,4 +101,4 @@ reistablish connectivity."
 
 (defun cwriteln (connection-id text)
   "Write TEXT raw to document object of CONNECTION-ID with new line."
-  (message connection-id (format nil "document.writeln('~A');" text)))
+  (execute connection-id (format nil "document.writeln('~A');" text)))

clog.lisp

@@ -59,11 +59,14 @@ application."
 (defvar *connection-lock* (bordeaux-threads:make-lock)
   "Protect the connection hash tables")
 
+(defvar *queries* (make-hash-table) "Waiting queries")
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; generate-connection-id ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun generate-connection-id ()
+  "Generate unique ids for use in connections and sripts. (Private)"
   (incf *new-id*))
 
 ;;;;;;;;;;;;;;;;;;;;
@@ -102,9 +105,35 @@ application."
 ;; handle-message ;;
 ;;;;;;;;;;;;;;;;;;;;
 
+(defvar *queries-lock* (bordeaux-threads:make-lock))
+(defvar *queries-sems* (make-hash-table))
+
+(defun store-query (id answer)
+  (bordeaux-threads:with-lock-held (*queries-lock*)
+    (setf (gethash id *queries-sems*) (bordeaux-threads:make-semaphore))
+    (setf (gethash id *queries*) answer)))
+
+(defun wait-for-answer (id)
+  (bordeaux-threads:wait-on-semaphore (gethash id *queries-sems*) :timeout 3)
+  (let ((answer (gethash id *queries*)))
+    (bordeaux-threads:with-lock-held (*queries-lock*)
+      (remhash id *queries*)
+      (remhash id *queries-sems*))
+    answer))
+
 (defun handle-message (connection message)
-  (let ((id (gethash connection *connections*)))
-    (format t "msg: ~A sent ~A - ~A~%" id message connection)))
+  (let ((id (gethash connection *connections*))
+	(ml (ppcre:split ":" message :limit 2)))
+    (cond ((equal (car ml) "0")
+	   (when *verbose-output*
+	     (format t "~A Ping ~A~%" id (car ml))))
+	  (t
+	   (when *verbose-output*
+	     (format t "~A ~A = ~A~%" id (car ml) (cadr ml)))
+	   (bordeaux-threads:with-lock-held (*queries-lock*)
+	     (setf (gethash (parse-integer (car ml)) *queries*) (cadr ml)))
+	   (bordeaux-threads:signal-semaphore
+	    (gethash (parse-integer (car ml)) *queries-sems*))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; handle-close-connection ;;
@@ -156,9 +185,7 @@ application."
   "Inititalze CLOG on a socket using HOST and PORT to serve BOOT-FILE as 
 the default route to establish web-socket connections and static files
 located at STATIC-ROOT."
-
   (set-on-connect on-connect-handler)  
-  
   (setf *app*
 	(lack:builder
 	 (:static :path (lambda (path)
@@ -168,14 +195,11 @@ located at STATIC-ROOT."
 		  :root static-root)
 	 (lambda (env)
 	   (clog-server env))))
-  
   (setf *client-handler* (clack:clackup *app* :address host :port port))
-
   (when *verbose-output*
-    (progn
     (format t "HTTP listening on : ~A:~A~%" host port)
     (format t "HTML Root         : ~A~%"    static-root)
-      (format t "Boot file default : ~A~%"    boot-file))))
+    (format t "Boot file default : ~A~%"    boot-file)))
 
 ;;;;;;;;;;;;;;
 ;; shutdown ;;

test/test-clog.lisp

@@ -1,10 +1,10 @@
 (defpackage #:test-clog
   (:use #:cl)
-  (:export test-connect on-connect))
+  (:export test-connect on-connect1 on-connect2))
 
 (in-package :test-clog)
 
-(defun on-connect (id)
+(defun on-connect1 (id)
   (format t "Connection ~A is valid? ~A~%" id (clog-connection:validp id))
   ;; (clog:execute-script id "alert('test1');")
   (dotimes (n 10)
@@ -19,9 +19,13 @@
   (clog-connection:cwrite id "<br><b>shutting down connection</b>")
   (clog-connection:shutdown id))
 
+(defun on-connect2 (id)
+  (clog-connection:cwrite id "<b>Query Result : </b>")
+  (clog-connection:cwrite id (clog-connection:query id "navigator.appVersion")))
+
 (defun test-connect ()
   (print "Init connection")
-  (clog:initialize #'on-connect :boot-file "/debug.html")
+  (clog:initialize #'on-connect2 :boot-file "/debug.html")
   (print "Open browser")
   (clog:open-browser)
 )