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)

(defvar *stop-escape* nil)

;; 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)
  (murja.json:bind-json (sessionid call) (param)
			message 
			
			(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 param)))))

(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)))
   (post-js :accessor post-js :initform "" :initarg :post-js)
   (closure :initarg :closure :initform (error "Gimme closure") :accessor closure)
   (parameter-value-getter :initarg :parameter-value-getter :initform nil :accessor parameter-value-getter)))

(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))
  (if *stop-escape*
      s 
      (hunchentoot:escape-for-html 
       s)))

(defmethod render ((s t))
  (if s
      (if *stop-escape*
	  (prin1-to-string s)
	  (hunchentoot:escape-for-html 
	   (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
    (let* ((*stop-escape* (member :stop-escape attrs))
	   (attrs (alexandria:plist-hash-table attrs)))
      (remhash :stop-escape attrs)
      (let ((attrs (alexandria:hash-table-plist attrs)))
	(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))
	   (renderation (render c))
	   (json (json:stringify (hash ("id" id)
				       ("new-html" renderation)))))
      (hunchensocket:send-text-message *current-ws* json))))

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

(defmethod initialize-instance :after ((c component) &key)
  (with-slots (tag children) c 
    (assert (or (member tag *single-element-tags*)
		(equalp tag :script)
		children))
    c))

(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 &key (post-js "") (parameter-value-getter "window.event.target.value"))
  (let ((ev (make-instance 'event
			   :closure fn
			   :post-js post-js
			   :parameter-value-getter parameter-value-getter)))
    (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', ~a); ~a /*post-js*/; return false;" (generated-js-id e) (parameter-value-getter e) (post-js 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 (&rest unused)
							  (declare (ignore unused))
							  (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 param)
  (declare (ignore sessionid))
  (let* ((fn (gethash call-dst *js-identifiers-in-scope*)))
    (with-slots (closure) fn
      (murja.middleware.db:with-db
	  (format t "Calling ~a~%" fn)
	(funcall closure param)))))

(defun @newui (next)
  (render (funcall next)))