ported sosc library to Racket

sosc/bytevector.rkt

@@ -0,0 +1,64 @@
+#lang racket
+
+(require "../rhs/rhs.rkt" rnrs/bytevectors-6 rnrs/io/ports-6)
+
+(provide (all-defined-out)
+         put-bytevector
+         get-bytevector-n
+         bytevector-length)
+
+;; bytevector -> (port -> any) -> any
+(define with-input-from-bytevector
+  (lambda (b f)
+    (let* ((p (open-bytevector-input-port b))
+	   (r (f p)))
+      (close-port p)
+      r)))
+
+;; bytevector -> int -> int -> bytevector
+(define bytevector-section
+  (lambda (v l r)
+    (let* ((n (- r l))
+	   (w (make-bytevector n 0)))
+      (bytevector-copy! v l w 0 n)
+      w)))
+
+;; bytevector -> byte -> int
+(define bytevector-find-index
+  (lambda (v x)
+    (letrec ((f (lambda (i)
+		  (if (= (bytevector-u8-ref v i) x)
+		      i
+		      (f (+ i 1))))))
+      (f 0))))
+
+;; Tree bytevector -> bytevector
+(define flatten-bytevectors
+  (lambda (t)
+    (let* ((l (flatten t))
+	   (n (map1 bytevector-length l))
+	   (m (sum n))
+	   (v (make-bytevector m)))
+      (let loop ((i 0)
+		 (l l)
+		 (n n))
+	(if (null? l)
+	    v
+	    (let ((l0 (car l))
+		  (n0 (car n)))
+	      (bytevector-copy! l0 0 v i n0)
+	      (loop (+ i n0) (cdr l) (cdr n))))))))
+
+;; number a => (bytevector -> int -> a -> ()) -> int -> a
+(define bytevector-make-and-set1
+  (lambda (f k n)
+    (let ((v (make-bytevector k 0)))
+      (f v 0 n)
+      v)))
+
+;; number a => (bytevector -> int -> a -> ()) -> int -> a
+(define bytevector-make-and-set
+  (lambda (f k n)
+    (let ((v (make-bytevector k 0)))
+      (f v 0 n (endianness big))
+      v)))

sosc/ip.rkt

