;;; guile-websocket --- WebSocket client/server
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
-;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of guile-websocket.
;;;
#:use-module (8sync)
#:use-module (8sync ports)
#:use-module (8sync systems web)
+ #:use-module (8sync systems websocket client)
#:use-module (8sync systems websocket frame)
#:use-module (8sync systems websocket utils)
- #:export (<websocket-server>
- .websocket-handler))
-
-;; See section 4.2 for explanation of the handshake.
-(define (read-handshake-request client-socket)
- "Read HTTP request from CLIENT-SOCKET that should contain the
-headers required for a WebSocket handshake."
- ;; See section 4.2.1.
- (read-request client-socket))
+ #:export (<websocket-server>))
(define (make-handshake-response client-key)
"Return an HTTP response object for upgrading to a WebSocket
(define no-op (const #f))
-(define (make-simple-counter)
- (let ((count 0))
- (lambda ()
- (set! count (1+ count))
- count)))
-
(define-actor <websocket-server> (<web-server>)
- ((ws-send websocket-server-send))
+ ()
(upgrade-paths #:init-value `(("websocket" .
- ,(wrap-apply websocket-client-loop)))
+ ,(wrap-apply make-websocket-actor)))
#:allocation #:each-subclass
#:accessor .upgrade-paths)
- (gen-client-id #:init-thunk make-simple-counter)
-
- ;; active websocket connections
- (ws-clients #:init-thunk make-hash-table
- #:accessor .ws-clients)
-
- (on-ws-message #:init-keyword #:on-ws-message
- #:getter .on-ws-message)
- (on-ws-client-connect #:init-keyword #:on-ws-client-connect
- #:init-value no-op
- #:getter .on-ws-client-connect)
- (on-ws-client-disconnect #:init-keyword #:on-ws-client-disconnect
- #:init-value no-op
- #:getter .on-ws-client-disconnect))
-
-(define (web-server-gen-client-id websocket-server)
- ((slot-ref websocket-server 'gen-client-id)))
-
-(define (websocket-client-loop websocket-server client request body)
- "Serve client connected via CLIENT by performing the HTTP
-handshake and listening for control and data frames. HANDLER is
-called for each complete message that is received."
- ;; TODO: We'll also want to handle stuff like the sub-protocol.
- (define (handle-data-frame type data)
- ((.on-ws-message websocket-server)
- websocket-server client-id
- (match type
- ('text (utf8->string data))
- ('binary data))))
-
- (define (read-frame-maybe)
- (and (not (eof-object? (lookahead-u8 client)))
- (read-frame client)))
-
- ;; Allows other actors to send things to this specific client
- ;; @@: We probably could just increment a counter...
- (define client-id (web-server-gen-client-id websocket-server))
-
- (define (close-down)
- (close-port client)
- (hash-remove! (.ws-clients websocket-server) client-id)
- ((.on-ws-client-disconnect websocket-server)
- websocket-server client-id))
-
- (hash-set! (.ws-clients websocket-server) client-id client)
+ (on-ws-connection #:init-keyword #:on-ws-connection
+ #:init-value no-op
+ #:getter .on-ws-connection)
+
+ (on-ws-close #:init-keyword #:on-ws-close
+ #:init-value no-op
+ #:getter .on-ws-close)
+ (on-ws-error #:init-keyword #:on-ws-error
+ #:init-value no-op
+ #:getter .on-ws-error)
+ (on-ws-message #:init-keyword #:on-ws-message
+ #:init-value no-op
+ #:getter .on-ws-message)
+ (on-ws-open #:init-keyword #:on-ws-open
+ #:init-value no-op
+ #:getter .on-ws-open))
+
+(define (make-websocket-actor websocket-server client request body)
+ "Setup websocket actor connected via CLIENT by performing the HTTP
+handshake."
;; Disable buffering for websockets
(setvbuf client 'none)
- ((.on-ws-client-connect websocket-server)
- websocket-server client-id)
-
;; Perform the HTTP handshake and upgrade to WebSocket protocol.
(let* ((client-key (assoc-ref (request-headers request) 'sec-websocket-key))
(response (make-handshake-response client-key)))
- (write-response response client)
- (let loop ((fragments '())
- (type #f))
- (let ((frame (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
- ;; client before closing the socket. The client may no
- ;; longer be listening.
- (false-if-exception
- (write-frame (make-close-frame (frame-data frame)) client))
- (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)) client)
- (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)))))))
-
-(define (websocket-server-send websocket-server message client-id data)
- (cond ((hash-ref (.ws-clients websocket-server) client-id) =>
- (lambda (client)
- (write-frame
- (cond ((string? data)
- (make-text-frame data))
- ((bytevector? data)
- (make-binary-frame data)))
- client)
- ;; ok is like success, amirite
- (<-reply message 'ok)))
- (else
- ;; No such client with that id.
- ;; Either it closed, or it was never there.
- (<-reply message 'client-gone))))
+ (write-response response client))
+
+ (let* ((websocket-id (create-actor websocket-server <websocket>
+ #:socket client
+ #:state 'open
+ #:on-close (.on-ws-close websocket-server)
+ #:on-error (.on-ws-error websocket-server)
+ #:on-message (.on-ws-message websocket-server)
+ #:on-open (.on-ws-open websocket-server)))
+ (hive ((@@ (8sync actors) actor-hive) websocket-server))
+ (websocket ((@@ (8sync actors) hive-resolve-local-actor) hive websocket-id)))
+ ((.on-ws-connection websocket-server) websocket-id)
+ (websocket-loop websocket 'message)))
projects / 8sync.git / blobdiff