plain-racket-server-semi-threaded.rkt
This commit is contained in:
parent
dcd9368c67
commit
070bea7c8e
|
@ -35,6 +35,7 @@
|
|||
(set! server-variation 'syndicate-js)]
|
||||
["--racket" "use threaded racket server" (set! server-variation 'racket)]
|
||||
["--racket-evt" "use evented racket server" (set! server-variation 'racket-evt)]
|
||||
["--racket-semi-threaded" "use semi-threaded racket server" (set! server-variation 'racket-semi-threaded)]
|
||||
["--other" name "use other server" (set! server-variation name)])
|
||||
|
||||
(when (not server-variation)
|
||||
|
@ -74,6 +75,7 @@
|
|||
['imperative-syndicate+tcp (format-racket-server-command-line "echo-server-imperative-syndicate-tcp-driver.rkt")]
|
||||
['racket (format-racket-server-command-line "plain-racket-server.rkt")]
|
||||
['racket-evt (format-racket-server-command-line "plain-racket-server-evt.rkt")]
|
||||
['racket-semi-threaded (format-racket-server-command-line "plain-racket-server-semi-threaded.rkt")]
|
||||
['erlang
|
||||
(define erlang-version-command
|
||||
"erl -noshell -eval 'io:format(erlang:system_info(otp_release)), halt().'")
|
||||
|
|
|
@ -0,0 +1,74 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/match)
|
||||
(require racket/tcp)
|
||||
(require racket/port)
|
||||
(require logbook)
|
||||
(require racket/cmdline)
|
||||
|
||||
(define server-entry-name #f)
|
||||
(define server-entry-type #f)
|
||||
|
||||
(command-line #:program "plain-racket-server-semi-threaded.rkt"
|
||||
#:once-each
|
||||
["--logbook-entry-name" name
|
||||
"set logbook entry name to use when recording run statistics"
|
||||
(set! server-entry-name name)]
|
||||
["--logbook-entry-type" type
|
||||
"set logbook entry type to use"
|
||||
(set! server-entry-type type)])
|
||||
|
||||
(when (not server-entry-type)
|
||||
(error 'plain-racket-server "Please supply the --logbook-entry-type command-line argument."))
|
||||
|
||||
(define L (default-logbook))
|
||||
(define E (logbook-entry L "minimart" server-entry-name server-entry-type))
|
||||
(define Tmem (logbook-table E "server-memory-use" #:column-spec '(time-seconds memory-use)))
|
||||
(define Tconn (logbook-table E "server-connections" #:column-spec '(time-seconds connection-count)))
|
||||
|
||||
(define connection-count 0)
|
||||
(define first-connection-seen? #f)
|
||||
|
||||
(define statistics-poll-interval 2000)
|
||||
|
||||
(void (thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(sleep (/ statistics-poll-interval 1000.0))
|
||||
(printf "~a connections\n" connection-count)
|
||||
(flush-output)
|
||||
(define now (current-inexact-milliseconds))
|
||||
(write-logbook-datum! Tmem (list (/ now 1000.0) (current-memory-use)))
|
||||
(write-logbook-datum! Tconn (list (/ now 1000.0) connection-count))
|
||||
(when (and first-connection-seen? (zero? connection-count))
|
||||
(close-logbook L)
|
||||
(exit 0))
|
||||
(loop)))))
|
||||
|
||||
(define (connection in out)
|
||||
(set! connection-count (+ connection-count 1))
|
||||
(set! first-connection-seen? #t)
|
||||
(thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(sync (handle-evt (read-line-evt in 'any)
|
||||
(match-lambda
|
||||
[(? eof-object?)
|
||||
(close-input-port in)
|
||||
(close-output-port out)
|
||||
(set! connection-count (- connection-count 1))]
|
||||
[line
|
||||
(fprintf out "~a\n" line)
|
||||
(flush-output out)
|
||||
(loop)])))))))
|
||||
|
||||
(define (listener port-number)
|
||||
(define s (tcp-listen port-number 128 #t))
|
||||
(let loop ()
|
||||
(sync (handle-evt (tcp-accept-evt s)
|
||||
(lambda (item)
|
||||
(match-define (list in out) item)
|
||||
(connection in out)
|
||||
(loop))))))
|
||||
|
||||
(listener 5999)
|
Loading…
Reference in New Issue