diff --git a/clog-connection.lisp b/clog-connection.lisp index f1b4231..1328b8a 100644 --- a/clog-connection.lisp +++ b/clog-connection.lisp @@ -19,24 +19,240 @@ (in-package :clog-connection) (defsection @clog-connection (:title "CLOG Connection") - "Low level connectivity to the web client and boot file script." + "Low level connectivity to the web client and boot file +script." + "CLOG system startup and shutdown" + + (*verbose-output* variable) + + (initialize function) + (shutdown function) + (set-on-connect function) + + "CLOG system utilities" + + (escape-string function) + "CLOG connections" - (execute function) - (query function) - (validp function) - (cclose function) - (shutdown function) - (put function) - (put-line function) - (new-line function)) + (execute function) + (query function) + (validp function) + (cclose function) + (shutdown function) + (put function) + (put-line function) + (new-line function) + (generate-id function)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Implemetation - clog-connection ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar *verbose-output* t "Verbose server output (default true)") + +(defvar *app* nil "Clack 'app' middle-ware") +(defvar *client-handler* nil "Clack 'handler' for socket traffic") +(defvar *on-connect-handler* nil "New connection event handler.") + +(defvar *new-id* 0 "Connection IDs") + +(defvar *connections* (make-hash-table) "Connections to IDs") +(defvar *connection-ids* (make-hash-table) "IDs to connections") + +(defvar *connection-lock* (bordeaux-threads:make-lock) + "Protect the connection hash tables") +(defvar *queries-lock* (bordeaux-threads:make-lock) + "Protect query hash tables") + +(defvar *queries* (make-hash-table) "Query ID to Answers") +(defvar *queries-sems* (make-hash-table) "Query ID to semiphores") +(defvar *query-time-out* 3 "Number of seconds to timeout waiting for a query") + +;;;;;;;;;;;;;;;;; +;; generate-id ;; +;;;;;;;;;;;;;;;;; + +(defun generate-id () + "Generate unique ids for use in connections and sripts." + (incf *new-id*)) + +;;;;;;;;;;;;;;;;;;;; +;; get-connection ;; +;;;;;;;;;;;;;;;;;;;; + +(defun get-connection (connection-id) + "Return the connection associated with CONNECITION-ID. (Private)" + (gethash connection-id *connection-ids*)) + +;;;;;;;;;;;;;;;; +;; prep-query ;; +;;;;;;;;;;;;;;;; + +(defun prep-query (id default-answer) + "Setup up a query to be received from a script identified by ID an returning +with DEFAULT-ANSWER in case of a time out. (Private)" + (bordeaux-threads:with-lock-held (*queries-lock*) + (setf (gethash id *queries-sems*) (bordeaux-threads:make-semaphore)) + (setf (gethash id *queries*) default-answer))) + +;;;;;;;;;;;;;;;;;;;;; +;; wait-for-answer ;; +;;;;;;;;;;;;;;;;;;;;; + +(defun wait-for-answer (id &key (timeout *query-time-out*)) + "Block after prep-query and sending the query script with ID and TIMEOUT with +the default answer. (Private)" + (bordeaux-threads:wait-on-semaphore (gethash id *queries-sems*) :timeout timeout) + (let ((answer (gethash id *queries*))) + (bordeaux-threads:with-lock-held (*queries-lock*) + (remhash id *queries*) + (remhash id *queries-sems*)) + answer)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; handle-new-connection ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun handle-new-connection (connection id) + (cond (id + (when *verbose-output* + (format t "Reconnection id - ~A to ~A~%" id connection)) + (bordeaux-threads:with-lock-held (*connection-lock*) + (setf (gethash id *connection-ids*) connection) + (setf (gethash connection *connections*) id))) + (t + (setf id (generate-id)) + (bordeaux-threads:with-lock-held (*connection-lock*) + (setf (gethash connection *connections*) id) + (setf (gethash id *connection-ids*) connection)) + (when *verbose-output* + (format t "New connection id - ~A - ~A~%" id connection)) + (websocket-driver:send connection + (format nil "clog['connection_id']=~A" id)) + (bordeaux-threads:make-thread + (lambda () + (funcall *on-connect-handler* id)))))) + +;;;;;;;;;;;;;;;;;;;; +;; handle-message ;; +;;;;;;;;;;;;;;;;;;;; + +(defun handle-message (connection message) + (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 ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun handle-close-connection (connection) + (let ((id (gethash connection *connections*))) + (when id + (when *verbose-output* + (format t "Connection id ~A has closed. ~A~%" id connection)) + (bordeaux-threads:with-lock-held (*connection-lock*) + (remhash id *connection-ids*) + (remhash connection *connections*))))) + +;;;;;;;;;;;;;;;;; +;; clog-server ;; +;;;;;;;;;;;;;;;;; + +(defun clog-server (env) + (let ((ws (websocket-driver:make-server env))) + (websocket-driver:on :open ws + (lambda () + (let ((id (getf env :query-string))) + (when (typep id 'string) + (setf id (parse-integer id))) + (handle-new-connection ws id)))) + + (websocket-driver:on :message ws + (lambda (msg) (handle-message ws msg))) + + (websocket-driver:on :close ws + (lambda (&key code reason) + (declare (ignore code reason)) + (handle-close-connection ws))) + (lambda (responder) + (declare (ignore responder)) + (websocket-driver:start-connection ws)))) + +;;;;;;;;;;;;;;;; +;; initialize ;; +;;;;;;;;;;;;;;;; + +(defun initialize (on-connect-handler + &key + (host "0.0.0.0") + (port 8080) + (boot-file "/boot.html") + (static-root #P"./static-files/")) + "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) + (cond ((ppcre:scan "^(?:/clog$)" path) nil) + ((equal path "/") boot-file) + (t path))) + :root static-root) + (lambda (env) + (clog-server env)))) + (setf *client-handler* (clack:clackup *app* :address host :port port)) + (when *verbose-output* + (format t "HTTP listening on : ~A:~A~%" host port) + (format t "HTML Root : ~A~%" static-root) + (format t "Boot file default : ~A~%" boot-file))) + +;;;;;;;;;;;;;; +;; shutdown ;; +;;;;;;;;;;;;;; + +(defun shutdown () + "Shutdown CLOG." + (clack:stop *client-handler*) + (bordeaux-threads:with-lock-held (*connection-lock*) + (clrhash *connections*) + (clrhash *connection-ids*)) + (setf *app* nil) + (setf *client-handler* nil)) + +;;;;;;;;;;;;;;;;;;;; +;; set-on-connect ;; +;;;;;;;;;;;;;;;;;;;; + +(defun set-on-connect (on-connect-handler) + "Change the ON-CONNECTION-HANDLER set during Initialize." + (setf *on-connect-handler* on-connect-handler)) + +;;;;;;;;;;;;;;;;;;; +;; escape-string ;; +;;;;;;;;;;;;;;;;;;; + +(defun escape-string (str) + "Escape STR for sending to browser script." + (let ((res)) + (setf res (ppcre:regex-replace-all "\\x22" str "\\x22")) + (setf res (ppcre:regex-replace-all "\\x27" res "\\x27")) + (setf res (ppcre:regex-replace-all "\\x0A" res "\\x0A")) + (setf res (ppcre:regex-replace-all "\\x0D" res "\\x0D")) + res)) ;;;;;;;;;;;;; ;; execute ;; @@ -44,7 +260,7 @@ (defun execute (connection-id message) "Execute SCRIPT on CONNECTION-ID, disregard return value." - (let ((con (clog::get-connection connection-id))) + (let ((con (get-connection connection-id))) (when con (websocket-driver:send con message)))) @@ -54,13 +270,13 @@ (defun query (connection-id script) "Execute SCRIPT on CONNECTION-ID, return value." - (let ((uid (clog::generate-connection-id))) - (clog::prep-query uid nil) + (let ((uid (generate-id))) + (prep-query uid nil) (execute connection-id (format nil "ws.send (\"~A:\"+eval(\"~A\"));" uid - (clog:escape-string script))) - (clog::wait-for-answer uid))) + (escape-string script))) + (wait-for-answer uid))) ;;;;;;;;;;;; ;; validp ;; @@ -68,7 +284,7 @@ (defun validp (connection-id) "Check if CONNECTION-ID is valid." - (if (clog::get-connection connection-id) + (if (get-connection connection-id) t nil)) @@ -96,7 +312,7 @@ reistablish connectivity." (defun put (connection-id text) "Write TEXT to document object of CONNECTION-ID with out new line." - (execute connection-id (format nil "document.write('~A');" (clog:escape-string text)))) + (execute connection-id (format nil "document.write('~A');" (escape-string text)))) ;;;;;;;;;;;;;; ;; put-line ;; @@ -104,7 +320,7 @@ reistablish connectivity." (defun put-line (connection-id text) "Write TEXT to document object of CONNECTION-ID with new line and HTML
." - (execute connection-id (format nil "document.writeln('~A
');" (clog:escape-string text)))) + (execute connection-id (format nil "document.writeln('~A
');" (escape-string text)))) ;;;;;;;;;;;;;; ;; new-line ;; diff --git a/clog.asd b/clog.asd index 8b687e4..42deaa9 100644 --- a/clog.asd +++ b/clog.asd @@ -11,5 +11,5 @@ #:bordeaux-threads #:trivial-open-browser #:lack-middleware-static #:lack-middleware-session #:mgl-pax) - :components ((:file "clog") - (:file "clog-connection"))) + :components ((:file "clog-connection") + (:file "clog"))) diff --git a/clog.lisp b/clog.lisp index e9cb3ef..f5449ae 100644 --- a/clog.lisp +++ b/clog.lisp @@ -26,165 +26,44 @@ application." (clog asdf:system) - (@clog-top-level section)) + (@clog-top-level section)) (defsection @clog-top-level (:title "CLOG Top level") - "CLOG system startup and shutdown" - (*verbose-output* variable) - + "CLOG Startup and Shutdown" + (initialize function) (shutdown function) - (set-on-connect function) + (set-on-connect function) + + "CLOG base class" + + (attach function) "CLOG utilities" + (alert-box function) + (escape-string function) (open-browser function)) + +(defclass base () + ((connection-id + :accessor connection-id + :initarg :connection-id) + (web-id + :accessor web-id + :initarg :web-id))) + +(defun attach (connection-id web-id) + (make-instance 'base :connection-id connection-id :web-id web-id)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Implementation - clog ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar *verbose-output* t "Verbose server output (default true)") - -(defvar *app* nil "Clack 'app' middle-ware") -(defvar *client-handler* nil "Clack 'handler' for socket traffic") -(defvar *on-connect-handler* nil "New connection event handler.") - -(defvar *new-id* 0 "Connection IDs") - -(defvar *connections* (make-hash-table) "Connections to IDs") -(defvar *connection-ids* (make-hash-table) "IDs to connections") - -(defvar *connection-lock* (bordeaux-threads:make-lock) - "Protect the connection hash tables") -(defvar *queries-lock* (bordeaux-threads:make-lock) - "Protect query hash tables") - -(defvar *queries* (make-hash-table) "Query ID to Answers") -(defvar *queries-sems* (make-hash-table) "Query ID to semiphores") -(defvar *query-time-out* 3 "Number of seconds to timeout waiting for a query") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; generate-connection-id ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun generate-connection-id () - "Generate unique ids for use in connections and sripts. (Private)" - (incf *new-id*)) - -;;;;;;;;;;;;;;;;;;;; -;; get-connection ;; -;;;;;;;;;;;;;;;;;;;; - -(defun get-connection (connection-id) - "Return the connection associated with CONNECITION-ID. (Private)" - (gethash connection-id *connection-ids*)) - -;;;;;;;;;;;;;;;; -;; prep-query ;; -;;;;;;;;;;;;;;;; - -(defun prep-query (id default-answer) - "Setup up a query to be received from a script identified by ID an returning -with DEFAULT-ANSWER in case of a time out. (Private)" - (bordeaux-threads:with-lock-held (*queries-lock*) - (setf (gethash id *queries-sems*) (bordeaux-threads:make-semaphore)) - (setf (gethash id *queries*) default-answer))) - -;;;;;;;;;;;;;;;;;;;;; -;; wait-for-answer ;; -;;;;;;;;;;;;;;;;;;;;; - -(defun wait-for-answer (id &key (timeout *query-time-out*)) - "Block after prep-query and sending the query script with ID and TIMEOUT with -the default answer. (Private)" - (bordeaux-threads:wait-on-semaphore (gethash id *queries-sems*) :timeout timeout) - (let ((answer (gethash id *queries*))) - (bordeaux-threads:with-lock-held (*queries-lock*) - (remhash id *queries*) - (remhash id *queries-sems*)) - answer)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; handle-new-connection ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun handle-new-connection (connection id) - (cond (id - (when *verbose-output* - (format t "Reconnection id - ~A to ~A~%" id connection)) - (bordeaux-threads:with-lock-held (*connection-lock*) - (setf (gethash id *connection-ids*) connection) - (setf (gethash connection *connections*) id))) - (t - (setf id (generate-connection-id)) - (bordeaux-threads:with-lock-held (*connection-lock*) - (setf (gethash connection *connections*) id) - (setf (gethash id *connection-ids*) connection)) - (when *verbose-output* - (format t "New connection id - ~A - ~A~%" id connection)) - (websocket-driver:send connection - (format nil "clog['connection_id']=~A" id)) - (bordeaux-threads:make-thread - (lambda () - (funcall *on-connect-handler* id)))))) - -;;;;;;;;;;;;;;;;;;;; -;; handle-message ;; -;;;;;;;;;;;;;;;;;;;; - -(defun handle-message (connection message) - (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 ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun handle-close-connection (connection) - (let ((id (gethash connection *connections*))) - (when id - (when *verbose-output* - (format t "Connection id ~A has closed. ~A~%" id connection)) - (bordeaux-threads:with-lock-held (*connection-lock*) - (remhash id *connection-ids*) - (remhash connection *connections*))))) - -;;;;;;;;;;;;;;;;; -;; clog-server ;; -;;;;;;;;;;;;;;;;; - -(defun clog-server (env) - (let ((ws (websocket-driver:make-server env))) - (websocket-driver:on :open ws - (lambda () - (let ((id (getf env :query-string))) - (when (typep id 'string) - (setf id (parse-integer id))) - (handle-new-connection ws id)))) - - (websocket-driver:on :message ws - (lambda (msg) (handle-message ws msg))) - - (websocket-driver:on :close ws - (lambda (&key code reason) - (declare (ignore code reason)) - (handle-close-connection ws))) - (lambda (responder) - (declare (ignore responder)) - (websocket-driver:start-connection ws)))) ;;;;;;;;;;;;;;;; ;; initialize ;; @@ -199,55 +78,26 @@ the default answer. (Private)" "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) - (cond ((ppcre:scan "^(?:/clog$)" path) nil) - ((equal path "/") boot-file) - (t path))) - :root static-root) - (lambda (env) - (clog-server env)))) - (setf *client-handler* (clack:clackup *app* :address host :port port)) - (when *verbose-output* - (format t "HTTP listening on : ~A:~A~%" host port) - (format t "HTML Root : ~A~%" static-root) - (format t "Boot file default : ~A~%" boot-file))) + (clog-connection:initialize on-connect-handler + :host host + :port port + :boot-file boot-file + :static-root static-root)) ;;;;;;;;;;;;;; ;; shutdown ;; ;;;;;;;;;;;;;; (defun shutdown () - "Shutdown CLOG." - (clack:stop *client-handler*) - (bordeaux-threads:with-lock-held (*connection-lock*) - (clrhash *connections*) - (clrhash *connection-ids*)) - (setf *app* nil) - (setf *client-handler* nil)) + (clog-connection:shutdown)) -;;;;;;;;;;;;;;;;;;;; -;; set-on-connect ;; -;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;; +;; alert-box ;; +;;;;;;;;;;;;;;; -(defun set-on-connect (on-connect-handler) - "Change the ON-CONNECTION-HANDLER set during Initialize." - (setf *on-connect-handler* on-connect-handler)) - -;;;;;;;;;;;;;;;;;;; -;; escape-string ;; -;;;;;;;;;;;;;;;;;;; - -(defun escape-string (str) - "Escape STR for sending to browser script." - (let ((res)) - (setf res (ppcre:regex-replace-all "\\x22" str "\\x22")) - (setf res (ppcre:regex-replace-all "\\x27" res "\\x27")) - (setf res (ppcre:regex-replace-all "\\x0A" res "\\x0A")) - (setf res (ppcre:regex-replace-all "\\x0D" res "\\x0D")) - res)) +(defun alert-box (id message) + (clog-connection:execute + id (format nil "alert('~A');" (clog-connection:escape-string message)))) ;;;;;;;;;;;;;;;;;; ;; open-browser ;; diff --git a/test/test-clog-connection.lisp b/test/test-clog-connection.lisp new file mode 100644 index 0000000..b6ea2db --- /dev/null +++ b/test/test-clog-connection.lisp @@ -0,0 +1,31 @@ +(defpackage #:test-clog-connection + (:use #:cl) + (:export test on-connect)) + +(in-package :test-clog-connection) + +(defun on-connect (id) + (format t "Connection ~A is valid? ~A~%" id (clog-connection:validp id)) + (dotimes (n 10) + (clog-connection:put id "connection-write") + (clog-connection:put-line id "connection-writeln") + (sleep .2)) + (clog-connection:put id "
Query Result : ") + (clog-connection:put-line id (clog-connection:query id "navigator.appVersion")) + (clog-connection:new-line id) + (clog-connection:put id "
simulate network interupt") + (clog-connection:cclose id) + (sleep .2) + (clog-connection:put id "
reconnected") + (sleep .2) + (clog-connection:put id "
shutting down connection") + (sleep .2) + ;; It is generally uneccessary to shutdown the connection + (clog-connection:shutdown id)) + +(defun test () + (print "Init connection") + (clog:initialize #'on-connect :boot-file "/debug.html") + (print "Open browser") + (clog:open-browser) +) diff --git a/test/test-clog.lisp b/test/test-clog.lisp index da47655..fe61f26 100644 --- a/test/test-clog.lisp +++ b/test/test-clog.lisp @@ -1,31 +1,15 @@ (defpackage #:test-clog - (:use #:cl) - (:export test-connect on-connect)) + (:use #:cl #:clog) + (:export test on-connect)) (in-package :test-clog) (defun on-connect (id) - (format t "Connection ~A is valid? ~A~%" id (clog-connection:validp id)) - (dotimes (n 10) - (clog-connection:put id "connection-write") - (clog-connection:put-line id "connection-writeln") - (sleep .2)) - (clog-connection:put id "
Query Result : ") - (clog-connection:put-line id (clog-connection:query id "navigator.appVersion")) - (clog-connection:new-line id) - (clog-connection:put id "
simulate network interupt") - (clog-connection:cclose id) - (sleep .2) - (clog-connection:put id "
reconnected") - (sleep .2) - (clog-connection:put id "
shutting down connection") - (sleep .2) - ;; It is generally uneccessary to shutdown the connection - (clog-connection:shutdown id)) + (alert-box id "We are here")) -(defun test-connect () +(defun test () (print "Init connection") - (clog:initialize #'on-connect :boot-file "/debug.html") + (initialize #'on-connect :boot-file "/debug.html") (print "Open browser") - (clog:open-browser) + (open-browser) )