Fully WebSocket Server.

We're now using clack, lack, ningle, and websocket-driver.

Quite a few more dependencies.

live-chat-core.lisp

@@ -1,70 +0,0 @@
-(in-package #:cl-user)
-
-(in-package #:live-chat-core)
-
-;; (defvar *messages* (make-array 0 :adjustable t :fill-pointer t)
-;;   "Array to store chat messages.")
-
-(defun handle-post-message (message)
-  "Handle a new message being posted to the chat."
-  (insert-message message)
-  ;; (vector-push-extend message *messages*)
-  (format nil "Message received: ~a" message))
-
-(defun render-chat-messages ()
-  "Render the list of chat messages as HTML."
-  (let ((messages (fetch-messages)))
-    (if messages
-        (cl-who:with-html-output-to-string (*standard-output* nil :indent t)
-          (:h3 :class "title is-3" "Chat Messages")
-          (loop for msg in messages
-                do (cl-who:htm
-                    (:div :class "box" (cl-who:str msg)))))
-        "")))
-
-(defun render-chat-ui ()
-  "Render the main chat page with HTMX integration."
-  (cl-who:with-html-output-to-string (*standard-output* nil :prologue t :indent t)
-    (:html :lang "en"
-           (:head
-            (:meta :charset "utf-8")
-            (:meta :name "viewport" :content "width=device-width, initial-scale=1")
-            (:title "Live Chat")
-            (:link :rel "stylesheet"
-                   :href "https://cdnjs.cloudflare.com/ajax/libs/bulma/1.0.2/css/bulma.min.css"
-                   :integrity "sha512-RpeJZX3aH5oZN3U3JhE7Sd+HG8XQsqmP3clIbu4G28p668yNsRNj3zMASKe1ATjl/W80wuEtCx2dFA8xaebG5w=="
-                   :crossorigin "anonymous"
-                   :referrerpolicy "no-referrer")
-            (:script :src "https://cdnjs.cloudflare.com/ajax/libs/htmx/2.0.3/htmx.min.js"
-                     :integrity "sha512-dQu3OKLMpRu85mW24LA1CUZG67BgLPR8Px3mcxmpdyijgl1UpCM1RtJoQP6h8UkufSnaHVRTUx98EQT9fcKohw=="
-                     :crossorigin "anonymous"
-                     :referrerpolicy "no-referrer"))
-           (:body
-            (:section :class "section"
-                      (:div :class "container"
-                            (:h1 :class "title" "Live Chat")
-
-                            ;; Form for sending messages
-                            (:form :id "post-message-form"
-                                   :name "post-message-form"
-                                   :hx-post "/post-message"
-                                   :hx-swap "innerHTML"
-                                   :hx-target "#chat-messages"
-                                   (:div :class "field has-addons"
-                                         (:div :class "control is-expanded"
-                                               (:input :class "input is-expanded"
-                                                       :form "post-message-form"
-                                                       :placeholder "Ender your message..."
-                                                       :type "text" :name "message"))
-                                         (:div :class "control"
-                                               (:button :class "button is-link is-light"
-                                                        :form "post-message-form"
-                                                        :type "submit" "Send"))))))
-
-            ;; Chat messages will be updated by HTMX via GET to /chat-messages
-            (:section :class "section"
-                      (:div :class "container"
-                            :id "chat-messages"
-                            :hx-get "/chat-messages"
-                            :hx-trigger "every 2s"
-                            (cl-who:str (render-chat-messages))))))))

live-chat-db.lisp

@@ -3,48 +3,51 @@
 (defvar *db* nil
   "Database connection object.")
 
-(defun open-database ()
+(defvar *db-lock* (bt:make-lock)
-  "Open the SQLite database."
+  "Lock to ensure thread-safe access to database.")
-  (setf *db* (dbi:connect-cached
-              :sqlite3 :database-name
-              (asdf:system-relative-pathname :live-chat "chat.db"))))
 
-(defun close-database ()
+(defmacro with-database (conn &body body)
-  "Close the SQLite database."
+  "Open the SQLite database."
-  (when *db* (dbi:disconnect *db*)))
+  `(let ((*db* ,conn))
+     (bt:with-lock-held (*db-lock*)
+       ,@body)))
+
+(defun db ()
+  (dbi:connect-cached
+   :sqlite3 :database-name
+   (asdf:system-relative-pathname :live-chat "chat.db")))
 
 (defun create-messages-table ()
   "Create the messages table if it doesn't exist."
-  (open-database)
+  (with-database (db)
-  (let ((query (dbi:prepare *db*
+    (let ((query (dbi:prepare
-                            "CREATE TABLE IF NOT EXISTS messages
+                  *db*
-(id INTEGER PRIMARY KEY AUTOINCREMENT,
+                  "CREATE TABLE IF NOT EXISTS messages (id
- content TEXT NOT NULL)")))
+ INTEGER PRIMARY KEY AUTOINCREMENT,content TEXT NOT NULL)")))
-    (dbi:execute query (list)))
+      (dbi:execute query (list)))))
-  (close-database))
 
 (defun insert-message (message)
   "Insert a new message into the database."
-  (open-database)
+  (with-database (db)
-  (let ((query (dbi:prepare *db*
+    (let ((query (dbi:prepare
-                            "INSERT INTO messages (content) VALUES (?)")))
+                  *db*
-    (dbi:execute query (list message))
+                  "INSERT INTO messages (content) VALUES (?)")))
-    (close-database)
+      (dbi:execute query (list message))
-    message))
+      message)))
 
 (defun fetch-messages ()
   "Fetch all messages from the database."
-  (open-database)
+  (with-database (db)
-  (let* ((query (dbi:prepare *db*
+    (let* ((query (dbi:prepare *db*
-                             "SELECT content FROM messages ORDER BY id"))
+                               "SELECT content FROM messages ORDER BY id"))
-         (query (dbi:execute query (list)))
+           (query (dbi:execute query (list)))
-         (results (loop for row = (dbi:fetch query)
+           (results (loop for row = (dbi:fetch query)
-                        while row
+                          while row
-                        collect (getf row :|content|))))
+                          collect (getf row :|content|))))
-    (close-database)
+      (reverse results))))
-    (reverse results)))
 
 (defun clear-messages ()
   "Clear all messages from the database."
-  (let ((query (dbi:prepare *db* "DELETE FROM messages")))
+  (with-database (db)
-    (dbi:execute query (list))))
+    (let ((query (dbi:prepare *db* "DELETE FROM messages")))
+      (dbi:execute query (list)))))

live-chat-hunchentoot.lisp

@@ -1,43 +0,0 @@
-(in-package #:live-chat-hunchentoot)
-
-(defvar *server* nil
-  "The server acceptor.")
-
-(hunchentoot:define-easy-handler (chat-index :uri "/") ()
-  "Handle GET requests to / and render the chat UI."
-  (render-chat-ui))
-
-(hunchentoot:define-easy-handler (chat-handler :uri "/chat-messages") ()
-  "Handle GET requests to /chat-messages and render the chat UI."
-  (render-chat-messages))
-
-(hunchentoot:define-easy-handler (chat-post-handler :uri "/post-message" :default-request-type :post) ()
-  "Handle POST requests to /post-message and process the message."
-  (let ((message (hunchentoot:post-parameter "message")))
-    (when (and message (not (string= message "")))
-      (handle-post-message message)))
-  (render-chat-messages))
-
-(defun start-chat-server (&optional (address "localhost") (port 8080))
-  "Start the Hunchentoot chat server."
-  (setf (cl-who:html-mode) :html5
-        *server* (make-instance 'hunchentoot:easy-acceptor
-                                :address address
-                                :port port))
-  (hunchentoot:start *server*)
-  (format t "Chat server started on port 8080~%")
-  (wait-for-hunchentoot-listener "hunchentoot-listener-"))
-
-;; https://stackoverflow.com/a/30424968
-(defun wait-for-hunchentoot-listener (name)
-  (bt2:join-thread
-   (find-if
-    (lambda (th)
-      (prefixp name (bt2:thread-name th)))
-    (bt2:all-threads))))
-
-;; https://github.com/brown/base?tab=readme-ov-file#prefixp-prefix-sequence-key-test-eql
-(defun prefixp (prefix sequence &key (test #'eql))
-  "Does PREFIX match a prefix of SEQUENCE?"
-  (let ((mismatch (mismatch prefix sequence :test test)))
-    (or (null mismatch) (= mismatch (length prefix)))))

live-chat-main.lisp

@@ -1,5 +1,60 @@
 (in-package #:live-chat)
 
-(defun main ()
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  (create-messages-table)
+(defvar *handler* nil
-  (start-chat-server))
+  "The clack chat server app.")
+
+;; to wrap with multiple middlewares at once, use lack's builder macro
+(defparameter *app*
+  (lack:builder
+   :session
+   (:static :path "/public/"
+            :root #P"/static-files/")
+   ;; (lambda (app)
+   ;;   (lambda (env)
+   ;;     (prog1 (funcall app env)
+   ;;       (do-before-responding))))
+   (:mount "/ws-chat-messages" #'live-chat-ws:make-websocket-server)
+   live-chat-routes::*app*))
+
+;; Start the chat server
+(defun start-chat-server (&rest args &key (address "localhost") (port 8080) &allow-other-keys)
+  "Start the Clack chat server."
+  (setf *handler*
+        (apply #'clack:clackup *app*
+               :port port :host address args))
+  (when *handler*
+    (format t "Chat server started on ~A port ~A~%" address port)))
+
+(defun stop-chat-server (&rest args)
+  (declare (ignore args))
+  (when *handler*
+    (prog1
+        (clack:stop *handler*)
+      (setf *handler* nil)))
+  (unless *handler*
+    (format t "Chat server stopped.~%")))
+
+(defun restart-chat-server (&rest args)
+  (apply #'stop-chat-server args)
+  (apply #'start-chat-server args))
+
+(defun main (&rest args &key (foreground nil) &allow-other-keys)
+  (progn
+    (setf (cl-who:html-mode) :html5)
+    (create-messages-table)
+    (apply #'restart-chat-server args)))
+
+;; https://stackoverflow.com/a/30424968
+(defun wait-for-hunchentoot-listener (name)
+  (bt:join-thread
+   (find-if
+    (lambda (th)
+      (prefixp name (bt:thread-name th)))
+    (bt:all-threads))))
+
+;; https://github.com/brown/base?tab=readme-ov-file#prefixp-prefix-sequence-key-test-eql
+(defun prefixp (prefix sequence &key (test #'eql))
+  "Does PREFIX match a prefix of SEQUENCE?"
+  (let ((mismatch (mismatch prefix sequence :test test)))
+    (or (null mismatch) (= mismatch (length prefix)))))

live-chat-routes.lisp

@@ -0,0 +1,25 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(in-package #:live-chat-routes)
+
+;; Define a app for routing
+(defparameter *app* (make-instance 'ningle:app))
+
+;; Route to render the chat UI
+(setf (ningle:route *app* "/" :method :GET)
+      #'(lambda (params)
+          (declare (ignore params))
+          (live-chat-ui:render-chat-ui)))
+
+;; Route for chat messages
+(setf (ningle:route *app* "/chat-messages" :method :GET)
+      #'(lambda (params) 
+          (declare (ignore params))
+          (live-chat-ui:render-chat-messages)))
+
+;; Route for posting messages
+(setf (ningle:route *app* "/post-message" :method :POST)
+      #'(lambda (params)
+          (let ((message (cdr (assoc "message" params :test 'equal))))
+            (when (and message (not (string= message "")))
+              (handle-post-message message)))
+          (live-chat-ui:render-chat-messages)))

live-chat-ui.lisp

@@ -0,0 +1,92 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(in-package #:live-chat-ui)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar *default-prefix* "/lisp-chat")
+
+(defun set-subpath-prefix (prefix)
+  (setf *default-prefix* prefix))
+
+(defun subpath-prefix (path)
+  (format nil "~a~a" *default-prefix* path))
+  
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Render chat messages
+(defun render-chat-messages ()
+  "Render the list of chat messages as HTML."
+  (let ((messages (fetch-messages)))
+    (if messages
+        (cl-who:with-html-output-to-string (*standard-output* nil :indent t)
+          (loop for msg in messages
+                do (cl-who:htm
+                    (:div :class "box"
+                          :style "overflow:auto;"
+                          (cl-who:str msg)))))
+        "")))
+
+;; Render chat UI
+(defun render-chat-ui ()
+  "Render the main chat page with HTMX integration."
+  (cl-who:with-html-output-to-string (*standard-output* nil :prologue t :indent t)
+    (:html :lang "en"
+           (:head
+            (:meta :charset "utf-8")
+            (:meta :name "viewport" :content "width=device-width, initial-scale=1")
+            (:title "Live Chat")
+            (:link :rel "stylesheet"
+                   :href "https://cdnjs.cloudflare.com/ajax/libs/bulma/1.0.2/css/bulma.min.css"
+                   :integrity "sha512-RpeJZX3aH5oZN3U3JhE7Sd+HG8XQsqmP3clIbu4G28p668yNsRNj3zMASKe1ATjl/W80wuEtCx2dFA8xaebG5w=="
+                   :crossorigin "anonymous"
+                   :referrerpolicy "no-referrer")
+            (:script :src "https://cdnjs.cloudflare.com/ajax/libs/htmx/2.0.3/htmx.min.js"
+                     :integrity "sha512-dQu3OKLMpRu85mW24LA1CUZG67BgLPR8Px3mcxmpdyijgl1UpCM1RtJoQP6h8UkufSnaHVRTUx98EQT9fcKohw=="
+                     :crossorigin "anonymous"
+                     :referrerpolicy "no-referrer")
+            (:script :src "https://cdnjs.cloudflare.com/ajax/libs/htmx/2.0.3/ext/ws.min.js"
+                     :integrity "sha512-1OIiXEswZd/etj60BUwFmyoi0OhrWdoYlzayJpSBivoMV0pQPIQr+vtAn3W3htsbWtLRU8DrBl0epdK4DQbj/w=="
+                     :crossorigin "anonymous"
+                     :referrerpolicy "no-referrer"))
+           (:body
+            (:section :class "section"
+                      (:div :class "container"
+                            (:h1 :class "title" "Live Chat")
+                            (:div :class "field has-addons"
+                                  (:div :class "control is-expanded"
+                                        (:input :class "input is-expanded"
+                                                :id "chat-input"
+                                                :autocomplete "off"
+                                                :placeholder "Enter your message..."
+                                                :type "text" :name "message"))
+                                  (:div :class "control"
+                                        (:button :class "button is-link is-light"
+                                                 :type "submit" "Send")))))
+            (:section :class "section"
+                      (:div :class "container"
+                            :hx-ext "ws"
+                            :ws-connect (subpath-prefix "/ws-chat-messages")
+                            (:h3 :class "title is-3" "Chat Messages")
+                            (:div :class "container"
+                                  :id "chat-messages"
+                                  :hx-get "/chat-messages"
+                                  (cl-who:str (render-chat-messages)))))
+            (:script "
+////////////////////////////////////////////////////////////////////////////////
+
+function receivedMessage(msg) {
+    document.querySelector('#chat-messages')
+        .insertAdjacentHTML('afterbegin', msg.data);
+}
+
+// TODO {{ server-name }}:{{ server-port }}
+const ws = new WebSocket('ws://' + window.location.host + '/ws-chat-messages');
+ws.addEventListener('message', receivedMessage);
+
+////////////////////////////////////////////////////////////////////////////////
+
+const inputField = document.getElementById('chat-input');
+inputField.addEventListener('keyup', (evt) => {
+    if (evt.key === 'Enter') {
+        ws.send(evt.target.value);
+        evt.target.value = '';
+    }
+});")))))

live-chat-ws.lisp

@@ -0,0 +1,51 @@
+(in-package #:live-chat-ws)
+
+(defvar *connections* (make-hash-table))
+
+(defun handle-post-message (message)
+  "Handle a new message being posted to the chat."
+  (let ((message (cl-who:escape-string message)))
+    (format *standard-output* "Message received: ~a~%" message)
+    (live-chat-db:insert-message message)))
+
+(defun handle-new-connection (con)
+  (setf (gethash con *connections*)
+        (princ-to-string (gensym "USER-"))))
+
+(defun broadcast-to-room (connection message)
+  (handle-post-message message)
+  (let ((message
+          (cl-who:with-html-output-to-string (*standard-output*)
+            (:div :class "box"
+                  (format t "~a: ~a" (gethash connection *connections*) message)))))
+    (loop :for con :being :the :hash-key :of *connections* :do
+      (send con message))))
+
+(defun handle-close-connection (connection)
+  (let ((message 
+          (cl-who:with-html-output-to-string (*standard-output*)
+            (:div :class "box"
+                  (format t "... ~a disconnected."
+                          (gethash connection *connections*))))))
+    (loop :for con :being :the :hash-key :of *connections* :do
+      (send con message))))
+
+(defun make-websocket-server (env)
+  (handler-case
+      (let ((ws (make-server env)))
+        (on :open ws
+            (lambda ()
+              (handle-new-connection ws)))
+        (on :message ws
+            (lambda (msg)
+              (broadcast-to-room ws msg)))
+        (on :close ws
+            (lambda (&key code reason)
+              (declare (ignore code reason))
+              (handle-close-connection ws)))
+        (lambda (responder)
+          (declare (ignore responder))
+          (start-connection ws)))
+    (error (e)
+      (declare (ignore e))
+      (format nil "Something went wrong. Try again?"))))

live-chat.asd

@@ -12,10 +12,15 @@
   :depends-on (#:bordeaux-threads
                #:cl-dbi
                #:cl-who
-               #:hunchentoot)
+               #:clack
+               #:lack
+               #:ningle
+               ;; WebSocket chat server backend
+               #:websocket-driver)
   :components ((:file "package")
                (:file "live-chat-db")
-               (:file "live-chat-core")
+               (:file "live-chat-ui")
-               (:file "live-chat-hunchentoot")
+               (:file "live-chat-routes")
                (:file "live-chat-cgi")
+               (:file "live-chat-ws")
                (:file "live-chat-main")))

package.lisp

@@ -8,40 +8,59 @@
            #:close-database
            #:create-messages-table
            #:insert-message
-           #:fetch-messages))
+           #:fetch-messages
+           #:clear-messages))
 
-(defpackage #:live-chat-core
+(defpackage #:live-chat-ui
   (:use #:cl)
   (:local-nicknames (#:cl-who #:cl-who))
   (:import-from #:live-chat-db
                 #:insert-message
                 #:fetch-messages)
-  (:export #:render-chat-messages
+  (:export #:set-subpath-prefix
+           #:render-chat-messages
            #:render-chat-ui
            #:handle-post-message
            #:*messages*))
 
 (defpackage #:live-chat-cgi
   (:use #:cl)
-  (:import-from #:live-chat-core)
+  (:import-from #:live-chat-ui)
   (:export #:cgi-handler))
 
-(defpackage #:live-chat-hunchentoot
+(defpackage #:live-chat-routes
   (:use #:cl)
-  (:import-from #:live-chat-core
+  (:import-from #:live-chat-db
+                #:insert-message)
+  (:import-from #:live-chat-ui
                 #:handle-post-message
                 #:render-chat-messages
                 #:render-chat-ui)
   (:local-nicknames (#:cl-who #:cl-who)
-                    (#:hunchentoot #:hunchentoot))
+                    (#:myway #:myway))
-  (:export #:start-chat-server))
+  (:export #:app))
+
+(defpackage #:live-chat-ws
+  (:use #:cl)
+  (:import-from #:websocket-driver
+                #:make-client
+                #:make-server
+                #:on
+                #:send
+                #:start-connection
+                #:close-connection)
+  (:export #:make-websocket-server
+           #:handle-close-connection
+           #:broadcast-to-room
+           #:handle-new-connection
+           #:*connections*))
 
 (uiop:define-package #:live-chat
   (:use #:cl)
-  (:use-reexport #:live-chat-core
+  (:import-from #:clack #:clackup)
-                 #:live-chat-cgi
+  (:use-reexport #:live-chat-ui
                  #:live-chat-db
-                 #:live-chat-hunchentoot))
+                 #:live-chat-routes))
 
 (in-package #:live-chat)
 

readme.org

@@ -1,3 +1,11 @@
 * What It Is
 
-Twitch.TV-like live chat on the web. Uses HTMX to poll for messages. No database support (yet).
+Twitch.TV-like live chat on the web. Uses HTMX to poll for messages.
+
+* Database Connection
+
+It's using CL-DBI for SQLite connection.
+
+* WebSocket Support
+
+Now with WebSocket support for authentic live chat.