41 lines
1.5 KiB
Scheme
41 lines
1.5 KiB
Scheme
(module web-hammer mzscheme
|
|
(require net/url)
|
|
(provide server-performance)
|
|
(provide (all-from net/url))
|
|
|
|
(define BUFFER-SIZE 8192)
|
|
|
|
;; server-performance : Url Nat Nat Nat -> Num
|
|
;; num-clients client threads request the url from the server repeatedly
|
|
;; think-time-msecs appart for duration-seconds
|
|
;; the performance is completed requests per second
|
|
(define (server-performance url num-clients think-time-msec duration-seconds)
|
|
(let ([cust (make-custodian)]
|
|
[think-time-seconds (/ think-time-msec 1000)]
|
|
[responses (make-vector num-clients 0)]
|
|
[start (current-milliseconds)])
|
|
(parameterize ([current-custodian cust])
|
|
(let loop ([n num-clients])
|
|
(let ([n-1 (sub1 n)])
|
|
(unless (zero? n)
|
|
(thread
|
|
(lambda ()
|
|
(let request ()
|
|
(with-handlers ([exn:fail? void])
|
|
(parameterize ([current-custodian (make-custodian)])
|
|
(let ([port (get-pure-port url)])
|
|
(let discard-all ()
|
|
(let ([s (read-string BUFFER-SIZE port)])
|
|
(unless (eof-object? s)
|
|
(discard-all)))))
|
|
(custodian-shutdown-all (current-custodian)))
|
|
; vector-set! is inside ignore errors so it doesn't happen for unfulfilled requests
|
|
(vector-set! responses n-1 (add1 (vector-ref responses n-1))))
|
|
(sleep think-time-seconds)
|
|
(request))))
|
|
(loop n-1)))))
|
|
(sleep duration-seconds)
|
|
(custodian-shutdown-all cust)
|
|
(let ([stop (current-milliseconds)])
|
|
(* 1000 (/ (apply + (vector->list responses)) (- stop start)))))))
|