diff --git a/clog.asd b/clog.asd index 622399a..c493d1c 100644 --- a/clog.asd +++ b/clog.asd @@ -10,7 +10,7 @@ :description "CLOG - The Common Lisp Omnificent GUI" :author "David Botton " :license "BSD" - :version "1.9.0" + :version "2.2" :serial t :depends-on (#:clack #:websocket-driver #:alexandria #:hunchentoot #:cl-ppcre #:bordeaux-threads #:trivial-open-browser #:parse-float #:quri diff --git a/source/clog-connection-websockets.lisp b/source/clog-connection-websockets.lisp index b942e48..69a6206 100644 --- a/source/clog-connection-websockets.lisp +++ b/source/clog-connection-websockets.lisp @@ -17,13 +17,13 @@ (defvar *client-handler* nil "Clack 'handler' for socket traffic") (defvar *long-poll-first* nil - "Dynamic variable indicating to use html output instead of + "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 + "Dynamic variable indicating to extend long polling beyond extablishing websocket for output.") (defvar *long-poll-url* nil - "Dynamic variable indicating the url path used.") + "Dynamic variable indicating the url path used.") (defparameter *compiled-boot-js* (with-open-file (stream (merge-pathnames #P"static-files/js/boot.js" @@ -50,13 +50,13 @@ (setf (gethash id *connection-ids*) connection) (handler-case (websocket-driver:close-connection old - "Aborting this old connection since receiving a reconnection request.") + "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. ~ + (when *verbose-output* + (format t "Failed to close the old connection when establishing reconnection. ~ This can be normal: The old connection could not work for the client, ~ so the client is requesting to reconnect.~%Condition - ~A.~&" - c)))))) + c)))))) (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. @@ -95,67 +95,67 @@ (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 + ;; 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 *browser-gc-on-ping* - ;; run browser gc - (execute connection-id - "Object.entries(clog).forEach(function(c,i,a) + ;; a ping + (when *browser-gc-on-ping* + ;; run browser gc + (execute connection-id + "Object.entries(clog).forEach(function(c,i,a) {if ((c[1] !== null) && (typeof c[1] === 'object') && (c[1].nodeType===1)) {if (c[1].isConnected===false) {$(clog['body']).trigger('gc', c[0])}}})")) - (when *verbose-output* - (format t "Connection ~A Ping~%" connection-id) - (execute connection-id "null"))) + (when *verbose-output* + (format t "Connection ~A Ping~%" connection-id) + (execute connection-id "null"))) ((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 - (let* ((debug-hook (gethash "clog-debug" event-hash))) - (if (and debug-hook (not *disable-clog-debugging*)) - (funcall debug-hook event data) - (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)))) + ;; 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 + (let* ((debug-hook (gethash "clog-debug" event-hash))) + (if (and debug-hook (not *disable-clog-debugging*)) + (funcall debug-hook event data) + (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*)))))) + ;; 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)))) @@ -169,11 +169,11 @@ (when *verbose-output* (format t "Connection close request ~A.~%" connection)) - (when *reconnect-delay* - (when *verbose-output* - (format t "Connection close request ~A delayed ~A for reconnects.~%" - connection *reconnect-delay*)) - (sleep *reconnect-delay*)) + (when *reconnect-delay* + (when *verbose-output* + (format t "Connection close request ~A delayed ~A for reconnects.~%" + connection *reconnect-delay*)) + (sleep *reconnect-delay*)) (handler-case (let ((id (gethash connection *connections*))) (when id @@ -231,7 +231,7 @@ (handler-case (websocket-driver:start-connection ws) (t (c) - (format t "Condition caught in websocket-driver:start-connection - ~A.~&" c))))) + (format t "Condition caught in websocket-driver:start-connection - ~A.~&" c))))) (t (c) (format t "Condition caught in clog-server start-up - ~A.~&" c) (values '(400 nil) c)))) @@ -242,20 +242,20 @@ (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)) + (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 @@ -279,130 +279,125 @@ the contents sent to the brower." (set-on-connect on-connect-handler) (when boot-file (set-clog-path "/" boot-file)) + (setf *static-root* static-root) + (setf *clog-port* port) (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 "" id) - stream) - (when post-data - (write-sequence - (format nil "" - 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 "" - 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)))) + (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 "" id) + stream) + (when post-data + (write-sequence + (format nil "" + 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 "" + post-data) + stream)) + (finish-output stream))))))))) + ;; Pass the handling on to next rule + (t (funcall app env)))))) + (lambda (env) + (let* ((path (getf env :path-info))) + (cond ((and (eq static-boot-js nil) + (equalp path "/js/boot.js")) + `(200 (:content-type "text/javascript") + (,*compiled-boot-js*))) + ((ppcre:scan "^(?:/clog$)" path) + (clog-server env)) + (t + (lack/middleware/static::call-app-file *static-root* env))))))) ;; Wrap lack middlewares (setf *app* (reduce #'funcall lack-middleware-list @@ -475,15 +470,15 @@ DEFAULT-ANSWER." (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 ((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 @@ -500,7 +495,7 @@ DEFAULT-ANSWER." (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." -" + " diff --git a/source/clog-connection.lisp b/source/clog-connection.lisp index ddc7259..3e98dce 100644 --- a/source/clog-connection.lisp +++ b/source/clog-connection.lisp @@ -34,11 +34,13 @@ script." "CLOG system startup and shutdown" - (*verbose-output* variable) - (*browser-gc-on-ping* variable) - (*break-on-error* variable) + (*verbose-output* variable) + (*browser-gc-on-ping* variable) + (*break-on-error* variable) (*disable-clog-debugging* variable) - (*reconnect-delay* variable) + (*reconnect-delay* variable) + (*static-root* variable) + (*clog-port* variable) (initialize function) (random-port function) @@ -89,6 +91,8 @@ script." (defvar *break-on-error* t "Allow invoking debugger (default t)") (defvar *disable-clog-debugging* nil "When true turns off debug hooks (default nil)") (defvar *reconnect-delay* 7 "Time to delay in seconds for possible reconnect (default 7)") +(defparameter *static-root* nil "Contains the static-root setting after initialization.") +(defparameter *clog-port* 8080 "Port this instance of clog was started on") (defvar *on-connect-handler* nil "New connection event handler.") diff --git a/source/clog-system.lisp b/source/clog-system.lisp index c26b140..d0cded5 100644 --- a/source/clog-system.lisp +++ b/source/clog-system.lisp @@ -20,20 +20,9 @@ "Set a debug hook that is called for every event with (event data) that must be (funcall event data).") -(defvar *overide-static-root* nil - "Override the static-root settings. This is not normally a good idea, but if -trying to run the tutorials or demos and unable to have your local directory -the same as the clog directy this overides the relative paths used in them.") - -(defvar *static-root* nil - "Contains the static-root setting after initialization.") - (defvar *extended-routing* nil "If true extended routing is done.") -(defparameter *clog-port* 8080 - "Port this instance of clog was started on") - ;;;;;;;;;;;;;;;; ;; initialize ;; ;;;;;;;;;;;;;;;; @@ -134,11 +123,8 @@ number is chosen." (setf *clog-running* t) (when (or (eql port 0) (eq port nil)) (setf port (clog-connection:random-port))) - (setf *clog-port* port) - (setf *static-root* (truename (or *overide-static-root* - static-root))) (apply #'clog-connection:initialize - (append (list #'on-connect :static-root *static-root* :port *clog-port*) + (append (list #'on-connect :static-root static-root :port port) rest)))) ;;;;;;;;;;;;;;;;;;;;;;; diff --git a/source/clog.lisp b/source/clog.lisp index acf1e3b..10c67f8 100644 --- a/source/clog.lisp +++ b/source/clog.lisp @@ -17,6 +17,8 @@ (mgl-pax:define-package :clog (:documentation "CLOG - The Common List Omnificent GUI") (:import-from :clog-connection + :*clog-port* + :*static-root* #:make-hash-table* #:escape-string #:generate-id diff --git a/tools/clog-builder-panels.lisp b/tools/clog-builder-panels.lisp index ae565f8..a542e36 100644 --- a/tools/clog-builder-panels.lisp +++ b/tools/clog-builder-panels.lisp @@ -509,7 +509,9 @@ not a temporarily attached one when using select-control." (*default-title-class* *builder-title-class*) (*default-border-class* *builder-border-class*) ext-panel - (win (create-gui-window obj :top 40 :left (+ *builder-left-panel-size* 5) + (win (create-gui-window obj + :top (menu-bar-height obj) + :left (+ *builder-left-panel-size* 5) :width 645 :height 430 :client-movement *client-side-movement*)) (box (create-panel-box-layout (window-content win) diff --git a/tools/clog-builder-project-tree.lisp b/tools/clog-builder-project-tree.lisp index f57d9ff..7b810d3 100644 --- a/tools/clog-builder-project-tree.lisp +++ b/tools/clog-builder-project-tree.lisp @@ -86,6 +86,11 @@ (lambda (obj) (let* ((*default-title-class* *builder-title-class*) (*default-border-class* *builder-border-class*)) + (setf *static-root* + (merge-pathnames (if (equal (current-project app) "clog") + "./static-root/" + "./www/") + (format nil "~A" (asdf:system-source-directory (current-project app))))) (input-dialog obj "Run form:" (lambda (result) (when result @@ -100,7 +105,9 @@ :capture-console nil :capture-result nil :eval-in-package "clog-user"))) - :default-value entry-point)))) + :default-value entry-point) + (alert-toast obj "Static Root Set" + *static-root* :color-class "w3-yellow" :time-out 3)))) (labels ((project-tree-dir-select (node dir) (let ((filter (equalp (text-value filter-btn) "filter"))) diff --git a/tools/clog-builder-projects.lisp b/tools/clog-builder-projects.lisp index f2833f0..ea9f079 100644 --- a/tools/clog-builder-projects.lisp +++ b/tools/clog-builder-projects.lisp @@ -81,6 +81,13 @@ (let ((app (connection-data-item panel "builder-app-data")) (val (text-value (entry-point panel)))) (unless (equal val "") + (setf *static-root* + (merge-pathnames (if (equal (current-project app) "clog") + "./static-root/" + "./www/") + (format nil "~A" (asdf:system-source-directory (current-project app))))) + (alert-toast panel "Static Root Set" + *static-root* :color-class "w3-yellow") (setf clog:*clog-debug* (lambda (event data) (with-clog-debugger (panel diff --git a/tools/clog-builder-repl.lisp b/tools/clog-builder-repl.lisp index 7924a2d..4fe951a 100644 --- a/tools/clog-builder-repl.lisp +++ b/tools/clog-builder-repl.lisp @@ -2,6 +2,8 @@ (defun on-open-repl-console (obj repl) (let* ((win (on-open-file obj :title "CLOG REPL Console" + :top (+ (menu-bar-height obj) 485) + :left (+ *builder-left-panel-size* 5) :is-console t :closer-html "⨀" :editor-use-console-for-evals t))) @@ -18,6 +20,8 @@ (*default-title-class* *builder-title-class*) (*default-border-class* *builder-border-class*) (win (create-gui-window obj :title "CLOG Builder REPL" + :top (menu-bar-height obj) + :left (+ *builder-left-panel-size* 5) :has-pinner t :keep-on-top t :width 700 :height 480