add osc-devices
Ignore-this: 56da01e981b760cfc49a3007a67d629 darcs-hash:20100925134808-16a00-b2f8d2cd283140d964d264bec00e3ed67421bcae
This commit is contained in:
j.forth
Jamie Forth
parent
3ef5a50d7a
commit
05d6d6a27b
12 changed files with 983 additions and 5 deletions
86
devices/client.lisp
Normal file
86
devices/client.lisp
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
(cl:in-package #:osc)
|
||||
|
||||
(defun make-osc-client (&key(protocol :udp) debug-mode
|
||||
(buffer-size *default-osc-buffer-size*)
|
||||
address-tree cleanup-fun)
|
||||
(ecase protocol
|
||||
(:udp (make-instance 'osc-client-udp
|
||||
:debug-mode debug-mode
|
||||
:socket-buffer (make-socket-buffer
|
||||
buffer-size)
|
||||
:address-tree (if address-tree
|
||||
address-tree
|
||||
(make-osc-tree))
|
||||
:cleanup-fun cleanup-fun))
|
||||
(:tcp (make-instance 'osc-client-tcp
|
||||
:debug-mode debug-mode
|
||||
:socket-buffer (make-socket-buffer
|
||||
buffer-size)
|
||||
:address-tree (if address-tree
|
||||
address-tree
|
||||
(make-osc-tree))
|
||||
:cleanup-fun cleanup-fun))))
|
||||
|
||||
(defmethod initialize-instance :after ((client osc-client-udp) &key)
|
||||
(make-client-responders client))
|
||||
|
||||
(defgeneric make-client-responders (server))
|
||||
|
||||
(defmethod make-client-responders ((client osc-client-udp))
|
||||
(add-osc-responder client "/cl-osc/server/registered"
|
||||
(cmd args device address port timetag)
|
||||
(format t "Registered with server at ~A~%"
|
||||
(make-addr+port-string address port)))
|
||||
(add-osc-responder client "/cl-osc/server/quit"
|
||||
(cmd args device address port timetag)
|
||||
(format t "Server ~A has quit~%"
|
||||
(make-addr+port-string address port))))
|
||||
|
||||
(defgeneric register (client)
|
||||
(:method ((client osc-client-udp))
|
||||
(send client "/cl-osc/register" (port client))))
|
||||
|
||||
(defmethod osc-device-cleanup ((device osc-client-udp))
|
||||
(send device "/cl-osc/quit")
|
||||
(call-next-method))
|
||||
|
||||
(defun make-osc-client-endpoint-tcp (socket debug-mode buffer-size
|
||||
address-tree clients &optional
|
||||
cleanup-fun)
|
||||
(socket-make-stream socket
|
||||
:input nil :output t
|
||||
:element-type '(unsigned-byte 8)
|
||||
:buffering :full)
|
||||
(let ((client (make-instance 'osc-client-endpoint-tcp
|
||||
:debug-mode debug-mode
|
||||
:address-tree address-tree
|
||||
:socket-buffer (make-socket-buffer
|
||||
buffer-size)
|
||||
:clients clients
|
||||
:cleanup-fun cleanup-fun)))
|
||||
(set-socket socket client)
|
||||
(set-listening-thread (make-listening-thread client) client)
|
||||
client))
|
||||
|
||||
(defmethod make-listening-thread ((receiver osc-client-tcp))
|
||||
"Creates a listening thread for tcp clients."
|
||||
(sb-thread:make-thread
|
||||
(lambda ()
|
||||
(unwind-protect
|
||||
(loop
|
||||
do (multiple-value-bind (buffer length address port)
|
||||
(socket-receive (socket receiver)
|
||||
(socket-buffer receiver) nil)
|
||||
(when (eq length 0) ; Closed by remote
|
||||
(sb-thread:terminate-thread
|
||||
sb-thread:*current-thread*))
|
||||
(multiple-value-bind (message timetag)
|
||||
(decode-bundle buffer length)
|
||||
(when (debug-mode receiver)
|
||||
(print-osc-debug-msg receiver message length
|
||||
address port timetag))
|
||||
(dispatch (address-tree receiver) message receiver
|
||||
address port timetag))))
|
||||
(osc-device-cleanup receiver)))
|
||||
:name (format nil "osc-client-tcp-connection: ~A~%"
|
||||
(name receiver))))
|
||||
126
devices/device.lisp
Normal file
126
devices/device.lisp
Normal file
|
|
@ -0,0 +1,126 @@
|
|||
(cl:in-package #:osc)
|
||||
|
||||
;;;=====================================================================
|
||||
;;; OSC device base class
|
||||
;;;=====================================================================
|
||||
|
||||
(defclass osc-device ()
|
||||
((socket
|
||||
:reader socket
|
||||
:writer set-socket
|
||||
:initform nil)
|
||||
(debug-mode
|
||||
:reader debug-mode
|
||||
:writer set-debug-mode
|
||||
:initarg :debug-mode)
|
||||
(cleanup-fun
|
||||
:reader cleanup-fun
|
||||
:initarg :cleanup-fun
|
||||
:initform nil)))
|
||||
|
||||
;;;=====================================================================
|
||||
;;; OSC device mixin classes
|
||||
;;;=====================================================================
|
||||
|
||||
(defclass udp-device (osc-device) ())
|
||||
|
||||
(defclass tcp-device (osc-device) ())
|
||||
|
||||
(defclass listening-device (osc-device)
|
||||
((listening-thread
|
||||
:reader listening-thread
|
||||
:writer set-listening-thread
|
||||
:initform nil)))
|
||||
|
||||
(defclass receiving-device (listening-device)
|
||||
((socket-buffer
|
||||
:reader socket-buffer
|
||||
:initarg :socket-buffer
|
||||
:initform (make-socket-buffer))))
|
||||
|
||||
(defclass dispatching-device (listening-device)
|
||||
((address-tree
|
||||
:reader address-tree
|
||||
:initarg :address-tree
|
||||
:initform (make-osc-tree))))
|
||||
|
||||
(defclass dispatching-device-udp (dispatching-device receiving-device
|
||||
udp-device) ())
|
||||
|
||||
|
||||
;;;=====================================================================
|
||||
;;; OSC device abstract classes
|
||||
;;;=====================================================================
|
||||
|
||||
(defclass osc-transmitter (osc-device) ())
|
||||
|
||||
(defclass osc-client (dispatching-device receiving-device
|
||||
osc-transmitter) ())
|
||||
|
||||
(defclass osc-server (dispatching-device osc-transmitter)
|
||||
((buffer-size
|
||||
:reader buffer-size
|
||||
:initarg :buffer-size)
|
||||
(clients
|
||||
:reader clients
|
||||
:initarg :clients
|
||||
:initform (make-clients-hash))))
|
||||
|
||||
(defclass osc-client-endpoint (osc-client)
|
||||
((clients
|
||||
:reader clients
|
||||
:initarg :clients)))
|
||||
|
||||
|
||||
;;;=====================================================================
|
||||
;;; OSC device concrete classes
|
||||
;;;=====================================================================
|
||||
|
||||
(defclass osc-transmitter-udp (osc-transmitter udp-device) ())
|
||||
|
||||
(defclass osc-client-udp (osc-client dispatching-device-udp) ())
|
||||
|
||||
(defclass osc-client-tcp (osc-client tcp-device) ())
|
||||
|
||||
(defclass osc-server-udp (osc-server dispatching-device-udp
|
||||
osc-transmitter-udp) ())
|
||||
|
||||
(defclass osc-server-tcp (osc-server osc-transmitter tcp-device) ())
|
||||
|
||||
(defclass osc-client-endpoint-tcp (osc-client-endpoint
|
||||
osc-client-tcp) ())
|
||||
|
||||
|
||||
;;;=====================================================================
|
||||
;;; Device generic functions
|
||||
;;;=====================================================================
|
||||
|
||||
(defgeneric protocol (osc-device)
|
||||
(:method ((osc-device udp-device))
|
||||
:udp)
|
||||
(:method ((osc-device tcp-device))
|
||||
:tcp))
|
||||
|
||||
(defgeneric name (osc-device)
|
||||
(:method ((osc-device osc-device))
|
||||
(concatenate 'string
|
||||
(symbol-name (class-name (class-of osc-device)))
|
||||
"-"
|
||||
(make-name-string osc-device))))
|
||||
|
||||
(defmethod buffer-size ((osc-device dispatching-device))
|
||||
(length (socket-buffer osc-device)))
|
||||
|
||||
(defgeneric quit (osc-device))
|
||||
|
||||
(defgeneric osc-device-cleanup (device)
|
||||
(:method :before ((osc-device osc-device))
|
||||
(when (cleanup-fun osc-device)
|
||||
(funcall (cleanup-fun osc-device) osc-device)))
|
||||
(:method ((osc-device osc-device))
|
||||
(when (debug-mode osc-device)
|
||||
(format t "~%OSC device stopped: ~A~%"
|
||||
(name osc-device)))
|
||||
(when (socket osc-device)
|
||||
(socket-close (socket osc-device))
|
||||
(set-socket nil osc-device))))
|
||||
37
devices/dispatching-device.lisp
Normal file
37
devices/dispatching-device.lisp
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
(cl:in-package #:osc)
|
||||
|
||||
(defmethod make-listening-thread ((receiver dispatching-device-udp))
|
||||
"Creates a listening thread for udp devices (client and server)."
|
||||
(sb-thread:make-thread
|
||||
(lambda ()
|
||||
(unwind-protect
|
||||
(loop
|
||||
do (multiple-value-bind (buffer length address port)
|
||||
(socket-receive (socket receiver)
|
||||
(socket-buffer receiver) nil)
|
||||
(multiple-value-bind (message timetag)
|
||||
(osc:decode-bundle buffer length)
|
||||
(when (debug-mode receiver)
|
||||
(print-osc-debug-msg receiver message length
|
||||
address port timetag))
|
||||
(osc:dispatch (address-tree receiver) message
|
||||
receiver address port timetag))))
|
||||
(osc-device-cleanup receiver)))
|
||||
:name (format nil "osc-receiver-udp: ~A~%" (name receiver))))
|
||||
|
||||
|
||||
;;;=====================================================================
|
||||
;;; OSC Responders
|
||||
;;;=====================================================================
|
||||
|
||||
(defmacro add-osc-responder (dispatcher cmd-name
|
||||
(cmd args disp addr port timetag) &body
|
||||
body)
|
||||
`(dp-register (address-tree ,dispatcher) ,cmd-name
|
||||
(lambda (,cmd ,args ,disp ,addr ,port ,timetag)
|
||||
(declare (ignorable ,cmd ,args ,disp ,addr
|
||||
,port ,timetag)) ,@body)))
|
||||
|
||||
(defgeneric remove-osc-responder (dispatcher address)
|
||||
(:method ((dispatcher dispatching-device) address)
|
||||
(dp-remove (address-tree dispatcher) address)))
|
||||
259
devices/examples/osc-device-examples.lisp
Normal file
259
devices/examples/osc-device-examples.lisp
Normal file
|
|
@ -0,0 +1,259 @@
|
|||
(cl:in-package #:osc)
|
||||
|
||||
(asdf:oos 'asdf:load-op 'osc)
|
||||
|
||||
;;;=====================================================================
|
||||
;;; OSC UDP transmitter -> server
|
||||
;;;=====================================================================
|
||||
|
||||
(defparameter *osc-server* (make-osc-server :protocol :udp
|
||||
:debug-mode t))
|
||||
|
||||
(boot *osc-server* 57127)
|
||||
|
||||
(defparameter *osc-transmitter* (make-osc-transmitter
|
||||
:debug-mode t))
|
||||
|
||||
(connect *osc-transmitter* 57127 :host-name "localhost")
|
||||
(device-active-p *osc-transmitter*)
|
||||
(device-socket-name *osc-transmitter*)
|
||||
(address *osc-transmitter*)
|
||||
(port *osc-transmitter*)
|
||||
(device-socket-peername *osc-transmitter*)
|
||||
(peer-address *osc-transmitter*)
|
||||
(peer-port *osc-transmitter*)
|
||||
|
||||
(send *osc-transmitter* "/bar" 1 2 9)
|
||||
|
||||
(send-bundle *osc-transmitter*
|
||||
:time ; current real time
|
||||
"/foo" 1 2 3)
|
||||
|
||||
(send-bundle *osc-transmitter*
|
||||
:now ; immediately
|
||||
"/foo" 1 2 3)
|
||||
|
||||
(send-bundle *osc-transmitter*
|
||||
(unix-time->timetag 1234567890.1234567d0)
|
||||
"/foo" 1 2 3)
|
||||
|
||||
(quit *osc-transmitter*)
|
||||
(quit *osc-server*)
|
||||
|
||||
|
||||
;;;=====================================================================
|
||||
;;; OSC UDP client <-> server
|
||||
;;;=====================================================================
|
||||
|
||||
(defparameter *osc-server* (make-osc-server :protocol :udp
|
||||
:debug-mode t))
|
||||
|
||||
(boot *osc-server* 57127)
|
||||
|
||||
(defparameter *osc-client* (make-osc-client
|
||||
:protocol :udp
|
||||
:debug-mode t))
|
||||
|
||||
(connect *osc-client* 57127 :host-name "localhost")
|
||||
|
||||
;; A UDP server can't know about a client unless it registers.
|
||||
(print-clients *osc-server*)
|
||||
(register *osc-client*)
|
||||
(print-clients *osc-server*)
|
||||
(quit *osc-client*) ; quit notifies the server
|
||||
(print-clients *osc-server*)
|
||||
|
||||
(connect *osc-client* 57127 :host-name "localhost")
|
||||
|
||||
(send *osc-client* "/foo" 2 99)
|
||||
|
||||
(send-bundle *osc-client*
|
||||
(unix-time->timetag 1234567890.1234567d0)
|
||||
"/foo" 1 2 3)
|
||||
|
||||
(send-bundle *osc-client* :now "/foo" 1)
|
||||
|
||||
(send-bundle *osc-client* :time "/foo" 1)
|
||||
|
||||
;; Using the server as a transmitter.
|
||||
(send-to *osc-server* (address *osc-client*) (port *osc-client*)
|
||||
"/bar" 1 2 3)
|
||||
|
||||
;; If a client is registered...
|
||||
(send-to-client *osc-server* (make-name-string *osc-client*)
|
||||
"/bar" 2 99)
|
||||
|
||||
(register *osc-client*)
|
||||
|
||||
(send-to-client *osc-server* (make-name-string *osc-client*)
|
||||
"/bar" 2 99)
|
||||
|
||||
(send-bundle-to-client *osc-server*
|
||||
(make-name-string *osc-client*)
|
||||
:time
|
||||
"/bar" 2 99)
|
||||
|
||||
(add-osc-responder *osc-server* "/echo-sum"
|
||||
(cmd args device address port timetag)
|
||||
(send-to device address port "/echo-answer" (apply #'+ args)))
|
||||
|
||||
(add-osc-responder *osc-client* "/echo-answer"
|
||||
(cmd args device address port timetag)
|
||||
(format t "~%Sum is ~A" (car args)))
|
||||
|
||||
(send *osc-client* "/echo-sum" 1 2 3 4)
|
||||
|
||||
(add-osc-responder *osc-server* "/timetag+1"
|
||||
(cmd args device address port timetag)
|
||||
(send-bundle-to device address port (timetag+ timetag 1) "/future"))
|
||||
|
||||
(send-bundle *osc-client* (get-current-timetag)
|
||||
"/timetag+1")
|
||||
|
||||
;; Send a messages to all registered clients.
|
||||
(send-all *osc-server* "/foo" 1 2 3)
|
||||
|
||||
(send-bundle-all *osc-server* :now "/foo" 1 2 3)
|
||||
|
||||
(quit *osc-client*)
|
||||
(quit *osc-server*)
|
||||
|
||||
|
||||
;;;=====================================================================
|
||||
;;; OSC TCP client <-> server
|
||||
;;;=====================================================================
|
||||
|
||||
(defparameter *osc-server* (make-osc-server :protocol :tcp
|
||||
:debug-mode t))
|
||||
|
||||
(boot *osc-server* 57127)
|
||||
|
||||
(defparameter *osc-client* (make-osc-client
|
||||
:protocol :tcp
|
||||
:debug-mode t))
|
||||
|
||||
(connect *osc-client* 57127 :host-name "localhost")
|
||||
|
||||
(device-active-p *osc-client*)
|
||||
(device-socket-name *osc-client*)
|
||||
(device-socket-peername *osc-client*)
|
||||
|
||||
(send *osc-client* "/foo" 1 2 3)
|
||||
|
||||
(send-to-client *osc-server* (make-name-string
|
||||
*osc-client*)
|
||||
"/foo" 1 2 3)
|
||||
|
||||
(defparameter *osc-client2* (make-osc-client
|
||||
:protocol :tcp
|
||||
:debug-mode t))
|
||||
|
||||
(connect *osc-client2* 57127
|
||||
:host-address "127.0.0.1"
|
||||
:port 57666) ; choose local port
|
||||
|
||||
(device-socket-name *osc-client2*)
|
||||
|
||||
(send *osc-client2* "/bar" 4 5 6 9)
|
||||
|
||||
(print-clients *osc-server*)
|
||||
|
||||
(add-osc-responder *osc-server* "/print-sum"
|
||||
(cmd args device address port timetag)
|
||||
(format t "Sum = ~A~%" (apply #'+ args)))
|
||||
|
||||
(send *osc-client2* "/print-sum" 4 5 6 9)
|
||||
|
||||
(add-osc-responder *osc-server* "/echo-sum"
|
||||
(cmd args disp address port timetag)
|
||||
(send disp cmd (apply #'+ args)))
|
||||
|
||||
(send *osc-client2* "/echo-sum" 4 5 6 9)
|
||||
|
||||
(send-all *osc-server* "/bar" 1 2 3) ; send to all peers
|
||||
|
||||
(add-osc-responder *osc-server* "/echo-sum-all"
|
||||
(cmd args disp address port timetag)
|
||||
(send-all disp cmd (apply #'+ args)))
|
||||
|
||||
; Send to all peers (excluding self).
|
||||
(send *osc-client2* "/echo-sum-all" 1 2 3)
|
||||
|
||||
(quit *osc-client*)
|
||||
(quit *osc-client2*)
|
||||
(quit *osc-server*)
|
||||
|
||||
|
||||
;;;=====================================================================
|
||||
;;; OSC UDP client <-> sclang
|
||||
;;;=====================================================================
|
||||
|
||||
(defparameter *osc-client* (make-osc-client
|
||||
:protocol :udp
|
||||
:debug-mode t))
|
||||
|
||||
(connect *osc-client* 57120 :host-name "localhost" :port 57127)
|
||||
(address *osc-client*)
|
||||
(port *osc-client*)
|
||||
(peer-address *osc-client*)
|
||||
(peer-port *osc-client*)
|
||||
|
||||
;;---------------------------------------------------------------------
|
||||
;; run in sc
|
||||
c=OSCresponder(
|
||||
nil,
|
||||
'/foo',
|
||||
{|t,r,msg,addr| [t,r,msg,addr].postln}).add
|
||||
;;---------------------------------------------------------------------
|
||||
|
||||
(send *osc-client* "/foo" 1 2 3)
|
||||
|
||||
(send-bundle *osc-client*
|
||||
(get-current-timetag)
|
||||
"/foo" 3)
|
||||
|
||||
(add-osc-responder *osc-client* "/echo-sum"
|
||||
(cmd args disp addr port timetag)
|
||||
(send disp cmd (apply #'+ args)))
|
||||
|
||||
;;---------------------------------------------------------------------
|
||||
;; Send /echo-sum from sc, and lisp returns the sum.
|
||||
n=NetAddr("localhost", 57127)
|
||||
|
||||
e=OSCresponder(
|
||||
nil,
|
||||
'/echo-sum',
|
||||
{|t,r,msg,addr|
|
||||
[t,r,msg,addr].postln;
|
||||
}).add
|
||||
|
||||
n.sendMsg('/echo-sum', 1, 2, 3) // send numbers, lisp returns sum.
|
||||
;;---------------------------------------------------------------------
|
||||
|
||||
(quit *osc-client*)
|
||||
|
||||
|
||||
;;;=====================================================================
|
||||
;;; OSC UDP client <-> scsynth
|
||||
;;;=====================================================================
|
||||
|
||||
(defparameter *osc-client* (make-osc-client
|
||||
:protocol :udp
|
||||
:debug-mode t))
|
||||
|
||||
(connect *osc-client* 57110 :host-name "localhost" :port 57127)
|
||||
|
||||
(send *osc-client* "/s_new" "default" 1001 0 0 "freq" 500)
|
||||
|
||||
(send *osc-client* "/n_free" 1001)
|
||||
|
||||
(send-bundle *osc-client*
|
||||
(timetag+ (get-current-timetag) 2) ; 2 secs later
|
||||
"/s_new" "default" 1001 0 0 "freq" 500)
|
||||
|
||||
(send *osc-client* "/n_free" 1001)
|
||||
|
||||
(quit *osc-client*) ; Sends default /quit notification which scsynth
|
||||
; ignores. Ideally osc-client should be subclassed
|
||||
; to allow scsynth specific behaviour to be
|
||||
; implemented.
|
||||
26
devices/listening-device.lisp
Normal file
26
devices/listening-device.lisp
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
(cl:in-package #:osc)
|
||||
|
||||
(defgeneric make-listening-thread (listening-device))
|
||||
|
||||
(defmethod connect progn ((listening-device listening-device)
|
||||
host-port &key host-address host-name port)
|
||||
(declare (ignore host-port host-address host-name port))
|
||||
(set-listening-thread (make-listening-thread listening-device)
|
||||
listening-device))
|
||||
|
||||
(defmethod quit ((device listening-device))
|
||||
(sb-thread:terminate-thread (listening-thread device)))
|
||||
|
||||
(defmethod osc-device-cleanup ((device listening-device))
|
||||
(set-listening-thread nil device)
|
||||
(call-next-method))
|
||||
|
||||
(defmethod osc-device-cleanup ((device receiving-device))
|
||||
(fill (socket-buffer device) 0)
|
||||
(call-next-method))
|
||||
|
||||
(defun print-osc-debug-msg (receiver message length address port
|
||||
timetag)
|
||||
(format t "~%~A~%received:~A~A ~A bytes from ~A ~A ~%timetag:~A~A~%unix-time:~A~F~%"
|
||||
(name receiver) #\Tab message length address port #\Tab
|
||||
timetag #\Tab (when timetag (timetag->unix-time timetag))))
|
||||
181
devices/server.lisp
Normal file
181
devices/server.lisp
Normal file
|
|
@ -0,0 +1,181 @@
|
|||
(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)
|
||||
(setf (gethash (make-peername-string (socket transmitter))
|
||||
(clients server))
|
||||
transmitter))
|
||||
|
||||
(defun unregister-tcp-client (server transmitter)
|
||||
(remhash (make-peername-string (socket 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))
|
||||
73
devices/socket-functions.lisp
Normal file
73
devices/socket-functions.lisp
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
(cl:in-package #:osc)
|
||||
|
||||
(defparameter *default-osc-buffer-size* 1024)
|
||||
|
||||
(defun make-socket-buffer (&optional (size *default-osc-buffer-size*))
|
||||
(make-sequence '(vector (unsigned-byte 8)) size))
|
||||
|
||||
(defun make-socket (protocol)
|
||||
(ecase protocol
|
||||
(:udp (make-udp-socket))
|
||||
(:tcp (make-tcp-socket))))
|
||||
|
||||
(defun make-tcp-socket ()
|
||||
(make-instance 'inet-socket :type :stream :protocol :tcp))
|
||||
|
||||
(defun make-udp-socket ()
|
||||
(make-instance 'inet-socket :type :datagram :protocol :udp))
|
||||
|
||||
(defun make-peername-string (socket)
|
||||
(multiple-value-bind (addr port)
|
||||
(socket-peername socket)
|
||||
(make-addr+port-string addr port)))
|
||||
|
||||
(defun make-name-string (osc-device)
|
||||
(when (socket osc-device)
|
||||
(multiple-value-bind (addr port)
|
||||
(socket-name (socket osc-device))
|
||||
(make-addr+port-string addr port))))
|
||||
|
||||
(defun make-addr+port-string (addr port)
|
||||
(format nil "~{~A~^.~}:~A" (coerce addr 'list) port))
|
||||
|
||||
(defun device-active-p (osc-device)
|
||||
(when (socket osc-device)
|
||||
(socket-open-p (socket osc-device))))
|
||||
|
||||
(defun device-socket-name (osc-device)
|
||||
(socket-name (socket osc-device)))
|
||||
|
||||
(defun port (osc-device)
|
||||
(if (device-active-p osc-device)
|
||||
(multiple-value-bind (addr port)
|
||||
(device-socket-name osc-device)
|
||||
(declare (ignore addr))
|
||||
port)
|
||||
(warn "Device not connected.")))
|
||||
|
||||
(defun address (osc-device)
|
||||
(if (device-active-p osc-device)
|
||||
(multiple-value-bind (addr port)
|
||||
(device-socket-name osc-device)
|
||||
(declare (ignore port))
|
||||
addr)
|
||||
(warn "Device not connected.")))
|
||||
|
||||
(defun device-socket-peername (osc-device)
|
||||
(socket-peername (socket osc-device)))
|
||||
|
||||
(defun peer-port (osc-device)
|
||||
(if (device-active-p osc-device)
|
||||
(multiple-value-bind (addr port)
|
||||
(device-socket-peername osc-device)
|
||||
(declare (ignore addr))
|
||||
port)
|
||||
(warn "Device not connected.")))
|
||||
|
||||
(defun peer-address (osc-device)
|
||||
(if (device-active-p osc-device)
|
||||
(multiple-value-bind (addr port)
|
||||
(device-socket-peername osc-device)
|
||||
(declare (ignore port))
|
||||
addr)
|
||||
(warn "Device not connected.")))
|
||||
125
devices/transmitter.lisp
Normal file
125
devices/transmitter.lisp
Normal file
|
|
@ -0,0 +1,125 @@
|
|||
(cl:in-package #:osc)
|
||||
|
||||
;; Only UDP devices can be transmitters.
|
||||
|
||||
(defun make-osc-transmitter (&key debug-mode cleanup-fun)
|
||||
(make-instance 'osc-transmitter-udp
|
||||
:debug-mode debug-mode
|
||||
:cleanup-fun cleanup-fun))
|
||||
|
||||
(defgeneric connect (osc-transmitter host-port &key host-address
|
||||
host-name port)
|
||||
(:method-combination progn :most-specific-last))
|
||||
|
||||
(defmethod connect progn ((transmitter osc-transmitter) host-port
|
||||
&key (host-address nil addr)
|
||||
(host-name "localhost" name) port)
|
||||
(when (and addr name)
|
||||
(error "Supplied both :host-address and :host-name to connect"))
|
||||
(cond (addr
|
||||
(when (typep host-address 'string)
|
||||
(setf host-address
|
||||
(sb-bsd-sockets:make-inet-address host-address))))
|
||||
(t
|
||||
(setf host-address
|
||||
(sb-bsd-sockets:host-ent-address
|
||||
(sb-bsd-sockets:get-host-by-name
|
||||
host-name)))))
|
||||
(if (not (device-active-p transmitter))
|
||||
(progn
|
||||
(let ((socket (make-socket (protocol transmitter))))
|
||||
(socket-bind socket #(127 0 0 1) port)
|
||||
(socket-connect socket host-address host-port)
|
||||
(socket-make-stream socket
|
||||
:input nil :output t
|
||||
:element-type '(unsigned-byte 8)
|
||||
:buffering :full)
|
||||
(set-socket socket transmitter))
|
||||
(when (debug-mode transmitter)
|
||||
(format t "~%Device connected: ~A~%~A -> ~A~%"
|
||||
(name transmitter) #\Tab
|
||||
(make-addr+port-string (peer-address transmitter)
|
||||
(peer-port transmitter)))))
|
||||
(warn "Already connected"))
|
||||
transmitter)
|
||||
|
||||
(defmethod quit ((transmitter osc-transmitter-udp))
|
||||
(if (device-active-p transmitter)
|
||||
(osc-device-cleanup transmitter)
|
||||
(warn "Not connected: ~A" (name transmitter))))
|
||||
|
||||
|
||||
;;;=====================================================================
|
||||
;;; Sending functions
|
||||
;;;=====================================================================
|
||||
|
||||
(defmacro osc-write-to-stream (stream &body msg)
|
||||
`(progn (write-sequence ,@msg ,stream)
|
||||
(finish-output ,stream)))
|
||||
|
||||
(defgeneric send (transmitter &rest msg-args)
|
||||
(:method ((transmitter osc-transmitter) &rest msg-args)
|
||||
(let ((msg (apply #'encode-message msg-args)))
|
||||
(osc-write-to-stream
|
||||
(slot-value (socket transmitter) 'stream) msg))))
|
||||
|
||||
(defgeneric send-bundle (transmitter timetag &rest msg-args)
|
||||
(:method ((transmitter osc-transmitter) timetag &rest msg-args)
|
||||
(let ((msg (encode-bundle msg-args timetag)))
|
||||
(osc-write-to-stream
|
||||
(slot-value (socket transmitter) 'stream) msg))))
|
||||
|
||||
;; Unconnected sending
|
||||
|
||||
(defgeneric send-to (transmitter address port &rest msg-args)
|
||||
(:method ((transmitter osc-transmitter-udp) address port &rest
|
||||
msg-args)
|
||||
(socket-send (socket transmitter)
|
||||
(apply #'encode-message msg-args) nil
|
||||
:address (list address port))))
|
||||
|
||||
(defgeneric send-bundle-to (transmitter address port timestamp &rest
|
||||
msg-args)
|
||||
(:method ((transmitter osc-transmitter-udp) address port timestamp
|
||||
&rest msg-args)
|
||||
(socket-send (socket transmitter)
|
||||
(apply #'encode-bundle msg-args (list timestamp)) nil
|
||||
:address (list address port))))
|
||||
|
||||
;; Server functions
|
||||
|
||||
(defgeneric send-all (server &rest msg-args))
|
||||
|
||||
(defmethod send-all ((server osc-server-udp) &rest msg-args)
|
||||
(loop for addr+port being the hash-value in (clients server)
|
||||
do (apply #'send-to server (first addr+port) (second addr+port)
|
||||
msg-args)))
|
||||
|
||||
(defmethod send-all ((server osc-server-tcp) &rest msg-args)
|
||||
(loop for endpoint being the hash-value in (clients server)
|
||||
do (apply #'send endpoint msg-args)))
|
||||
|
||||
(defmethod send-all ((client-endpoint osc-client-endpoint) &rest
|
||||
msg-args)
|
||||
(loop for endpoint being the hash-value in (clients client-endpoint)
|
||||
unless (eq endpoint client-endpoint) ; don't send to sender
|
||||
do (apply #'send endpoint msg-args)))
|
||||
|
||||
(defgeneric send-bundle-all (server timetag &rest msg-args))
|
||||
|
||||
(defmethod send-bundle-all ((server osc-server-udp) timetag &rest
|
||||
msg-args)
|
||||
(loop for addr+port being the hash-value in (clients server)
|
||||
do (apply #'send-bundle-to server (first addr+port)
|
||||
(second addr+port) timetag msg-args)))
|
||||
|
||||
(defmethod send-bundle-all ((server osc-server-tcp) timetag &rest
|
||||
msg-args)
|
||||
(loop for endpoint being the hash-value in (clients server)
|
||||
do (apply #'send-bundle endpoint timetag msg-args)))
|
||||
|
||||
(defmethod send-bundle-all ((client-endpoint osc-client-endpoint)
|
||||
timetag &rest msg-args)
|
||||
(loop for endpoint being the hash-value in (clients client-endpoint)
|
||||
unless (eq endpoint client-endpoint) ; don't send to sender
|
||||
do (apply #'send-bundle endpoint timetag msg-args)))
|
||||
|
|
@ -62,11 +62,12 @@
|
|||
dispatch for a given address pattern.."
|
||||
(list (gethash pattern tree)))
|
||||
|
||||
(defun dispatch (tree osc-message)
|
||||
(defun dispatch (tree osc-message &optional device address port
|
||||
timetag)
|
||||
"calls the function(s) matching the address(pattern) in the osc
|
||||
message with the data contained in the message"
|
||||
(let ((pattern (car osc-message)))
|
||||
(dolist (x (dp-match tree pattern))
|
||||
(unless (eq x NIL)
|
||||
(apply #'x (cdr osc-message))))))
|
||||
|
||||
(funcall x (car osc-message) (cdr osc-message) device address
|
||||
port timetag)))))
|
||||
|
|
|
|||
17
osc.asd
17
osc.asd
|
|
@ -11,4 +11,19 @@
|
|||
:components ((:file "osc" :depends-on ("osc-time"))
|
||||
(:file "osc-dispatch" :depends-on ("osc"))
|
||||
(:file "osc-time" :depends-on ("package"))
|
||||
(:file "package")))
|
||||
(:file "package")
|
||||
(:module "devices"
|
||||
:depends-on ("package")
|
||||
::components
|
||||
((:file "socket-functions")
|
||||
(:file "device")
|
||||
(:file "transmitter"
|
||||
:depends-on ("device"
|
||||
"socket-functions"))
|
||||
(:file "listening-device"
|
||||
:depends-on ("transmitter"))
|
||||
(:file "dispatching-device"
|
||||
:depends-on ("listening-device"))
|
||||
(:file "client"
|
||||
:depends-on ("dispatching-device"))
|
||||
(:file "server" :depends-on ("client"))))))
|
||||
|
|
|
|||
1
osc.lisp
1
osc.lisp
|
|
@ -101,6 +101,7 @@
|
|||
(integer (write-to-vector #\i))
|
||||
(float (write-to-vector #\f))
|
||||
(simple-string (write-to-vector #\s))
|
||||
(keyword (write-to-vector #\s))
|
||||
(t (write-to-vector #\b)))))
|
||||
(cat lump
|
||||
(pad (padding-length (length lump))))))
|
||||
|
|
|
|||
50
package.lisp
50
package.lisp
|
|
@ -16,4 +16,52 @@
|
|||
#:get-unix-time
|
||||
#:unix-time->timetag
|
||||
#:timetag->unix-time
|
||||
#:print-as-double))
|
||||
#:print-as-double
|
||||
|
||||
#:osc-transmitter ; osc-devices
|
||||
#:osc-transmitter-udp
|
||||
#:osc-client
|
||||
#:osc-client-udp
|
||||
#:osc-client-tcp
|
||||
#:osc-server
|
||||
#:osc-server-udp
|
||||
#:osc-server-tcp
|
||||
#:protocol
|
||||
#:name
|
||||
#:buffer-size
|
||||
#:quit
|
||||
#:osc-device-cleanup
|
||||
#:make-listening-thread ; listening
|
||||
#:add-osc-responder ; dispatching
|
||||
#:remove-osc-responder
|
||||
#:make-osc-transmitter ; transmitters
|
||||
#:connect
|
||||
#:send
|
||||
#:send-bundle
|
||||
#:send-to
|
||||
#:send-bundle-to
|
||||
#:send-all
|
||||
#:send-bundle-all
|
||||
#:make-osc-client ; clients
|
||||
#:make-client-responders
|
||||
#:register
|
||||
#:make-osc-server ; servers
|
||||
#:boot
|
||||
#:make-server-responders
|
||||
#:register-udp-client
|
||||
#:unregister-udp-client
|
||||
#:register-tcp-client
|
||||
#:unregister-tcp-client
|
||||
#:post-register-hook
|
||||
#:get-tcp-client
|
||||
#:print-clients
|
||||
#:send-to-client
|
||||
#:send-bundle-to-client
|
||||
#:*default-osc-buffer-size* ; socket stuff
|
||||
#:make-name-string
|
||||
#:device-active-p
|
||||
#:device-socket-name
|
||||
#:address
|
||||
#:port
|
||||
#:peer-address
|
||||
#:peer-port))
|
||||
|
|
|
|||
Loading…
Reference in a new issue