[gambit-list] Strange Networking Bug on MinGW (LONG)

François Magnan francois.magnan at licef.ca
Fri Feb 8 16:51:05 EST 2008


Hi,

I worked hard to isolate one of my bugs and I found a rather  
disturbing minimal example that reproduces the bug. It can be observed  
in all the latests  versions of Gambit (including 4.2.1).

Basically, I start a minimal multithread web server and in another  
thread I start a loop that calls a serie of open-tcp-client to  
different ips in the local network. The default web browser is  
launched to get the page served by the web server.

On MacOSX Leopard everything is fine. On WindowsXP (MingW compiled  
version of Gambit) the page takes an unnaceptable loooong time to  
load. The website index.html must require multiple HTTP GET to render  
(a page with multiple pictures for example).

What is the most disturbing is that if I replace the calls to "read-u8- 
line" by simple "read-line", the bug disapears. The bug is therefore  
somehow related to "read-u8".

Here is the sample code. You have to define  "Server-ROOT" at the top  
so it points to a website on your local hard-drive.
I didn't try on Linux but to try it the code will have to be adapted a  
little bit (how to launch the default browser on Linux?).

What could lead to this huge difference between a sequence of read-u8  
and read-line on WinXP???

Thank you,
Francois Magnan


;;; Gambit Networking Test Example
;;;
;;; Minimal web server that gets incredibly slow on WinXP (MinGW) if  
it is run in parallel with another thread that does a network scan.
;;;
;;; If the "read-u8-line" calls are replaced by "read-line" the bug  
disapears.
;;;
;;; On MacOSX Leopard the bug is not present.
;;;
;;; Was tested with versions: Gambit-C 4.0.1, 4.1.2, 4.2.1
;;;


;;;
;;;; Server-ROOT
;;;


;;; *******************
;;; Put here the path to a static website with many files to load to  
render index.html
;;; *******************

;(define Server-ROOT "/Users/magnan/TELOS/interface/TELOS-Desktop")
(define Server-ROOT "C:/TELOS/interface/TELOS-Desktop")


;;;
;;;; main
;;;


(define (main)
   (start-server)
   (start-broadcast)
   (start-client)
)



;;;
;;;; Minimal Web Server
;;;


(define (start-server)
   (let ((rpc-command-queue (open-tcp-server
                             (list port-number: 8000))))
     (thread-start!
      (make-thread
       (lambda ()
	(let loop ()
	  (let ((incoming-connection (read rpc-command-queue)))
	    (force-output)
	    (serve-connection incoming-connection))
	  (loop)))))))


(define (serve-connection incoming-connection)
   (thread-start!
    (make-thread
     (lambda ()
       (let* ((line (read-u8-line incoming-connection))
	     (splitted (split-string line #\space))
	     (path     (cadr splitted)))
	(read-all-headers incoming-connection)
	(force-output)
	(with-exception-catcher
	 (lambda (e)
	   (##display-exception e (current-output-port)))
	 (lambda ()
	   (serve-file path incoming-connection))))))))


(define (read-all-headers incoming-connection)
   (let ((line (read-u8-line incoming-connection)))
     (pp (list "read header line" line))
     (force-output)
     (if (not (equal? line ""))
	(read-all-headers incoming-connection))))
	


(define (split-string str sep-char)
   (call-with-input-string
    str
    (lambda (p) (read-fields p sep-char #f))))


(define (read-fields port sep inc-sep?)
   (read-all port
             (lambda (p)
               (read-line p sep inc-sep?))))


(define (serve-file path incoming-connection)
   (let* ((complete-path (string-append Server-ROOT path))
	 (fileInfo (file-info complete-path))
	 (size     (file-info-size fileInfo))
	 (mimetype (compute-mimetype complete-path))
	 (header   (compute-get-result-header size mimetype)))
     (display header incoming-connection)
     (output-file-data complete-path incoming-connection)
     (close-port incoming-connection)))


(define (compute-get-result-header size mimetype)
   (string-append "HTTP/1.0 200 OK\r\n"
                  "Content-type: " mimetype "\r\n"
                  "Content-length: " (number->string size) "\r\n"
                  "\r\n"))


(define (output-file-data filePath connection)
   (with-input-from-file filePath
     (lambda ()
       (letrec ((output-file-data-rec (lambda ()
				       (let ((rc (read-char)))
					 (if (not (equal? rc #!eof))
					     (begin
					       (write-char rc connection)
					       (output-file-data-rec)))))))
	(output-file-data-rec)))))


(define (compute-mimetype filePath)
   (let* ((ext  (path-extension filePath))
         (rext (and (string? ext) (substring ext 1 (string-length  
ext)))))
     (case (string->symbol rext)
       ((jpg jpeg JPG JPEG)
        "image/jpeg")
       ((gif GIF)
        "image/gif")
       ((png PNG)
        "image/png")
       ((html HTML htm HTM)
        "text/html")
       ((js JS)
        "text/javascript")
       ((css CSS)
        "text/css")
       (else
        "application/octet-stream"
        ))))


;;;
;;;; start-broadcast
;;;


(define (start-broadcast)
   (thread-start!
    (make-thread
     (lambda ()
       (let* ((hostname     (host-name))
	     (hi           (host-info hostname))
	     (host-ips  (host-info-addresses hi))
	     (host-ip      (car host-ips)))
	(letrec ((network-broadcast (lambda (i)
				      (if (= i 255)
					  #t
					  (begin
					    (u8vector-set! host-ip 3 i)
					    (call-addr host-ip)
					    (thread-sleep! 0.2)
					    (network-broadcast (+ i 1)))))))
	  (network-broadcast 1)))))))
	

(define (call-addr target-addr)
   (pp (list "trying to reach" target-addr))
   (with-exception-catcher
	 (lambda (e)
	   #f)
	 (lambda ()
	   (let ((port (open-tcp-client (list server-address: target-addr
					      port-number: 5000))))
	     (with-exception-catcher
	      (lambda (e)
		#f)
	      (lambda ()
		(input-port-timeout-set! port 0.1)
		(output-port-timeout-set! port 0.1)		
		(write (list 1 2 3) port)))
	     (close-port port)))))


;;;
;;;; Client
;;;


(define (start-client)
   (if (equal? (get-host-os) "WinXP")
       (shell-command "start http://localhost:8000/index.html")
       (shell-command "open \"http://localhost:8000/index.html\"")))


(define (get-host-os)
   (with-exception-handler
    (lambda (e)
      "WinXP")
    (lambda ()
      (let* ((p (open-process '(path: "/usr/bin/uname"
                                      arguments: ("-s"))))
             (r (read-line p)))
        (close-port p)
        r))))


;;;
;;;; read-u8-line
;;;


(define (read-u8-line port)
   (letrec ((read-loop (lambda (acc)
                         (let ((b (read-u8 port)))
                           (if (or (equal? b 13) (equal? b 10) (equal?  
b #!eof))
                               (begin
				(read-u8 port)
                                 acc)
                               (read-loop (string-append acc (list- 
 >string (list (integer->char b))))))))))
     (read-loop "")))






;;;
;;;; start main
;;;


(main)


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mailman.iro.umontreal.ca/pipermail/gambit-list/attachments/20080208/be2512d8/attachment.htm>


More information about the Gambit-list mailing list