minimart-benchmark-2017/echo-server.rkt

86 lines
2.6 KiB
Racket

#lang racket/base
(require racket/match)
(require racket/tcp)
(require racket/port)
(require minimart)
(require minimart/drivers/timer)
(require logbook)
(require racket/cmdline)
(define server-entry-name #f)
(define server-entry-type #f)
(command-line #:program "echo-server.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 'echo-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)
(define (statistician)
(list (spawn (lambda (e s)
(match e
[(message (timer-expired 'statistician now) _ _)
;; (collect-garbage)
;; (collect-garbage)
;; (collect-garbage)
(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))
(exit 0))
(transition s
(send (set-timer 'statistician statistics-poll-interval 'relative)))]
[_ #f]))
#f
(sub (timer-expired 'statistician ?)))
(send (set-timer 'statistician statistics-poll-interval 'relative))))
(define (listener port-number)
(spawn (lambda (e s)
(match e
[(message (event _ (list (list in out))) _ _)
(transition s (connection in out))]
[_ #f]))
#f
(sub (event (tcp-accept-evt (tcp-listen port-number 128 #t)) ?)
#:meta-level 1)))
(define (connection in out)
(set! connection-count (+ connection-count 1))
(set! first-connection-seen? #t)
(spawn (lambda (e s)
(match e
[(message (event _ (list (? eof-object?))) _ _)
(close-input-port in)
(close-output-port out)
(set! connection-count (- connection-count 1))
(transition s (quit))]
[(message (event _ (list line)) _ _)
(fprintf out "~a\n" line)
(flush-output out)
(transition s '())]
[_ #f]))
#f
(sub (event (read-line-evt in 'any) ?)
#:meta-level 1)))
(run-ground (listener 5999)
(spawn-timer-driver)
(statistician))