PR1411 Jays observations re thread-server
This commit is contained in:
Tim Brown
parent
29997da340
commit
9da549ea87
|
|
@ -1,30 +1,35 @@
|
|||
#lang racket/base
|
||||
; An echo server -- ripped off the racket homepage
|
||||
(provide server current-listen-port)
|
||||
(provide server current-listen-port current-conn-timeout)
|
||||
|
||||
(require racket/port "generic-server.rkt")
|
||||
|
||||
(define (server)
|
||||
;; Although this is ≡ (serve copy-port), I’m explicit about i and o
|
||||
;; to illustrate the calling convention for serve
|
||||
(serve (lambda (i o) (copy-port i o))))
|
||||
|
||||
(module+
|
||||
main
|
||||
(define-values (server-thread shutdown-server) (server))
|
||||
(thread-wait server-thread))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ () (thread-wait server-thread))
|
||||
shutdown-server))
|
||||
|
||||
(module+
|
||||
test
|
||||
(require rackunit racket/tcp)
|
||||
(define-values (server-thread shutdown-server) (server))
|
||||
|
||||
(define-values (cl:from cl:to)
|
||||
(tcp-connect "localhost" (current-listen-port)))
|
||||
(file-stream-buffer-mode cl:to 'none)
|
||||
(file-stream-buffer-mode cl:from 'none)
|
||||
(fprintf cl:to "Monkeys!")
|
||||
(flush-output cl:to)
|
||||
(close-output-port cl:to)
|
||||
(check-equal? (read-string 1024 cl:from) "Monkeys!")
|
||||
(tcp-abandon-port cl:from)
|
||||
(sleep 5)
|
||||
(shutdown-server))
|
||||
test
|
||||
(require rackunit racket/tcp)
|
||||
(define-values (server-thread shutdown-server) (server))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(define-values (cl:from cl:to)
|
||||
(tcp-connect "localhost" (current-listen-port)))
|
||||
(file-stream-buffer-mode cl:to 'none)
|
||||
(file-stream-buffer-mode cl:from 'none)
|
||||
(fprintf cl:to "Monkeys!")
|
||||
(flush-output cl:to)
|
||||
(close-output-port cl:to)
|
||||
(check-equal? (read-string 1024 cl:from) "Monkeys!")
|
||||
(tcp-abandon-port cl:from))
|
||||
shutdown-server))
|
||||
|
|
@ -1,38 +1,35 @@
|
|||
#lang racket/base
|
||||
;; with thanks to "More: Systems Programming with Racket"
|
||||
(provide serve current-listen-port)
|
||||
(provide serve
|
||||
current-listen-port
|
||||
current-conn-timeout)
|
||||
|
||||
(require racket/tcp)
|
||||
(require mzlib/thread
|
||||
racket/tcp)
|
||||
|
||||
(define current-listen-port (make-parameter 12345))
|
||||
|
||||
(define (accept-and-handle listener handler)
|
||||
(define cust (make-custodian))
|
||||
(define handler-thread
|
||||
(parameterize ([current-custodian cust])
|
||||
(define-values (in out) (tcp-accept listener))
|
||||
(file-stream-buffer-mode in 'none)
|
||||
(file-stream-buffer-mode out 'none)
|
||||
(thread (lambda ()
|
||||
(handler in out)
|
||||
(close-output-port out)
|
||||
(close-input-port in)))))
|
||||
(thread (lambda ()
|
||||
(thread-wait handler-thread)
|
||||
(custodian-shutdown-all cust))))
|
||||
(define current-conn-timeout (make-parameter #f))
|
||||
|
||||
(define (serve handler)
|
||||
(define serving-sem (make-semaphore))
|
||||
(define main-cust (make-custodian))
|
||||
(define server-thread
|
||||
(parameterize ([current-custodian main-cust])
|
||||
(define listener (tcp-listen (current-listen-port) 5 #t))
|
||||
(semaphore-post serving-sem) ; listening... so caller is ready to continue
|
||||
(define (loop)
|
||||
(accept-and-handle listener handler)
|
||||
(loop))
|
||||
(thread loop)))
|
||||
(values server-thread (lambda () (custodian-shutdown-all main-cust))))
|
||||
(define (serve conn-proc)
|
||||
;; use of semaphore `s` allows us to wait until the server is listening before continuing
|
||||
;; -- needed for test suites that “just want to get on with it”
|
||||
(define s (make-semaphore 0))
|
||||
(define t (thread
|
||||
(λ ()
|
||||
(run-server (current-listen-port)
|
||||
conn-proc
|
||||
(current-conn-timeout)
|
||||
void ; handler
|
||||
(λ (port-no
|
||||
(max-allow-wait 4)
|
||||
(reuse? #f)
|
||||
(hostname #f))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ () (tcp-listen port-no max-allow-wait reuse? hostname))
|
||||
(λ () (semaphore-post s))))))))
|
||||
(semaphore-wait s)
|
||||
(values t (λ () (kill-thread t))))
|
||||
|
||||
;; tested via the echo-server (in this directory)
|
||||
;; (module+ test)
|
||||
|
|
|
|||
|
|
@ -1,49 +1,49 @@
|
|||
#lang racket/base
|
||||
; It may look like an HTTPS server, but it very isn’t
|
||||
(provide server current-listen-port)
|
||||
(provide server
|
||||
current-listen-port
|
||||
current-conn-timeout)
|
||||
|
||||
(require racket/match
|
||||
racket/port
|
||||
openssl
|
||||
syntax/modresolve
|
||||
"generic-server.rkt")
|
||||
|
||||
(define (server)
|
||||
(serve
|
||||
(lambda (i o)
|
||||
(define ssl-srvr-ctx (ssl-make-server-context 'secure))
|
||||
(define test.pem-path (build-path
|
||||
(let-values (([base name mbd?]
|
||||
(split-path (resolve-module-path 'openssl)))) base)
|
||||
"test.pem"))
|
||||
(ssl-load-certificate-chain! ssl-srvr-ctx test.pem-path)
|
||||
(ssl-load-private-key! ssl-srvr-ctx test.pem-path)
|
||||
(define-values (s:i s:o)
|
||||
(ports->ssl-ports i o
|
||||
#:mode 'accept
|
||||
#:context ssl-srvr-ctx
|
||||
#:close-original? #t
|
||||
#:shutdown-on-close? #t
|
||||
))
|
||||
(define request-lines
|
||||
(for/list ((l (in-lines s:i 'return-linefeed)) #:break (string=? l "")) l))
|
||||
(define-syntax-rule (out/flush fmt args ...)
|
||||
(begin (fprintf s:o fmt args ...) (flush-output s:o)))
|
||||
(define (conn-proc i o)
|
||||
(define ssl-srvr-ctx (ssl-make-server-context 'secure))
|
||||
(define test.pem-path (build-path
|
||||
(let-values (([base name mbd?]
|
||||
(split-path (resolve-module-path 'openssl)))) base)
|
||||
"test.pem"))
|
||||
(ssl-load-certificate-chain! ssl-srvr-ctx test.pem-path)
|
||||
(ssl-load-private-key! ssl-srvr-ctx test.pem-path)
|
||||
(define-values (s:i s:o)
|
||||
(ports->ssl-ports i o
|
||||
#:mode 'accept
|
||||
#:context ssl-srvr-ctx
|
||||
#:close-original? #t
|
||||
#:shutdown-on-close? #t))
|
||||
(define request-lines
|
||||
(for/list ((l (in-lines s:i 'return-linefeed)) #:break (string=? l "")) l))
|
||||
(define-syntax-rule (out/flush fmt args ...)
|
||||
(begin (fprintf s:o fmt args ...) (flush-output s:o)))
|
||||
|
||||
(match request-lines
|
||||
[(cons (regexp #px"^(GET)\\s+(\\S+)(\\s+HTTP/\\S+)?$" (list _ method uri _)) _)
|
||||
(define content (format "~s (but at least it's secure)" uri))
|
||||
(out/flush
|
||||
"HTTP/1.1 200 OK\r\nContent-type: text/html\r\nContent-length: ~a\r\n\r\n~a"
|
||||
(string-length content) content)]
|
||||
[(cons (regexp #px"^(\\S+)\\s+(\\S+)(\\s+HTTP/\\S+)?$"
|
||||
(list request method request-uri http-version)) _)
|
||||
(out/flush "HTTP/1.1 405 Method Not Allowed\r\n\r\n")]
|
||||
[_ (out/flush "HTTP/1.1 400 Bad Request\r\n\r\n")]))))
|
||||
(match request-lines
|
||||
[(cons (regexp #px"^(GET)\\s+(\\S+)(\\s+HTTP/\\S+)?$" (list _ method uri _)) _)
|
||||
(define content (format "~s (but at least it's secure)" uri))
|
||||
(out/flush
|
||||
"HTTP/1.1 200 OK\r\nContent-type: text/html\r\nContent-length: ~a\r\n\r\n~a"
|
||||
(string-length content) content)]
|
||||
[(cons (regexp #px"^(\\S+)\\s+(\\S+)(\\s+HTTP/\\S+)?$"
|
||||
(list request method request-uri http-version)) _)
|
||||
(out/flush "HTTP/1.1 405 Method Not Allowed\r\n\r\n")]
|
||||
[_ (out/flush "HTTP/1.1 400 Bad Request\r\n\r\n")]))
|
||||
|
||||
(define (server) (serve conn-proc))
|
||||
|
||||
(module+
|
||||
main
|
||||
(define-values (server-thread shutdown-server) (server))
|
||||
(thread-wait server-thread))
|
||||
(dynamic-wind void (λ () (thread-wait server-thread)) shutdown-server))
|
||||
|
||||
(module+ test)
|
||||
|
|
|
|||
|
|
@ -3,9 +3,9 @@
|
|||
;; oozes security leaks and I wouldn’t be surprised if it leaked fids too.
|
||||
(require racket/port racket/match racket/tcp "generic-server.rkt")
|
||||
|
||||
(provide server current-listen-port)
|
||||
|
||||
(define serving-sem (make-semaphore))
|
||||
(provide server
|
||||
current-listen-port
|
||||
current-conn-timeout)
|
||||
|
||||
(define (http-tunnel-serve in out)
|
||||
(let/ec
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user