Merged #857

racket-ws/bench/bench-ev.rkt

@@ -0,0 +1,40 @@
+#lang racket/base
+(module+ main
+  (require racket/tcp)
+
+  (define PORT 8000)
+
+  (define RESPONSE #"HTTP/1.1 200 OK\r\nContent-Length: 1\r\n\r\n!")
+  (define END (bytes-length RESPONSE))
+  (define BUFFER-SIZE 64)
+  (define BUFFER (make-bytes BUFFER-SIZE))
+  (define const-eof (λ (x) eof))
+
+  (define EVTS null)
+  (define l (tcp-listen PORT 10 #t #f))
+  (define (accept-f l)
+    (define from (car l))
+    (define to (cadr l))
+    (define (read-f from)
+      (define read-k
+        ;; XXX This drops performance from about 132k/s to 120k/s,
+        ;; but is necessary because of crashing the benchmarks
+        (with-handlers ([exn:fail? const-eof])
+          (read-bytes-avail!* BUFFER from 0 BUFFER-SIZE)))
+      (cond
+        [(eof-object? read-k)
+         (close-input-port from)
+         (close-output-port to)
+         (set! EVTS (remq e EVTS))]
+        [else
+         (write-bytes-avail* RESPONSE to 0 END)]))
+    (define e
+      (handle-evt from read-f))
+    (set! EVTS (cons e EVTS)))
+  (define accept-evt
+    (handle-evt (tcp-accept-evt l) accept-f))
+  (printf "Ready\n")
+  (flush-output)
+  (let loop ()
+    (apply sync accept-evt EVTS)
+    (loop)))

racket-ws/bench/bench-th.rkt

@@ -0,0 +1,35 @@
+#lang racket/base
+(module+ main
+  (require racket/tcp)
+
+  (define PORT 8000)
+
+  (define RESPONSE #"HTTP/1.1 200 OK\r\nContent-Length: 1\r\n\r\n!")
+  (define END (bytes-length RESPONSE))
+  (define BUFFER-SIZE 64)
+  (define BUFFER (make-bytes BUFFER-SIZE))
+  (define const-eof (λ (x) eof))
+
+  (define l (tcp-listen PORT 10 #t #f))
+
+  (printf "Ready\n")
+  (flush-output)
+
+  (let accept-loop ()
+    (define-values (from to) (tcp-accept l))
+    (thread
+     (λ ()
+       (let conn-loop ()
+         (define read-k
+           ;; XXX This drops performance from about 132k/s to 120k/s,
+           ;; but is necessary because of crashing the benchmarks
+           (with-handlers ([exn:fail? const-eof])
+             (read-bytes-avail! BUFFER from 0 BUFFER-SIZE)))
+         (cond
+           [(eof-object? read-k)
+            (close-input-port from)
+            (close-output-port to)]
+           [else
+            (write-bytes-avail RESPONSE to 0 END)
+            (conn-loop)]))))
+    (accept-loop)))

racket-ws/bench/bench-thf.rkt

@@ -0,0 +1,35 @@
+#lang racket/base
+(module+ main
+  (require racket/tcp)
+
+  (define PORT 8000)
+
+  (define RESPONSE #"HTTP/1.1 200 OK\r\nContent-Length: 1\r\n\r\n!")
+  (define END (bytes-length RESPONSE))
+  (define BUFFER-SIZE 64)
+  (define BUFFER (make-bytes BUFFER-SIZE))
+  (define const-eof (λ (x) eof))
+
+  (define l (tcp-listen PORT 10 #t #f))
+
+  (printf "Ready\n")
+  (flush-output)
+
+  (let accept-loop ()
+    (define-values (from to) (tcp-accept l))
+    (thread
+     (λ ()
+       (let conn-loop ()
+         (define read-k
+           ;; XXX This drops performance from about 132k/s to 120k/s,
+           ;; but is necessary because of crashing the benchmarks
+           (with-handlers ([exn:fail? const-eof])
+             (read-bytes-avail!* BUFFER from 0 BUFFER-SIZE)))
+         (cond
+           [(eof-object? read-k)
+            (close-input-port from)
+            (close-output-port to)]
+           [else
+            (write-bytes-avail* RESPONSE to 0 END)
+            (conn-loop)]))))
+    (accept-loop)))

racket-ws/bench/bench.rkt

@@ -5,6 +5,8 @@
          json
          db)
 
+(define DEPLOY? (box #t))
+
 (define (response/json x)
   (response/output
    #:mime-type #"application/json"
@@ -17,23 +19,42 @@
 
 (define (go! db-host)
   (define c
-    (virtual-connection
-     (connection-pool
-      (λ ()
-        (mysql-connect #:user "benchmarkdbuser"
-                       #:password "benchmarkdbpass"
-                       #:database "hello_world"
-                       #:server db-host)))))
+    (cond
+      [(unbox DEPLOY?)
+       (virtual-connection
+        (connection-pool
+         (λ ()
+           (mysql-connect #:user "benchmarkdbuser"
+                          #:password "benchmarkdbpass"
+                          #:database "hello_world"
+                          #:server db-host))))]
+      [else
+       (define c (sqlite3-connect #:database 'memory))
+       (query-exec c "create table World ( id int, randomNumber int )")
+       (for ([i (in-range (add1 10000))])
+         (query-exec c "insert into World values ( $1, $1 )" i))
+       c]))
 
   (define (db-one)
-    (define random-id (add1 (random 10000)))
-    (query-list c "select * from World where randomNumber = $1" random-id))
+    (define id (add1 (random 10000)))
+    (define randomNumber
+      (query-value c "select randomNumber from World where id = ?" id))
+    (hash 'id id 'randomNumber randomNumber))
 
   (define (page/db req)
     (response/json
      (db-one)))
 
-  (define (page/dbs req i)
+  (define (clamp lo x hi)
+    (cond
+      [(x . < . lo) lo]
+      [(hi . < . x) hi]
+      [else          x]))
+
+  (define (page/dbs req is)
+    (define maybe-num (string->number is))
+    (define maybe-i (or maybe-num 0))
+    (define i (clamp 1 maybe-i 500))
     (response/json
      (for/list ([j (in-range i)])
        (db-one))))
@@ -44,7 +65,7 @@
       page/json]
      [("db")
       page/db]
-     [("dbs" (integer-arg))
+     [("dbs" (string-arg))
       page/dbs]))
 
   (serve/servlet
@@ -52,11 +73,15 @@
    #:port 8000
    #:listen-ip #f
    #:command-line? #t
+   #:banner? (not (unbox DEPLOY?))
    #:servlet-regexp #rx""
    #:servlet-path "/"))
 
 (module+ main
   (require racket/cmdline)
   (command-line #:program "bench"
+                #:once-each
+                ["--test" "Run in test mode"
+                 (set-box! DEPLOY? #f)]
                 #:args (db-host-s)
                 (go! db-host-s)))