Adding WebSocket support

collects/meta/props

@@ -1119,6 +1119,8 @@ path/s is either such a string or a list of them.
 "collects/mzscheme/examples/msgbox.rkt" drdr:command-line #f
 "collects/mzscheme/examples/tree-finish.rkt" drdr:command-line #f
 "collects/net" responsible (eli jay mflatt)
+"collects/net/websocket" responsible (jay)
+"collects/net/websocket.rkt" responsible (jay)
 "collects/openssl" responsible (mflatt)
 "collects/parser-tools" responsible (mflatt)
 "collects/parser-tools/private-lex/error-tests.rkt" drdr:command-line #f
@@ -1463,6 +1465,9 @@ path/s is either such a string or a list of them.
 "collects/tests/mzcom/test.rktl" drdr:command-line #f
 "collects/tests/net" responsible (jay eli)
 "collects/tests/net/url-port.rkt" responsible (jay)
+"collects/tests/net/websocket" responsible (jay)
+"collects/tests/net/websocket/example.rkt" drdr:command-line #f
+"collects/tests/net/websocket.rkt" responsible (jay)
 "collects/tests/plai" responsible (jay)
 "collects/tests/plai/gc/bad-mutators/mut-1.rkt" drdr:command-line #f
 "collects/tests/plai/gc/bad-mutators/mutator0.rkt" drdr:command-line #f

collects/net/scribblings/net.scrbl

@@ -7,6 +7,7 @@
 
 @include-section["url.scrbl"]
 @include-section["uri-codec.scrbl"]
+@include-section["websocket.scrbl"]
 @include-section["ftp.scrbl"]
 @include-section["sendurl.scrbl"]
 @include-section["smtp.scrbl"]

collects/net/scribblings/websocket.scrbl

