adjusted the framework preferences system to work better with failures under windows
original commit: cde613218e
This commit is contained in:
Robby Findler
commit
5b5c803b8c
|
|
@ -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"]
|
||||
|
|
|
|||
121
collects/net/scribblings/websocket.scrbl
Normal file
121
collects/net/scribblings/websocket.scrbl
Normal file
|
|
@ -0,0 +1,121 @@
|
|||
#lang scribble/doc
|
||||
@(require "common.ss"
|
||||
scribble/bnf
|
||||
(for-label net/url
|
||||
unstable/contract
|
||||
web-server/http
|
||||
racket/list
|
||||
racket/async-channel
|
||||
(prefix-in raw: (for-label net/tcp-unit))
|
||||
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"] or @litchar["wss"]. }
|
||||
|
||||
@defproc[(wss-url? [x any/c]) boolean?]{ Returns true if @racket[x] is a @racket[url?] and has a @racket[url-scheme] equal to @litchar["wss"]. }
|
||||
|
||||
@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)))]
|
||||
[#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]
|
||||
[#: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")].
|
||||
|
||||
The @racket[#:tcp@] keyword is provided for building an SSL server.
|
||||
}
|
||||
|
||||
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)))
|
||||
]
|
||||
|
|
@ -13,7 +13,9 @@
|
|||
|
||||
(define separate-by-default?
|
||||
;; internal configuration, 'browser-default lets some browsers decide
|
||||
(get-preference 'new-browser-for-urls (lambda () 'browser-default)))
|
||||
(get-preference 'new-browser-for-urls
|
||||
(lambda () 'browser-default)
|
||||
#:timeout-lock-there (lambda (path) 'browser-default)))
|
||||
|
||||
;; all possible unix browsers, filtered later to just existing executables
|
||||
;; order matters: the default will be the first of these that is found
|
||||
|
|
|
|||
|
|
@ -1,27 +1,258 @@
|
|||
#lang racket
|
||||
(require net/ftp tests/eli-tester)
|
||||
|
||||
(define server "ftp.gnu.org")
|
||||
(define port 21)
|
||||
(define user "anonymous")
|
||||
(define passwd "nonny")
|
||||
(define (tcp-serve-port cop tp)
|
||||
(define listener (tcp-listen 0))
|
||||
(define-values (_1 the-port _2 _3) (tcp-addresses listener #t))
|
||||
(values
|
||||
(thread
|
||||
(λ ()
|
||||
(define-values (ip op) (tcp-accept listener))
|
||||
(define ip->cop-t
|
||||
(thread (λ ()
|
||||
(copy-port ip cop))))
|
||||
(define tp->op-t
|
||||
(thread (λ ()
|
||||
(copy-port tp op))))
|
||||
|
||||
(thread-wait tp->op-t)
|
||||
(thread-wait ip->cop-t)
|
||||
|
||||
(flush-output op)
|
||||
(flush-output cop)
|
||||
|
||||
(close-output-port op)
|
||||
(close-input-port ip)))
|
||||
the-port))
|
||||
|
||||
(define (ftp-port-split n)
|
||||
(quotient/remainder n 256))
|
||||
|
||||
(provide tests)
|
||||
(define (tests)
|
||||
(define cop (open-output-string))
|
||||
(define-values (pasv1-thread pasv1-port)
|
||||
(tcp-serve-port (current-output-port) (open-input-string #<<END
|
||||
drwxr-xr-x 2 1003 1003 4096 Jan 16 2004 3dldf
|
||||
-rw-r--r-- 1 1003 65534 1492 Jan 25 2001 =README
|
||||
-rw-r--r-- 1 1003 65534 745 Mar 20 1997 =README-about-.diff-files
|
||||
-rw-r--r-- 1 1003 65534 1042 Jan 08 2000 =README-about-.gz-files
|
||||
drwxrwxr-x 3 0 1003 4096 Feb 08 2005 GNUinfo
|
||||
drwxrwsr-x 3 0 1003 4096 Aug 14 2003 GNUsBulletins
|
||||
drwxrwxr-x 2 0 1003 4096 Mar 25 18:42 Licenses
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 MailingListArchives
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 MicrosPorts
|
||||
-rw-r--r-- 1 1003 65534 29107 May 03 1998 ProgramIndex
|
||||
-rw-r--r-- 1 1003 65534 257 Jun 12 2000 README.DESCRIPTIONS
|
||||
drwxrwxr-x 2 0 1003 4096 Dec 29 2007 a2ps
|
||||
drwxrwxr-x 2 0 1003 4096 Feb 12 16:45 acct
|
||||
drwxrwxr-x 2 0 1003 4096 Jun 09 2006 adns
|
||||
drwxr-xr-x 2 1003 1003 4096 Jul 14 2008 aeneas
|
||||
drwxrwxr-x 2 0 1003 4096 Dec 20 2008 anubis
|
||||
drwxr-xr-x 2 1003 1003 4096 Feb 24 00:20 archimedes
|
||||
drwxrwxr-x 4 0 1003 4096 Apr 16 2008 aspell
|
||||
lrwxr-xr-x 1 0 0 15 Mar 11 2005 aspell-dict-csb -> aspell/dict/csb
|
||||
lrwxrwxrwx 1 0 0 14 Nov 24 2003 aspell-dict-ga -> aspell/dict/ga
|
||||
lrwxrwxrwx 1 0 0 14 Mar 22 2004 aspell-dict-hr -> aspell/dict/hr
|
||||
lrwxrwxrwx 1 0 0 14 Mar 12 2004 aspell-dict-is -> aspell/dict/is
|
||||
lrwxrwxrwx 1 0 0 14 Nov 24 2003 aspell-dict-it -> aspell/dict/it
|
||||
lrwxrwxrwx 1 0 0 14 Apr 26 2004 aspell-dict-sk -> aspell/dict/sk
|
||||
drwxrwxr-x 13 0 1003 8192 Jul 03 14:05 auctex
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 18:10 autoconf
|
||||
drwxr-xr-x 2 1003 1003 4096 Jul 06 14:30 autoconf-archive
|
||||
drwxrwxr-x 32 0 1003 4096 Jul 25 18:10 autogen
|
||||
drwxrwxr-x 2 0 1003 8192 Dec 08 2009 automake
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 26 2007 avl
|
||||
drwxr-xr-x 2 1003 1003 4096 Jul 15 2009 ballandpaddle
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 barcode
|
||||
drwxrwxr-x 8 0 1003 4096 Jan 18 2010 bash
|
||||
drwxrwxr-x 3 0 1003 8192 Jan 18 2007 bayonne
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 bc
|
||||
drwxrwxr-x 2 0 1003 4096 Mar 03 15:25 binutils
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 06 02:25 bison
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 bool
|
||||
drwxr-xr-x 10 1003 1003 4096 Jul 30 2007 bpel2owfn
|
||||
-rw-r--r-- 1 1003 65534 420 Nov 15 2000 brl.README
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 calc
|
||||
drwxrwxr-x 2 0 1003 4096 Dec 16 2008 ccaudio
|
||||
drwxrwxr-x 2 0 1003 4096 Oct 25 2009 ccrtp
|
||||
drwxrwxr-x 2 0 1003 8192 May 19 00:50 ccscript
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 cfengine
|
||||
drwxr-xr-x 2 1003 1003 4096 Jul 11 2009 cflow
|
||||
drwxrwxr-x 2 0 1003 4096 Nov 14 2009 cgicc
|
||||
drwxrwxr-x 2 0 1003 4096 Jan 12 2004 chess
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 cim
|
||||
drwxrwxr-x 2 0 1003 4096 Mar 25 17:25 classpath
|
||||
drwxrwxr-x 2 0 1003 4096 Apr 28 2007 classpathx
|
||||
drwxrwxr-x 6 0 1003 4096 Jul 07 17:30 clisp
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 clx
|
||||
drwxr-xr-x 2 1003 1003 4096 Jun 05 2004 combine
|
||||
lrwxrwxrwx 1 0 0 9 Nov 18 2003 commonc++ -> commoncpp
|
||||
drwxrwxr-x 2 0 1003 8192 Aug 11 06:30 commoncpp
|
||||
drwxrwxr-x 2 0 1003 4096 Feb 13 2008 config
|
||||
drwxrwxr-x 2 0 1003 8192 Apr 23 16:45 coreutils
|
||||
drwxrwxr-x 2 0 1003 4096 Mar 10 13:20 cpio
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 cpp2html
|
||||
drwxr-xr-x 2 1003 1003 4096 Mar 18 06:45 cppi
|
||||
drwxr-xr-x 2 1003 1003 4096 Apr 11 2009 cssc
|
||||
drwxrwxr-x 2 0 1003 4096 Feb 21 2008 dap
|
||||
-rw-r--r-- 1 1003 65534 110 Jun 06 1999 dc.README
|
||||
drwxrwxr-x 2 0 1003 4096 Feb 11 2009 ddd
|
||||
drwxr-xr-x 2 1003 1003 4096 Apr 06 18:50 ddrescue
|
||||
drwxrwxr-x 2 0 1003 4096 Jan 30 2004 dejagnu
|
||||
drwxr-xr-x 2 1003 1003 4096 Jul 07 20:50 denemo
|
||||
-rw-r--r-- 1 1003 65534 145 May 22 2001 dia.README
|
||||
drwxr-xr-x 2 1003 1003 4096 Jul 07 19:35 dico
|
||||
drwxrwxr-x 2 0 1003 4096 Sep 17 2007 diction
|
||||
-rw-r--r-- 1 1003 65534 134 Apr 15 2002 dictionary.README
|
||||
drwxrwxr-x 2 0 1003 4096 May 03 17:00 diffutils
|
||||
drwxr-xr-x 2 1003 1003 4096 Apr 11 11:55 dionysus
|
||||
drwxrwxr-x 2 0 0 4096 Apr 03 2007 dismal
|
||||
-rw-r--r-- 1 1003 65534 492 Apr 03 2007 djgpp.README
|
||||
drwxr-xr-x 2 1003 1003 4096 Feb 18 2005 dominion
|
||||
drwxrwxr-x 5 0 1003 4096 Dec 10 2008 dotgnu
|
||||
-rw-r--r-- 1 1003 65534 96 Feb 09 1999 dumb.README
|
||||
drwxrwxr-x 2 0 1003 4096 Jul 10 2009 ed
|
||||
drwxrwxr-x 2 0 1003 4096 Apr 08 18:05 edma
|
||||
drwxrwxr-x 2 0 1003 4096 Feb 17 00:20 electric
|
||||
-rw-r--r-- 1 1003 65534 835 Jan 24 1999 elisp-archive.README
|
||||
drwxrwxr-x 3 0 1003 4096 May 08 04:01 emacs
|
||||
drwxr-xr-x 2 1003 1003 4096 Sep 16 2008 emms
|
||||
drwxrwxr-x 2 0 1003 4096 Jun 01 23:25 enscript
|
||||
drwxr-xr-x 2 1003 1003 4096 Jan 26 2008 erc
|
||||
drwxr-xr-x 2 1003 1003 4096 Jan 10 2010 fdisk
|
||||
drwxr-xr-x 2 1003 1003 4096 Nov 16 2008 ferret
|
||||
drwxrwxr-x 2 0 1003 4096 Jun 06 2009 findutils
|
||||
drwxrwxr-x 2 0 0 4096 Mar 20 2007 flex
|
||||
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 fontutils
|
||||
drwxr-xr-x 2 1003 1003 4096 Apr 20 21:05 freedink
|
||||
drwxrwxr-x 2 0 1003 4096 Jan 04 2009 freefont
|
||||
END
|
||||
)))
|
||||
(define-values (pasv1-port-maj pasv1-port-min)
|
||||
(ftp-port-split pasv1-port))
|
||||
(define-values (pasv2-thread pasv2-port)
|
||||
(tcp-serve-port (current-output-port) (open-input-string #<<END
|
||||
1) Sometimes diffs between two versions were either too large to be
|
||||
worth making, or too difficult. In those cases where a .diff file is
|
||||
missing, please just FTP the latest version.
|
||||
|
||||
2) The .diff file suffix signifies a patch file produced by the GNU
|
||||
'diff' program.
|
||||
|
||||
A diff file like this has all of the changes from one version of a
|
||||
program to the next (i.e. gcc-2.6.2-2.6.3.diff will take gcc-2.6.2 and
|
||||
produce gcc 2.6.3).
|
||||
|
||||
You can use the "patch" program to apply the diff to your sources.
|
||||
(The "patch" program is available on prep.ai.mit.edu in directory
|
||||
/pub/gnu/ if it isn't already installed on your system.)
|
||||
|
||||
(You might also want to take a look at the diff file, the format is
|
||||
pretty obvious and could be educational. ;-)
|
||||
|
||||
Thank You!
|
||||
|
||||
END
|
||||
)))
|
||||
(define-values (pasv2-port-maj pasv2-port-min)
|
||||
(ftp-port-split pasv2-port))
|
||||
(define-values (main-thread main-port)
|
||||
(tcp-serve-port cop (open-input-string (format #<<END
|
||||
220 GNU FTP server ready.
|
||||
230-Due to U.S. Export Regulations, all cryptographic software on this
|
||||
230-site is subject to the following legal notice:
|
||||
230-
|
||||
230- This site includes publicly available encryption source code
|
||||
230- which, together with object code resulting from the compiling of
|
||||
230- publicly available source code, may be exported from the United
|
||||
230- States under License Exception "TSU" pursuant to 15 C.F.R. Section
|
||||
230- 740.13(e).
|
||||
230-
|
||||
230-This legal notice applies to cryptographic software only. Please see
|
||||
230-the Bureau of Industry and Security (www.bxa.doc.gov) for more
|
||||
230-information about current U.S. regulations.
|
||||
230 Login successful.
|
||||
250-If you have problems downloading and are seeing "Access denied" or
|
||||
250-"Permission denied", please make sure that you started your FTP client
|
||||
250-in a directory to which you have write permission.
|
||||
250-
|
||||
250-Please note that all files ending in `.gz' are compressed with `gzip',
|
||||
250-not with the unix `compress' program. Get the file below for more
|
||||
250-info.
|
||||
250-
|
||||
250-For a list of mirrors and other ways of getting GNU software, FTP the
|
||||
250-file /pub/gnu/GNUinfo/FTP from ftp.gnu.org or one of its mirror sites.
|
||||
250-
|
||||
250-Programs that are directly in this directory are actually GNU
|
||||
250-programs, developed under the auspices of GNU.
|
||||
250-
|
||||
250-We do, however, distribute some non-GNU programs through our FTP
|
||||
250-server, or provide pointers to where they are. We put these
|
||||
250-programs/pointers in the subdirectory non-gnu since they are not
|
||||
250-developed by the GNU project. They are, of course, part of the GNU
|
||||
250-system. See:
|
||||
250-http://www.gnu.org/philosophy/categories.html#TheGNUsystem
|
||||
250 Directory successfully changed.
|
||||
227 Entering Passive Mode (127,0,0,1,~a,~a)
|
||||
200 Switching to Binary mode.
|
||||
150 Here comes the directory listing.
|
||||
226 Directory send OK.
|
||||
227 Entering Passive Mode (127,0,0,1,~a,~a)
|
||||
200 Switching to Binary mode.
|
||||
150 Opening BINARY mode data connection for =README-about-.diff-files (745 bytes).
|
||||
226 File send OK.
|
||||
221 Goodbye.
|
||||
|
||||
END
|
||||
pasv1-port-maj pasv1-port-min
|
||||
pasv2-port-maj pasv2-port-min
|
||||
))))
|
||||
|
||||
(define server "localhost")
|
||||
(define port main-port)
|
||||
(define user "anonymous")
|
||||
(define passwd "nonny")
|
||||
(define conn #f)
|
||||
(define pth "=README-about-.diff-files")
|
||||
(define tmp-dir (make-temporary-file "ftp~a" 'directory))
|
||||
(test (ftp-connection? 1) => #f
|
||||
(test (ftp-port-split 18291) => (values 71 115)
|
||||
(ftp-connection? 1) => #f
|
||||
(set! conn (ftp-establish-connection server port user passwd))
|
||||
(ftp-connection? conn)
|
||||
(ftp-cd conn "gnu")
|
||||
(for ([f (in-list (ftp-directory-list conn))])
|
||||
(match-define (list type ftp-date name) f)
|
||||
(when (ftp-connection? conn)
|
||||
(test
|
||||
(ftp-make-file-seconds ftp-date)))
|
||||
(ftp-cd conn "gnu")
|
||||
(for ([f (in-list (ftp-directory-list conn))])
|
||||
(match-define (list type ftp-date name) f)
|
||||
(test
|
||||
(ftp-make-file-seconds ftp-date)))
|
||||
|
||||
(ftp-download-file conn tmp-dir pth)
|
||||
(delete-file (build-path tmp-dir pth))
|
||||
(delete-directory/files tmp-dir)
|
||||
(ftp-download-file conn tmp-dir pth)
|
||||
|
||||
(ftp-close-connection conn)))
|
||||
(ftp-close-connection conn)
|
||||
|
||||
(delete-file (build-path tmp-dir pth))
|
||||
(delete-directory/files tmp-dir)
|
||||
|
||||
(thread-wait pasv1-thread)
|
||||
(thread-wait pasv2-thread)
|
||||
(thread-wait main-thread)
|
||||
|
||||
(get-output-string cop) =>
|
||||
#<<END
|
||||
USER anonymous
|
||||
CWD gnu
|
||||
PASV
|
||||
TYPE I
|
||||
LIST
|
||||
PASV
|
||||
TYPE I
|
||||
RETR =README-about-.diff-files
|
||||
QUIT
|
||||
|
||||
END
|
||||
|
||||
))))
|
||||
|
||||
(tests)
|
||||
34
collects/tests/net/stress/websocket.rkt
Normal file
34
collects/tests/net/stress/websocket.rkt
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
#lang racket/base
|
||||
(require tests/stress
|
||||
net/websocket
|
||||
net/url
|
||||
racket/async-channel)
|
||||
|
||||
(fit "websocket echo server"
|
||||
500
|
||||
(λ (n)
|
||||
(define confirm (make-async-channel))
|
||||
(define 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))))))
|
||||
(define port (async-channel-get confirm))
|
||||
|
||||
(define THREADS 10)
|
||||
(define REQS n)
|
||||
|
||||
(for-each thread-wait
|
||||
(for/list ([t (in-range THREADS)])
|
||||
(thread
|
||||
(λ ()
|
||||
(define conn (ws-connect (string->url (format "ws://localhost:~a" port))))
|
||||
(for ([r (in-range REQS)])
|
||||
(ws-send! conn "ping")
|
||||
(ws-recv conn))))))
|
||||
|
||||
(shutdown!)))
|
||||
55
collects/tests/net/url-port.rkt
Normal file
55
collects/tests/net/url-port.rkt
Normal file
|
|
@ -0,0 +1,55 @@
|
|||
#lang racket
|
||||
(require net/url
|
||||
mzlib/thread
|
||||
tests/eli-tester)
|
||||
|
||||
(define ((make-tester url->port) response)
|
||||
(define port-no 9001)
|
||||
(define server-cust
|
||||
(make-custodian))
|
||||
(parameterize ([current-custodian server-cust])
|
||||
(thread
|
||||
(λ ()
|
||||
(run-server port-no
|
||||
(lambda (ip op)
|
||||
(thread (λ () (port->string ip)))
|
||||
(display response op)
|
||||
(flush-output op))
|
||||
+inf.0))))
|
||||
(sleep 1)
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(port->string
|
||||
(url->port
|
||||
(url "http" #f "localhost" port-no
|
||||
#t empty empty #f))))
|
||||
(λ ()
|
||||
(custodian-shutdown-all server-cust))))
|
||||
|
||||
(define get-pure
|
||||
(make-tester get-pure-port))
|
||||
(define get-impure
|
||||
(make-tester get-impure-port))
|
||||
|
||||
(test
|
||||
(get-pure
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n")
|
||||
=>
|
||||
"This is the data in the first chunk and this is the second one"
|
||||
|
||||
(get-pure
|
||||
"HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one")
|
||||
=>
|
||||
"This is the data in the first chunk and this is the second one"
|
||||
|
||||
(get-impure
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n23\r\nThis is the data in the first chunk\r\n1A\r\nand this is the second one\r\n0\r\n")
|
||||
=>
|
||||
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n23\r\nThis is the data in the first chunk\r\n1A\r\nand this is the second one\r\n0\r\n"
|
||||
|
||||
(get-impure
|
||||
"HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one\r\n")
|
||||
=>
|
||||
"HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one\r\n"
|
||||
)
|
||||
98
collects/tests/net/websocket.rkt
Normal file
98
collects/tests/net/websocket.rkt
Normal file
|
|
@ -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)))))
|
||||
36
collects/tests/net/websocket/example.rkt
Normal file
36
collects/tests/net/websocket/example.rkt
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
#lang racket
|
||||
(require net/websocket
|
||||
web-server/http
|
||||
racket/runtime-path
|
||||
web-server/templates
|
||||
web-server/servlet-env)
|
||||
|
||||
(framing-mode 'old)
|
||||
|
||||
(define stop-ws!
|
||||
(ws-serve (λ (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))
|
||||
#:port 8080))
|
||||
|
||||
(define-runtime-path example-pth ".")
|
||||
|
||||
(serve/servlet (λ (req)
|
||||
(response/full
|
||||
200 #"Okay"
|
||||
(current-seconds) TEXT/HTML-MIME-TYPE
|
||||
empty
|
||||
(list (string->bytes/utf-8 (include-template "index.html")))))
|
||||
#:servlet-path "/"
|
||||
#:port 8081
|
||||
#:extra-files-paths (list example-pth))
|
||||
25
collects/tests/net/websocket/index.html
Normal file
25
collects/tests/net/websocket/index.html
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
|
||||
<html xmlns="http://www.w3.org/1999/xhtml">
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/>
|
||||
<title>Websocket Test</title>
|
||||
<link rel="stylesheet" href="style.css" type="text/css"/>
|
||||
<script src="http://ajax.googleapis.com/ajax/libs/jquery/1.4.1/jquery.min.js"></script>
|
||||
<script src="script.js"></script>
|
||||
</head>
|
||||
<body>
|
||||
<div id="body">
|
||||
<div id="inbox">
|
||||
</div>
|
||||
<div id="input">
|
||||
<form action="#" method="post" id="commandForm" onSubmit="return newCommand()">
|
||||
<fieldset>
|
||||
<legend>Command</legend>
|
||||
<input id="commandInput" type="text" style="width:500px" />
|
||||
<input id="submit" type="submit" value="Send" />
|
||||
</fieldset>
|
||||
</form>
|
||||
</div>
|
||||
</div>
|
||||
</body>
|
||||
</html>
|
||||
72
collects/tests/net/websocket/script.js
Normal file
72
collects/tests/net/websocket/script.js
Normal file
|
|
@ -0,0 +1,72 @@
|
|||
var ws;
|
||||
|
||||
$(document).ready(function() {
|
||||
if (!window.console) window.console = {};
|
||||
if (!window.console.log) window.console.log = function() {};
|
||||
|
||||
ws = new WebSocket("ws://localhost:8080/");
|
||||
|
||||
ws.onopen = function() {
|
||||
console.log("websocket connected");
|
||||
ws.onmessage = function(event) {
|
||||
showCommand(eval("\"" + event.data + "\""));
|
||||
};
|
||||
|
||||
$(window).bind('beforeunload', function() {
|
||||
ws.close();
|
||||
});
|
||||
};
|
||||
|
||||
ws.onclose = function() {
|
||||
console.log("websocket disconnected");
|
||||
};
|
||||
|
||||
$("#commandForm").bind("submit", function(e) {
|
||||
e.preventDefault();
|
||||
e.stopPropagation();
|
||||
|
||||
newCommand($(this));
|
||||
return false;
|
||||
});
|
||||
|
||||
$("#commandForm").bind("keypress", function(e) {
|
||||
if (e.keyCode == 13) {
|
||||
e.preventDefault();
|
||||
e.stopPropagation();
|
||||
|
||||
newCommand($(this));
|
||||
}
|
||||
});
|
||||
|
||||
$("#commandInput").select();
|
||||
});
|
||||
|
||||
function newCommand(form) {
|
||||
var submit = form.find("#commandSubmit");
|
||||
var text = form.find("#commandInput");
|
||||
submit.disable();
|
||||
ws.send(text.val());
|
||||
text.val("").select();
|
||||
submit.enable();
|
||||
}
|
||||
|
||||
function showCommand(message) {
|
||||
var node = $("<p>" + message + "</p>");
|
||||
node.hide();
|
||||
$("#inbox").append(node);
|
||||
node.show();
|
||||
}
|
||||
|
||||
jQuery.fn.enable = function(opt_enable) {
|
||||
if (arguments.length && !opt_enable) {
|
||||
this.attr("disabled", "disabled");
|
||||
} else {
|
||||
this.removeAttr("disabled");
|
||||
}
|
||||
return this;
|
||||
};
|
||||
|
||||
jQuery.fn.disable = function() {
|
||||
this.enable(false);
|
||||
return this;
|
||||
};
|
||||
48
collects/tests/net/websocket/style.css
Normal file
48
collects/tests/net/websocket/style.css
Normal file
|
|
@ -0,0 +1,48 @@
|
|||
body {
|
||||
background: white;
|
||||
margin: 10px;
|
||||
}
|
||||
|
||||
body,
|
||||
input {
|
||||
font-family: sans-serif;
|
||||
font-size: 10pt;
|
||||
color: black;
|
||||
}
|
||||
|
||||
table {
|
||||
border-collapse: collapse;
|
||||
border: 0;
|
||||
}
|
||||
|
||||
td {
|
||||
border: 0;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
#body {
|
||||
position: absolute;
|
||||
bottom: 10px;
|
||||
left: 10px;
|
||||
}
|
||||
|
||||
#input {
|
||||
margin-top: 0.5em;
|
||||
}
|
||||
|
||||
#inbox div {
|
||||
padding-top: 0.25em;
|
||||
}
|
||||
|
||||
#nav {
|
||||
float: right;
|
||||
z-index: 99;
|
||||
}
|
||||
|
||||
legend {
|
||||
display: none;
|
||||
}
|
||||
|
||||
fieldset {
|
||||
border: none;
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user