X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=8sync%2Fsystems%2Fwebsocket%2Fserver.scm;fp=8sync%2Fsystems%2Fwebsocket%2Fserver.scm;h=2a91b926dcf905f4c4db4d8ae6e44b631d1fa20a;hb=ab7d0294d28fa686226e714a606c102e1f265a41;hp=c29ce51e44c40c545219f258daad01dee5207631;hpb=5074289a33640bb3bd78a711d7ceb645d7ae0cfd;p=8sync.git diff --git a/8sync/systems/websocket/server.scm b/8sync/systems/websocket/server.scm index c29ce51..2a91b92 100644 --- a/8sync/systems/websocket/server.scm +++ b/8sync/systems/websocket/server.scm @@ -1,7 +1,7 @@ ;;; guile-websocket --- WebSocket client/server ;;; Copyright © 2015 David Thompson ;;; Copyright © 2017 Christopher Allan Webber -;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of guile-websocket. ;;; @@ -36,17 +36,10 @@ #: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-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 ()) (define (make-handshake-response client-key) "Return an HTTP response object for upgrading to a WebSocket @@ -61,124 +54,50 @@ string." (define no-op (const #f)) -(define (make-simple-counter) - (let ((count 0)) - (lambda () - (set! count (1+ count)) - count))) - (define-actor () - ((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 + #: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)))