@@ -0,0 +1,82 @@
+#lang racket
+
+;; from plt/ip.scm ;;;;;;;;;;
+
+
+(require (prefix-in plt: racket)
+         (prefix-in plt: racket/udp)
+         "bytevector.rkt"
+         )
+
+(provide (all-defined-out))
+
+
+;; data udp
+(struct udp* (s h p))
+
+;; any -> bool
+(define udp:socket?
+  udp*?)
+
+;; string -> int -> socket
+(define udp:open
+  (lambda (h p)
+    (udp* (plt:udp-open-socket h p) h p)))
+
+;; socket -> bytevector -> ()
+(define udp:send
+  (lambda (u b)
+    (let ((s (udp*-s u))
+	  (h (udp*-h u))
+	  (p (udp*-p u)))
+      (plt:udp-send-to* s h p b))))
+
+;; socket -> maybe bytevector
+(define udp:recv
+  (lambda (u)
+    (let* ((s (udp*-s u))
+	   (h (udp*-h u))
+	   (p (udp*-p u))
+	   (b (bytes 8192))
+	   (r (plt:sync/timeout 1.0 (plt:udp-receive!-evt s b))))
+      (if r
+	  (plt:subbytes b 0 (plt:car r))
+	  #f))))
+
+;; socket -> ()
+(define udp:close
+  (lambda (u)
+    (plt:udp-close (udp*-s u))))
+
+;; data tcp
+(plt:define-struct tcp* (i o h p))
+
+;; any -> bool
+(define tcp:socket?
+  tcp*?)
+
+;; string -> int -> socket
+(define tcp:open
+  (lambda (h p)
+    (let-values
+     (((i o) (plt:tcp-connect h p)))
+     (plt:file-stream-buffer-mode i 'none)
+     (plt:file-stream-buffer-mode o 'none)
+     (make-tcp* i o h p))))
+
+;; socket -> bytevector -> ()
+(define tcp:send
+  (lambda (fd b)
+    (let ((o (tcp*-o fd)))
+      (put-bytevector o b))))
+
+;; socket -> int -> maybe bytevector
+(define tcp:read
+  (lambda (fd n)
+    (get-bytevector-n (tcp*-i fd) n)))
+
+;; socket -> ()
+(define tcp:close
+  (lambda (fd)
+    (close-input-port (tcp*-i fd))
+    (close-output-port (tcp*-o fd))))

sosc/sosc.rkt

@@ -0,0 +1,522 @@
+#lang racket
+
+
+
+(require
+  rnrs
+  rnrs/bytevectors-6
+  "../rhs/rhs.rkt"
+  "bytevector.rkt"
+  )
+
+
+(provide message
+         bundle
+         encode-osc
+         decode-osc
+         encode-u8
+         encode-i16
+         encode-i32
+         encode-f32
+         encode-pstr
+         encode-u32
+         decode-u32 )
+
+;; bytevector -> int
+(define decode-u8
+  (lambda (v)
+    (bytevector-u8-ref v 0)))
+
+;; bytevector -> int
+(define decode-u16
+  (lambda (v)
+    (bytevector-u16-ref v 0 (endianness big))))
+
+;; bytevector -> int
+(define decode-u32
+  (lambda (v)
+    (bytevector-u32-ref v 0 (endianness big))))
+
+;; bytevector -> int
+(define decode-u64
+  (lambda (v)
+    (bytevector-u64-ref v 0 (endianness big))))
+
+;; bytevector -> int
+(define decode-i8
+  (lambda (v)
+    (bytevector-s8-ref v 0)))
+
+;; bytevector -> int
+(define decode-i16
+  (lambda (v)
+    (bytevector-s16-ref v 0 (endianness big))))
+
+;; bytevector -> int
+(define decode-i32
+  (lambda (v)
+    (bytevector-s32-ref v 0 (endianness big))))
+
+;; bytevector -> int
+(define decode-i64
+  (lambda (v)
+    (bytevector-s64-ref v 0 (endianness big))))
+
+;; bytevector -> double
+(define decode-f32
+  (lambda (v)
+    (bytevector-ieee-single-ref v 0 (endianness big))))
+
+;; bytevector -> double
+(define decode-f64
+  (lambda (v)
+    (bytevector-ieee-double-ref v 0 (endianness big))))
+
+;; bytevector -> string
+(define decode-str
+  (lambda (b)
+    (utf8->string b)))
+
+;; bytevector -> string
+(define decode-pstr
+  (lambda (v)
+    (let* ((n (decode-u8 v))
+	   (w (bytevector-section v 1 (+ n 1))))
+      (decode-str w))))
+
+;; bytevector -> string
+(define decode-cstr
+  (lambda (v)
+    (let* ((n (bytevector-find-index v 0))
+	   (w (bytevector-section v 0 n)))
+      (decode-str w))))
+
+;; int -> bytevector
+(define encode-u8
+  (lambda (n)
+    (bytevector-make-and-set1
+     bytevector-u8-set!
+     1
+     (exact n))))
+
+;; int -> bytevector
+(define encode-u16
+  (lambda (n)
+    (bytevector-make-and-set
+     bytevector-u16-set!
+     2
+     (exact n))))
+
+;; int -> bytevector
+(define encode-u32
+  (lambda (n)
+    (bytevector-make-and-set
+     bytevector-u32-set!
+     4
+     (exact n))))
+
+;; int -> bytevector
+(define encode-u64
+  (lambda (n)
+    (bytevector-make-and-set
+     bytevector-u64-set!
+     8
+     (exact n))))
+
+;; int -> bytevector
+(define encode-i8
+  (lambda (n)
+    (bytevector-make-and-set1
+     bytevector-s8-set!
+     1
+     (exact n))))
+
+;; int -> bytevector
+(define encode-i16
+  (lambda (n)
+    (bytevector-make-and-set
+     bytevector-s16-set!
+     2
+     (exact n))))
+
+;; int -> bytevector
+(define encode-i32
+  (lambda (n)
+    (bytevector-make-and-set
+     bytevector-s32-set!
+     4
+     (exact n))))
+
+;; int -> bytevector
+(define encode-i64
+  (lambda (n)
+    (bytevector-make-and-set
+     bytevector-s64-set!
+     8
+     (exact n))))
+
+;; double -> bytevector
+(define encode-f32
+  (lambda (n)
+    (bytevector-make-and-set
+     bytevector-ieee-single-set!
+     4
+     (inexact n))))
+
+;; double -> bytevector
+(define encode-f64
+  (lambda (n)
+    (bytevector-make-and-set
+     bytevector-ieee-double-set!
+     8
+     (inexact n))))
+
+;; string -> bytevector
+(define encode-str
+  (lambda (s)
+    (string->utf8 s)))
+
+;; string -> bytevector
+(define encode-pstr
+  (lambda (s)
+    (let* ((b (encode-str s))
+	   (n (encode-u8 (bytevector-length b))))
+      (list n b))))
+
+;; string -> [bytevector]
+(define encode-cstr
+  (lambda (s)
+    (let* ((b (encode-str s))
+	   (z (encode-u8 0)))
+      (list b z))))
+
+;; port -> string
+(define read-pstr
+  (lambda (p)
+    (let* ((n (lookahead-u8 p))
+	   (v (read-bstr p (+ n 1))))
+      (decode-pstr v))))
+
+;; port -> string
+(define read-cstr
+  (lambda (p)
+    (let loop ((l nil)
+	       (b (get-u8 p)))
+      (if (= b 0)
+	  (list->string (map1 integer->char (reverse l)))
+	  (loop (cons b l) (get-u8 p))))))
+
+;; port -> int -> bytevector
+(define read-bstr
+  (lambda (p n)
+    (get-bytevector-n p n)))
+
+;; port -> int
+(define read-i16
+  (lambda (p)
+    (decode-i16 (read-bstr p 2))))
+
+;; port -> int
+(define read-u16
+  (lambda (p)
+    (decode-u16 (read-bstr p 2))))
+
+;; port -> int
+(define read-i32
+  (lambda (p)
+    (decode-i32 (read-bstr p 4))))
+
+;; port -> int
+(define read-u32
+  (lambda (p)
+    (decode-u32 (read-bstr p 4))))
+
+;; port -> int
+(define read-i64
+  (lambda (p)
+    (decode-i64 (read-bstr p 8))))
+
+;; port -> int
+(define read-u64
+  (lambda (p)
+    (decode-u64 (read-bstr p 8))))
+
+;; port -> double
+(define read-f32
+  (lambda (p)
+    (decode-f32 (read-bstr p 4))))
+
+;; port -> double
+(define read-f64
+  (lambda (p)
+    (decode-f64 (read-bstr p 8))))
+
+;; int
+(define seconds-from-1900-to-1970
+  (+ (* 70 365 24 60 60) (* 17 24 60 60)))
+
+;; double -> int
+(define ntpr->ntp
+  (lambda (n)
+    (exact (round (* n (expt 2 32))))))
+
+;; double -> double
+(define utc->ntpr
+  (lambda (n)
+    (+ n seconds-from-1900-to-1970)))
+
+;; int -> double
+(define ntp->utc
+  (lambda (n)
+    (- (/ n (expt 2 32)) seconds-from-1900-to-1970)))
+
+;; port -> string
+(define read-ostr
+  (lambda (p)
+    (let* ((s (read-cstr p))
+	   (n (mod (cstring-length s) 4))
+	   (i (- 4 (mod n 4))))
+      (if (not (= n 0))
+	  (read-bstr p i)
+	  #f)
+      s)))
+
+;; port -> bytevector
+(define read-obyt
+  (lambda (p)
+    (let* ((n (read-i32 p))
+	   (b (read-bstr p n))
+	   (i (- 4 (mod n 4))))
+      (if (not (= n 0))
+	  (read-bstr p i)
+	  #f)
+      b)))
+
+;; datum = int | double | string | bytevector
+
+;; port -> char -> datum
+(define read-value
+  (lambda (p t)
+    (cond
+     ((equal? t oI32) (read-i32 p))
+     ((equal? t oI64) (read-i64 p))
+     ((equal? t oU64) (read-u64 p))
+     ((equal? t oF32) (read-f32 p))
+     ((equal? t oF64) (read-f64 p))
+     ((equal? t oSTR) (read-ostr p))
+     ((equal? t oBYT) (read-obyt p))
+     ((equal? t oMID) (read-u32 p))
+     (else (error "read-value" "bad type" t)))))
+
+;; port -> [char] -> [datum]
+(define read-arguments
+  (lambda (p types)
+    (if (null? types)
+	'()
+	(cons (read-value p (car types))
+	      (read-arguments p (cdr types))))))
+
+;; port -> (string:[datum])
+(define read-message
+  (lambda (p)
+    (let* ((address (read-ostr p))
+	   (types (read-ostr p)))
+      (cons address
+	    (read-arguments p (cdr (string->list types)))))))
+
+;; port -> (utc:[message])
+(define read-bundle
+  (lambda (p)
+    (let ((bundletag (read-ostr p))
+	  (timetag (ntp->utc (read-u64 p)))
+	  (parts (list)))
+      (if (not (equal? bundletag "#bundle"))
+	  (error "read-bundle"
+		 "illegal bundle tag"
+		 bundletag)
+	  (cons timetag
+		(let loop ((parts (list)))
+		  (if (eof-object? (lookahead-u8 p))
+		      (reverse parts)
+		      (begin
+			;; We have no use for the message size...
+			(read-i32 p)
+			(loop (cons (read-packet p) parts))))))))))
+
+;; byte
+(define hash-u8
+  (char->integer #\#))
+
+;; port -> osc
+(define read-packet
+  (lambda (p)
+    (if (equal? (lookahead-u8 p) hash-u8)
+	(read-bundle p)
+	(read-message p))))
+
+;; bytevector -> osc
+(define decode-osc
+  (lambda (b)
+    (with-input-from-bytevector b read-packet)))
+
+;; [byte] -> ()
+(define osc-display
+  (lambda (l)
+    (zip-with
+     (lambda (b n)
+       (display (list (number->string b 16) (integer->char b)))
+       (if (= 3 (mod n 4))
+	   (newline)
+	   (display #\space)))
+     l
+     (enum-from-to 0 (- (length l) 1)))))
+
+;; string -> int
+(define cstring-length
+  (lambda (s)
+    (+ 1 (string-length s))))
+
+;; int -> int
+;; (equal? (map osc-align (enum-from-to 0 7)) (list 0 3 2 1 0 3 2 1))
+(define osc-align
+  (lambda (n)
+    (- (fxand (+ n 3) (fxnot 3)) n)))
+
+;; int -> [bytevector]
+(define padding-of
+  (lambda (n) (replicate (osc-align n) (encode-u8 0))))
+
+;; string -> [bytevector]
+(define encode-string
+  (lambda (s)
+    (list (encode-cstr s) (padding-of (cstring-length s)))))
+
+;; bytevector -> [bytevector]
+(define encode-bytes
+  (lambda (b)
+    (let ((n (bytevector-length b)))
+      (list (encode-i32 n)
+	    b
+            (padding-of n)))))
+
+;; datum -> bytevector
+(define encode-value
+  (lambda (e)
+    (cond ((number? e) (if (integer? e)
+			   (encode-i32 e)
+			   (encode-f32 e)))
+	  ((string? e) (encode-string e))
+	  ((bytevector? e) (encode-bytes e))
+	  (else (error "encode-value" "illegal value" e)))))
+
+;; [datum] -> bytevector
+(define encode-types
+  (lambda (l)
+    (encode-string
+     (list->string
+      (cons #\,
+	    (map1 (lambda (e)
+		    (cond ((number? e) (if (integer? e)
+					   #\i
+					   #\f))
+			  ((string? e) #\s)
+			  ((bytevector? e) #\b)
+			  (else (error "encode-types" "type?" e))))
+		 l))))))
+
+;; osc -> [bytevector]
+(define encode-message
+  (lambda (m)
+    (list (encode-string (car m))
+	  (encode-types (cdr m))
+	  (map1 encode-value (cdr m)))))
+
+;; osc -> [bytevector]
+(define encode-bundle-ntp
+  (lambda (b)
+    (list (encode-string "#bundle")
+	  (encode-u64 (ntpr->ntp (car b)))
+	  (map1 (lambda (e)
+		  (if (message? e)
+		      (encode-bytes (encode-osc e))
+		      (error "encode-bundle" "illegal value" e)))
+		(cdr b)))))
+
+;; osc -> [bytevector]
+(define encode-bundle
+  (lambda (b)
+    (encode-bundle-ntp (cons (utc->ntpr (car b)) (cdr b)))))
+
+;; osc -> bytevector
+(define encode-osc
+  (lambda (p)
+    (flatten-bytevectors
+     (if (bundle? p)
+	 (encode-bundle p)
+	 (encode-message p)))))
+
+;; any | [any] -> datum | [datum]
+(define purify
+  (lambda (e)
+    (cond ((or (number? e) (string? e) (bytevector? e)) e)
+	  ((list? e) (map1 purify e))
+	  ((symbol? e) (symbol->string e))
+	  ((boolean? e) (if e 1 0))
+	  (else (error "purify" "illegal input" e)))))
+
+;; char
+(define oI32 #\i)
+(define oI64 #\h)
+(define oU64 #\t)
+(define oF32 #\f)
+(define oF64 #\d)
+(define oSTR #\s)
+(define oBYT #\b)
+(define oMID #\m)
+
+;; string -> [any] -> osc
+(define message
+  (lambda (c l)
+    (if (string? c)
+	(cons c l)
+	(error "message" "illegal address"))))
+
+;; float -> [any] -> osc
+(define bundle
+  (lambda (t l)
+    (if (number? t)
+	(cons t l)
+	(error "bundle" "illegal timestamp" t))))
+
+;; osc -> bool
+(define message?
+  (lambda (p)
+    (string? (car p))))
+
+;; osc -> bool
+(define bundle?
+  (lambda (p)
+    (number? (car p))))
+
+;; osc -> bool
+(define verify-message
+  (lambda (m)
+    (and (string? (car m))
+	  (all (lambda (e) (or (number? e)
+			       (string? e)))
+	       (cdr m)))))
+
+;; osc -> bool
+(define verify-bundle
+  (lambda (b)
+    (and (integer? (car b))
+	  (all (lambda (e) (or (verify-message e)
+				(and (verify-bundle e)
+				      (>= (car e) (car b)))))
+	       (cdr b)))))
+
+;; osc -> bool
+(define verify-packet
+  (lambda (p)
+    (or (verify-message p)
+	 (verify-bundle p))))

sosc/transport.rkt

@@ -0,0 +1,42 @@
+#lang racket
+
+;; from transport.scm ;;;;;;;
+
+(require "bytevector.rkt"
+         "sosc.rkt"
+         "ip.rkt")
+
+(provide (all-defined-out))
+
+
+
+;; socket -> osc -> ()
+(define send
+  (lambda (fd m)
+    (let ((b (encode-osc m)))
+      (cond ((udp:socket? fd)
+             (udp:send fd b))
+            ((tcp:socket? fd)
+             (tcp:send fd (encode-u32 (bytevector-length b)))
+             (tcp:send fd b))))))
+
+;; port -> maybe osc
+(define recv
+  (lambda (fd)
+    (cond ((udp:socket? fd)
+           (let ((b (udp:recv fd)))
+             (and b (decode-osc b))))
+          ((tcp:socket? fd)
+           (let* ((b (tcp:read fd 4))
+                  (n (decode-u32 b)))
+             (decode-osc (tcp:read fd n)))))))
+
+;; port -> string -> osc
+(define wait
+  (lambda (fd s)
+    (let ((p (recv fd)))
+      (cond
+       ((not p) (error "wait" "timed out"))
+       ((not (string=? (first p) s)) (error "wait" "bad return packet" p s))
+       (else p)))))
+