osc/devices/server.lisp

(cl:in-package #:osc)

(defun make-osc-server (&key (protocol :udp) debug-mode
                          (buffer-size *default-osc-buffer-size*)
                          cleanup-fun)
  (ecase protocol
    (:udp (make-instance 'osc-server-udp
                         :debug-mode debug-mode
                         :cleanup-fun cleanup-fun
                         :buffer-size buffer-size))
    (:tcp (make-instance 'osc-server-tcp
                         :debug-mode debug-mode
                         :cleanup-fun cleanup-fun
                         :buffer-size buffer-size))))

(defgeneric boot (osc-server port))

(defmethod boot :around ((server osc-server) port)
  (if (device-active-p server)
      (warn "~%Server ~A already running" (machine-instance)))
  (set-socket (make-socket (protocol server)) server)
  (socket-bind (socket server) #(0 0 0 0) port)
  (call-next-method)
  (format t "~%Server ~A listening on port ~A~%"
          (machine-instance) port))

(defmethod boot ((server osc-server-udp) port)
  (declare (ignore port))
  "UDP server sockets are used for receiving and unconnected sending."
  (set-listening-thread (make-listening-thread server) server))

(defmethod boot ((server osc-server-tcp) port)
  (declare (ignore port))
  (set-listening-thread
   (sb-thread:make-thread
    (lambda ()
      (unwind-protect
           (progn (socket-listen (socket server) 10)
                  (loop for socket = (socket-accept (socket server))
                     for endpoint = (make-osc-client-endpoint-tcp
                                     socket
                                     (debug-mode server)
                                     (buffer-size server)
                                     (address-tree server)
                                     (clients server)
                                     (make-unregister-self-fun server))
                     do (register-tcp-client server endpoint)))
        (osc-device-cleanup server)))
    :name (format nil "osc-server-tcp: ~A" (name server)))
   server)
  server)

(defmethod osc-device-cleanup ((device osc-server-udp))
  (loop for client-name being the hash-key in (clients device)
     using (hash-value addr+port)
     do (notify-quit device client-name)
     do (unregister-udp-client device
                               (first addr+port)
                               (second addr+port)))
  (call-next-method))

(defmethod osc-device-cleanup ((device osc-server-tcp))
  (loop for client being the hash-value in (clients device)
     do (quit client))
  (call-next-method))

(defun make-clients-hash ()
  (make-hash-table :test 'equal))


;;;=====================================================================
;;; UDP server functions
;;;=====================================================================

(defmethod initialize-instance :after ((server osc-server-udp) &key)
  (make-server-responders server))

(defgeneric make-server-responders (server))

(defmethod make-server-responders ((server osc-server-udp))
  (add-osc-responder server "/cl-osc/register"
      (cmd args device address port timetag)
    (let ((listening-port (car args))) ; Optional port for sending
                                        ; return messages to.
      (register-udp-client device address
                           (if listening-port listening-port port))))
  (add-osc-responder server "/cl-osc/quit"
      (cmd args device address port timetag)
    (unregister-udp-client device address port)))

(defun register-udp-client (server addr port)
  (let ((client-name (make-addr+port-string addr port)))
    (format t "Client registered: ~A~%" client-name)
    (setf (gethash client-name (clients server))
          (list addr port))
    (post-register-hook server client-name)))

(defun unregister-udp-client (server addr port)
  (let ((client-name (make-addr+port-string addr port)))
    (format t "Client quit: ~A~%" client-name)
    (remhash client-name (clients server))))

(defgeneric post-register-hook (server client-name)
  (:method ((server osc-server-udp) client-name)
    (format t "Post-register hook for client: ~A~%" client-name)
    (notify-registered server client-name)))

(defun notify-registered (server client-name)
  (send-to-client server client-name "/cl-osc/server/registered"))

(defun notify-quit (server client-name)
  (send-to-client server client-name "/cl-osc/server/quit"))


;;;=====================================================================
;;; TCP server functions
;;;=====================================================================

(defun register-tcp-client (server transmitter)
  "Clients are keyed on the names-string of the server-side socket,
not the peer name because the peer may close the socket after which
the peer name is no longer available. FIXME: Maybe we want to store
the peername independently of the socket's connection status?"
  (let ((client-name (make-name-string transmitter)))
    (when (debug-mode server)
      (format t "Client registered: ~A~%" client-name))
    (setf (gethash client-name (clients server)) transmitter)))

(defun unregister-tcp-client (server transmitter)
  (remhash (make-name-string transmitter)
           (clients server)))

(defun make-unregister-self-fun (server)
  #'(lambda (client)
      (unregister-tcp-client server client)))

(defun get-tcp-client (server socket-peername)
  (gethash socket-peername (clients server)))

(defgeneric print-clients (server))

(defmethod print-clients ((server osc-server-udp))
  (loop for addr+port being the hash-value in (clients server)
     for i from 1
     do (format t "~A. Connected to: ~A~%" i (make-addr+port-string
                                              (first addr+port)
                                              (second addr+port)))))

(defmethod print-clients ((server osc-server-tcp))
  (loop for endpoint being the hash-value in (clients server)
     for i from 1
     do (format t "~A. Connected to: ~A~%" i (make-addr+port-string
                                              (peer-address endpoint)
                                              (peer-port endpoint)))))

;;;=====================================================================
;;; Server sending functions
;;;=====================================================================

(defgeneric send-to-client (server client-name &rest msg)
  (:method :around ((server osc-server) client-name &rest msg)
           (let ((client (gethash client-name (clients server))))
             (if client
                 (apply #'call-next-method server client msg)
                 (warn "No client called ~A~%" client-name)))))

(defmethod send-to-client ((server osc-server-udp) client-name &rest
                                                                 msg)
  (apply #'send-to server (first client-name) (second client-name)
         msg))

(defmethod send-to-client ((server osc-server-tcp) client &rest msg)
  (apply #'send client msg))

(defgeneric send-bundle-to-client (server client-name timetag &rest
                                                                msg)
  (:method :around ((server osc-server) client-name timetag &rest msg)
           (let ((client (gethash client-name (clients server))))
             (if client
                 (apply #'call-next-method server client timetag msg)
                 (warn "No client called ~A~%" client-name)))))

(defmethod send-bundle-to-client ((server osc-server-udp) client-name
                                  timetag &rest msg)
  (apply #'send-bundle-to server (first client-name)
         (second client-name) timetag msg))