#lang racket/base
(require web-server/servlet-env
         web-server/dispatch
         web-server/http
         net/url
         net/url-connect
         racket/port
         db)

#|
This program tests the combination of virtual connections and
connection pools in the context of web servlets, where servlet threads
may be killed unexpectedly if the client hangs up.

Errors to watch for:
 - connection-pool-lease: cannot obtain connection; connection pool limit reached
   Might mean a connection has become locked. Or could be a race condition, pool
   connection not released in time. (Seen in 5.2.1, not near-5.3 versions.)
 - tcp-write: error writing (Broken pipe)
   Probably okay, seems to come from web-server trying to write response.
 - TIMEOUT (and programs exits)
   This would be bad; all connections are locked up. I haven't seen it happen.
|#

(define NOISY? #f)

(define c (virtual-connection
           (connection-pool
            (lambda () (dsn-connect 'pg))
            #:max-connections 12)))

(unless (table-exists? c "foo")
  (query-exec c "create table foo (n integer, s text)"))

(define (add req n s)
  (query-exec c "insert into foo (n, s) values ($1, $2)" n s)
  (response/xexpr
   `(html (body (p "Thanks, there are now "
                   ,(format "~a" (query-value c "select count(s) from foo where n = $1" n))
                   " values associated with " ,(number->string n) ".")))))

(define (ask req n)
  (response/xexpr
   `(html (body (p "These are the strings associated with "
                   ,(number->string n)
                   ":")
                (ol
                 ,@(for/list ([s (in-query c "select s from foo where n = $1" n)])
                     `(li ,(format "~a" s))))))))

(define (find req ss)
  (response/xexpr
   `(html (body (p "These are the numbers containing "
                   ,(format "~s" ss)
                   ":")
                (ol
                 ,@(for/list ([n (query-list c "select n from foo where strpos(s, $1) > 0 order by n" ss)])
                     `(li ,(format "~a" n))))))))

(define-values (dispatch to-url0)
  (dispatch-rules
   [("ask" (integer-arg)) ask]
   [("find" (string-arg)) find]
   [("add" (integer-arg) (string-arg)) add]))

(define (to-url . args)
  (string->url
   (string-append "http://localhost:10000" (apply to-url0 args))))

(thread
 (lambda ()
   (serve/servlet dispatch
                  #:port 10000
                  #:servlet-path "/ask/0"
                  #:servlet-regexp #rx"")))

(sleep 1)

(define (random-letter _)
  (integer->char (+ (char->integer #\a) (random 26))))

(define (get url)
  (let* ([c (make-custodian)]
         [fast? (zero? (random 5))]
         [t
          (parameterize ((current-custodian c))
            (thread
             (lambda ()
               (let* ([ts1 (current-milliseconds)]
                      [result (call/input-url url get-pure-port port->string)]
                      [ts2 (current-milliseconds)])
                 (when NOISY? (eprintf "~s ms\n" (inexact->exact (floor (- ts2 ts1)))))))))])
    (if fast?
        (or (sync/timeout (+ 0.005 (* 0.001 (random 5))) t)
            (begin (custodian-shutdown-all c)
                   (when NOISY? (eprintf "fast timeout\n"))))
        (or (sync/timeout 1 t)
            (begin (custodian-shutdown-all c)
                   (eprintf "TIMEOUT\n")
                   (exit 1))))))

(define workers
  (for/list ([t 10])
    (thread
     (lambda ()
       (for ([r 1000])
         (case (random 3)
           ((0) (get (to-url ask (random 10))))
           ((1) (get (to-url find (build-string 3 random-letter))))
           ((2) (get (to-url add (random 10) (build-string 40 random-letter))))))))))

(for-each thread-wait workers)
(eprintf "Whew, done.\n")
(sleep 5)
