Plaster

commonlisp
(ql:quickload '(lichat-ws-server lichat-tcp-server ubiquitous)) (defpackage #:tynet-lichat (:use #:cl)) (in-package #:tynet-lichat) ;; Subclassing (defclass server (lichat-ws-server:server lichat-tcp-server:server) ((storage :initarg :storage :accessor storage)) (:default-initargs :storage :lichat :ws-port lichat-ws-server:*default-port* :tcp-port lichat-tcp-server:*default-port*)) (defmethod initialize-instance ((server server) &key ws-port tcp-port) (call-next-method) (ubiquitous:restore (storage server)) (ubiquitous:defaulted-value (make-hash-table :test 'equal) :profiles) (ubiquitous:defaulted-value (make-hash-table :test 'equal) :channels) (setf (lichat-serverlib:salt server) (ubiquitous:defaulted-value (princ-to-string (random (get-universal-time))) :salt)) (setf (slot-value server 'lichat-ws-server:port) ws-port) (setf (slot-value server 'lichat-tcp-server:port) tcp-port)) (defclass channel (lichat-ws-server:channel lichat-tcp-server:channel) ()) (defclass user (lichat-ws-server:user lichat-tcp-server:user) ()) (defclass profile (lichat-serverlib:profile) ()) (defmethod lichat-serverlib:make-connection ((server server) &rest initargs) (if (getf initargs :socket) (apply #'make-instance 'lichat-tcp-server:connection initargs) (apply #'make-instance 'lichat-ws-server:connection initargs))) (defmethod lichat-serverlib:make-channel ((server server) &rest initargs) (apply #'make-instance 'channel initargs)) (defmethod lichat-serverlib:make-user ((server server) &rest initargs) (apply #'make-instance 'user initargs)) (defmethod lichat-serverlib:make-profile ((server server) &rest initargs) (apply #'make-instance 'profile initargs)) ;; Storage sync (ubiquitous:define-ubiquitous-writer profile (profile) (list :name (copy-seq (lichat-protocol:name profile)) :password (lichat-protocol:password profile) :lifetime (lichat-protocol:lifetime profile) :timeout (lichat-serverlib:timeout profile))) (ubiquitous:define-ubiquitous-reader profile (initargs) (apply #'make-instance 'profile initargs)) (defmethod lichat-serverlib:profiles ((server server)) (ubiquitous:value :profiles)) (defmethod (setf lichat-serverlib:profiles) (table (server server)) (setf (ubiquitous:value :profiles) table)) (defmethod (setf lichat-serverlib:find-profile) :after (profile name (server server)) (v:info :lichat.server "~a: Setting profile ~a" server profile) (ubiquitous:offload)) (defmethod lichat-serverlib:remove-profile :after (profile (server server)) (v:info :lichat.server "~a: Removing profile ~a" server profile) (ubiquitous:offload)) (ubiquitous:define-ubiquitous-writer channel (channel) (list :name (lichat-protocol:name channel) :permissions (lichat-protocol:permissions channel) :lifetime (lichat-protocol:lifetime channel) :timeout (lichat-serverlib:timeout channel))) (ubiquitous:define-ubiquitous-reader channel (initargs) (apply #'make-instance 'channel initargs)) (defmethod lichat-serverlib:channels ((server server)) (ubiquitous:value :channels)) (defmethod (setf lichat-serverlib:channels) (table (server server)) (setf (ubiquitous:value :channels) table)) (defmethod (setf lichat-serverlib:find-channel) :after (channel name (server server)) (v:info :lichat.server "~a: Setting channel ~a" server channel) (ubiquitous:offload)) (defmethod lichat-serverlib:remove-channel :after (channel (server server)) (v:info :lichat.server "~a: Removing channel ~a" server channel) (ubiquitous:offload)) (defmethod (setf lichat-serverlib:find-user) :after (user name (server server)) (v:info :lichat.server "~a: Setting user ~a" server user)) (defmethod lichat-serverlib:remove-user :after (user (server server)) (v:info :lichat.server "~a: Removing user ~a" server user)) ;; Thin wrappers (defmethod open-connection ((server server)) (lichat-tcp-server:open-connection server) (lichat-ws-server:open-connection server)) (defmethod close-connection ((server server)) (lichat-tcp-server:close-connection server) (lichat-ws-server:close-connection server) (ubiquitous:offload (storage server))) ;; Start local instance (defvar *server* (make-instance 'server :name "TyNET" :hostname "0.0.0.0")) ;;(setf (v:repl-level) :trace) (open-connection *server*)