ws-conn-close-status and ws-conn-close-reason; closes tonyg#8.

Author: tonyg

net/rfc6455/conn-api.rkt

@@ -9,6 +9,8 @@
 	 ws-conn-supports-payload-type?
 	 ws-conn-signals-status-on-close?
 	 ws-conn-closed?
+         ws-conn-close-status
+         ws-conn-close-reason
 	 ws-conn-line
 	 ws-conn-headers
 	 ws-send!
@@ -33,6 +35,8 @@
 (require web-server/http/request-structs)
 
 (struct ws-conn-base ([closed? #:mutable]
+                      [close-status #:mutable]
+                      [close-reason #:mutable]
                       line
                       headers
                       ip
@@ -52,6 +56,8 @@
   (ws-conn-supports-payload-type? ws-conn payload-type)
   (ws-conn-signals-status-on-close? ws-conn)
   (ws-conn-closed? ws-conn)
+  (ws-conn-close-status ws-conn)
+  (ws-conn-close-reason ws-conn)
   (ws-conn-line ws-conn)
   (ws-conn-headers ws-conn)
   (ws-send! ws-conn payload

net/rfc6455/examples/cat.rkt

@@ -9,10 +9,15 @@
   (require (only-in racket/port read-line-evt))
 
   (define server "ws://localhost:8081/")
+  (define close-status 1000)
+  (define close-reason "")
   (command-line #:once-each
-                ["--server" s
-                 "URL of Websocket server to contact"
-                 (set! server s)])
+                ["--server" URL "URL of Websocket server to contact"
+                 (set! server URL)]
+                ["--status" CODE "Status code to use during WebSocket close"
+                 (set! close-status (string->number CODE))]
+                ["--reason" MESSAGE "Explanatory text to use during close"
+                 (set! close-reason MESSAGE)])
 
   (define c (ws-connect (string->url server)))
   (let loop ()
@@ -28,4 +33,6 @@
                             (void)
                             (begin (printf "~a\n" line)
                                    (loop)))))))
-  (ws-close! c))
+  (ws-close! c
+             #:status close-status
+             #:reason close-reason))

net/rfc6455/examples/echo-server.rkt

@@ -0,0 +1,37 @@
+#lang racket
+;; Echo server, demonstrating the ws-serve interface.
+;; Public Domain.
+
+(module+ main
+  (require "../../rfc6455.rkt")
+
+  (define port 8081)
+  (define idle-timeout #f)
+  (command-line #:once-each
+                ["--timeout" SECONDS "Set per-connection idle timeout"
+                 (set! idle-timeout (string->number SECONDS))]
+                ["--port" PORT "Set service port"
+                 (set! port (string->number PORT))])
+
+  (define (connection-handler c state)
+    (define id (gensym 'conn))
+    (printf "~a: Connection received\n" id)
+    (let loop ()
+      (match (ws-recv c #:payload-type 'text)
+        [(? eof-object?) (void)]
+        [m
+         (printf "~a: Received: ~v\n" id m)
+         (ws-send! c m)
+         (loop)]))
+    (printf "~a: Close status: ~v ~v\n"
+            id
+            (ws-conn-close-status c)
+            (ws-conn-close-reason c))
+    (ws-close! c)
+    (printf "~a: Connection closed\n" id))
+
+  (when idle-timeout (ws-idle-timeout idle-timeout))
+  (define stop-service (ws-serve #:port port connection-handler))
+  (printf "Server running. Hit enter to stop service.\n")
+  (void (read-line))
+  (stop-service))

net/rfc6455/hybi00/client.rkt

@@ -49,6 +49,8 @@
 
   (define conn (new-web-server-connection ip op))
   (ws-conn-start! (hybi00-conn #f
+                               #f
+                               #f
                                sresponse
                                rheaders
                                ip

net/rfc6455/hybi00/conn.rkt

@@ -102,6 +102,8 @@
 	 (define (ws-conn-supports-payload-type? c payload-type) (eq? payload-type 'text))
 	 (define (ws-conn-signals-status-on-close? c) #f)
 	 (define (ws-conn-closed? c) (ws-conn-base-closed? c))
+         (define (ws-conn-close-status c) (ws-conn-base-close-status c))
+         (define (ws-conn-close-reason c) (ws-conn-base-close-reason c))
 	 (define (ws-conn-line c) (ws-conn-base-line c))
 	 (define (ws-conn-headers c) (ws-conn-base-headers c))
 	 (define (ws-send! c payload

net/rfc6455/hybi00/dispatcher.rkt

@@ -83,6 +83,8 @@
 
     (bump-connection-timeout! c)
     (conn-dispatch (ws-conn-start! (hybi00-conn #f
+                                                #f
+                                                #f
                                                 cline
                                                 headers
                                                 ip

net/rfc6455/rfc6455/client.rkt

@@ -62,6 +62,8 @@
 
   (define conn (new-web-server-connection ip op))
   (ws-conn-start! (rfc6455-conn #f
+                                #f
+                                #f
                                 response-line
                                 response-headers
                                 ip

net/rfc6455/rfc6455/conn.rkt

@@ -67,6 +67,11 @@
        [(8) ;; close; shutdown
 	(unless (ws-conn-base-closed? c)
 	  (write-frame (rfc6455-frame #t 8 #"") (ws-conn-base-op c) (rfc6455-conn-mask? c))
+          (when (>= (bytes-length payload) 2)
+            (define status (integer-bytes->integer payload #f #t 0 2))
+            (define reason (bytes->string/utf-8 (subbytes payload 2)))
+            (set-ws-conn-base-close-status! c status)
+            (set-ws-conn-base-close-reason! c reason))
 	  (set-ws-conn-base-closed?! c #t))
 	eof]
        [(9) ;; ping; reply
@@ -139,6 +144,8 @@
 	   (memq payload-type '(text binary)))
 	 (define (ws-conn-signals-status-on-close? c) #t)
 	 (define (ws-conn-closed? c) (ws-conn-base-closed? c))
+         (define (ws-conn-close-status c) (ws-conn-base-close-status c))
+         (define (ws-conn-close-reason c) (ws-conn-base-close-reason c))
 	 (define (ws-conn-line c) (ws-conn-base-line c))
 	 (define (ws-conn-headers c) (ws-conn-base-headers c))
 	 (define (ws-send! c payload

net/rfc6455/rfc6455/dispatcher.rkt

@@ -57,6 +57,8 @@
 
     (bump-connection-timeout! conn)
     (conn-dispatch (ws-conn-start! (rfc6455-conn #f
+                                                 #f
+                                                 #f
                                                  request-line
                                                  headers
                                                  (connection-i-port conn)

net/rfc6455/scribblings/rfc6455.scrbl

@@ -6,7 +6,7 @@
 		     web-server/http/request-structs
 		     net/rfc6455))
 
-@title[#:version "2.0.0"]{RFC 6455 WebSockets for Racket}
+@title[#:version "2.1.0"]{RFC 6455 WebSockets for Racket}
 @author[(author+email "Tony Garnock-Jones" "tonygarnockjones@gmail.com")]
 
 @;@local-table-of-contents[]
@@ -48,6 +48,10 @@ This package has been developed against
 
 @section{Changes}
 
+Version 2.1.0 of this library introduces @racket[ws-conn-close-status]
+and @racket[ws-conn-close-reason] for retrieving information from
+close frames sent by remote peers.
+
 Version 2.0.0 of this library introduces a new interface to streaming
 message reception, @racket[ws-recv-stream], and makes a breaking
 change to the way @racket[ws-conn?] values work as @(tech:event)s. The
@@ -173,6 +177,19 @@ Returns @racket[#t] if the given connection has been closed, and
 
 }
 
+@deftogether[(@defproc[(ws-conn-close-status [c ws-conn?]) (or/c #f number?)]
+              @defproc[(ws-conn-close-reason [c ws-conn?]) (or/c #f string?)])]{
+
+When @racket[ws-conn-closed?] returns @racket[#t], these procedures
+will respectively retrieve the "status code" and "reason" text from
+the close frame sent by the remote peer that caused the connection
+shutdown. If no such information is available, they will return
+@racket[#f]. Only RFC 6455 peers send information in their close
+frames; hybi-00 connections will always yield @racket[#f] from these
+procedures.
+
+}
+
 @defproc[(ws-connect [u (or/c ws-url? wss-url?)]
 		     [#:headers headers (listof header?) '()]
 		     [#:protocol protocol (or/c 'rfc6455 'hybi00) 'rfc6455])