new file mode 100644

@@ -0,0 +1,2 @@

+*.fasl

+*~

new file mode 100644

@@ -0,0 +1,84 @@

+(defpackage :fwoar.web-test

+  (:use :cl )

+  (:export ))

+(in-package :fwoar.web-test)

+

+(defclass websocket-server (hunchensocket:websocket-acceptor

+                            hunchentoot:easy-acceptor)

+  ())

+

+(defgeneric find-websocket-resource (acceptor request))

+

+(defmethod hunchentoot:acceptor-dispatch-request ((acceptor websocket-server)

+                                                  (request hunchensocket::websocket-request))

+  "Attempt WebSocket connection, else fall back to HTTP"

+  (cond ((and (member "upgrade" (cl-ppcre:split "\\s*,\\s*" (hunchentoot:header-in* :connection))

+                      :test #'string-equal)

+              (string= "websocket" (string-downcase (hunchentoot:header-in* :upgrade))))

+         (cond ((setf (hunchensocket:websocket-resource hunchentoot:*request*)

+                      (find-websocket-resource acceptor hunchentoot:*request*))

+                ;; Found the websocket resource

+                (hunchensocket::handle-handshake acceptor hunchentoot:*request* hunchentoot:*reply*)

+                ;; HACK! the empty string is also important because if there's

+                ;; no content Hunchentoot will declare the connection closed and

+                ;; set "Connection: Closed". But there can't be any actual

+                ;; content since otherwise it will piggyback onto the first

+                ;; websocket frame, which is interpreted as invalid by the

+                ;; client. It's also forbidden by the HTTP RFC2616:

+                ;;

+                ;;    [...] All 1xx (informational), 204 (no content), and 304

+                ;;    (not modified) responses MUST NOT include a

+                ;;    message-body. [...]

+                ;;

+                ;; There is a slight non-conformance here: this trick makes

+                ;; Hunchentoot send "Content-length: 0". Most browsers don't

+                ;; seem to care, but RFC2616 kind of implies that is forbidden,

+                ;; since it says the

+                ;;

+                ;;    [...] the presence of a message-body is signaled by the

+                ;;    inclusion of a Content-Length or Transfer-Encoding header

+                ;;    field in the requests's message-headers [...]

+                ;;

+                ;; Note however, we're sending a response, not a request.

+                ;;

+                (values "" nil nil))

+               (t

+                ;; Didn't find the websocket-specific resource, return 404.

+                (setf (hunchentoot:return-code hunchentoot:*reply*)

+                      hunchentoot:+http-not-found+)

+                (values nil nil nil))))

+        (t

+         ;; Client is not requesting websockets, let Hunchentoot do its HTTP

+         ;; thing undisturbed.

+         (call-next-method))))

+

+(defclass my-server (websocket-server)

+  ())

+

+(defclass chat-room (hunchensocket:websocket-resource)

+  ((name :initarg :name :initform (error "Name this room!") :reader name))

+  (:default-initargs :client-class 'user))

+

+(defclass user (hunchensocket:websocket-client)

+  ((name :initarg :user-agent :reader name :initform (error "Name this user!"))))

+

+(defvar *chat-rooms*

+  (list (make-instance 'chat-room :name "/bongo")

+        (make-instance 'chat-room :name "/fury")))

+

+(defmethod find-websocket-resource ((acceptor my-server) request)

+  (find (hunchentoot:script-name request)

+        *chat-rooms* :test #'string= :key #'name))

+

+(defun broadcast (room message &rest args)

+  (loop for peer in (hunchensocket:clients room)

+     do (hunchensocket:send-text-message peer (apply #'format nil message args))))

+

+(defmethod hunchensocket:client-connected ((room chat-room) user)

+  (broadcast room "~a has joined ~a" (name user) (name room)))

+

+(defmethod hunchensocket:client-disconnected ((room chat-room) user)

+  (broadcast room "~a has left ~a" (name user) (name room)))

+

+(defmethod hunchensocket:text-message-received ((room chat-room) user message)

+  (broadcast room "~a says ~a" (name user) message))