Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
Problem trying to do non-blocking I/O and reactor loop
#lang racket
;; 1. Run this:
;; racket bug-example.rkt
;; 2. Run ApacheBench:
;; $ ab -n 1000 -c 20 http://localhost:8081/
;; See the comments near the end of this file for a description of 3
;; problems.
;; Environment:
;; 1. Mac OS X Lion 10.7.4
;; 2. ApacheBench Version 2.3 <$Revision: 117807 (patched to work on
;; OS X Lion using Homebrew formula as described here:
;; <>
;; 3. Racket 5.2.1. (Same result with 5.2, which I tried on the off
;; chance that the select => epoll/kqueue change in 5.2.1 was relevant
;; -- but seems not.)
(define main-thread (current-thread))
(define h (make-hasheq)) ;exact-integer? -> evt?
(define next-id 0)
(define (events-to-sync)
;; (-> (listof evt?))
(hash-values h))
(struct sync-result
(id ;hash key in `h'
v ;`sync' result value; varies by event type
k)) ;the handler procedure, (any/c -> any), called with `v'
;; Add an event and a handler (a function to be called when the event
;; is ready). Return an id, which is an opaque value that can be used
;; with `remove-handler!'. THIS IS NOT THREAD-SAFE: See
;; call-from-main-thread instead.
(define (add-handler! e k)
;; (evt? (any/c . -> . any) . -> . any/c)
(unless (equal? (current-thread) main-thread)
(log-error "add-handler! NOT called from main-thread"))
(define id next-id)
;;(log-debug (format "add-handler! id=~a" id))
(set! next-id (add1 next-id))
(hash-set! h
(wrap-evt e
(lambda (v) (sync-result id v k))))
(define (remove-handler! id)
;; (any/c . -> . void)
(void (unless (equal? id thread-mailbox-handler-id)
;;(log-debug (format "remove-handler! id=~a" id))
(hash-remove! h id))))
;; Functions that don't offer non-blocking (for example `tcp-connect')
;; must be run using a worker thread. When the worker thread has a
;; result, it could cause the handler procedure to be called soon by
;; doing (add-handler! always-evt f). However, add-handler! is NOT
;; thread-safe. Instead, the worker thread uses
;; `call-from-main-thread' to ask the main thread to call
;; `add-handler!'. How `call-main-thread' does this is using
;; `thread-send'.
(define thread-mailbox-handler-id #f)
(define (maybe-add-thread-mailbox-evt!)
(unless thread-mailbox-handler-id ;need to init?
(define (thread-mailbox-event-handler _)
(displayln "thread mailbox handler called")
(add-handler! always-evt (thread-receive)))
(set! thread-mailbox-handler-id
(add-handler! (thread-receive-evt) thread-mailbox-event-handler))))
;; Although provided for use in a worker thread, also safe to call
;; from the main thread.
(define/contract (call-from-main-thread f)
((any/c . -> . any) . -> . void)
(thread-send main-thread f)
;; the reactor loop
;; Note: This will run forever now that we have a thread mailbox
;; handler that we never remove, so events-to-sync will never
;; be the empty list.
(define (reactor-loop)
(maybe-add-thread-mailbox-evt!) ;initialize
(define es (events-to-sync))
(unless (empty? es)
;; (match-define (sync-result id v k) (apply sync es))
;; (k v)
;; (remove-handler! id)
(define e (apply sync es))
[(sync-result? e)
((sync-result-k e) (sync-result-v e))
(remove-handler! (sync-result-id e))]
(log-warning "reactor-loop: unknown event type from apply")])
(define/contract (read-bytes-avail!/non-block b in k)
((and/c bytes? (not/c immutable?))
((or/c eof-object? exact-nonnegative-integer?) . -> . any)
. -> . void)
(add-handler! (read-bytes-avail!-evt b in) k)
(define/contract (write-string/non-block s out k)
(string? output-port? (exact-nonnegative-integer? . -> . any) . -> . void)
(void (add-handler! (write-bytes-avail-evt (string->bytes/utf-8 s) out) k)))
(define/contract (tcp-accept/non-block listener k)
(tcp-listener? (input-port? output-port? . -> . any) . -> . void)
(void (add-handler! listener (lambda (listener)
(define-values (i o) (tcp-accept listener))
(k i o)))))
(define/contract (tcp-serve/non-block k
#:port [port 80]
#:hostname [hostname #f]
#:reuse-port? [reuse-port? #f]
#:limit-memory/MB [limit-memory/MB 50]
#:max-wait [max-wait 40]
#:connection-timeout-secs [timeout 60])
(((input-port? output-port? (-> any) . -> . any))
(#:port exact-nonnegative-integer?
#:hostname (or/c #f string?)
#:reuse-port? boolean?
#:limit-memory/MB exact-positive-integer?
#:max-wait exact-positive-integer?
#:connection-timeout-secs exact-positive-integer?)
. ->* .
(let ([listener (tcp-listen port max-wait reuse-port? hostname)])
(with-handlers ([exn? fail-handler])
(displayln (format "serve: port=~a hostname=~a timeout=~a"
port hostname timeout))
(define (accept)
(tcp-accept/non-block listener
(lambda (in out)
(lambda (_)
;; (file-stream-buffer-mode in 'none)
;; (file-stream-buffer-mode out 'none)
(with-handlers ([exn? fail-handler])
(k in
(lambda ()
(close-input-port in)
(close-output-port out)
(log-info "closing tcp listener")
(tcp-close listener))
(define (fail-handler exn)
(log-error (exn->string exn #t)))
(define (exn->string exn stack-trace?)
;; (exn? boolean? . -> . string?)
(define (stack-trace-string exn)
(format "~a"
(map (lambda (x)
(format "'~a' ~a ~a\n"
(if (car x) (car x) "")
(if (cdr x) (srcloc-source (cdr x)) "")
(if (cdr x) (srcloc-line (cdr x)) "")))
(exn-continuation-marks exn)))))
(format "Thread will exit due to exception: \"~a\"~a"
(exn-message exn)
(if stack-trace?
(string-append "\nStack:\n" (stack-trace-string exn))
#:port 8081
#:reuse-port? #f
#:max-wait 20
(lambda (in out k)
(define (read-request) ;read until first double EOL
(define cum #"")
(define b (make-bytes 1024 0))
(define (read-more!)
b in (lambda (e)
;; PROBLEM 1: Very often (many, many time) there will
;; be an error, "peek-bytes-avail!: input port is
;; closed".
;; I also tried using regexp-match-evt but got a simlar
;; error re the input port being closed.
;; PROBLEM 2: Sometimes (very rarely, with `ab -c 20' this
;; will be a channel? instead of the documented
;; eof-object? or integer?
;; PROBLEM 3: Even more rarely, racket will abend with
;; "Process scheme segmentation fault: 11".
[(eof-object? e)
(write-response cum)]
(set! cum (bytes-append cum (subbytes b 0 e)))
[(regexp-match? #rx"(?:\r\n\r\n|\n\n|\r\r)$" cum)
(write-response cum)]
[else (read-more!)])]))))
(define (write-response req)
;;(log-debug (format "write-response. req=~a" req))
(write-string/non-block (string-append "HTTP/1.0 200 OK\r\n"
"Connection: close\r\n"
(lambda (_) (k))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment