mirrors/clog
1
Fork 0
mirror of https://github.com/rabbibotton/clog.git synced 2025-12-06 02:30:42 -08:00
Code Issues Projects Releases Wiki Activity

Source reorg.

Browse source
This commit is contained in:
David Botton 2020-12-15 21:46:08 -05:00
parent d7ae4c1bfd
commit f64bc7df44
5 changed files with 307 additions and 226 deletions
Download patch file Download diff file Expand all files Collapse all files

250
clog-connection.lisp
View file

@ -19,24 +19,240 @@
(in-package :clog-connection) (in-package :clog-connection)
(defsection @clog-connection (:title "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" "CLOG connections"
(execute function) (execute function)
(query function) (query function)
(validp function) (validp function)
(cclose function) (cclose function)
(shutdown function) (shutdown function)
(put function) (put function)
(put-line function) (put-line function)
(new-line function)) (new-line function)
(generate-id function))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implemetation - clog-connection ;; 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 ;; ;; execute ;;
@ -44,7 +260,7 @@
(defun execute (connection-id message) (defun execute (connection-id message)
"Execute SCRIPT on CONNECTION-ID, disregard return value." "Execute SCRIPT on CONNECTION-ID, disregard return value."
(let ((con (clog::get-connection connection-id))) (let ((con (get-connection connection-id)))
(when con (when con
(websocket-driver:send con message)))) (websocket-driver:send con message))))
@ -54,13 +270,13 @@
(defun query (connection-id script) (defun query (connection-id script)
"Execute SCRIPT on CONNECTION-ID, return value." "Execute SCRIPT on CONNECTION-ID, return value."
(let ((uid (clog::generate-connection-id))) (let ((uid (generate-id)))
(clog::prep-query uid nil) (prep-query uid nil)
(execute connection-id (execute connection-id
(format nil "ws.send (\"~A:\"+eval(\"~A\"));" (format nil "ws.send (\"~A:\"+eval(\"~A\"));"
uid uid
(clog:escape-string script))) (escape-string script)))
(clog::wait-for-answer uid))) (wait-for-answer uid)))
;;;;;;;;;;;; ;;;;;;;;;;;;
;; validp ;; ;; validp ;;
@ -68,7 +284,7 @@
(defun validp (connection-id) (defun validp (connection-id)
"Check if CONNECTION-ID is valid." "Check if CONNECTION-ID is valid."
(if (clog::get-connection connection-id) (if (get-connection connection-id)
t t
nil)) nil))
@ -96,7 +312,7 @@ reistablish connectivity."
(defun put (connection-id text) (defun put (connection-id text)
"Write TEXT to document object of CONNECTION-ID with out new line." "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 ;; ;; put-line ;;
@ -104,7 +320,7 @@ reistablish connectivity."
(defun put-line (connection-id text) (defun put-line (connection-id text)
"Write TEXT to document object of CONNECTION-ID with new line and HTML <br />." "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 ;; ;; new-line ;;

4
clog.asd
View file

@ -11,5 +11,5 @@
#:bordeaux-threads #:trivial-open-browser #:bordeaux-threads #:trivial-open-browser
#:lack-middleware-static #:lack-middleware-session #:lack-middleware-static #:lack-middleware-session
#:mgl-pax) #:mgl-pax)
:components ((:file "clog") :components ((:file "clog-connection")
(:file "clog-connection"))) (:file "clog")))

220
clog.lisp
View file

@ -26,165 +26,44 @@ application."
(clog asdf:system) (clog asdf:system)
(@clog-top-level section)) (@clog-top-level section))
(defsection @clog-top-level (:title "CLOG Top level") (defsection @clog-top-level (:title "CLOG Top level")
"CLOG system startup and shutdown"
(*verbose-output* variable) "CLOG Startup and Shutdown"
(initialize function) (initialize function)
(shutdown function) (shutdown function)
(set-on-connect function) (set-on-connect function)
"CLOG base class"
(attach function)
"CLOG utilities" "CLOG utilities"
(alert-box function)
(escape-string function) (escape-string function)
(open-browser 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 ;; 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 ;; ;; initialize ;;
@ -199,55 +78,26 @@ the default answer. (Private)"
"Inititalze CLOG on a socket using HOST and PORT to serve BOOT-FILE as "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 the default route to establish web-socket connections and static files
located at STATIC-ROOT." located at STATIC-ROOT."
(set-on-connect on-connect-handler) (clog-connection:initialize on-connect-handler
(setf *app* :host host
(lack:builder :port port
(:static :path (lambda (path) :boot-file boot-file
(cond ((ppcre:scan "^(?:/clog$)" path) nil) :static-root static-root))
((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 ;; ;; shutdown ;;
;;;;;;;;;;;;;; ;;;;;;;;;;;;;;
(defun shutdown () (defun shutdown ()
"Shutdown CLOG." (clog-connection:shutdown))
(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 ;; ;; alert-box ;;
;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;
(defun set-on-connect (on-connect-handler) (defun alert-box (id message)
"Change the ON-CONNECTION-HANDLER set during Initialize." (clog-connection:execute
(setf *on-connect-handler* on-connect-handler)) id (format nil "alert('~A');" (clog-connection:escape-string message))))
;;;;;;;;;;;;;;;;;;;
;; 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))
;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;
;; open-browser ;; ;; open-browser ;;

31
test/test-clog-connection.lisp Normal file
View 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)
)

28
test/test-clog.lisp
View file

@ -1,31 +1,15 @@
(defpackage #:test-clog (defpackage #:test-clog
(:use #:cl) (:use #:cl #:clog)
(:export test-connect on-connect)) (:export test on-connect))
(in-package :test-clog) (in-package :test-clog)
(defun on-connect (id) (defun on-connect (id)
(format t "Connection ~A is valid? ~A~%" id (clog-connection:validp id)) (alert-box id "We are here"))
(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-connect () (defun test ()
(print "Init connection") (print "Init connection")
(clog:initialize #'on-connect :boot-file "/debug.html") (initialize #'on-connect :boot-file "/debug.html")
(print "Open browser") (print "Open browser")
(clog:open-browser) (open-browser)
) )