+
+ websocket-close
+ websocket-loop
+ websocket-send))
+
+(define no-op (const #f))
+
+(define-actor <websocket> (<actor>)
+ ((*init* websocket-init)
+ (close websocket-close)
+ (open websocket-open)
+ (send websocket-send))
+
+ (state #:accessor .state #:init-value 'closed #:init-keyword #:state)
+ (socket #:accessor .socket #:init-value #f #:init-keyword #:socket)
+ (url #:getter .url #:init-value #f #:init-keyword #:url)
+ (uri #:accessor .uri #:init-value #f #:init-keyword #:uri)
+ (entropy-port #:accessor .entropy-port #:init-form (open-entropy-port))
+
+ (on-close #:init-keyword #:on-close
+ #:init-value no-op
+ #:accessor .on-close)
+ (on-error #:init-keyword #:on-error
+ #:init-value no-op
+ #:accessor .on-error)
+ (on-message #:init-keyword #:on-message
+ #:accessor .on-message)
+ (on-open #:init-keyword #:on-open
+ #:init-value no-op
+ #:accessor .on-open))
+
+(define-method (websocket-close (websocket <websocket>) message)
+ (when (websocket-open? websocket)
+ (false-if-exception (close-port (.socket websocket)))
+ (set! (.state websocket) 'closed)
+ (false-if-exception ((.on-close websocket) websocket))
+ (set! (.socket websocket) #f)))
+
+(define-method (websocket-open (websocket <websocket>) message uri-or-string)
+ (if (websocket-closed? websocket)
+ (let ((uri (match uri-or-string
+ ((? uri? uri) uri)
+ ((? string? str) (string->uri str)))))
+ (if (websocket-uri? uri)
+ (catch 'system-error
+ (lambda _
+ (set! (.uri websocket) uri)
+ (let ((sock (make-client-socket uri)))
+ (set! (.socket websocket) sock)
+ (handshake websocket)
+ (websocket-loop websocket message)))
+ (lambda (key . args)
+ ((.on-error websocket) websocket (format #f "open failed: ~s: ~s" uri-or-string args))))
+ ((.on-error websocket) websocket (format #f "not a websocket uri: ~s" uri-or-string))))
+ ((.on-error websocket) websocket (format #f "cannot open websocket in state: ~s" (.state websocket)))))
+
+(define (subbytevector bv start end)
+ (if (= (bytevector-length bv) end) bv
+ (let* ((length (- end start))
+ (sub (make-bytevector length)))
+ (bytevector-copy! bv start sub 0 length)
+ sub)))
+
+(define* (make-fragmented-frames data #:key (fragment-size (expt 2 15)))
+ (let ((length (if (string? data) (string-length data)
+ (bytevector-length data))))
+ (let loop ((offset 0))
+ (let* ((size (min fragment-size (- length offset)))
+ (end (+ offset size))
+ (final? (= end length))
+ (continuation? (not (zero? offset)))
+ (frame (if (string? data) (make-text-frame (substring data offset end) #:final? final? #:continuation? continuation?)
+ (make-binary-frame (subbytevector data offset end) #:final? final? #:continuation? continuation?))))
+ (if final? (list frame)
+ (cons frame (loop end)))))))
+
+(define-method (websocket-send (websocket <websocket>) message data)
+ (catch #t ; expect: wrong-type-arg (open port), system-error
+ (lambda _
+ (let* ((frames (make-fragmented-frames data)))
+ (let loop ((frames frames) (written '(nothing)))
+ (when (pair? frames)
+ (write-frame (car frames) (.socket websocket))
+ (loop (cdr frames) (cons (car frames) written))))))
+ (lambda (key . args)
+ (let ((message (format #f "~a: ~s" key args)))
+ ((.on-error websocket) websocket (format #f "send failed: ~s ~a\n" websocket message))
+ (websocket-close websocket message)))))
+
+(define-method (websocket-init (websocket <websocket>) message)
+ (and=> (.url websocket) (cut websocket-open websocket message <>)))
+
+(define-method (websocket-loop (websocket <websocket>) message)
+
+ (define (handle-data-frame type data)
+ ((.on-message websocket)
+ websocket
+ (match type
+ ('text (utf8->string data))
+ ('binary data))))
+
+ (define (read-frame-maybe)
+ (and (not (eof-object? (lookahead-u8 (.socket websocket))))
+ (read-frame (.socket websocket))))
+
+ (define (close-down)
+ (websocket-close websocket message))
+
+ ((.on-open websocket) websocket)
+
+ (let loop ((fragments '())
+ (type #f))
+ (let* ((socket (.socket websocket))
+ (frame (and (websocket-open? websocket)
+ (read-frame-maybe))))
+ (cond
+ ;; EOF - port is closed.
+ ;; @@: Sometimes the eof object appears here as opposed to
+ ;; at lookahead, but I'm not sure why
+ ((or (not frame) (eof-object? frame))
+ (close-down))
+ ;; Per section 5.4, control frames may appear interspersed
+ ;; along with a fragmented message.
+ ((close-frame? frame)
+ ;; Per section 5.5.1, echo the close frame back to the
+ ;; socket before closing the socket. The socket may no
+ ;; longer be listening.
+ (false-if-exception
+ (write-frame (make-close-frame (frame-data frame)) socket))
+ (close-down))
+ ((ping-frame? frame)
+ ;; Per section 5.5.3, a pong frame must include the exact
+ ;; same data as the ping frame.
+ (write-frame (make-pong-frame (frame-data frame)) socket)
+ (loop fragments type))
+ ((pong-frame? frame) ; silently ignore pongs
+ (loop fragments type))
+ ((first-fragment-frame? frame) ; begin accumulating fragments
+ (loop (list frame) (frame-type frame)))
+ ((final-fragment-frame? frame) ; concatenate all fragments
+ (handle-data-frame type (frame-concatenate
+ (reverse (cons frame fragments))))
+ (loop '() #f))
+ ((fragment-frame? frame) ; add a fragment
+ (loop (cons frame fragments) type))
+ ((data-frame? frame) ; unfragmented data frame
+ (handle-data-frame (frame-type frame) (frame-data frame))
+ (loop '() #f))))))