mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-06 02:30:42 -08:00
Source reorg.
This commit is contained in:
David Botton
parent
d7ae4c1bfd
commit
f64bc7df44
5 changed files with 307 additions and 226 deletions
|
|
@ -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 <br />."
|
||||
(execute connection-id (format nil "document.writeln('~A<br />');" (clog:escape-string text))))
|
||||
(execute connection-id (format nil "document.writeln('~A<br />');" (escape-string text))))
|
||||
|
||||
;;;;;;;;;;;;;;
|
||||
;; new-line ;;
|
||||
|
|
|
|||
4
clog.asd
4
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")))
|
||||
|
|
|
|||
220
clog.lisp
220
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 ;;
|
||||
|
|
|
|||
31
test/test-clog-connection.lisp
Normal file
31
test/test-clog-connection.lisp
Normal file
|
|
@ -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 "<b>connection-write</b>")
|
||||
(clog-connection:put-line id "<i>connection-writeln</i>")
|
||||
(sleep .2))
|
||||
(clog-connection:put id "<br><b>Query Result : </b>")
|
||||
(clog-connection:put-line id (clog-connection:query id "navigator.appVersion"))
|
||||
(clog-connection:new-line id)
|
||||
(clog-connection:put id "<hr>simulate network interupt")
|
||||
(clog-connection:cclose id)
|
||||
(sleep .2)
|
||||
(clog-connection:put id "<br><b>reconnected</b>")
|
||||
(sleep .2)
|
||||
(clog-connection:put id "<br><b>shutting down connection</b>")
|
||||
(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)
|
||||
)
|
||||
|
|
@ -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 "<b>connection-write</b>")
|
||||
(clog-connection:put-line id "<i>connection-writeln</i>")
|
||||
(sleep .2))
|
||||
(clog-connection:put id "<br><b>Query Result : </b>")
|
||||
(clog-connection:put-line id (clog-connection:query id "navigator.appVersion"))
|
||||
(clog-connection:new-line id)
|
||||
(clog-connection:put id "<hr>simulate network interupt")
|
||||
(clog-connection:cclose id)
|
||||
(sleep .2)
|
||||
(clog-connection:put id "<br><b>reconnected</b>")
|
||||
(sleep .2)
|
||||
(clog-connection:put id "<br><b>shutting down connection</b>")
|
||||
(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)
|
||||
)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue