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

Prepare for additional connection types

Browse source
This commit is contained in:
David Botton 2024-03-11 23:20:23 -04:00
parent 64b0c663e9
commit 1c9fa342ad
17 changed files with 619 additions and 620 deletions
Download patch file Download diff file Expand all files Collapse all files

1
clog.asd vendored
View file

@ -16,6 +16,7 @@
(:module "source" (:module "source"
:components ((:file "asdf-ext") :components ((:file "asdf-ext")
(:file "clog-connection") (:file "clog-connection")
(:file "clog-connection-websockets")
(:file "clog") (:file "clog")
(:file "clog-utilities") (:file "clog-utilities")
(:file "clog-base") (:file "clog-base")

24
source/clog-base.lisp
View file

@ -98,6 +98,18 @@ discarded, return CLOG-OBJ. (Internal)"))
(clog-connection:execute (connection-id obj) script)) (clog-connection:execute (connection-id obj) script))
obj) obj)
;;;;;;;;;;;;;;
;; js-query ;;
;;;;;;;;;;;;;;
(defgeneric js-query (clog-obj script &key default-answer)
(:documentation "Execure SCRIPT on browser and return result. (Internal)"))
(defmethod js-query ((obj clog-obj) script &key (default-answer nil))
(flush-connection-cache obj)
(clog-connection:query (connection-id obj) script
:default-answer default-answer))
;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; with-connection-cache ;; ;; with-connection-cache ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -121,18 +133,6 @@ flushed with FLUSH-CONNECTION-CACHE or a query is made."
(clog-connection:execute (connection-id clog-obj) script))) (clog-connection:execute (connection-id clog-obj) script)))
(setf *connection-cache* (list :cache)))) (setf *connection-cache* (list :cache))))
;;;;;;;;;;;;;;
;; js-query ;;
;;;;;;;;;;;;;;
(defgeneric js-query (clog-obj script &key default-answer)
(:documentation "Execure SCRIPT on browser and return result. (Internal)"))
(defmethod js-query ((obj clog-obj) script &key (default-answer nil))
(flush-connection-cache obj)
(clog-connection:query (connection-id obj) script
:default-answer default-answer))
;;;;;;;;;;;;; ;;;;;;;;;;;;;
;; execute ;; ;; execute ;;
;;;;;;;;;;;;; ;;;;;;;;;;;;;

36
source/clog-canvas.lisp
View file

