new file mode 100644

@@ -0,0 +1,75 @@

+(defpackage :fwoar.web-test.db

+  (:use :cl )

+  (:export :blog-post :id :title :author :content

+           :make-blog-post

+           :save-blog-post

+           :blog))

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

+

+(defgeneric id (ided-object))

+(defgeneric title (title-object))

+(defgeneric author (author-object))

+(defgeneric content (content-object))

+

+(defclass ided ()

+  ((%id :initarg :id :reader id)))

+

+(defun slugify (v)

+  (format nil "~(~{~a~^-~}~)"

+          (coerce (fwoar.string-utils:split " " v)

+                  'list)))

+

+(defclass blog-post (ided)

+  ((title :initarg :title :reader title :initform (error "must have a title"))

+   (author :initarg :author :reader author :initform (error "must have a author"))

+   (content :initarg :content :reader content :initform (error "must have a content")))

+  (:metaclass fwoar.server-aware-class:server-aware-class))

+

+(defmethod slot-unbound (class (blog-post blog-post) (slot-name (eql '%id)))

+  (setf (slot-value blog-post slot-name)

+        (slugify (title blog-post))))

+

+(defmethod yason:encode-slots progn ((object blog-post))

+  (yason:encode-object-elements

+   "title" (title object)

+   "author" (author object)

+   "content" (content object)))

+

+(defmacro new (class &rest initializer-syms)

+  `(make-instance ,class

+                  ,@(mapcan (serapeum:op (list (alexandria:make-keyword _1) _1))

+                            initializer-syms)))

+

+(defun make-blog-post (title author content)

+  (new 'blog-post title author content))

+

+(defun save-blog-post (blog post)

+  (montezuma:add-document-to-index blog post))

+

+

+(defmethod fset:compare ((a blog-post) (b blog-post))

+  (fset:compare-slots a b 'title 'author 'content))

+

+(defclass blog (montezuma:index)

+  ())

+

+(defmethod montezuma:add-document-to-index ((index blog) (doc blog-post)

+                                            &optional analyzer)

+  (with-accessors ((title title) (author author) (content content)) doc

+    (let* ((doc (make-instance 'montezuma:document)))

+      (montezuma:add-field doc (montezuma:make-field "title" title))

+      (montezuma:add-field doc (montezuma:make-field "author" author))

+      (montezuma:add-field doc (montezuma:make-field "content" content

+                                                     :index :tokenized))

+      (montezuma:add-document-to-index index doc analyzer))))

+

+(defmethod montezuma:get-document ((index blog) doc-number)

+  (let ((doc (call-next-method)))

+    (funcall (alexandria:compose

+              (data-lens:applying 'make-blog-post)

+              (data-lens:over 'montezuma:field-data)

+              (data-lens:juxt

+               (lambda (it) (montezuma:document-field it "title"))

+               (lambda (it) (montezuma:document-field it "author"))

+               (lambda (it) (montezuma:document-field it "content"))))

+             doc)))

new file mode 100644

@@ -0,0 +1,58 @@

+(defpackage :fwoar.mc-web

+  (:use :cl)

+  (:export

+   #:myway-server

+   #:*current-route*

+   #:routing

+   #:define-route-group

+   #:resolve-request))

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

+

+(defclass myway-acceptor (hunchentoot:acceptor)

+  ((%mapper :initform (myway:make-mapper) :reader mapper)))

+

+(defvar *current-route*)

+(define-method-combination route-group

+    ()

+  ((routes (:route *)))

+  (:arguments server)

+  `(progn

+     ,@(mapcar (lambda (method)

+                 `(let ((*method-route* ,(cadr (method-qualifiers method))))

+                    (myway:connect (mapper ,server) *method-route*

+                                   (call-method ,method))))

+               (stable-sort routes #'<

+                            :key (alexandria:compose #'length

+                                                     #'cadr

+                                                     #'method-qualifiers)))))

+

+(defmacro define-route-group (name (&rest args) &body body)

+  (let* ((docstring (when (and body (stringp (car body)))

+                      (car body)))

+         (body (if docstring

+                   (cdr body)

+                   body)))

+    (alexandria:with-gensyms (server)

+      `(defgeneric ,name (,server ,@args)

+         (:method-combination routing)

+         (:documentation ,docstring)

+         ,@(mapcar (serapeum:op `(:method

+                                     ,@(subseq _1 0 2)

+                                   (,server ,@(elt _1 2))

+                                   ,@(subseq _1 3)))

+                   body)))))

+

+(defgeneric resolve-request (acceptor request)

+  (:method-combination or :most-specific-first)

+  (:method or ((acceptor myway-acceptor) request)

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

+           (format nil "~s not found" (hunchentoot:script-name*))))

+

+(defmethod hunchentoot:acceptor-dispatch-request ((acceptor myway-acceptor) request)

+  (let ((router (mapper acceptor)))

+    (multiple-value-bind (result matched) (myway:dispatch router (hunchentoot:script-name*)

+                                                          :method (hunchentoot:request-method*))

+      (if matched

+          result

+          (or (resolve-request acceptor request)

+              (call-next-method))))))

new file mode 100644

@@ -0,0 +1,63 @@

+(defpackage :fwoar.myway-acceptor

+  (:use :cl)

+  (:export

+   #:*current-route*

+   #:define-route-group

+   #:resolve-request

+   #:myway-acceptor

+   #:route-group))

+(in-package :fwoar.myway-acceptor)

+

+(defclass myway-acceptor (hunchentoot:acceptor)

+  ((%mapper :initform (myway:make-mapper) :reader mapper)))

+

+(defvar *current-route*)

+(define-method-combination route-group

+    ()

+  ((routes (:route . *)))

+  (:arguments server)

+  `(progn

+     ,@(mapcar (lambda (method)

+                 (destructuring-bind (_ path . rest) (method-qualifiers method)

+                   (declare (ignore _))

+                   (let ((http-verb (when rest

+                                      (etypecase (car rest)

+                                        (keyword (list :method (car rest)))))))

+                     `(let ((*current-route* ,path))

+                        (myway:connect (mapper ,server) ,path

+                                       (call-method ,method)

+                                       ,@http-verb)))))

+               (stable-sort routes #'<

+                            :key (alexandria:compose #'length

+                                                     #'cadr

+                                                     #'method-qualifiers)))))

+

+(defmacro define-route-group (name (server &rest args) &body body)

+  (let* ((docstring (when (and body (stringp (car body)))

+                      (car body)))

+         (body (if docstring

+                   (cdr body)

+                   body)))

+    `(defgeneric ,name (,server ,@args)

+       (:method-combination route-group)

+       (:documentation ,docstring)

+       ,@(mapcar (serapeum:op `(:method

+                                   ,@(subseq _1 0 2)

+                                 (,@(elt _1 2))

+                                 ,@(subseq _1 3)))

+                 body))))

+

+(defgeneric resolve-request (acceptor request)

+  (:method-combination or :most-specific-first)

+  (:method or ((acceptor myway-acceptor) request)

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

+           (format nil "~s not found" (hunchentoot:script-name*))))

+

+(defmethod hunchentoot:acceptor-dispatch-request ((acceptor myway-acceptor) request)

+  (let ((router (mapper acceptor)))

+    (multiple-value-bind (result matched) (myway:dispatch router (hunchentoot:script-name*)

+                                                          :method (hunchentoot:request-method*))

+      (if matched

+          result

+          (or (resolve-request acceptor request)

+              (call-next-method))))))

new file mode 100644

@@ -0,0 +1,28 @@

+(defpackage :fwoar.server-aware-class

+  (:use :cl )

+  (:export

+   #:server-aware-class

+   #:serializable

+   #:publish-value

+   #:server))

+(in-package :fwoar.server-aware-class)

+

+(defgeneric publish-value (server class slot old-value new-value)

+  )

+

+(defclass server-aware-class (standard-class)

+  ((%server :accessor server :initform nil)))

+

+(defclass serializable ()

+  ())

+

+(defmethod closer-mop:validate-superclass ((meta server-aware-class) (class standard-class))

+  t)

+

+(defmethod (setf closer-mop:slot-value-using-class) :around (new-value (class server-aware-class) object slotd)

+  (if (and (server class) (c2mop:slot-boundp-using-class class object slotd))

+      (let ((old-value (c2mop:slot-value-using-class class object slotd)))

+        (call-next-method)

+        (publish-value (server class) (closer-mop:class-prototype class) (closer-mop:slot-definition-name slotd)

+                       old-value new-value))

+      (call-next-method)))

@@ -1,72 +1,49 @@

 (defpackage :fwoar.web-test

+  (:import-from :fwoar.myway-acceptor :define-route-group)

+  (:local-nicknames

+   (:db :fwoar.web-test.db))

   (:use :cl )

   (:export ))

 (in-package :fwoar.web-test)

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

-                            hunchentoot:easy-acceptor)

-  ())

+(defclass my-server (fwoar.websocket-acceptor:websocket-acceptor

+                     fwoar.myway-acceptor:myway-acceptor)

+  ((%models :initarg :models :reader models)))

+

+(defgeneric register-model (server model)

+  (:method (server model)

+    (error "~s is not a class or a class name" model))

+  (:method (server (model standard-class))

+    (error "can only register server-aware classes, got ~s!" model))

+  (:method ((server my-server) (model fwoar.server-aware-class:server-aware-class))

+    (setf (fwoar.server-aware-class:server model) server))

+  (:method ((server my-server) (model symbol))

+    (register-model server (find-class model))))

-(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 console-publisher ()

   ())

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

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

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

+(defmethod register-model ((publisher console-publisher)

+                           (model fwoar.server-aware-class:server-aware-class))

+  (setf (fwoar.server-aware-class:server model)

+        publisher))

+

+(defmethod update-instance-for-redefined-class ((instance my-server) added-slots discarded-slots property-list &key models)

+  (when (member '%models added-slots)

+    (setf (slot-value instance '%models) models)))

 (defclass user (hunchensocket:websocket-client)

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

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

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

+  (:default-initargs :client-class '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)

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

   (find (hunchentoot:script-name request)

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

@@ -75,10 +52,122 @@

      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))  

+  )  

+

+(defun render-post (post)

+  (spinneret:with-html

+    (:section

+     (:header

+      (:h* (db:title post))

+      (:div.author (db:author post)))

+     (:section (db:content post)))))

+

+(defun summarize (post)

+  (spinneret:with-html

+    (:li

+     (:a :href (format nil "/post/~a" (db:id post))

+         (db:title post)))))

+

+

+

+(defmethod fwoar.server-aware-class:publish-value ((server my-server)

+                                                   (object db:blog-post)

+                                                   (slot (eql 'posts))

+                                                   (old-value fset:map) (new-value fset:map))

+  (unless (fset:equal? old-value new-value)

+    (broadcast (car *chat-rooms*)

+               (yason:with-output-to-string* (:indent t)

+                 (yason:with-object ()

+                   (yason:encode-object-elements

+                    "slot" (string-downcase slot)

+                    "type" (string-downcase (class-name (class-of object))))

+                   (yason:with-object-element ("value")

+                     (yason:with-array ()

+                       (mapcar (lambda (it)

+                                 (let ((val (fset:lookup new-value it)))

+                                   (yason:with-object ()

+                                     (yason:encode-object-elements

+                                      "id" (id val)

+                                      "title" (title val)))))

+                               (fset:convert 'list (fset:domain (fset:map-difference-2 new-value old-value)))))))))))

+

+(defmethod fwoar.server-aware-class:publish-value ((server console-publisher)

+                                                   (object db:blog-post)

+                                                   slot

+                                                   (old-value string)

+                                                   (new-value string))

+  (unless (equal old-value new-value)

+    (format t "~&SLOT: ~s~%FROM: ~s~&TO: ~s~&"

+            slot

+            old-value

+            new-value)))

+

+

+(defgeneric m-index (thing)

+  )

+

+(defclass blog ()

+  ((%montezuma-index :initarg :montezuma :reader m-index)))

+

+(defun posts (blog)

+  (declare (ignorable blog))

+  (list (db:make-blog-post "First Post" "Ed L" "This is the first post")

+        (db:make-blog-post "Second Post" "Ed L" "This is the second post")

+        (db:make-blog-post "Third Post" "Ed L" "This is the third post")

+        (db:make-blog-post "Fourth Post" "Ed L" "This is the fourth post")))

+

+(defun connect-script ()

+  (ps:ps

+    (defun summarize (post)

+      (spinneret:with-html

+        (:li

+         (:a :href (ps:chain "/post/"

+                             (concat (ps:@ post id)))

+             (ps:@ post title)))))

+    (setf (ps:@ (ps:new (-web-socket "ws://localhost:12345/bongo")) onmessage)

+          (lambda (e)

+            (let ((data (ps:chain -j-s-o-n (parse (ps:@ e data)))))

+              (ps:chain data value

+                        (map (lambda (x)

+                               (ps:chain document

+                                         (query-selector "#posts")

+                                         (append-child (summarize x)))))))))))

+

+(defun page ()

+  (spinneret:with-html-string

+    (:doctype)

+    (:html

+     (:body

+      (:main

+       (:section

+        (:h* "My Blog")

+        (:ul#posts

+         (loop for post

+            in (fset:convert 'list (fset:range (posts blog)))

+            do (summarize post)))

+        (:script

+         (connect-script))))))))

+

+(define-route-group blog-methods (server blog)

+  (:route "/" ((server my-server) (blog blog))

+          (lambda (params)

+            (declare (ignore params))

+            ))

+  (:route "/post/:id" ((server my-server) (blog blog))

+          (lambda (params)

+            (spinneret:with-html-string

+                (:doctype)

+              (:html

+               (:body

+                (:main

+                 (:section

+                  (:h* "My Blog")

+                  (render-post

+                   (fset:lookup (posts blog) (getf params :id)))))))))))

+

new file mode 100644

@@ -0,0 +1,28 @@

+(defpackage :fwoar.websocket-acceptor

+  (:use :cl )

+  (:export

+   #:websocket-acceptor

+   #:find-websocket-resource))

+(in-package :fwoar.websocket-acceptor)

+

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

+  ())

+

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

+

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

+                                                  (request hunchensocket::websocket-request))

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

+version in hunchensocket to provide a better route-finding experience"

+  (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*))

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

+                (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 (call-next-method))))