(module
bokbok-packet
(make-core-object
core-object?
core-object-tag
core-object-value
max-receive-depth
max-receive-length
read-binary
write-binary
split-packet
join-packet)
(import chicken scheme)
(use extras)
(use ports)
(use numbers)
(define-record-type core-object
(make-core-object tag value)
core-object?
(tag core-object-tag)
(value core-object-value))
;; Literals in code can't be this big, so we have to cheat.
(define two63 (expt 2 63))
(define two64 (expt 2 64))
(define (read-s8 port)
(let ((v (read-byte port)))
(if (eof-object? v)
#!eof
(if (< v 128)
v
(- v 256)))))
(define (read-u16 port)
(let* ((b1 (read-byte port))
(b2 (read-byte port)))
(if (or (eof-object? b1) (eof-object? b2))
#!eof
(+ (* b1 256) b2))))
(define (write-u16 i port)
(write-byte (quotient i 256) port)
(write-byte (modulo i 256) port))
(define (read-s16 port)
(let ((v (read-u16 port)))
(if (eof-object? v)
#!eof
(if (< v 32768)
v
(- v 65536)))))
(define (write-s16 i port)
(if (negative? i)
(write-u16 (+ 65536 i) port)
(write-u16 i port)))
(define (read-u32 port)
(let ((w1 (read-u16 port))
(w2 (read-u16 port)))
(if (or (eof-object? w1) (eof-object? w2))
#!eof
(+ (* w1 65536) w2))))
(define (write-u32 i port)
(write-byte (quotient i 16777216) port)
(write-byte (quotient (modulo i 16777216) 65536) port)
(write-byte (quotient (modulo i 65536) 256) port)
(write-byte (modulo i 256) port))
(define (read-s32 port)
(let ((v (read-u32 port)))
(if (eof-object? v)
#!eof
(if (< v 2147483648)
v
(- v 4294967296)))))
(define (write-s32 i port)
(if (negative? i)
(write-u32 (+ 4294967296 i) port)
(write-u32 i port)))
(define (read-u64 port)
(let ((w1 (read-u32 port))
(w2 (read-u32 port)))
(if (or (eof-object? w1) (eof-object? w2))
#!eof
(+ (* w1 4294967296) w2))))
(define (write-u64 i port)
(write-u32 (quotient i 4294967296) port)
(write-u32 (modulo i 4294967296) port))
(define (read-s64 port)
(let ((v (read-u64 port)))
(if (eof-object? v)
#!eof
(if (< v two63)
v
(- v two64)))))
(define (write-s64 i port)
(if (negative? i)
(write-u64 (+ two64 i) port)
(write-u64 i port)))
(define (read-length port)
(let ((b (read-byte port)))
(cond
((eof-object? b)
#!eof)
((= b #x80)
'variable)
((< b #x80)
b)
((eq? b #x82)
(read-u16 port))
((eq? b #x84)
(read-u32 port))
((eq? b #x88)
(read-u64 port))
(else
(error "Unknown length prefix" b)))))
(define (write-length l port)
(cond
((< l #x80)
(write-byte l port))
((< l #x8000)
(write-byte #x82)
(write-u16 l port))
((< l #x80000000)
(write-byte #x84)
(write-u32 l port))
((< l two63)
(write-byte #x88)
(write-u64 l port))
(else
(error "Size too big" l))))
(define (write-binary obj port)
(cond
((list? obj)
(write-byte #xe0 port)
(write-byte #x80 port)
(for-each
(lambda (o)
(write-binary o port))
obj)
(write-byte #x00 port)
(write-byte #x00 port))
((symbol? obj)
(let ((s (symbol->string obj)))
(write-byte #xdd port)
(write-length (string-length s) port)
(write-string s #f port)))
((string? obj)
(write-byte #x0c port)
(write-length (string-length obj) port)
(write-string obj #f port))
((boolean? obj)
(write-byte #x01 port)
(write-byte #x01 port)
(write-byte (if obj #xff #x00) port))
((vector? obj)
(write-byte #x30 port)
(write-byte #x80 port)
(let ((final (vector-length obj)))
(let loop
((idx 0))
(if (>= idx final)
(begin
(write-byte #x00 port)
(write-byte #x00 port))
(begin
(write-binary (vector-ref obj idx) port)
(loop (+ idx 1)))))))
((and (integer? obj) (exact? obj))
(write-byte #x02 port)
(cond
((zero? obj)
(write-byte #x00 port))
((<= -128 obj 127)
(write-byte #x01 port)
(write-byte obj port))
((<= -32768 obj 32767)
(write-byte #x02 port)
(write-s16 obj port))
((<= -2147483648 obj 2147483647)
(write-byte #x04 port)
(write-s32 obj port))
((<= (- two63) obj (- two63 1))
(write-byte #x08 port)
(write-s64 obj port))
(else
;; Chop into 64-bit chunks
(let loop
((parts '())
(n obj))
(if (<= (- two63) n (- two63 1))
(begin
(write-length (* (+ 1 (length parts)) 8) port)
(if (negative? obj)
(if (zero? (car parts))
(write-s64 -1 port)
(write-s64 (- n 1) port))
(write-s64 n port))
(for-each
(lambda (p)
(write-u64 p port))
parts))
(loop
(cons (modulo n two64) parts)
(quotient n two64)))))))
((number? obj)
(write-byte #xfe port)
(let ((s (number->string obj)))
(write-length (string-length s) port)
(write-string s #f port)))
((core-object? obj)
(if (number? (core-object-tag obj))
(begin
(write-byte (core-object-tag obj) port)
(write-byte #x80 port))
(begin
(let ((t (symbol->string (core-object-tag obj))))
(write-byte #xFF port)
(write-byte #x80 port)
(write-byte #xdd port)
(write-length (string-length t) port)
(write-string t #f port))))
(write-binary (core-object-value obj) port)
(write-byte #x00 port)
(write-byte #x00 port))
(else
(error "Unsupported kind of thing to write" obj))))
(define (join-packet ps)
(with-output-to-string
(lambda ()
(write-binary ps (current-output-port)))))
(define max-receive-depth (make-parameter +inf.0))
(define max-receive-length (make-parameter +inf.0))
(define (read-binary* port level)
(when (>= level (max-receive-depth))
(error "Maximum receive depth exceeded"))
(let* ((t (read-byte port))
(l (read-length port)))
(assert (or (eq? l 'variable) (<= l (max-receive-length))))
(if (or (eof-object? t) (eof-object? l))
#!eof
(case t
((#xe0) ;; List
(assert (eq? l 'variable))
(let loop
((result '())
(length 0))
(when (>= length (max-receive-length))
(error "Maximum receive length exceeded in list"))
(let ((v (read-binary* port (+ level 1))))
(if (eof-object? v)
(reverse result)
(loop (cons v result)
(+ length 1))))))
((#xdd) ;; Symbol
(string->symbol (read-string l port)))
((#x0c) ;; String
(read-string l port))
((#x01) ;; Boolean
(let ((v (read-byte port)))
(case v
((#x00) #f)
((#xff) #t)
(else (error "Invalid boolean value" v)))))
((#x30) ;; Vector
(assert (eq? l 'variable))
(let loop
((result '())
(length 0))
(when (>= length (max-receive-length))
(error "Maximum receive length exceeded in vector"))
(let ((v (read-binary* port (+ level 1))))
(if (eof-object? v)
(list->vector (reverse result))
(loop (cons v result)
(+ length 1))))))
((#x02) ;; Integer
(case l
((#x00) 0)
((#x01) (read-s8 port))
((#x02) (read-s16 port))
((#x04) (read-s32 port))
((#x08) (read-s64 port))
(else
(assert (zero? (modulo l 8)))
(let loop
((result (read-s64 port))
(parts-left (- (/ l 8) 1)))
(if (zero? parts-left)
result
(let ((v (read-u64 port)))
(loop
(+ (* two64 result) v)
(- parts-left 1))))))))
((#xfe) ;; Arbitrary Scheme number
(let ((s (read-string l port)))
(string->number s)))
((#xff) ;; Symbol-tagged core object
(assert (eq? l 'variable))
(assert (= (read-byte port) #xdd))
(let ((tl (read-length port)))
(assert (<= tl (max-receive-length)))
(let* ((tag (string->symbol (read-string tl port)))
(inner-value (read-binary* port (+ level 1))))
(assert (= (read-byte port) #x00))
(assert (= (read-byte port) #x00))
(make-core-object tag inner-value))))
((#x00) ;; EOC
(assert (= l 0))
#!eof)
(else ;; Number-tagged core object
(assert (eq? l 'variable))
(let ((inner-value (read-binary* port (+ level 1))))
(assert (= (read-byte port) #x00))
(assert (= (read-byte port) #x00))
(make-core-object t inner-value)))))))
(define (read-binary port)
(read-binary* port 0))
(define (split-packet ps)
(with-input-from-string ps
(lambda ()
(read-binary (current-input-port)))))
)