@@ -0,0 +1,116 @@
+#lang scribble/doc
+@(require "common.ss"
+          scribble/bnf
+          (for-label net/url
+                     unstable/contract
+                     web-server/http
+                     racket/list
+                     racket/async-channel
+                     net/websocket
+                     net/websocket/client
+                     net/websocket/server
+                     net/websocket/conn))
+
+@title[#:tag "websocket"]{WebSocket}
+
+@defmodule[net/websocket]
+
+The @racketmodname[net/websocket] library provides
+utilities to run and communicate with WebSocket servers,
+as specified in @link["http://www.whatwg.org/specs/web-socket-protocol/"]{the WebSocket protocol} IETF draft
+as of August 16th, 2010.
+
+This module provides the exports from @racketmodname[net/websocket/client] and @racketmodname[net/websocket/server].
+ 
+@section{Client API}
+
+@defmodule[net/websocket/client]
+
+@defproc[(ws-url? [x any/c]) boolean?]{ Returns true if @racket[x] is a @racket[url?] and has a @racket[url-scheme] equal to @litchar["ws"]. }
+
+@defproc[(ws-connect [u ws-url?]
+                     [#:headers headers (listof header?) empty])
+         open-ws-conn?]{
+ Connects to the WebSocket server specified by @racket[u], providing @racket[headers] as additional headers.
+ Returns the connection handle.
+}
+                  
+This module also provides the exports from @racketmodname[net/websocket/conn].
+
+@section{Server API}
+
+@defmodule[net/websocket/server]
+
+@defproc[(ws-serve [conn-handle (open-ws-conn? any/c . -> . void)]
+                   [#:conn-headers 
+                    conn-headers
+                    (bytes? (listof header?) . -> . (values (listof header?) any/c))
+                    (λ (b hs) (values empty (void)))]
+                   [#:port port tcp-listen-port? 80]
+                   [#:listen-ip listen-ip (or/c string? false/c) #f]
+                   [#:max-waiting max-waiting integer? 4]
+                   [#:timeout timeout integer? (* 60 60)]
+                   [#:confirmation-channel
+                    confirm-ch
+                    (or/c false/c async-channel?)
+                    #f])
+         (-> void)]{
+ 
+ Starts a WebSocket server where each new connection uses @racket[conn-headers] to compute
+ what headers the client receives based on the client's request line and headers. @racket[conn-headers]
+ also returns a piece of state that will be passed to @racket[conn-handle] as its second argument.
+ After the connection handshake is finished, @racket[conn-handle] receives the connection and is in
+ sole control until the WebSocket connection completes.
+ 
+ All other arguments are used as in a @secref["dispatch-server-unit" #:doc '(lib "web-server/scribblings/web-server-internal.scrbl")].
+                    
+}
+       
+This module also provides the exports from @racketmodname[net/websocket/conn].
+
+@section{Connections}
+
+@defmodule[net/websocket/conn]
+
+@defparam[framing-mode mode (symbols 'old 'new)]{ Controls whether framing is as before August 16th, 2010 or after. (Most Web browsers currently support only @racket['old] and they are incompatible, so you must choose the correct one.) Defaults to @racket['old].}
+
+@defproc[(ws-conn? [x any/c]) boolean?]{ Returns true if @racket[x] is a WebSocket connection. }
+
+@defproc[(open-ws-conn? [x any/c]) boolean?]{ Returns true if @racket[x] is an open WebSocket connection. }
+
+@defproc[(ws-conn-line [ws ws-conn?]) bytes?]{ Returns the request/response line of the WebSocket connection. }
+@defproc[(ws-conn-closed? [ws ws-conn?]) boolean?]{ Returns true if the WebSocket connection has been closed. }
+@defproc[(ws-conn-headers [ws ws-conn?]) (listof header?)]{ Returns the headers of the WebSocket connection. }
+
+WebSocket connection support only blocking calls:
+
+@defproc[(ws-send! [ws open-ws-conn?] [s string?]) void]{ Sends @racket[s] over @racket[ws]. }
+@defproc[(ws-recv [ws open-ws-conn?]) (or/c string? eof-object?)]{ Receives a string from @racket[ws]. Returns @racket[eof] if the other end closes the connection. }
+
+@defproc[(ws-close! [ws open-ws-conn?]) void]{ Closes @racket[ws]. }
+
+@section{Example}
+
+This is a WebSocket echo server compatible with the browser origin security model:
+
+@racketblock[
+(ws-serve 
+ #:port 8080
+ (λ (wsc _)
+   (let loop ()
+     (define m (ws-recv wsc))
+     (printf "~a\n" m)
+     (unless (eof-object? m)
+       (ws-send! wsc m)
+       (loop))))
+ #:conn-headers 
+ (λ (_ hs)
+   (define origin 
+     (header-value (headers-assq* #"Origin" hs)))
+   (values 
+    (list
+     (make-header #"Sec-WebSocket-Origin" origin)
+     (make-header #"Sec-WebSocket-Location"
+                  #"ws://localhost:8080/"))
+    #f)))
+]

collects/net/websocket.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+(require net/websocket/client
+         net/websocket/server)
+(provide (all-from-out net/websocket/client
+                       net/websocket/server))

collects/net/websocket/client.rkt

@@ -0,0 +1,71 @@
+#lang racket
+(require net/url
+         web-server/http/response
+         web-server/http/request
+         web-server/http/request-structs
+         net/websocket/conn
+         net/websocket/handshake)
+(provide (except-out (all-from-out net/websocket/conn) ws-conn))
+
+(define (ws-url? u)
+  (and (url? u) (equal? (url-scheme u) "ws")))
+
+(provide/contract
+ [ws-url? (-> any/c boolean?)]
+ [ws-connect (->* (ws-url?)
+                  (#:headers (listof header?))
+                  open-ws-conn?)])
+
+(define (ws-connect url
+                    #:headers [headers empty])
+  (define host (or (url-host url) "localhost"))
+  (define port (or (url-port url) 80))
+  (define upath (url-path url))
+  (define the-path
+    (if (empty? upath)
+        "/"
+        (local 
+          [(define pre-path
+             (add-between 
+              (map (λ (pp)
+                     (define p (path/param-path pp))
+                     (case p
+                       [(up) ".."]
+                       [(same) "."]
+                       [else p]))
+                   upath)
+              "/"))]
+          (apply string-append
+                 (if (url-path-absolute? url)
+                     (list* "/"
+                            pre-path)
+                     pre-path)))))
+  ; Connect
+  (define-values (ip op) (tcp-connect host port))
+  ; Handshake (client)
+  (fprintf op "GET ~a HTTP/1.1\r\n" the-path)
+  (define-values (key1 key2 key3 client-ans) (generate-key))
+  (print-headers 
+   op
+   (list* (make-header #"Host" (string->bytes/utf-8 host))
+          (make-header #"Connection" #"Upgrade")
+          (make-header #"Upgrade" #"WebSocket")
+          (make-header #"Sec-WebSocket-Key1" (string->bytes/utf-8 key1))
+          (make-header #"Sec-WebSocket-Key2" (string->bytes/utf-8 key2))
+          headers))
+  
+  (write-bytes key3 op)
+  (flush-output op)
+  ; Handshake (server)
+  (define sresponse (read-bytes-line ip 'any))
+  (define rheaders (read-headers ip))
+  (define server-ans (read-bytes 16 ip))
+  (unless (bytes=? client-ans server-ans)
+    (error 'ws-connect "Invalid server handshake response. Expected ~e, got ~e" client-ans server-ans))
+  
+  (ws-conn #f sresponse rheaders ip op))
+
+(define (freadf ip s)
+  (define i (read-line ip 'any))
+  (unless (string=? s i)
+    (error 'ws-connect "Invalid server response. Expected ~e, got ~e" s i)))

collects/net/websocket/conn.rkt

@@ -0,0 +1,89 @@
+#lang racket
+(require web-server/http/request-structs)
+
+(define framing-mode (make-parameter 'old))
+
+(struct ws-conn ([closed? #:mutable] line headers ip op))
+(define (open-ws-conn? x)
+  (and (ws-conn? x) (not (ws-conn-closed? x))))
+(provide/contract
+ [framing-mode (parameter/c (symbols 'old 'new))]
+ [ws-conn (false/c bytes? (listof header?) input-port? output-port? . -> . open-ws-conn?)]
+ [ws-conn? (any/c . -> . boolean?)]
+ [open-ws-conn? (any/c . -> . boolean?)]
+ [ws-conn-line (ws-conn? . -> . bytes?)]
+ [ws-conn-closed? (ws-conn? . -> . boolean?)]
+ [ws-conn-headers (ws-conn? . -> . (listof header?))]
+ [ws-send! (-> open-ws-conn? string? void)]
+ [ws-recv (-> open-ws-conn? (or/c string? eof-object?))]
+ [ws-close! (-> open-ws-conn? void)])
+
+(define (write-ws-frame! t s op)
+  (define bs (string->bytes/utf-8 s))
+  (case (framing-mode)
+    [(new)
+     (write-byte t op)
+     (write-bytes (integer->integer-bytes (bytes-length bs) 8 #f #t) op)
+     (write-bytes bs op)]
+    [(old)
+     (write-byte #x00 op)
+     (write-bytes bs op)
+     (write-byte #xff op)])
+  (flush-output op))  
+
+(define (read-ws-frame ip)
+  (case (framing-mode)
+    [(new)
+     (let ()
+       (define frame (read-byte ip))
+       (when (eof-object? frame) (error 'read-ws-frame "Premature connection close"))
+       (define len-bs (read-bytes 8 ip))
+       (when (eof-object? len-bs) (error 'read-ws-frame "Premature connection close"))
+       (define len (integer-bytes->integer len-bs #f #t))
+       (define data-bs (read-bytes len ip))
+       (when (eof-object? data-bs) (error 'read-ws-frame "Premature connection close"))
+       (values frame (bytes->string/utf-8 data-bs)))]
+    [(old)
+     (let ()
+       (define l (read-byte ip))
+       (cond [(eof-object? l) (values #x00 #"")]
+             [(= #xff l)
+              (read-byte ip)
+              (values #x00 #"")]
+             [else
+              (values #xff (bytes->string/utf-8 (read-until-byte #xff ip)))]))]))
+
+(define (read-until-byte b ip)
+  (define ob (open-output-bytes))
+  (let loop ()
+    (define n (read-byte ip))
+    (unless (or (eof-object? n) (= n b))
+      (write-byte n ob)
+      (loop)))
+  (get-output-bytes ob))
+
+(define (ws-send! wsc s)
+  (match-define (ws-conn _ _ _ _ op) wsc)
+  (write-ws-frame! #xff s op))
+
+(define (ws-recv wsc)
+  (match-define (ws-conn _ _ _ ip _) wsc)
+  (define-values (ft m) (read-ws-frame ip))
+  (if (= #x00 ft)
+      eof
+      m))
+
+(define (ws-close! wsc)
+  (match-define (ws-conn _ _ _ ip op) wsc)
+  
+  (case (framing-mode)
+    [(new)
+     (write-ws-frame! #x00 "" op)]
+    [(old)
+     (write-byte #xff op)
+     (write-byte #x00 op)
+     (flush-output op)])
+  
+  (close-input-port ip)
+  (close-output-port op)
+  (set-ws-conn-closed?! wsc #t))

collects/net/websocket/handshake.rkt

@@ -0,0 +1,87 @@
+#lang racket
+(require file/md5)
+
+(define RANGE 100000)
+
+(provide/contract
+ [compute-ans (number? number? bytes? . -> . bytes?)]
+ [remove-alphas (string? . -> . string?)]
+ [count-spaces (string? . -> . exact-nonnegative-integer?)]
+ [key->number (string? . -> . exact-nonnegative-integer?)]
+ [handshake-solution (string? string? bytes? . -> . bytes?)]
+ [generate-key (-> (values string? string? bytes? bytes?))]
+ [random-char-between (char? char? . -> . char?)]
+ [random-alpha-char (-> char-alphabetic?)]
+ [add-spaces (exact-nonnegative-integer? string? . -> . string?)]
+ [add-alphas (string? . -> . string?)]
+ [number->key (exact-nonnegative-integer? . -> . string?)])
+ 
+(define (compute-ans n1 n2 key3)
+  (md5 (bytes-append (integer->integer-bytes n1 4 #f #t)
+                     (integer->integer-bytes n2 4 #f #t)
+                     key3)
+       #f))
+
+(define (remove-alphas key)
+  (apply string-append
+         (regexp-match* "[0-9]" key)))
+
+(define (count-spaces key)
+  (length (regexp-match* " " key)))
+
+(define (key->number key)
+  (define spaces (count-spaces key))
+  (define n1 (string->number (remove-alphas key)))
+  (/ n1 spaces))
+
+(define (handshake-solution key1 key2 key3)
+  (compute-ans (key->number key1) (key->number key2) key3))
+
+(define (generate-key)
+  (define n1 (random RANGE))
+  (define n2 (random RANGE))
+  (define key1 (number->key n1))
+  (define key2 (number->key n2))
+  (define key3 (apply bytes (build-list 8 (λ (i) (random 256)))))
+  (define ans 
+    (compute-ans n1 n2 key3))
+  (values key1 key2 key3 ans))
+
+(define (random-char-between botc topc)
+  (if (char=? botc topc)
+      botc
+      (let ()
+        (define bot (char->integer botc))
+        (define top (char->integer topc))
+        (integer->char (+ bot (random (- top bot)))))))
+
+(define (random-alpha-char)
+  (case (random 2)
+    [(0) (random-char-between #\a #\z)]
+    [(1) (random-char-between #\A #\Z)]))
+
+(define (add-spaces how-many s0)
+  (list->string
+   (reverse
+    (for/fold ([s1 empty])
+      ([c (in-string s0)]
+       [i (in-naturals)])
+      (if (i . < . how-many)
+          (list* #\space c s1)
+          (list* c s1))))))
+
+(define (add-alphas s0)
+  (list->string
+   (reverse
+    (for/fold ([s1 empty])
+      ([c (in-string s0)]
+       [i (in-naturals)])
+      (if (zero? (random 3))
+          (list* c s1)
+          (list* (random-alpha-char) c s1))))))
+
+(define (number->key n0)
+  (define s0 (number->string n0))
+  (define how-many-spaces (add1 (random (string-length s0))))
+  (define n1 (* n0 how-many-spaces))
+  (add-alphas (add-spaces how-many-spaces (number->string n1))))

collects/net/websocket/server.rkt

@@ -0,0 +1,75 @@
+#lang racket
+(require web-server/private/dispatch-server-unit
+         web-server/private/dispatch-server-sig
+         web-server/private/connection-manager
+         web-server/http/response
+         web-server/http/request
+         web-server/http/request-structs
+         racket/async-channel
+         unstable/contract
+         net/websocket/conn
+         net/websocket/handshake)
+(provide (except-out (all-from-out net/websocket/conn) ws-conn))
+
+(provide/contract
+ [ws-serve
+  (->* ((open-ws-conn? any/c . -> . void))
+       (#:conn-headers 
+        (bytes? (listof header?) . -> . (values (listof header?) any/c))
+        #:port
+        tcp-listen-port?
+        #:listen-ip
+        (or/c string? false/c)
+        #:max-waiting
+        integer?
+        #:timeout
+        integer?
+        #:confirmation-channel
+        (or/c false/c async-channel?))
+       (-> void))])
+
+(define (ws-serve conn-dispatch
+                  #:conn-headers [pre-conn-dispatch (λ (cline hs) (values empty (void)))]
+                  #:port [port 80]
+                  #:listen-ip [listen-ip #f]
+                  #:max-waiting [max-waiting 4]
+                  #:timeout [initial-connection-timeout (* 60 60)]
+                  #:confirmation-channel [confirm-ch #f])
+  (define (read-request c p port-addresses)
+    (values #f #t))
+  (define (dispatch c _)
+    (define ip (connection-i-port c))
+    (define op (connection-o-port c))
+    (define cline (read-bytes-line ip 'any))
+    (define headers (read-headers ip))
+    (define key1h (headers-assq* #"Sec-WebSocket-Key1" headers))
+    (unless key1h (error 'ws-serve "Invalid WebSocket request, no Key1"))
+    (define key1 (header-value key1h))
+    (define key2h (headers-assq* #"Sec-WebSocket-Key2" headers))
+    (unless key2h (error 'ws-serve "Invalid WebSocket request, no Key2"))
+    (define key2 (header-value key2h))
+    (define key3 (read-bytes 8 ip))
+    
+    (define-values (conn-headers state) (pre-conn-dispatch cline headers))
+    
+    (fprintf op "HTTP/1.1 101 WebSocket Protocol Handshake\r\n")
+    (print-headers 
+     op
+     (list* (make-header #"Upgrade" #"WebSocket")
+            (make-header #"Connection" #"Upgrade")
+            conn-headers))
+    
+    (write-bytes
+     (handshake-solution (bytes->string/utf-8 key1)
+                         (bytes->string/utf-8 key2)
+                         key3)
+     op)
+    (flush-output op)
+    
+    (define conn
+      (ws-conn #f cline conn-headers ip op))
+    
+    (conn-dispatch conn state))
+  
+  (define-values/invoke-unit/infer dispatch-server@)
+  (serve #:confirmation-channel confirm-ch))

collects/tests/net/websocket.rkt

@@ -0,0 +1,98 @@
+#lang racket
+(require net/websocket/client
+         net/websocket/server
+         net/websocket/conn
+         net/websocket/handshake
+         racket/async-channel
+         net/url
+         rackunit
+         tests/eli-tester)
+
+(define RANDOM-K 100)
+
+(test
+ (for ([i (in-range RANDOM-K)])
+   (define o (random 256))
+   (define t (random 256))
+   (define bot (if (o . < . t) o t))
+   (define top (if (o . < . t) t o))
+   (define botc (integer->char bot))
+   (define topc (integer->char top))
+   (test #:failure-prefix (format "~a / ~a" botc topc)
+         (<= bot (char->integer (random-char-between botc topc)) top)))
+ 
+ (for ([i (in-range RANDOM-K)])
+   (test (char-alphabetic? (random-alpha-char))))
+ 
+ (count-spaces "") => 0
+ (count-spaces "   ") => 3
+ (count-spaces (make-string RANDOM-K #\space)) => RANDOM-K
+ 
+ (count-spaces "18x 6]8vM;54 *(5:  {   U1]8  z [  8") => 12
+ (count-spaces "1_ tx7X d  <  nw  334J702) 7]o}` 0") => 10
+ 
+ (for ([i (in-range RANDOM-K)])
+   (define len (add1 i))
+   (define s (make-string len #\0))
+   (define how-many (random len))
+   (test (count-spaces (add-spaces how-many s)) => how-many))
+ 
+ (remove-alphas "A0A") => "0"
+ (remove-alphas "0") => "0"
+ (remove-alphas (make-string RANDOM-K #\A)) => ""
+ 
+ (remove-alphas "18x 6]8vM;54 *(5:  {   U1]8  z [  8") => "1868545188"
+ (remove-alphas "1_ tx7X d  <  nw  334J702) 7]o}` 0") => "1733470270"
+ 
+ (for ([i (in-range RANDOM-K)])
+   (define s (number->string i))
+   (test (remove-alphas (add-alphas s)) => s))
+ 
+ (key->number "18x 6]8vM;54 *(5:  {   U1]8  z [  8") => 155712099
+ (key->number "1_ tx7X d  <  nw  334J702) 7]o}` 0") => 173347027
+ 
+ (for ([i (in-range RANDOM-K)])
+   (test (key->number (number->key i)) => i))
+ 
+ (for ([i (in-range RANDOM-K)])
+   (define-values (k1 k2 k3 ans) (generate-key))
+   (test (handshake-solution k1 k2 k3) => ans))
+ 
+ (handshake-solution "18x 6]8vM;54 *(5:  {   U1]8  z [  8"
+                     "1_ tx7X d  <  nw  334J702) 7]o}` 0"
+                     #"Tm[K T2u")
+ =>
+ #"fQJ,fN/4F4!~K~MH"
+ 
+ (local [(define (test-echo-server)
+           (define conn #f)
+           (define r (number->string (random 1000)))
+           (define shutdown! #f)
+           (define p #f)
+           (define confirm (make-async-channel))
+           
+           (test (set! shutdown!
+                       (ws-serve #:port 0
+                                 #:confirmation-channel confirm
+                                 (λ (wsc _)
+                                   (let loop ()
+                                     (define m (ws-recv wsc))
+                                     (unless (eof-object? m)
+                                       (ws-send! wsc m)
+                                       (loop))))))
+                 shutdown!
+                 (set! p (async-channel-get confirm))
+                 p
+                 (set! conn (ws-connect (string->url (format "ws://localhost:~a" p))))
+                 conn
+                 (ws-send! conn r)
+                 (ws-recv conn) => r
+                 (ws-send! conn "a")
+                 (ws-recv conn) => "a"
+                 (ws-close! conn)
+                 (shutdown!)))]
+   (test
+    #:failure-prefix "old"
+    (parameterize ([framing-mode 'old]) (test-echo-server))
+    #:failure-prefix "new"
+    (parameterize ([framing-mode 'new]) (test-echo-server)))))