source: project/release/5/tcp-server/trunk/tcp-server.scm.orig @ 37611

Last change on this file since 37611 was 37611, checked in by felix winkelmann, 5 months ago

added tcp-server for C5, thanks to Mark Hudnall for porting

File size: 3.9 KB
Line 
1;;;; tcpserver.scm
2;
3; Copyright (c) 2000-2008, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25
26
27(declare (fixnum))
28
29
30(module tcp-server (tcp-server-prepare-hard-close-procedure
31                    tcp-server-accept-connection-procedure
32                    tcp-server-get-addresses-procedure
33                    make-tcp-server)
34
35  (import scheme chicken)
36  (use extras tcp srfi-18)
37
38;;; Constants:
39
40(define-constant default-request-count-limit 10000)
41
42;;; Parameters:
43
44(define tcp-server-prepare-hard-close-procedure
45  (make-parameter tcp-abandon-port))
46(define tcp-server-accept-connection-procedure
47  (make-parameter tcp-accept))
48(define tcp-server-get-addresses-procedure
49  (make-parameter tcp-addresses))
50
51;;; Main loop:
52
53(define (make-tcp-server listener thunk . maxc)
54  (let ([max-requests (optional maxc default-request-count-limit)]
55        [current-number-of-threads 0]
56        [verbose #f] )
57    (define (dribble fstr . args)
58      (when verbose
59        (fprintf (current-error-port) "[~A] ~?~%~!" (if (string? verbose) verbose "tcp-server") fstr args) ) )
60    (define (close-connection in out)
61      (dribble "closing connection...")
62      (close-output-port out)
63      (close-input-port in) )
64    (define (hard-close in out)
65      ((tcp-server-prepare-hard-close-procedure) in)
66      ((tcp-server-prepare-hard-close-procedure) out)
67      (close-input-port in)
68      (close-output-port out) )
69    (define (thread-fork thunk)
70      (set! current-number-of-threads (add1 current-number-of-threads))
71      (thread-start! (make-thread thunk))
72      (set! current-number-of-threads (sub1 current-number-of-threads)) )
73    (define (dispatch-request in out)
74      (handle-exceptions ex
75          (begin
76            (hard-close in out)
77            (signal ex) )
78        (current-input-port in)
79        (current-output-port out)
80        (thunk)
81        (close-connection in out) ) )
82    (lambda dbg
83      (set! verbose (optional dbg #f))
84      (dribble "waiting for requests...")
85      (let ([count 0])
86        (define (serve)
87          (let-values ([(in out)
88                        ((tcp-server-accept-connection-procedure) listener)])
89            (thread-fork
90             (lambda ()
91               (let ([id (thread-name (current-thread))])
92                 (when verbose
93                   (let-values ([(_ you)
94                                 ((tcp-server-get-addresses-procedure) in)])
95                     (dribble "request ~A from ~A; ~A (of ~A) started..." count you id current-number-of-threads) ) )
96                 (let ([k (dispatch-request in out)])
97                   (set! count (add1 count))
98                   (dribble "~A finished." id) ) ) ) ) ) )
99        (let loop ()
100          (if (< current-number-of-threads max-requests)
101              (serve)
102              (thread-yield!) )
103          (loop) ) ) ) ) )
104
105)
Note: See TracBrowser for help on using the repository browser.