src/murja-newui/newui.lisp
(defpackage murja.newui
(:use :cl)
(:export :*server* :component :render :@newui :c :with-state :e)
(:local-nicknames (:json :com.inuoe.jzon))
(:import-from :cl-hash-util :hash))
(in-package :murja.newui)
;; pitäiskö nää olla uniikkeja per käyttäjä 🤔
(defclass ui-session (hunchensocket:websocket-resource)
((path :initarg :path :reader ui-path :initform "/newui"))
(:default-initargs :client-class 'ui-user))
(defclass ui-user (hunchensocket:websocket-client)
((uid :initarg :uid :initform (uuid:make-v4-uuid) :reader uid)
(state :initarg :state :initform nil :reader state)))
(defvar handlers (list (make-instance 'ui-session)))
(defun find-handler (request)
(format t "Finding handler ~a from handlers ~a~%"
(hunchentoot:script-name request)
handlers)
(find (hunchentoot:script-name request) handlers :test #'string= :key #'ui-path))
(pushnew 'find-handler hunchensocket:*websocket-dispatch-table*)
(defmethod hunchensocket:client-connected ((session ui-session) (user ui-user))
(hunchensocket:send-text-message user (format nil "SESSIONID:~a" (uid user)))
(format t "~a Connected!~%" (uid user)))
(defmethod hunchensocket:client-disconnected ((session ui-session) user)
(format t "DisConnected!~%"))
;; (defun broadcast (room message &rest args)
;; (loop for peer in (hunchensocket:clients room)
;; do (hunchensocket:send-text-message peer (apply #'format nil message args))
(defun get-msg-param (split-msg param)
(some (lambda (kv)
(let* ((split (str:split #\: kv)))
(and (string= (first split) param)
(second split))))
split-msg))
(defparameter *current-ws* nil)
(defmethod hunchensocket:text-message-received ((session ui-session) user message)
(let* ((split-msg (str:split #\; message))
(sessionid (get-msg-param split-msg "sessionid"))
(call-dst (get-msg-param split-msg "CALL")))
(format t "~a called ~a~%" (uid user) message)
(loop for peer in (hunchensocket:clients session)
when (and (equalp (uid user) (uid peer))
(equalp (prin1-to-string (uid peer)) sessionid))
do (let ((*current-ws* peer))
(call-event sessionid call-dst)))))
(defparameter *server* nil)
;;(hunchentoot:stop *server*)
;;(hunchentoot:start *server*)
;; html generator thing
(defclass component ()
((tag :initarg :tag :initform (error "Gimme tag") :accessor tag)
(attrs :initarg :attributes :initform (error "Gimme attributes") :accessor attrs)
(children :accessor children :initarg :children :initform (error "Gimme kids"))))
(defgeneric render (c)
(:documentation "Returns html of this (c ...) tree"))
(defgeneric rerender (c)
(:documentation "Compiles c into html and pushes it into a websocket"))
(defclass state ()
(;;(observers :initarg :observers :initform nil :accessor observers)
(root-component :initarg :root :initform nil :accessor root-component)
(root-component-generator :accessor root-component-generator)
(state-map :initarg :state :initform (hash) :accessor state-map)))
(defclass event ()
((generated-js-id :accessor generated-js-id :initform (format nil "fn~a" (random 98765)))
(closure :initarg :closure :initform (error "Gimme closure") :accessor closure)))
(defmethod set-state ((s state) key value)
(with-slots (state-map root-component root-component-generator) s
(setf (gethash key state-map) value)
(setf root-component (funcall root-component-generator))
(rerender root-component)))
(defmethod get-state ((s state) key)
(gethash key (state-map s)))
(defsetf get-state set-state)
(defmethod render ((s string))
s)
(defmethod render ((s t))
(if s
(prin1-to-string s)
""))
(defparameter *single-element-tags* (list :link :meta :input :img)
"Contains tags that don't expand to <:tag attrs>children</:tag> but instead into <:tag attrs />")
(defmethod render ((c component))
(with-slots (tag attrs children) c
(if (member tag *single-element-tags*)
(format nil "<~a~{ ~a=\"~a\"~^~} />" tag attrs)
(format nil "~a~&
<~a~{ ~a=\"~a\"~^~}>~% ~{~a~}~%</~a>~%"
(if (equalp tag :html) "<!DOCTYPE html>" "")
tag attrs (mapcar (lambda (kid) (render kid)) children) tag))))
(defmethod rerender ((c component))
(with-slots (attrs) c
(let ((id (getf attrs :id)))
(hunchensocket:send-text-message *current-ws* (json:stringify (hash ("id" id)
("new-html" (render c))))))))
(defmethod render ((e event))
"pääseeköhän tähän väliin?")
(defmethod render ((s state))
(render (root-component s)))
(defmacro component (tag attrs children)
"Precisely the same constructor as `c`, but takes its children as a list instead of &rest arguments"
`(make-instance 'component
:tag ,tag
:attributes (list ,@attrs)
:children ,children))
(defmacro c (tag attrs &rest children)
`(make-instance 'component
:tag ,tag
:attributes (list ,@attrs)
:children (list ,@children)))
(defvar *js-identifiers-in-scope* (hash))
(defun e (fn)
(let ((ev (make-instance 'event :closure fn)))
(setf (gethash (generated-js-id ev) *js-identifiers-in-scope*) ev)
ev))
(defparameter *component-format-string*
"(c ~s (~{~s~^ ~}) ~{~s~^ ~})")
(defmethod print-object ((c component) out)
(with-slots (tag attrs children) c
(format out *component-format-string* tag attrs children)))
(defmethod print-object ((e event) out)
(format out "send('~a');" (generated-js-id e)))
;; (with-slots (generated-js-id closure) e
;; (format out "#<generated-js-id: ~a, closure: ~a>" generated-js-id (function-lambda-expression closure))))
(defmethod print-object ((s state) out)
(format out
"(with-state (~{(~a ~a)~})
~a)" (alexandria:hash-table-plist (state-map s)) (root-component s)))
(defmacro with-state (bindings (&key (root-id (random 123456)))
&body body)
(let* ((rewritten-symbols (map 'list #'first bindings))
(values (map 'list #'second bindings))
(_
(assert (equalp (length rewritten-symbols)
(length values))))
(actual-bindings-plist))
(declare (ignore _))
(dotimes (i (length rewritten-symbols))
(push (nth i values) actual-bindings-plist)
(push `(quote ,(nth i rewritten-symbols)) actual-bindings-plist))
(labels ((rewrite (element)
(cond ((listp element) (map 'list #'rewrite element))
((member element rewritten-symbols) `(get-state current-state (quote ,element)))
(t element))))
`(let ((current-state (make-instance 'state :state (alexandria:plist-hash-table (list ,@actual-bindings-plist))))
(root-component-id (format nil "id~a" ,root-id)))
(setf (root-component current-state)
,@(rewrite body))
(with-slots (attrs) (root-component current-state)
(push root-component-id attrs)
(push :id attrs))
(setf (root-component-generator current-state) (lambda ()
(let ((comp ,@(rewrite body)))
(with-slots (attrs) comp
(push root-component-id attrs)
(push :id attrs)
comp))))
current-state))))
(easy-routes:defroute demo ("/demo" :method :get) ()
(let ((state (with-state ((linnunrata-vakio 42)) ()
(c :body ()
(c :header () "Willkommen!")
(c :div (:class "sidebar-flex")
(c :div () (format nil "~d bugia korjaamatta" linnunrata-vakio))
(c :button (:onclick (e (lambda ()
(format t "lollero ~a~%" linnunrata-vakio)
(decf linnunrata-vakio))))
"Vähennä bugeja tjsp."))))))
(format t "state: ~a ~%" state)
(render
(c :html (:lang "en")
(c :head ()
(c :style () "body { background-color: #880088; }")
(c :script (:src "/resources/newui.js"))
(c :link (:rel :stylesheet :src "/resources/murja.css")))
state))))
(setf hunchentoot:*catch-errors-p* nil)
;; fixes the hunchensocket's header->keyword bug
(setf (fdefinition 'chunga::as-keyword-if-found) (fdefinition 'chunga::as-keyword))
(defun call-event (sessionid call-dst)
(declare (ignore sessionid))
(let* ((fn (gethash call-dst *js-identifiers-in-scope*)))
(with-slots (closure) fn
(format t "Calling ~a~%" fn)
(funcall closure))))
(defun @newui (next)
(render (funcall next)))