sosc.mzscheme.sls

#!r6rs
(library (sosc) (export udp:socket? udp:open udp:send udp:recv udp:close tcp:socket? tcp:open tcp:send tcp:read tcp:close with-input-from-bytevector bytevector-section bytevector-find-index flatten-bytevectors bytevector-make-and-set1 bytevector-make-and-set decode-u8 decode-u16 decode-u32 decode-u64 decode-i8 decode-i16 decode-i32 decode-i64 decode-f32 decode-f64 decode-str decode-pstr decode-cstr encode-u8 encode-u16 encode-u32 encode-u64 encode-i8 encode-i16 encode-i32 encode-i64 encode-f32 encode-f64 encode-str encode-pstr encode-cstr read-pstr read-cstr read-bstr read-i16 read-u16 read-i32 read-u32 read-i64 read-u64 read-f32 read-f64 seconds-from-1900-to-1970 ntpr->ntp utc->ntpr ntp->utc read-ostr read-obyt read-value read-arguments read-message read-bundle hash-u8 read-packet decode-osc osc-display cstring-length osc-align padding-of encode-string encode-bytes encode-value encode-types encode-message encode-bundle-ntp encode-bundle encode-osc purify oI32 oI64 oU64 oF32 oF64 oSTR oBYT oMID message bundle message? bundle? verify-message verify-bundle verify-packet send recv wait) (import (rnrs) (rhs) (prefix (scheme) plt:)) (plt:define-struct udp* (s h p)) (define udp:socket? udp*?) (define udp:open (lambda (h p) (make-udp* (plt:udp-open-socket h p) h p))) (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)))) (define udp:recv (lambda (u) (let* ((s (udp*-s u)) (h (udp*-h u)) (p (udp*-p u)) (b (plt:make-bytes 8192)) (r (plt:sync/timeout 1.0 (plt:udp-receive!-evt s b)))) (if r (plt:subbytes b 0 (plt:car r)) #f)))) (define udp:close (lambda (u) (plt:udp-close (udp*-s u)))) (plt:define-struct tcp* (i o h p)) (define tcp:socket? tcp*?) (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)))) (define tcp:send (lambda (fd b) (let ((o (tcp*-o fd))) (put-bytevector o b)))) (define tcp:read (lambda (fd n) (get-bytevector-n (tcp*-i fd) n))) (define tcp:close (lambda (fd) (close-input-port (tcp*-i fd)) (close-output-port (tcp*-o fd)))) (define with-input-from-bytevector (lambda (b f) (let* ((p (open-bytevector-input-port b)) (r (f p))) (close-port p) r))) (define bytevector-section (lambda (v l r) (let* ((n (- r l)) (w (make-bytevector n 0))) (bytevector-copy! v l w 0 n) w))) (define bytevector-find-index (lambda (v x) (letrec ((f (lambda (i) (if (= (bytevector-u8-ref v i) x) i (f (+ i 1)))))) (f 0)))) (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)))))))) (define bytevector-make-and-set1 (lambda (f k n) (let ((v (make-bytevector k 0))) (f v 0 n) v))) (define bytevector-make-and-set (lambda (f k n) (let ((v (make-bytevector k 0))) (f v 0 n (endianness big)) v))) (define decode-u8 (lambda (v) (bytevector-u8-ref v 0))) (define decode-u16 (lambda (v) (bytevector-u16-ref v 0 (endianness big)))) (define decode-u32 (lambda (v) (bytevector-u32-ref v 0 (endianness big)))) (define decode-u64 (lambda (v) (bytevector-u64-ref v 0 (endianness big)))) (define decode-i8 (lambda (v) (bytevector-s8-ref v 0))) (define decode-i16 (lambda (v) (bytevector-s16-ref v 0 (endianness big)))) (define decode-i32 (lambda (v) (bytevector-s32-ref v 0 (endianness big)))) (define decode-i64 (lambda (v) (bytevector-s64-ref v 0 (endianness big)))) (define decode-f32 (lambda (v) (bytevector-ieee-single-ref v 0 (endianness big)))) (define decode-f64 (lambda (v) (bytevector-ieee-double-ref v 0 (endianness big)))) (define decode-str (lambda (b) (utf8->string b))) (define decode-pstr (lambda (v) (let* ((n (decode-u8 v)) (w (bytevector-section v 1 (+ n 1)))) (decode-str w)))) (define decode-cstr (lambda (v) (let* ((n (bytevector-find-index v 0)) (w (bytevector-section v 0 n))) (decode-str w)))) (define encode-u8 (lambda (n) (bytevector-make-and-set1 bytevector-u8-set! 1 (exact n)))) (define encode-u16 (lambda (n) (bytevector-make-and-set bytevector-u16-set! 2 (exact n)))) (define encode-u32 (lambda (n) (bytevector-make-and-set bytevector-u32-set! 4 (exact n)))) (define encode-u64 (lambda (n) (bytevector-make-and-set bytevector-u64-set! 8 (exact n)))) (define encode-i8 (lambda (n) (bytevector-make-and-set1 bytevector-s8-set! 1 (exact n)))) (define encode-i16 (lambda (n) (bytevector-make-and-set bytevector-s16-set! 2 (exact n)))) (define encode-i32 (lambda (n) (bytevector-make-and-set bytevector-s32-set! 4 (exact n)))) (define encode-i64 (lambda (n) (bytevector-make-and-set bytevector-s64-set! 8 (exact n)))) (define encode-f32 (lambda (n) (bytevector-make-and-set bytevector-ieee-single-set! 4 (inexact n)))) (define encode-f64 (lambda (n) (bytevector-make-and-set bytevector-ieee-double-set! 8 (inexact n)))) (define encode-str (lambda (s) (string->utf8 s))) (define encode-pstr (lambda (s) (let* ((b (encode-str s)) (n (encode-u8 (bytevector-length b)))) (list n b)))) (define encode-cstr (lambda (s) (let* ((b (encode-str s)) (z (encode-u8 0))) (list b z)))) (define read-pstr (lambda (p) (let* ((n (lookahead-u8 p)) (v (read-bstr p (+ n 1)))) (decode-pstr v)))) (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)))))) (define read-bstr (lambda (p n) (get-bytevector-n p n))) (define read-i16 (lambda (p) (decode-i16 (read-bstr p 2)))) (define read-u16 (lambda (p) (decode-u16 (read-bstr p 2)))) (define read-i32 (lambda (p) (decode-i32 (read-bstr p 4)))) (define read-u32 (lambda (p) (decode-u32 (read-bstr p 4)))) (define read-i64 (lambda (p) (decode-i64 (read-bstr p 8)))) (define read-u64 (lambda (p) (decode-u64 (read-bstr p 8)))) (define read-f32 (lambda (p) (decode-f32 (read-bstr p 4)))) (define read-f64 (lambda (p) (decode-f64 (read-bstr p 8)))) (define seconds-from-1900-to-1970 (+ (* 70 365 24 60 60) (* 17 24 60 60))) (define ntpr->ntp (lambda (n) (exact (round (* n (expt 2 32)))))) (define utc->ntpr (lambda (n) (+ n seconds-from-1900-to-1970))) (define ntp->utc (lambda (n) (- (/ n (expt 2 32)) seconds-from-1900-to-1970))) (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))) (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))) (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))))) (define read-arguments (lambda (p types) (if (null? types) '() (cons (read-value p (car types)) (read-arguments p (cdr types)))))) (define read-message (lambda (p) (let* ((address (read-ostr p)) (types (read-ostr p))) (cons address (read-arguments p (cdr (string->list types))))))) (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 (read-i32 p) (loop (cons (read-packet p) parts)))))))))) (define hash-u8 (char->integer #\#)) (define read-packet (lambda (p) (if (equal? (lookahead-u8 p) hash-u8) (read-bundle p) (read-message p)))) (define decode-osc (lambda (b) (with-input-from-bytevector b read-packet))) (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))))) (define cstring-length (lambda (s) (+ 1 (string-length s)))) (define osc-align (lambda (n) (- (fxand (+ n 3) (fxnot 3)) n))) (define padding-of (lambda (n) (replicate (osc-align n) (encode-u8 0)))) (define encode-string (lambda (s) (list (encode-cstr s) (padding-of (cstring-length s))))) (define encode-bytes (lambda (b) (let ((n (bytevector-length b))) (list (encode-i32 n) b (padding-of n))))) (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))))) (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)))))) (define encode-message (lambda (m) (list (encode-string (car m)) (encode-types (cdr m)) (map1 encode-value (cdr m))))) (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))))) (define encode-bundle (lambda (b) (encode-bundle-ntp (cons (utc->ntpr (car b)) (cdr b))))) (define encode-osc (lambda (p) (flatten-bytevectors (if (bundle? p) (encode-bundle p) (encode-message p))))) (define purify (lambda (e) (cond ((or3 (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))))) (define oI32 #\i) (define oI64 #\h) (define oU64 #\t) (define oF32 #\f) (define oF64 #\d) (define oSTR #\s) (define oBYT #\b) (define oMID #\m) (define message (lambda (c l) (if (string? c) (cons c l) (error "message" "illegal address")))) (define bundle (lambda (t l) (if (number? t) (cons t l) (error "bundle" "illegal timestamp" t)))) (define message? (lambda (p) (string? (car p)))) (define bundle? (lambda (p) (number? (car p)))) (define verify-message (lambda (m) (and2 (string? (car m)) (all (lambda (e) (or (number? e) (string? e))) (cdr m))))) (define verify-bundle (lambda (b) (and2 (integer? (car b)) (all (lambda (e) (or2 (verify-message e) (and2 (verify-bundle e) (>= (car e) (car b))))) (cdr b))))) (define verify-packet (lambda (p) (or2 (verify-message p) (verify-bundle p)))) (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)))))) (define recv (lambda (fd) (cond ((udp:socket? fd) (let ((b (udp:recv fd))) (and2 b (decode-osc b)))) ((tcp:socket? fd) (let* ((b (tcp:read fd 4)) (n (decode-u32 b))) (decode-osc (tcp:read fd n))))))) (define wait (lambda (fd s) (let ((p (recv fd))) (cond ((not p) (error "wait" "timed out")) ((not (string=? (head p) s)) (error "wait" "bad return packet" p s)) (else p))))))