@ -56,7 +56,7 @@
(defmethod create-context2d ((obj clog-canvas)) (defmethod create-context2d ((obj clog-canvas))
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=clog['~A'].getContext('2d')" (js-execute obj (format nil "clog['~A']=clog['~A'].getContext('2d')"
web-id web-id
(html-id obj))) (html-id obj)))
@ -443,7 +443,7 @@ https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D/global
(:documentation "Create blank image data")) (:documentation "Create blank image data"))
(defmethod create-image-data ((obj clog-context2d) width height) (defmethod create-image-data ((obj clog-context2d) width height)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.createImageData(~A,~A)" (js-execute obj (format nil "clog['~A']=~A.createImageData(~A,~A)"
web-id (script-id obj) web-id (script-id obj)
width height)) width height))
@ -459,7 +459,7 @@ https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D/global
(:documentation "Create conic gradient")) (:documentation "Create conic gradient"))
(defmethod create-conic-gradient ((obj clog-context2d) start-angle x y) (defmethod create-conic-gradient ((obj clog-context2d) start-angle x y)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.createConicGradient(~A,~A,~A)" (js-execute obj (format nil "clog['~A']=~A.createConicGradient(~A,~A,~A)"
web-id (script-id obj) web-id (script-id obj)
start-angle x y)) start-angle x y))
@ -475,7 +475,7 @@ https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D/global
(:documentation "Create linear gradient")) (:documentation "Create linear gradient"))
(defmethod create-linear-gradient ((obj clog-context2d) x0 y0 x1 y1) (defmethod create-linear-gradient ((obj clog-context2d) x0 y0 x1 y1)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.createLinearGradient(~A,~A,~A,~A)" (js-execute obj (format nil "clog['~A']=~A.createLinearGradient(~A,~A,~A,~A)"
web-id (script-id obj) web-id (script-id obj)
x0 y0 x1 y1)) x0 y0 x1 y1))
@ -491,7 +491,7 @@ https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D/global
(:documentation "Create radial gradient")) (:documentation "Create radial gradient"))
(defmethod create-radial-gradient ((obj clog-context2d) x0 y0 r0 x1 y1 r1) (defmethod create-radial-gradient ((obj clog-context2d) x0 y0 r0 x1 y1 r1)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.createRadialGradient(~A,~A,~A,~A,~A,~A)" (js-execute obj (format nil "clog['~A']=~A.createRadialGradient(~A,~A,~A,~A,~A,~A)"
web-id (script-id obj) web-id (script-id obj)
x0 y0 r0 x1 y1 r1)) x0 y0 r0 x1 y1 r1))
@ -612,7 +612,7 @@ https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D/global
(:documentation "Get image data from clog-context2d. Returns a CLOG-IMAGE-DATA")) (:documentation "Get image data from clog-context2d. Returns a CLOG-IMAGE-DATA"))
(defmethod get-image-data ((obj clog-context2d) sx sy sw sh) (defmethod get-image-data ((obj clog-context2d) sx sy sw sh)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.getImageData(~A,~A,~A,~A)" (js-execute obj (format nil "clog['~A']=~A.getImageData(~A,~A,~A,~A)"
web-id (script-id obj) web-id (script-id obj)
sx sy sw sh)) sx sy sw sh))
@ -639,7 +639,7 @@ https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D/global
(:documentation "Get current transform matrix as clog-matrix")) (:documentation "Get current transform matrix as clog-matrix"))
(defmethod get-transform ((obj clog-context2d)) (defmethod get-transform ((obj clog-context2d))
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.getTransform()" (js-execute obj (format nil "clog['~A']=~A.getTransform()"
web-id (script-id obj))) web-id (script-id obj)))
(make-instance 'clog-matrix (make-instance 'clog-matrix
@ -695,7 +695,7 @@ https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D/global
(:documentation "Measure text returns a clog-text-metrics object")) (:documentation "Measure text returns a clog-text-metrics object"))
(defmethod measure-text ((obj clog-context2d) text) (defmethod measure-text ((obj clog-context2d) text)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.measureText('~A')" (js-execute obj (format nil "clog['~A']=~A.measureText('~A')"
web-id web-id
(script-id obj) text)) (script-id obj) text))
@ -1033,7 +1033,7 @@ json array 6 element for 2d or 16 for 3d."))
(defmethod create-matrix ((obj clog-canvas) &key matrix) (defmethod create-matrix ((obj clog-canvas) &key matrix)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=DOMMatrix(~A)" (js-execute obj (format nil "clog['~A']=DOMMatrix(~A)"
web-id web-id
(if matrix (if matrix
@ -1082,7 +1082,7 @@ json array 6 element for 2d or 16 for 3d."))
(:documentation "Return flip-x a clog-matrix")) (:documentation "Return flip-x a clog-matrix"))
(defmethod flip-x ((obj clog-matrix)) (defmethod flip-x ((obj clog-matrix))
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.flipX()" (js-execute obj (format nil "clog['~A']=~A.flipX()"
web-id (script-id obj))) web-id (script-id obj)))
(make-instance 'clog-matrix (make-instance 'clog-matrix
@ -1097,7 +1097,7 @@ json array 6 element for 2d or 16 for 3d."))
(:documentation "Return flip-y a clog-matrix")) (:documentation "Return flip-y a clog-matrix"))
(defmethod flip-y ((obj clog-matrix)) (defmethod flip-y ((obj clog-matrix))
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.flipY()" (js-execute obj (format nil "clog['~A']=~A.flipY()"
web-id (script-id obj))) web-id (script-id obj)))
(make-instance 'clog-matrix (make-instance 'clog-matrix
@ -1112,7 +1112,7 @@ json array 6 element for 2d or 16 for 3d."))
(:documentation "Return inverse a clog-matrix")) (:documentation "Return inverse a clog-matrix"))
(defmethod inverse ((obj clog-matrix)) (defmethod inverse ((obj clog-matrix))
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.inverse()" (js-execute obj (format nil "clog['~A']=~A.inverse()"
web-id (script-id obj))) web-id (script-id obj)))
(make-instance 'clog-matrix (make-instance 'clog-matrix
@ -1127,7 +1127,7 @@ json array 6 element for 2d or 16 for 3d."))
(:documentation "Return multiply a clog-matrix")) (:documentation "Return multiply a clog-matrix"))
(defmethod multiply ((obj clog-matrix) by-matrix) (defmethod multiply ((obj clog-matrix) by-matrix)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.multiply(~A)" (js-execute obj (format nil "clog['~A']=~A.multiply(~A)"
web-id (script-id obj) (script-id by-matrix))) web-id (script-id obj) (script-id by-matrix)))
(make-instance 'clog-matrix (make-instance 'clog-matrix
@ -1144,7 +1144,7 @@ json array 6 element for 2d or 16 for 3d."))
(:documentation "Return rotate a clog-matrix")) (:documentation "Return rotate a clog-matrix"))
(defmethod rotate ((obj clog-matrix) angle) (defmethod rotate ((obj clog-matrix) angle)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.rotate(~A)" (js-execute obj (format nil "clog['~A']=~A.rotate(~A)"
web-id (script-id obj) angle)) web-id (script-id obj) angle))
(make-instance 'clog-matrix (make-instance 'clog-matrix
@ -1162,7 +1162,7 @@ json array 6 element for 2d or 16 for 3d."))
sy sz ox oy oz")) sy sz ox oy oz"))
(defmethod scale-matrix ((obj clog-matrix) sx &optional sy sz ox oy oz) (defmethod scale-matrix ((obj clog-matrix) sx &optional sy sz ox oy oz)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.scale(~A~A~A~A~A~A)" (js-execute obj (format nil "clog['~A']=~A.scale(~A~A~A~A~A~A)"
web-id (script-id obj) sx web-id (script-id obj) sx
(if sy (format nil ",~A" sy) "") (if sy (format nil ",~A" sy) "")
@ -1183,7 +1183,7 @@ sy sz ox oy oz"))
sy sz ox oy oz")) sy sz ox oy oz"))
(defmethod scale3d ((obj clog-matrix) sx &optional sy sz ox oy oz) (defmethod scale3d ((obj clog-matrix) sx &optional sy sz ox oy oz)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.scale3d(~A~A~A~A~A~A)" (js-execute obj (format nil "clog['~A']=~A.scale3d(~A~A~A~A~A~A)"
web-id (script-id obj) sx web-id (script-id obj) sx
(if sy (format nil ",~A" sy) "") (if sy (format nil ",~A" sy) "")
@ -1205,7 +1205,7 @@ sy sz ox oy oz"))
(:documentation "Return translate-matrix a clog-matrix by x y and optionally z")) (:documentation "Return translate-matrix a clog-matrix by x y and optionally z"))
(defmethod translate-matrix ((obj clog-matrix) x y &optional z) (defmethod translate-matrix ((obj clog-matrix) x y &optional z)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.translate(~A,~A~A)" (js-execute obj (format nil "clog['~A']=~A.translate(~A,~A~A)"
web-id (script-id obj) x y web-id (script-id obj) x y
(if z (format nil ",~A" z) ""))) (if z (format nil ",~A" z) "")))
@ -1228,7 +1228,7 @@ sy sz ox oy oz"))
(defmethod create-path2d ((obj clog-canvas) &key path2d) (defmethod create-path2d ((obj clog-canvas) &key path2d)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=Path2D(~A)" (js-execute obj (format nil "clog['~A']=Path2D(~A)"
web-id web-id
(if path2d (if path2d

493
source/clog-connection-websockets.lisp Normal file
View file

@ -0,0 +1,493 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2024 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-connection-websockets.lisp ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :clog-connection)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implemetation - clog-connection-websockets
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *app* nil "Clack 'app' middle-ware")
(defvar *client-handler* nil "Clack 'handler' for socket traffic")
(defvar *long-poll-first* nil
"Dynamic variable indicating to use html output instead of
websocket for output at start if connection.")
(defvar *extended-long-poll* nil
"Dynamic variable indicating to extend long polling beyond
extablishing websocket for output.")
(defvar *long-poll-url* nil
"Dynamic variable indicating the url path used.")
(defparameter *compiled-boot-js*
(with-open-file (stream (merge-pathnames #P"static-files/js/boot.js"
(asdf:system-source-directory :clog)))
(let ((content (make-string (file-length stream))))
(read-sequence content stream)
content))
"A compiled version of current version of boot.js (private)")
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; handle-new-connection ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun handle-new-connection (connection id)
"Handle new incoming websocket CONNECTIONS with ID from boot page. (Private)"
(handler-case
(cond ((and id (gethash id *connection-data*))
(format t "Reconnection id - ~A to ~A~%" id connection)
(handler-case
(websocket-driver:close-connection (gethash id *connection-ids*)
"Aborting this old connection since receiving a reconnection request.")
(t (c)
(when *verbose-output*
(format t "Failed to close the old connection when establishing reconnection. This can be normal: The old connection could probably don't work for the client, so the client is requesting to reconnect.~%Condition - ~A.~&"
c))))
(setf (gethash id *connection-ids*) connection)
(setf (gethash connection *connections*) id))
(id
(format t "Reconnection id ~A not found. Closing the connection.~%" id)
(websocket-driver:close-connection connection)) ; Don't send the reason for better security.
(t
(setf id (random-hex-string))
(setf (gethash connection *connections*) id)
(setf (gethash id *connection-ids*) connection)
(setf (gethash id *connection-data*)
(make-hash-table* :test #'equal))
(setf (gethash "connection-id" (get-connection-data id)) id)
(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 ()
(if *break-on-error*
(funcall *on-connect-handler* id)
(handler-case
(funcall *on-connect-handler* id)
(t (c)
(format t "Condition caught connection ~A - ~A.~&" id c)
(values 0 c)))))
:name (format nil "CLOG connection ~A"
id))))
(t (c)
(format t "Condition caught in handle-new-connection - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;;;;;
;; handle-message ;;
;;;;;;;;;;;;;;;;;;;;
(defun handle-message (connection message)
"Handle incoming websocket MESSAGE on CONNECTION. (Private)"
(handler-case
(let ((connection-id (gethash connection *connections*))
(ml (ppcre:split ":" message :limit 2)))
(cond ((null connection-id)
;; a zombie connection
(when *verbose-output*
(format t "A zombie connection ~A. CLOG doesn't remember its connection-id. Closing it.~%"
connection))
(websocket-driver:close-connection connection)) ; don't send the reason for better security
((equal (first ml) "0")
;; a ping
(when *verbose-output*
(format t "Connection ~A Ping~%" connection-id)))
((equal (first ml) "E")
;; an event
(let* ((em (ppcre:split " " (second ml) :limit 2))
(event-id (first em))
(data (second em)))
(when *verbose-output*
(format t "Connection ~A Hook = ~A Data = ~A~%"
connection-id event-id data))
(bordeaux-threads:make-thread
(lambda ()
(if *break-on-error*
(let* ((event-hash (get-connection-data connection-id))
(event (when event-hash
(gethash event-id event-hash))))
(when event
(funcall event data)))
(handler-case
(let* ((event-hash (get-connection-data connection-id))
(event (when event-hash
(gethash event-id
event-hash))))
(when event
(funcall event data)))
(t (c)
(format t "Condition caught in handle-message for event - ~A.~&" c)
(values 0 c)))))
:name (format nil "CLOG event handler ~A"
event-id))))
(t
;; a JavaScript execution result
(let ((server-query-id (first ml))
(browser-returned-answer (second ml)))
(when *verbose-output*
(format t "Connection ~A ~A = ~A ~A = ~A~%"
connection-id
'server-query-id
server-query-id
'browser-returned-answer
browser-returned-answer))
(setf (gethash (parse-integer server-query-id) *queries*) browser-returned-answer)
(bordeaux-threads:signal-semaphore
(gethash (parse-integer server-query-id) *queries-sems*))))))
(t (c)
(format t "Condition caught in handle-message - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; handle-close-connection ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun handle-close-connection (connection)
"Close websocket CONNECTION. (Private)"
(handler-case
(let ((id (gethash connection *connections*)))
(when id
(when *verbose-output*
(format t "Connection id ~A has closed. ~A~%" id connection))
(remhash id *connection-data*)
(remhash id *connection-ids*)
(remhash connection *connections*)))
(t (c)
(format t "Condition caught in handle-close-connection - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;;
;; clog-server ;;
;;;;;;;;;;;;;;;;;
(defun clog-server (env)
"Setup websocket server on ENV. (Private)"
(handler-case
(let ((ws (websocket-driver:make-server env)))
(websocket-driver:on :open ws
(lambda ()
(handler-case
(let* ((query (getf env :query-string))
(items (when query
(quri:url-decode-params query)))
(id (when items
(cdr (assoc "r" items
:test #'equalp)))))
(handle-new-connection ws id))
(t (c)
(print env)
(format t "Condition caught in clog-server :open - ~A.~&" c)
(values 0 c)))))
(websocket-driver:on :message ws
(lambda (msg)
(handler-case
(handle-message ws msg)
(t (c)
(format t "Condition caught in clog-server :message - ~A.~&" c)
(values 0 c)))))
(websocket-driver:on :error ws
(lambda (msg)
(format t "Websocket error - ~A~&" msg)))
(websocket-driver:on :close ws
(lambda (&key code reason)
(declare (ignore code reason))
(handler-case
(handle-close-connection ws)
(t (c)
(format t "Condition caught in clog-server :close - ~A.~&" c)
(values 0 c)))))
(lambda (responder)
(declare (ignore responder))
(websocket-driver:start-connection ws)))
(t (c)
(format t "Condition caught in clog-server start-up - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;
;; initialize ;;
;;;;;;;;;;;;;;;;
(defun initialize (on-connect-handler
&key
(host "0.0.0.0")
(port 8080)
(server :hunchentoot)
(lack-middleware-list nil)
(extended-routing nil)
(long-poll-first nil)
(boot-file "/boot.html")
(boot-function nil)
(static-boot-html nil)
(static-boot-js nil)
(static-root #P"./static-files/")
(ssl nil)
(ssl-key-file nil)
(ssl-cert-file nil))
"Initialize CLOG on a socket using HOST and PORT to serve BOOT-FILE as the
default route for '/' to establish web-socket connections and static files
located at STATIC-ROOT. The webserver used with CLACK can be chosen with
:SERVER and middlewares prepended with :LACK-MIDDLEWARE-LIST,
NOT supporting LACK.BUILDER DSL.
If LONG-POLLING-FIRST is t, the output is sent as HTML instead of
websocket commands until the end of the on-new-window-handler, if
LONG-POLLING-FIRST is a number will keep long polling till that number of
queries to browser. LONG-POLLING-FIRST is used in webserver applications to
enable crawling of your website. If BOOT-FILE is nil no initial clog-path's will
be setup, use clog-path to add. The on-connect-handler needs to indentify the
path by querying the browser. See PATH-NAME (in CLOG-LOCATION). If
EXTENDED-ROUTING is t routes will match even if extend with additional / and
additional paths. If static-boot-js is nil then boot.js is served from the file
/js/boot.js instead of the compiled version. If static-boot-html is t if
boot.html is not present will use compiled version otherwise if set to nil (default)
if a boot file not found returns returns a blank page, if it is set to :error will
signal an error and if set to a string will display the string. boot-function if set is
called with the url and the contents of boot-file and its return value replaces
the contents sent to the brower."
(set-on-connect on-connect-handler)
(when boot-file
(set-clog-path "/" boot-file))
(setf *app*
(lack:builder
(lambda (app)
(lambda (env)
;; if not static-boot-js use internal compiled boot.js
(if (and (eq static-boot-js nil)
(equalp (getf env :path-info) "/js/boot.js"))
`(200 (:content-type "text/javascript")
(,*compiled-boot-js*))
(funcall app env))))
(lambda (app)
(lambda (env)
;; Special handling of "clog paths"
(let* ((url-path (getf env :path-info))
(clog-path (gethash url-path *url-to-boot-file*)))
(unless clog-path
(when extended-routing
(maphash (lambda (k v)
(unless (equal k "/")
(when (ppcre:scan (format nil "^~A/" k)
url-path)
(setf clog-path v))))
*url-to-boot-file*)))
(cond (clog-path
(let ((file (uiop:subpathname static-root clog-path)))
(with-open-file (stream file :direction :input
:if-does-not-exist nil)
(let ((page-data (if stream
(make-string (file-length stream))
(if static-boot-html
(cond ((eq static-boot-html t)
"")
((eq static-boot-html :error)
(error (format nil "Can not open boot file - ~A"
file)))
(t
static-boot-html))
(compiled-boot-html nil nil))))
(post-data nil))
(when stream
(read-sequence page-data stream))
(when boot-function
(setf page-data (funcall boot-function
url-path
page-data)))
(when (search "multipart/form-data;"
(getf env :content-type))
(let ((id (random-hex-string))
(req (lack.request:make-request env)))
(setf (gethash id *connection-data*)
(lack.request:request-body-parameters req))
(setf post-data id)))
(when (equal (getf env :content-type)
"application/x-www-form-urlencoded")
(setf post-data (cond ((eq (class-name (class-of (getf env :raw-body)))
'circular-streams:circular-input-stream)
(let ((array-buffer (make-array (getf env :content-length)
:adjustable t
:fill-pointer t)))
(read-sequence array-buffer (getf env :raw-body))
(flex:octets-to-string array-buffer)))
(t
(let ((string-buffer (make-string (getf env :content-length))))
(read-sequence string-buffer (getf env :raw-body))
string-buffer)))))
(cond (long-poll-first
(let ((id (random-hex-string)))
(setf (gethash id *connection-data*) (make-hash-table* :test #'equal))
(setf (gethash "connection-id" (get-connection-data id)) id)
(format t "New html connection id - ~A~%" id)
(lambda (responder)
(let* ((writer (funcall responder '(200 (:content-type "text/html"))))
(stream (lack.util.writer-stream:make-writer-stream writer))
(*long-poll-url* url-path)
(*long-poll-first* stream)
(*extended-long-poll* (if (eq long-poll-first t)
:extend
long-poll-first)))
(write-sequence page-data stream)
(write-sequence
(format nil "<script>clog['connection_id']='~A';Open_ws();</script>" id)
stream)
(when post-data
(write-sequence
(format nil "<script>clog['post-data']='~A'</script>"
post-data)
stream))
(if *break-on-error*
(funcall *on-connect-handler* id)
(handler-case
(funcall *on-connect-handler* id)
(t (c)
(format t "Condition caught connection ~A - ~A.~&" id c)
(values 0 c))))
(when *long-poll-first*
(setf *long-poll-first* nil)
(handler-case
(finish-output stream)
(t (c)
(format t "Condition caught finish-output ~A - ~A.~&" id c)
(values 0 c))))
(format t "HTML connection closed - ~A~%" id)))))
(t
(lambda (responder)
(let* ((writer (funcall responder '(200 (:content-type "text/html"))))
(stream (lack.util.writer-stream:make-writer-stream writer)))
(write-sequence page-data stream)
(when post-data
(write-sequence
(format nil "<script>clog['post-data']='~A'</script>"
post-data)
stream))
(finish-output stream)))))))))
;; Pass the handling on to next rule
(t (funcall app env))))))
(:static :path (lambda (path)
;; Request is static path if not the websocket connection.
;; Websocket url is /clog
(cond ((ppcre:scan "^(?:/clog$)" path) nil)
(t path)))
:root static-root)
;; Handle Websocket connection
(lambda (env)
(clog-server env))))
;; Wrap lack middlewares
(setf *app* (reduce #'funcall
lack-middleware-list
:initial-value *app*
:from-end t))
(setf *client-handler* (clack:clackup *app* :server server :address host :port port :ssl ssl :ssl-key-file ssl-key-file :ssl-cert-file ssl-cert-file))
(format t "HTTP listening on : ~A:~A~%" host port)
(format t "HTML root : ~A~%" static-root)
(format t "SSL : ~A~%" (if ssl
"yes"
"no"))
(format t "SSL Key File : ~A~%" ssl-key-file)
(format t "SSL Cert File : ~A~%" ssl-cert-file)
(format t "Long poll first : ~A~%" (if long-poll-first
"yes"
"no"))
(format t "Boot function added : ~A~%" (if boot-function
"yes"
"no"))
(format t "Boot html source use : ~A~%" (if static-boot-html
"static file"
"compiled version, when no file"))
(format t "Boot js source use : ~A~%" (if static-boot-js
"static file"
"compiled version"))
(format t "Boot file for path / : ~A~%" boot-file)
*client-handler*)
;;;;;;;;;;;;;;;;;;;;;;;;;
;; shutdown-connection ;;
;;;;;;;;;;;;;;;;;;;;;;;;;
(defun shutdown-connection ()
(clack:stop *client-handler*)
(setf *app* nil)
(setf *client-handler* nil))
;;;;;;;;;;;;
;; cclose ;;
;;;;;;;;;;;;
(defun cclose (connection-id)
"Close connection to CONNECTION-ID. The boot file may try to reestablish
connectivity."
(execute connection-id "ws.close()"))
;;;;;;;;;;;;;
;; execute ;;
;;;;;;;;;;;;;
(defun execute (connection-id message)
"Execute SCRIPT on CONNECTION-ID, disregard return value."
(if *long-poll-first*
(write-sequence (format nil "<script>~A</script>~%" message)
*long-poll-first*)
(let ((con (get-connection connection-id)))
(when con
(websocket-driver:send con message)))))
;;;;;;;;;;;
;; query ;;
;;;;;;;;;;;
(defun query (connection-id script &key (default-answer nil))
"Execute SCRIPT on CONNECTION-ID, return value. If times out answer
DEFAULT-ANSWER."
;; Provide delay if needed to establish websocket connection for
;; response.
(when *long-poll-first*
(finish-output *long-poll-first*)
(loop
for n from 1 to 10 do
(let ((con (get-connection connection-id)))
(when con
(unless (or (eq *extended-long-poll* :extend)
(> (decf *extended-long-poll*) 0))
(format t "Closing long-poll for ~A~%" connection-id)
(setf *long-poll-first* nil))
(return))
(format t "Awaiting websocket connection for ~A~%" connection-id)
(sleep .1))))
(let ((uid (generate-id)))
(prep-query uid (when default-answer (format nil "~A" default-answer)))
(execute connection-id
(format nil "ws.send (\"~A:\"+eval(\"~A\"));"
uid
(escape-string script)))
(wait-for-answer uid)))
;;;;;;;;;;;;;;;;;;;;;;;;
;; compiled-boot-html ;;
;;;;;;;;;;;;;;;;;;;;;;;;
(defun compiled-boot-html (path content)
(declare (ignore path content))
"Returns a compiled version version of boot.html. The compiled boot.html
uses the jQuery CDN instead of the static js files."
"<!doctype HTML>
<HTML>
<HEAD>
<meta http-equiv='Cache-Control' content='no-cache, no-store, must-revalidate' />
<meta http-equiv='Pragma' content='no-cache' />
<meta http-equiv='Expires' content='0' />
<meta charset='utf-8'>
<meta name='viewport' content='width=device-width, initial-scale=1'>
<script src='https://code.jquery.com/jquery-3.6.0.min.js'
integrity='sha256-/xUj+3OJU5yExlq6GSYGSHk7tPXikynS7ogEvDej/m4='
crossorigin='anonymous'></script>
<script src='/js/boot.js' type='text/javascript'></script>
<noscript><%= (@ meta) %></noscript>
</HEAD>
<BODY>
<noscript><%= (@ body) %></noscript>
</BODY>
<noscript>Your browser must support JavaScript and be HTML 5 compilant to see this site.</noscript>
</HTML>")

532
source/clog-connection.lisp
View file

@ -10,6 +10,7 @@
;;; the low level connectivity between lisp and the browser. ;;; the low level connectivity between lisp and the browser.
;;; ;;;
;;; clog <-> clog-connection <-> ;;; clog <-> clog-connection <->
;;; [clog-connection-websockets.lisp] - connection type specific layer
;;; clack <-> Hunchentoot (by default) <-> ;;; clack <-> Hunchentoot (by default) <->
;;; internet/localhost <-> browser ;;; internet/localhost <-> browser
;;; ;;;
@ -46,22 +47,25 @@ script."
"CLOG system utilities" "CLOG system utilities"
(escape-string function) (escape-string function)
(generate-id function)
(random-hex-string function)
(make-hash-table* function)
"CLOG connection interface"
(execute function)
(query function)
(validp function)
(cclose function)
(shutdown function)
(compiled-boot-html function) (compiled-boot-html function)
"CLOG connections" "CLOG low level browser access"
(execute function)
(query function)
(validp function)
(cclose function)
(shutdown function)
(put function) (put function)
(put-line function) (put-line function)
(new-line function) (new-line function)
(alert-box function) (alert-box function)
(generate-id function)
(random-hex-string function)
(debug-mode function) (debug-mode function)
(set-html-on-close function)) (set-html-on-close function))
@ -80,9 +84,6 @@ script."
(defvar *verbose-output* nil "Verbose server output (default false)") (defvar *verbose-output* nil "Verbose server output (default false)")
(defvar *break-on-error* t "Allow invoking debugger (default true)") (defvar *break-on-error* t "Allow invoking debugger (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 *on-connect-handler* nil "New connection event handler.")
(defvar *connections* (make-hash-table*) "Connections to IDs") (defvar *connections* (make-hash-table*) "Connections to IDs")
@ -105,23 +106,6 @@ generate random hex strings for connection IDs")
(defvar *url-to-boot-file* (make-hash-table* :test 'equalp) "URL to boot-file") (defvar *url-to-boot-file* (make-hash-table* :test 'equalp) "URL to boot-file")
(defvar *long-poll-first* nil
"Dynamic variable indicating to use html output instead of
websocket for output at start if connection.")
(defvar *extended-long-poll* nil
"Dynamic variable indicating to extend long polling beyond
extablishing websocket for output.")
(defvar *long-poll-url* nil
"Dynamic variable indicating the url path used.")
(defparameter *compiled-boot-js*
(with-open-file (stream (merge-pathnames #P"static-files/js/boot.js"
(asdf:system-source-directory :clog)))
(let ((content (make-string (file-length stream))))
(read-sequence content stream)
content))
"A compiled version of current version of boot.js (private)")
;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;
;; generate-id ;; ;; generate-id ;;
;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;
@ -198,182 +182,6 @@ the default answer. (Private)"
(format t "Condition caught in wait-for-answer - ~A.~&" c) (format t "Condition caught in wait-for-answer - ~A.~&" c)
(values 0 c)))) (values 0 c))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; handle-new-connection ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun handle-new-connection (connection id)
"Handle new incoming websocket CONNECTIONS with ID from boot page. (Private)"
(handler-case
(cond ((and id (gethash id *connection-data*))
(format t "Reconnection id - ~A to ~A~%" id connection)
(handler-case
(websocket-driver:close-connection (gethash id *connection-ids*)
"Aborting this old connection since receiving a reconnection request.")
(t (c)
(when *verbose-output*
(format t "Failed to close the old connection when establishing reconnection. This can be normal: The old connection could probably don't work for the client, so the client is requesting to reconnect.~%Condition - ~A.~&"
c))))
(setf (gethash id *connection-ids*) connection)
(setf (gethash connection *connections*) id))
(id
(format t "Reconnection id ~A not found. Closing the connection.~%" id)
(websocket-driver:close-connection connection)) ; Don't send the reason for better security.
(t
(setf id (random-hex-string))
(setf (gethash connection *connections*) id)
(setf (gethash id *connection-ids*) connection)
(setf (gethash id *connection-data*)
(make-hash-table* :test #'equal))
(setf (gethash "connection-id" (get-connection-data id)) id)
(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 ()
(if *break-on-error*
(funcall *on-connect-handler* id)
(handler-case
(funcall *on-connect-handler* id)
(t (c)
(format t "Condition caught connection ~A - ~A.~&" id c)
(values 0 c)))))
:name (format nil "CLOG connection ~A"
id))))
(t (c)
(format t "Condition caught in handle-new-connection - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;;;;;
;; handle-message ;;
;;;;;;;;;;;;;;;;;;;;
(defun handle-message (connection message)
"Handle incoming websocket MESSAGE on CONNECTION. (Private)"
(handler-case
(let ((connection-id (gethash connection *connections*))
(ml (ppcre:split ":" message :limit 2)))
(cond ((null connection-id)
;; a zombie connection
(when *verbose-output*
(format t "A zombie connection ~A. CLOG doesn't remember its connection-id. Closing it.~%"
connection))
(websocket-driver:close-connection connection)) ; don't send the reason for better security
((equal (first ml) "0")
;; a ping
(when *verbose-output*
(format t "Connection ~A Ping~%" connection-id)))
((equal (first ml) "E")
;; an event
(let* ((em (ppcre:split " " (second ml) :limit 2))
(event-id (first em))
(data (second em)))
(when *verbose-output*
(format t "Connection ~A Hook = ~A Data = ~A~%"
connection-id event-id data))
(bordeaux-threads:make-thread
(lambda ()
(if *break-on-error*
(let* ((event-hash (get-connection-data connection-id))
(event (when event-hash
(gethash event-id event-hash))))
(when event
(funcall event data)))
(handler-case
(let* ((event-hash (get-connection-data connection-id))
(event (when event-hash
(gethash event-id
event-hash))))
(when event
(funcall event data)))
(t (c)
(format t "Condition caught in handle-message for event - ~A.~&" c)
(values 0 c)))))
:name (format nil "CLOG event handler ~A"
event-id))))
(t
;; a JavaScript execution result
(let ((server-query-id (first ml))
(browser-returned-answer (second ml)))
(when *verbose-output*
(format t "Connection ~A ~A = ~A ~A = ~A~%"
connection-id
'server-query-id
server-query-id
'browser-returned-answer
browser-returned-answer))
(setf (gethash (parse-integer server-query-id) *queries*) browser-returned-answer)
(bordeaux-threads:signal-semaphore
(gethash (parse-integer server-query-id) *queries-sems*))))))
(t (c)
(format t "Condition caught in handle-message - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; handle-close-connection ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun handle-close-connection (connection)
"Close websocket CONNECTION. (Private)"
(handler-case
(let ((id (gethash connection *connections*)))
(when id
(when *verbose-output*
(format t "Connection id ~A has closed. ~A~%" id connection))
(remhash id *connection-data*)
(remhash id *connection-ids*)
(remhash connection *connections*)))
(t (c)
(format t "Condition caught in handle-close-connection - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;;
;; clog-server ;;
;;;;;;;;;;;;;;;;;
(defun clog-server (env)
"Setup websocket server on ENV. (Private)"
(handler-case
(let ((ws (websocket-driver:make-server env)))
(websocket-driver:on :open ws
(lambda ()
(handler-case
(let* ((query (getf env :query-string))
(items (when query
(quri:url-decode-params query)))
(id (when items
(cdr (assoc "r" items
:test #'equalp)))))
(handle-new-connection ws id))
(t (c)
(print env)
(format t "Condition caught in clog-server :open - ~A.~&" c)
(values 0 c)))))
(websocket-driver:on :message ws
(lambda (msg)
(handler-case
(handle-message ws msg)
(t (c)
(format t "Condition caught in clog-server :message - ~A.~&" c)
(values 0 c)))))
(websocket-driver:on :error ws
(lambda (msg)
(format t "Websocket error - ~A~&" msg)))
(websocket-driver:on :close ws
(lambda (&key code reason)
(declare (ignore code reason))
(handler-case
(handle-close-connection ws)
(t (c)
(format t "Condition caught in clog-server :close - ~A.~&" c)
(values 0 c)))))
(lambda (responder)
(declare (ignore responder))
(websocket-driver:start-connection ws)))
(t (c)
(format t "Condition caught in clog-server start-up - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;
;; random-port ;; ;; random-port ;;
;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;
@ -385,214 +193,17 @@ the default answer. (Private)"
(usocket:socket-close l) (usocket:socket-close l)
p)) p))
;;;;;;;;;;;;;;;;
;; initialize ;;
;;;;;;;;;;;;;;;;
(defun initialize (on-connect-handler
&key
(host "0.0.0.0")
(port 8080)
(server :hunchentoot)
(lack-middleware-list nil)
(extended-routing nil)
(long-poll-first nil)
(boot-file "/boot.html")
(boot-function nil)
(static-boot-html nil)
(static-boot-js nil)
(static-root #P"./static-files/")
(ssl nil)
(ssl-key-file nil)
(ssl-cert-file nil))
"Initialize CLOG on a socket using HOST and PORT to serve BOOT-FILE as the
default route for '/' to establish web-socket connections and static files
located at STATIC-ROOT. The webserver used with CLACK can be chosen with
:SERVER and middlewares prepended with :LACK-MIDDLEWARE-LIST,
NOT supporting LACK.BUILDER DSL.
If LONG-POLLING-FIRST is t, the output is sent as HTML instead of
websocket commands until the end of the on-new-window-handler, if
LONG-POLLING-FIRST is a number will keep long polling till that number of
queries to browser. LONG-POLLING-FIRST is used in webserver applications to
enable crawling of your website. If BOOT-FILE is nil no initial clog-path's will
be setup, use clog-path to add. The on-connect-handler needs to indentify the
path by querying the browser. See PATH-NAME (in CLOG-LOCATION). If
EXTENDED-ROUTING is t routes will match even if extend with additional / and
additional paths. If static-boot-js is nil then boot.js is served from the file
/js/boot.js instead of the compiled version. If static-boot-html is t if
boot.html is not present will use compiled version otherwise if set to nil (default)
if a boot file not found returns returns a blank page, if it is set to :error will
signal an error and if set to a string will display the string. boot-function if set is
called with the url and the contents of boot-file and its return value replaces
the contents sent to the brower."
(set-on-connect on-connect-handler)
(when boot-file
(set-clog-path "/" boot-file))
(setf *app*
(lack:builder
(lambda (app)
(lambda (env)
;; if not static-boot-js use internal compiled boot.js
(if (and (eq static-boot-js nil)
(equalp (getf env :path-info) "/js/boot.js"))
`(200 (:content-type "text/javascript")
(,*compiled-boot-js*))
(funcall app env))))
(lambda (app)
(lambda (env)
;; Special handling of "clog paths"
(let* ((url-path (getf env :path-info))
(clog-path (gethash url-path *url-to-boot-file*)))
(unless clog-path
(when extended-routing
(maphash (lambda (k v)
(unless (equal k "/")
(when (ppcre:scan (format nil "^~A/" k)
url-path)
(setf clog-path v))))
*url-to-boot-file*)))
(cond (clog-path
(let ((file (uiop:subpathname static-root clog-path)))
(with-open-file (stream file :direction :input
:if-does-not-exist nil)
(let ((page-data (if stream
(make-string (file-length stream))
(if static-boot-html
(cond ((eq static-boot-html t)
"")
((eq static-boot-html :error)
(error (format nil "Can not open boot file - ~A"
file)))
(t
static-boot-html))
(compiled-boot-html nil nil))))
(post-data nil))
(when stream
(read-sequence page-data stream))
(when boot-function
(setf page-data (funcall boot-function
url-path
page-data)))
(when (search "multipart/form-data;"
(getf env :content-type))
(let ((id (random-hex-string))
(req (lack.request:make-request env)))
(setf (gethash id *connection-data*)
(lack.request:request-body-parameters req))
(setf post-data id)))
(when (equal (getf env :content-type)
"application/x-www-form-urlencoded")
(setf post-data (cond ((eq (class-name (class-of (getf env :raw-body)))
'circular-streams:circular-input-stream)
(let ((array-buffer (make-array (getf env :content-length)
:adjustable t
:fill-pointer t)))
(read-sequence array-buffer (getf env :raw-body))
(flex:octets-to-string array-buffer)))
(t
(let ((string-buffer (make-string (getf env :content-length))))
(read-sequence string-buffer (getf env :raw-body))
string-buffer)))))
(cond (long-poll-first
(let ((id (random-hex-string)))
(setf (gethash id *connection-data*) (make-hash-table* :test #'equal))
(setf (gethash "connection-id" (get-connection-data id)) id)
(format t "New html connection id - ~A~%" id)
(lambda (responder)
(let* ((writer (funcall responder '(200 (:content-type "text/html"))))
(stream (lack.util.writer-stream:make-writer-stream writer))
(*long-poll-url* url-path)
(*long-poll-first* stream)
(*extended-long-poll* (if (eq long-poll-first t)
:extend
long-poll-first)))
(write-sequence page-data stream)
(write-sequence
(format nil "<script>clog['connection_id']='~A';Open_ws();</script>" id)
stream)
(when post-data
(write-sequence
(format nil "<script>clog['post-data']='~A'</script>"
post-data)
stream))
(if *break-on-error*
(funcall *on-connect-handler* id)
(handler-case
(funcall *on-connect-handler* id)
(t (c)
(format t "Condition caught connection ~A - ~A.~&" id c)
(values 0 c))))
(when *long-poll-first*
(setf *long-poll-first* nil)
(handler-case
(finish-output stream)
(t (c)
(format t "Condition caught finish-output ~A - ~A.~&" id c)
(values 0 c))))
(format t "HTML connection closed - ~A~%" id)))))
(t
(lambda (responder)
(let* ((writer (funcall responder '(200 (:content-type "text/html"))))
(stream (lack.util.writer-stream:make-writer-stream writer)))
(write-sequence page-data stream)
(when post-data
(write-sequence
(format nil "<script>clog['post-data']='~A'</script>"
post-data)
stream))
(finish-output stream)))))))))
;; Pass the handling on to next rule
(t (funcall app env))))))
(:static :path (lambda (path)
;; Request is static path if not the websocket connection.
;; Websocket url is /clog
(cond ((ppcre:scan "^(?:/clog$)" path) nil)
(t path)))
:root static-root)
;; Handle Websocket connection
(lambda (env)
(clog-server env))))
;; Wrap lack middlewares
(setf *app* (reduce #'funcall
lack-middleware-list
:initial-value *app*
:from-end t))
(setf *client-handler* (clack:clackup *app* :server server :address host :port port :ssl ssl :ssl-key-file ssl-key-file :ssl-cert-file ssl-cert-file))
(format t "HTTP listening on : ~A:~A~%" host port)
(format t "HTML root : ~A~%" static-root)
(format t "SSL : ~A~%" (if ssl
"yes"
"no"))
(format t "SSL Key File : ~A~%" ssl-key-file)
(format t "SSL Cert File : ~A~%" ssl-cert-file)
(format t "Long poll first : ~A~%" (if long-poll-first
"yes"
"no"))
(format t "Boot function added : ~A~%" (if boot-function
"yes"
"no"))
(format t "Boot html source use : ~A~%" (if static-boot-html
"static file"
"compiled version, when no file"))
(format t "Boot js source use : ~A~%" (if static-boot-js
"static file"
"compiled version"))
(format t "Boot file for path / : ~A~%" boot-file)
*client-handler*)
;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;
;; shutdown-clog ;; ;; shutdown-clog ;;
;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;
(defun shutdown-clog () (defun shutdown-clog ()
"Shutdown CLOG." "Shutdown CLOG."
(clack:stop *client-handler*) (shutdown-connection)
(clrhash *connection-data*) (clrhash *connection-data*)
(clrhash *connections*) (clrhash *connections*)
(clrhash *connection-ids*) (clrhash *connection-ids*)
(clrhash *url-to-boot-file*) (clrhash *url-to-boot-file*))
(setf *app* nil)
(setf *client-handler* nil))
;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;
;; set-on-connect ;; ;; set-on-connect ;;
@ -621,58 +232,28 @@ the contents sent to the brower."
;; escape-string ;; ;; escape-string ;;
;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;
(defun escape-string (str) (defun escape-string (str &key (no-nil nil) (html nil))
"Escape STR for sending to browser script." "Escape STR for sending to browser script. If no-nil is t (default is nil)
(let ((res)) if str is NIL returns empty string otherwise returns nil. If html is t the
(setf res (ppcre:regex-replace-all "\\x5C" str "\\x5C")) ; \ quotes are changed to html entities and \n and \r are eliminated. Escape
(setf res (ppcre:regex-replace-all "\\x22" res "\\x22")) ; " string is used for wire readiness i.e. ability to be evaluated client side
(setf res (ppcre:regex-replace-all "\\x27" res "\\x27")) ; ' and not for security purposes or html escapes."
(setf res (ppcre:regex-replace-all "\\x0A" res "\\x0A")) ; \n (if (and (not str) (not no-nil))
(setf res (ppcre:regex-replace-all "\\x0D" res "\\x0D")) ; \r nil
res)) (let ((res))
(setf res (format nil "~@[~A~]" str))
;;;;;;;;;;;;; (setf res (ppcre:regex-replace-all "\\x5C" res "\\x5C")) ; \
;; execute ;; (cond (html
;;;;;;;;;;;;; (setf res (ppcre:regex-replace-all "\\x22" res "&#x22;")) ; "
(setf res (ppcre:regex-replace-all "\\x27" res "&#x27;")) ; '
(defun execute (connection-id message) (setf res (ppcre:regex-replace-all "\\x0A" res "&#x0A;")) ; \n
"Execute SCRIPT on CONNECTION-ID, disregard return value." (setf res (ppcre:regex-replace-all "\\x0D" res "&#x0D"))) ; \r
(if *long-poll-first* (t
(write-sequence (format nil "<script>~A</script>~%" message) (setf res (ppcre:regex-replace-all "\\x22" res "\\x22")) ; "
*long-poll-first*) (setf res (ppcre:regex-replace-all "\\x27" res "\\x27")) ; '
(let ((con (get-connection connection-id))) (setf res (ppcre:regex-replace-all "\\x0A" res "\\x0A")) ; \n
(when con (setf res (ppcre:regex-replace-all "\\x0D" res "\\x0D")))) ; \r
(websocket-driver:send con message))))) res)))
;;;;;;;;;;;
;; query ;;
;;;;;;;;;;;
(defun query (connection-id script &key (default-answer nil))
"Execute SCRIPT on CONNECTION-ID, return value. If times out answer
DEFAULT-ANSWER."
;; Provide delay if needed to establish websocket connection for
;; response.
(when *long-poll-first*
(finish-output *long-poll-first*)
(loop
for n from 1 to 10 do
(let ((con (get-connection connection-id)))
(when con
(unless (or (eq *extended-long-poll* :extend)
(> (decf *extended-long-poll*) 0))
(format t "Closing long-poll for ~A~%" connection-id)
(setf *long-poll-first* nil))
(return))
(format t "Awaiting websocket connection for ~A~%" connection-id)
(sleep .1))))
(let ((uid (generate-id)))
(prep-query uid (when default-answer (format nil "~A" default-answer)))
(execute connection-id
(format nil "ws.send (\"~A:\"+eval(\"~A\"));"
uid
(escape-string script)))
(wait-for-answer uid)))
;;;;;;;;;;;; ;;;;;;;;;;;;
;; validp ;; ;; validp ;;
@ -684,15 +265,6 @@ DEFAULT-ANSWER."
t t
nil)) nil))
;;;;;;;;;;;;
;; cclose ;;
;;;;;;;;;;;;
(defun cclose (connection-id)
"Close connection to CONNECTION-ID. The boot file may try to reistablish
connectivity."
(execute connection-id "ws.close()"))
;;;;;;;;;;;;;; ;;;;;;;;;;;;;;
;; shutdown ;; ;; shutdown ;;
;;;;;;;;;;;;;; ;;;;;;;;;;;;;;
@ -754,31 +326,3 @@ HTML <br />."
the browser contents in case of connection loss." the browser contents in case of connection loss."
(execute connection-id (format nil "clog['html_on_close']='~A'" (execute connection-id (format nil "clog['html_on_close']='~A'"
(escape-string html)))) (escape-string html))))
;;;;;;;;;;;;;;;;;;;;;;;;
;; compiled-boot-html ;;
;;;;;;;;;;;;;;;;;;;;;;;;
(defun compiled-boot-html (path content)
(declare (ignore path content))
"Returns a compiled version version of boot.html. The compiled boot.html
uses the jQuery CDN instead of the static js files."
"<!doctype HTML>
<HTML>
<HEAD>
<meta http-equiv='Cache-Control' content='no-cache, no-store, must-revalidate' />
<meta http-equiv='Pragma' content='no-cache' />
<meta http-equiv='Expires' content='0' />
<meta charset='utf-8'>
<meta name='viewport' content='width=device-width, initial-scale=1'>
<script src='https://code.jquery.com/jquery-3.6.0.min.js'
integrity='sha256-/xUj+3OJU5yExlq6GSYGSHk7tPXikynS7ogEvDej/m4='
crossorigin='anonymous'></script>
<script src='/js/boot.js' type='text/javascript'></script>
<noscript><%= (@ meta) %></noscript>
</HEAD>
<BODY>
<noscript><%= (@ body) %></noscript>
</BODY>
<noscript>Your browser must support JavaScript and be HTML 5 compilant to see this site.</noscript>
</HTML>")

2
source/clog-document.lisp
View file

@ -123,7 +123,7 @@ clog-document object. (Private)"))
(defmethod (setf title) (value (obj clog-document)) (defmethod (setf title) (value (obj clog-document))
(execute obj (execute obj
(format nil "title='~A'" (clog-connection:escape-string value))) (format nil "title='~A'" (escape-string value)))
value) value)
;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;

15
source/clog-element.lisp
View file

@ -48,7 +48,7 @@ clog array but is not in the DOM. If HTML-ID is nil one is generated.
(private)" (private)"
(let ((web-id (if html-id (let ((web-id (if html-id
html-id html-id
(format nil "CLOG~A" (clog-connection:generate-id))))) (format nil "CLOG~A" (generate-id)))))
(clog-connection:execute (clog-connection:execute
connection-id connection-id
(format nil (format nil
@ -144,14 +144,13 @@ after attachment is changed to one unique to this session."))
&key (clog-type 'clog-element) &key (clog-type 'clog-element)
(new-id nil)) (new-id nil))
(if new-id (if new-id
(let ((id (format nil "CLOG~A" (clog-connection:generate-id)))) (let ((id (format nil "CLOG~A" (generate-id))))
(clog-connection:execute (connection-id obj) (js-execute obj
(format nil "$('#~A').attr('id','~A');clog['~A']=$('#~A').get(0)" (format nil "$('#~A').attr('id','~A');clog['~A']=$('#~A').get(0)"
html-id id id id)) html-id id id id))
(setf html-id id)) (setf html-id id))
(clog-connection:execute (connection-id obj) (js-execute obj (format nil "clog['~A']=$('#~A').get(0)"
(format nil "clog['~A']=$('#~A').get(0)" html-id html-id)))
html-id html-id)))
(make-clog-element (connection-id obj) html-id :clog-type clog-type)) (make-clog-element (connection-id obj) html-id :clog-type clog-type))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

29
source/clog-form.lisp
View file

@ -16,15 +16,13 @@
(:documentation "Get the form data as an a-list sent by the get method")) (:documentation "Get the form data as an a-list sent by the get method"))
(defmethod form-get-data ((obj clog-obj)) (defmethod form-get-data ((obj clog-obj))
(quri:uri-query-params (quri:uri-query-params (quri:uri (js-query obj "location.href"))))
(quri:uri (clog-connection:query (connection-id obj) "location.href"))))
(defgeneric form-post-data (clog-obj) (defgeneric form-post-data (clog-obj)
(:documentation "Get the form data as an a-list sent by post method")) (:documentation "Get the form data as an a-list sent by post method"))
(defmethod form-post-data ((obj clog-obj)) (defmethod form-post-data ((obj clog-obj))
(quri:url-decode-params (quri:url-decode-params (js-query obj "clog['post-data']")))
(clog-connection:query (connection-id obj) "clog['post-data']")))
(defgeneric form-multipart-data (clog-obj) (defgeneric form-multipart-data (clog-obj)
(:documentation "Get the form data as an a-list sent with the multipart (:documentation "Get the form data as an a-list sent with the multipart
@ -438,9 +436,8 @@ have this set true ever. Autofocus on element when form loaded."))
group called NAME.")) group called NAME."))
(defmethod radio-value ((obj clog-obj) name) (defmethod radio-value ((obj clog-obj) name)
(clog-connection:query (connection-id obj) (js-query obj (format nil "$('input:radio[name=~A]:checked').val()"
(format nil "$('input:radio[name=~A]:checked').val()" name)))
name)))
;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;
;; checkbox-value ;; ;; checkbox-value ;;
@ -450,9 +447,8 @@ group called NAME."))
(:documentation "Returns t or nil on the selected checkbox button.")) (:documentation "Returns t or nil on the selected checkbox button."))
(defmethod checkbox-value ((obj clog-obj) name) (defmethod checkbox-value ((obj clog-obj) name)
(js-on-p (clog-connection:query (connection-id obj) (js-on-p (js-query obj (format nil "$('input:checkbox[name=~A]:checked').val()"
(format nil "$('input:checkbox[name=~A]:checked').val()" name))))
name))))
;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;
;; select-value ;; ;; select-value ;;
@ -463,20 +459,18 @@ group called NAME."))
be unique name on entire document.")) be unique name on entire document."))
(defmethod select-value ((obj clog-obj) name) (defmethod select-value ((obj clog-obj) name)
(clog-connection:query (connection-id obj) (js-query obj (format nil "$('select[name=~A] option:selected').val()" name)))
(format nil "$('select[name=~A] option:selected').val()" name)))
;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;
;; textarea-value ;; ;; textarea-value ;;
;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;
(defgeneric textarea-value (clog-obj name) (defgeneric textarea-value (clog-obj name)
(:documentation "Returns the value of textarea item called NAME and must (:documentation "Returns the value of textarea item called NAME and must
be unique name on entire document.")) be unique name on entire document."))
(defmethod textarea-value ((obj clog-obj) name) (defmethod textarea-value ((obj clog-obj) name)
(clog-connection:query (clog::connection-id obj) (js-query obj (format nil "$('textarea#~A').val()" name)))
(format nil "$('textarea#~A').val()" name)))
;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;
;; name-value ;; ;; name-value ;;
@ -487,8 +481,7 @@ be unique name on entire document."))
be unique name on entire document.")) be unique name on entire document."))
(defmethod name-value ((obj clog-obj) name) (defmethod name-value ((obj clog-obj) name)
(clog-connection:query (connection-id obj) (js-query obj (format nil "$('input[name=~A]').val()" name)))
(format nil "$('input[name=~A]').val()" name)))
;;;;;;;;;;;;; ;;;;;;;;;;;;;
;; pattern ;; ;; pattern ;;

12
source/clog-gui.lisp
View file

@ -846,7 +846,7 @@ window-to-top-by-param or window-by-param."))
(html-id nil)) (html-id nil))
(let ((app (connection-data-item obj "clog-gui"))) (let ((app (connection-data-item obj "clog-gui")))
(unless html-id (unless html-id
(setf html-id (clog-connection:generate-id))) (setf html-id (generate-id)))
(when (eql (hash-table-count (windows app)) 0) (when (eql (hash-table-count (windows app)) 0)
;; If previously no open windows reset default position ;; If previously no open windows reset default position
(setf (last-x app) 0) (setf (last-x app) 0)
@ -1433,7 +1433,7 @@ interactions. Use window-end-modal to undo."))
"Create an alert toast with option :TIME-OUT. If place-top is t then alert "Create an alert toast with option :TIME-OUT. If place-top is t then alert
is placed in DOM at top of html body instead of bottom of html body." is placed in DOM at top of html body instead of bottom of html body."
(unless html-id (unless html-id
(setf html-id (clog-connection:generate-id))) (setf html-id (generate-id)))
(let* ((body (connection-data-item obj "clog-body")) (let* ((body (connection-data-item obj "clog-body"))
(win (create-child body (win (create-child body
(format nil (format nil
@ -1472,7 +1472,7 @@ is placed in DOM at top of html body instead of bottom of html body."
(html-id nil)) (html-id nil))
"Create an alert dialog box with CONTENT centered." "Create an alert dialog box with CONTENT centered."
(unless html-id (unless html-id
(setf html-id (clog-connection:generate-id))) (setf html-id (generate-id)))
(let* ((body (connection-data-item obj "clog-body")) (let* ((body (connection-data-item obj "clog-body"))
(win (create-gui-window obj (win (create-gui-window obj
:title title :title title
@ -1525,7 +1525,7 @@ is placed in DOM at top of html body instead of bottom of html body."
"Create an input dialog box with CONTENT centered and an input box. "Create an input dialog box with CONTENT centered and an input box.
Calls on-input with input box contents or nil if canceled." Calls on-input with input box contents or nil if canceled."
(unless html-id (unless html-id
(setf html-id (clog-connection:generate-id))) (setf html-id (generate-id)))
(let* ((body (connection-data-item obj "clog-body")) (let* ((body (connection-data-item obj "clog-body"))
(inp (if (eql rows 1) (inp (if (eql rows 1)
(format nil "<input type='text' id='~A-input' size='~A' value='~A'>" (format nil "<input type='text' id='~A-input' size='~A' value='~A'>"
@ -1607,7 +1607,7 @@ Calls on-input with input box contents or nil if canceled."
"Create a confirmation dialog box with CONTENT centered. "Create a confirmation dialog box with CONTENT centered.
Calls on-input with t if confirmed or nil if canceled." Calls on-input with t if confirmed or nil if canceled."
(unless html-id (unless html-id
(setf html-id (clog-connection:generate-id))) (setf html-id (generate-id)))
(let* ((body (connection-data-item obj "clog-body")) (let* ((body (connection-data-item obj "clog-body"))
(win (create-gui-window obj (win (create-gui-window obj
:title title :title title
@ -1698,7 +1698,7 @@ The size of any texarea field is controled by the size and rows parameters
Calls on-input after OK or Cancel with an a-list of field name to value Calls on-input after OK or Cancel with an a-list of field name to value
if confirmed or nil if canceled." if confirmed or nil if canceled."
(unless html-id (unless html-id
(setf html-id (clog-connection:generate-id))) (setf html-id (generate-id)))
(let* ((body (connection-data-item obj "clog-body")) (let* ((body (connection-data-item obj "clog-body"))
(fls (format nil "~{~A~}" (fls (format nil "~{~A~}"
(mapcar (lambda (l) (mapcar (lambda (l)

2
source/clog-helpers.lisp
View file

@ -102,7 +102,7 @@ set (logging to browser console) in the default debug.html boot-file."
(unless *clog-running* (unless *clog-running*
(initialize nil :boot-file boot-file :port port)) (initialize nil :boot-file boot-file :port port))
(set-on-new-window (lambda (body) (set-on-new-window (lambda (body)
(clog-connection:debug-mode (connection-id body)) (debug-mode body)
(when clog-web-initialize (when clog-web-initialize
(clog-web:clog-web-initialize body)) (clog-web:clog-web-initialize body))
(when clog-gui-initialize (when clog-gui-initialize

11
source/clog-jquery.lisp
View file

@ -32,12 +32,11 @@ Some sample jquery selectors:
selector1, selectorN, ...")) selector1, selectorN, ..."))
(defmethod create-jquery ((obj clog-obj) jquery) (defmethod create-jquery ((obj clog-obj) jquery)
(let ((html-id (format nil "CLOG~A" (clog-connection:generate-id)))) (let ((html-id (format nil "CLOG~A" (generate-id))))
(clog-connection:execute (js-execute obj
(connection-id obj) (format nil
(format nil "clog['~A']=$(\"~A\")"
"clog['~A']=$(\"~A\")" html-id jquery))
html-id jquery))
(make-clog-element (connection-id obj) html-id :clog-type 'clog-jquery))) (make-clog-element (connection-id obj) html-id :clog-type 'clog-jquery)))
;;;;;;;;;;;; ;;;;;;;;;;;;

2
source/clog-panel.lisp
View file

@ -229,7 +229,7 @@ HTML-ID if set is the base and top,left,right,center, bottom are added e.g.
if :HTML-ID \"myid\" then the HTML-ID for center will be: myid-center" if :HTML-ID \"myid\" then the HTML-ID for center will be: myid-center"
(let ((panel-box (make-instance 'clog-panel-box-layout))) (let ((panel-box (make-instance 'clog-panel-box-layout)))
(unless html-id (unless html-id
(setf html-id (clog-connection:generate-id))) (setf html-id (generate-id)))
(setf (top-panel panel-box) (setf (top-panel panel-box)
(create-panel clog-obj :left 0 :top 0 :right 0 :height top-height (create-panel clog-obj :left 0 :top 0 :right 0 :height top-height
:units units :units units

39
source/clog-utilities.lisp
View file

@ -8,18 +8,6 @@
(cl:in-package :clog) (cl:in-package :clog)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - make-hash-table*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun make-hash-table* (&rest args)
"Use native concurrent hash tables"
;; This covers sbcl ecl mazzano lw and ccl.
;; (lw and ccl default hash is synchronized)
#+(or sbcl ecl mezzano)
(apply #'make-hash-table :synchronized t args)
#-(or sbcl ecl mezzano) (apply #'make-hash-table args))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - with-clog-create ;; ;; Implementation - with-clog-create ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -167,33 +155,6 @@ CLOG-OBJ unless :NAME is set and is used instead."))
(t (t
(values default value)))) (values default value))))
;;;;;;;;;;;;;;;;;;;
;; escape-string ;;
;;;;;;;;;;;;;;;;;;;
(defun escape-string (str &key (no-nil nil) (html nil))
"Escape STR for sending to browser script. If no-nil is t (default is nil)
if str is NIL returns empty string otherwise returns nil. If html is t the
quotes are changed to html entities and \n and \r are eliminated. Escape
string is used for wire readiness i.e. ability to be evaluated client side
and not for security purposes or html escapes."
(if (and (not str) (not no-nil))
nil
(let ((res))
(setf res (format nil "~@[~A~]" str))
(setf res (ppcre:regex-replace-all "\\x5C" res "\\x5C")) ; \
(cond (html
(setf res (ppcre:regex-replace-all "\\x22" res "&#x22;")) ; "
(setf res (ppcre:regex-replace-all "\\x27" res "&#x27;")) ; '
(setf res (ppcre:regex-replace-all "\\x0A" res "&#x0A;")) ; \n
(setf res (ppcre:regex-replace-all "\\x0D" res "&#x0D"))) ; \r
(t
(setf res (ppcre:regex-replace-all "\\x22" res "\\x22")) ; "
(setf res (ppcre:regex-replace-all "\\x27" res "\\x27")) ; '
(setf res (ppcre:regex-replace-all "\\x0A" res "\\x0A")) ; \n
(setf res (ppcre:regex-replace-all "\\x0D" res "\\x0D")))) ; \r
res)))
;;;;;;;;;;;;;; ;;;;;;;;;;;;;;
;; lf-to-br ;; ;; lf-to-br ;;
;;;;;;;;;;;;;; ;;;;;;;;;;;;;;

4
source/clog-web.lisp
View file

@ -843,7 +843,7 @@ propetery will be set to nil on creation."))
"Create an alert toast with option :TIME-OUT. If place-top is t then alert "Create an alert toast with option :TIME-OUT. If place-top is t then alert
is placed in DOM at top of OBJ instead of bottom of OBJ." is placed in DOM at top of OBJ instead of bottom of OBJ."
(unless html-id (unless html-id
(setf html-id (clog-connection:generate-id))) (setf html-id (generate-id)))
(let* ((panel (create-child obj (let* ((panel (create-child obj
(format nil (format nil
" <div class='w3-panel ~A w3-animate-right w3-display-container'>~ " <div class='w3-panel ~A w3-animate-right w3-display-container'>~
@ -914,7 +914,7 @@ the value if set in the theme settings."
(when (getf (settings website) :color-class) (when (getf (settings website) :color-class)
(setf color-class (getf (settings website) :color-class))))) (setf color-class (getf (settings website) :color-class)))))
(unless html-id (unless html-id
(setf html-id (clog-connection:generate-id))) (setf html-id (generate-id)))
(let* ((fls (format nil "~{~A~}" (let* ((fls (format nil "~{~A~}"
(mapcar (lambda (l) (mapcar (lambda (l)
(cond (cond

24
source/clog-webgl.lisp
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;; ;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2021 David Botton ;;;; ;;;; (c) 2020-2024 David Botton ;;;;
;;;; License BSD 3 Clause ;;;; ;;;; License BSD 3 Clause ;;;;
;;;; ;;;; ;;;; ;;;;
;;;; clog-webgl.lisp ;;;; ;;;; clog-webgl.lisp ;;;;
@ -176,7 +176,7 @@ can be webgl (version 1) or webgl2 (default)"))
(defmethod create-webgl ((obj clog-canvas) &key (context "webgl2")) (defmethod create-webgl ((obj clog-canvas) &key (context "webgl2"))
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=clog['~A'].getContext('~A')" (js-execute obj (format nil "clog['~A']=clog['~A'].getContext('~A')"
web-id web-id
(html-id obj) context)) (html-id obj) context))
@ -869,7 +869,7 @@ See https://github.com/KhronosGroup/WebGL/blob/main/specs/latest/2.0/webgl2.idl
For :GLENUM values")) For :GLENUM values"))
(defmethod create-shader ((obj clog-webgl) glenum-type) (defmethod create-shader ((obj clog-webgl) glenum-type)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.createShader(~A.~A)" (js-execute obj (format nil "clog['~A']=~A.createShader(~A.~A)"
web-id web-id
(script-id obj) (script-id obj) glenum-type)) (script-id obj) (script-id obj) glenum-type))
@ -944,7 +944,7 @@ Returns a GLenum indicating whether the shader is a vertex shader (gl.VERTEX_SHA
(:documentation "Create a clog-webgl-program")) (:documentation "Create a clog-webgl-program"))
(defmethod create-program ((obj clog-webgl)) (defmethod create-program ((obj clog-webgl))
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.createProgram()" (js-execute obj (format nil "clog['~A']=~A.createProgram()"
web-id web-id
(script-id obj))) (script-id obj)))
@ -1010,7 +1010,7 @@ Returns a GLint indicating the number of uniform blocks containing active unifor
(:documentation "Returns the location of an uniform variable in clog-webgl-program")) (:documentation "Returns the location of an uniform variable in clog-webgl-program"))
(defmethod uniform-location ((obj clog-webgl-program) name) (defmethod uniform-location ((obj clog-webgl-program) name)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.getUniformLocation(~A,'~A')" (js-execute obj (format nil "clog['~A']=~A.getUniformLocation(~A,'~A')"
web-id web-id
(script-id (gl obj)) (script-id obj) name)) (script-id (gl obj)) (script-id obj) name))
@ -1037,7 +1037,7 @@ validation of WebGLProgram objects."))
(:documentation "Query about unknown attributes")) (:documentation "Query about unknown attributes"))
(defmethod active-attribute ((obj clog-webgl-program) index) (defmethod active-attribute ((obj clog-webgl-program) index)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.getActiveAttrib(~A,~A)" (js-execute obj (format nil "clog['~A']=~A.getActiveAttrib(~A,~A)"
web-id web-id
(script-id (gl obj)) (script-id obj) index)) (script-id (gl obj)) (script-id obj) index))
@ -1049,7 +1049,7 @@ validation of WebGLProgram objects."))
(:documentation "Query about unknown uniforms")) (:documentation "Query about unknown uniforms"))
(defmethod active-uniform ((obj clog-webgl-program) index) (defmethod active-uniform ((obj clog-webgl-program) index)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.getActiveUniform(~A,~A)" (js-execute obj (format nil "clog['~A']=~A.getActiveUniform(~A,~A)"
web-id web-id
(script-id (gl obj)) (script-id obj) index)) (script-id (gl obj)) (script-id obj) index))
@ -1117,7 +1117,7 @@ in WebGL2 the following added:
:PIXEL_UNPACK_BUFFER : Buffer used for pixel transfer operations.")) :PIXEL_UNPACK_BUFFER : Buffer used for pixel transfer operations."))
(defmethod create-webgl-buffer ((obj clog-webgl) &key bind-type) (defmethod create-webgl-buffer ((obj clog-webgl) &key bind-type)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.createBuffer()" (js-execute obj (format nil "clog['~A']=~A.createBuffer()"
web-id web-id
(script-id obj))) (script-id obj)))
@ -1195,7 +1195,7 @@ DATA-TYPE is the WebGL data type as a string \"Float32Array\""))
(:documentation "Create a clog-webgl-vertex-array")) (:documentation "Create a clog-webgl-vertex-array"))
(defmethod create-vertex-array ((obj clog-webgl)) (defmethod create-vertex-array ((obj clog-webgl))
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.createVertexArray()" (js-execute obj (format nil "clog['~A']=~A.createVertexArray()"
web-id web-id
(script-id obj))) (script-id obj)))
@ -1234,7 +1234,7 @@ clear* and blit-frame-buffer.
and blit-frame-buffer.")) and blit-frame-buffer."))
(defmethod create-webgl-frame-buffer ((obj clog-webgl) &key bind-type) (defmethod create-webgl-frame-buffer ((obj clog-webgl) &key bind-type)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.createFramebuffer()" (js-execute obj (format nil "clog['~A']=~A.createFramebuffer()"
web-id web-id
(script-id obj))) (script-id obj)))
@ -1289,7 +1289,7 @@ and blit-frame-buffer"))
is set binds the render-buffer to :RENDERBUFFER")) is set binds the render-buffer to :RENDERBUFFER"))
(defmethod create-webgl-render-buffer ((obj clog-webgl) &key bind-type) (defmethod create-webgl-render-buffer ((obj clog-webgl) &key bind-type)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.createRenderbuffer()" (js-execute obj (format nil "clog['~A']=~A.createRenderbuffer()"
web-id web-id
(script-id obj))) (script-id obj)))
@ -1343,7 +1343,7 @@ in WebGL 2 also:
:TEXTURE_2D_ARRAY : A two-dimensional array texture.")) :TEXTURE_2D_ARRAY : A two-dimensional array texture."))
(defmethod create-webgl-texture ((obj clog-webgl) &key bind-type) (defmethod create-webgl-texture ((obj clog-webgl) &key bind-type)
(let ((web-id (clog-connection:generate-id))) (let ((web-id (generate-id)))
(js-execute obj (format nil "clog['~A']=~A.createTexture()" (js-execute obj (format nil "clog['~A']=~A.createTexture()"
web-id web-id
(script-id obj))) (script-id obj)))

4
source/clog-window.lisp
View file

@ -33,7 +33,7 @@ them.")
(defun open-clog-popup (obj &key (path *clog-popup-path*) (defun open-clog-popup (obj &key (path *clog-popup-path*)
(add-sync-to-path t) (add-sync-to-path t)
(sync-key (clog-connection:random-hex-string)) (sync-key (random-hex-string))
(name "_blank") (name "_blank")
(specs "") (specs "")
(wait-timeout 10)) (wait-timeout 10))
@ -447,7 +447,7 @@ unless is a localhost url."))
(defmethod open-window ((obj clog-window) url &key (defmethod open-window ((obj clog-window) url &key
(name "_blank") (name "_blank")
(specs "")) (specs ""))
(let ((new-id (format nil "CLOG~A" (clog-connection:generate-id)))) (let ((new-id (format nil "CLOG~A" (generate-id))))
(execute obj (format nil "clog['~A']=open('~A','~A','~A')" (execute obj (format nil "clog['~A']=open('~A','~A','~A')"
new-id url name specs)) new-id url name specs))
(make-clog-window (connection-id obj) :html-id new-id))) (make-clog-window (connection-id obj) :html-id new-id)))

9
source/clog.lisp
View file

@ -16,6 +16,11 @@
(mgl-pax:define-package :clog (mgl-pax:define-package :clog
(:documentation "The Common List Omnificent GUI - CLOG") (:documentation "The Common List Omnificent GUI - CLOG")
(:import-from :clog-connection
#:make-hash-table*
#:escape-string
#:generate-id
#:random-hex-string)
(:use #:cl #:parse-float #:mgl-pax)) (:use #:cl #:parse-float #:mgl-pax))
(cl:in-package :clog) (cl:in-package :clog)
@ -84,6 +89,10 @@ embedded in a native template application.)"
"Declerative Syntax Support" "Declerative Syntax Support"
(with-clog-create macro) (with-clog-create macro)
"CLOG ID utilities"
(generate-id function)
(random-hex-string function)
"CLOG-Group - Utility Class for CLOG-Obj storage" "CLOG-Group - Utility Class for CLOG-Obj storage"
(clog-group class) (clog-group class)
(create-group function) (create-group function)