tcp.scm

Scheme跨平台编译器

(define tcp-connect-timeout)
(define tcp-accept-timeout)

(let ()
  (define ((check loc) x)
    (when x (##sys#check-exact x loc))
    x)
  (define minute (* 60 1000))
  (set! tcp-read-timeout (make-parameter minute (check 'tcp-read-timeout)))
  (set! tcp-write-timeout (make-parameter minute (check 'tcp-write-timeout))) 
  (set! tcp-connect-timeout (make-parameter #f (check 'tcp-connect-timeout))) 
  (set! tcp-accept-timeout (make-parameter #f (check 'tcp-accept-timeout))) )

(define ##net#io-ports
  (let ((make-input-port make-input-port)
	(make-output-port make-output-port) 
	(tbs tcp-buffer-size)
	(make-string make-string) )
    (lambda (fd)
      (unless (##net#make-nonblocking fd)
	(##sys#update-errno)
	(##sys#signal-hook #:network-error (##sys#string-append "can not create TCP ports - " strerror)) )
      (let* ((buf (make-string +input-buffer-size+))
	     (data (vector fd #f #f))
	     (buflen 0)
	     (bufindex 0)
	     (iclosed #f) 
	     (oclosed #f)
	     (outbufsize (tbs))
	     (outbuf (and outbufsize (fx> outbufsize 0) ""))
	     (tmr (tcp-read-timeout))
	     (tmw (tcp-write-timeout))
	     (read-input
	      (lambda ()
		(let loop ()
		  (let ((n (##net#recv fd buf +input-buffer-size+ 0)))
		    (cond ((eq? -1 n)
			   (cond ((eq? errno _ewouldblock) 
				  (when tmr
				    (##sys#thread-block-for-timeout! 
				     ##sys#current-thread
				     (fx+ (##sys#fudge 16) tmr) ) )
				  (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
				  (yield)
				  (when (##sys#slot ##sys#current-thread 13)
				    (##sys#signal-hook
				     #:network-error
				     "read operation timed out" fd) )
				  (loop) )
				 (else
				  (##sys#update-errno)
				  (##sys#signal-hook 
				   #:network-error
				   (##sys#string-append "can not read from socket - " strerror) 
				   fd) ) ) )
			  (else
			   (set! buflen n)
			   (set! bufindex 0) ) ) ) ) ) )
	     (in
	      (make-input-port
	       (lambda ()
		 (when (fx>= bufindex buflen)
		   (read-input))
		 (if (fx>= bufindex buflen)
		     #!eof
		     (let ((c (##core#inline "C_subchar" buf bufindex)))
		       (set! bufindex (fx+ bufindex 1))
		       c) ) )
	       (lambda ()
		 (or (fx< bufindex buflen)
		     (let ((f (##net#select fd)))
		       (when (eq? f -1)
			 (##sys#update-errno)
			 (##sys#signal-hook
			  #:network-error
			  (##sys#string-append "can not check socket for input - " strerror) 
			  fd) )
		       (eq? f 1) ) ) )
	       (lambda ()
		 (unless iclosed
		   (set! iclosed #t)
		   (unless (##sys#slot data 1) (##net#shutdown fd _sd_receive))
		   (when (and oclosed (eq? -1 (##net#close fd)))
		     (##sys#update-errno)
		     (##sys#signal-hook
		      #:network-error
		      (##sys#string-append "can not close socket input port - " strerror)
		      fd) ) ) )
	       #f
	       (lambda (p n dest start)	; read-string!
		 (let loop ((n n) (m 0) (start start))
		   (cond ((eq? n 0) m)
			 ((fx< bufindex buflen)
			  (let* ((rest (fx- buflen bufindex))
				 (n2 (if (fx< n rest) n rest)))
			    (##core#inline "C_substring_copy" buf dest bufindex (fx+ bufindex n2) start)
			    (set! bufindex (fx+ bufindex n2))
			    (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) )
			 (else
			  (read-input)
			  (if (eq? buflen 0) 
			      m
			      (loop n m start) ) ) ) ) )
	       (lambda (p limit)	; read-line
		 (let loop ((str #f))
		   (cond ((fx< bufindex buflen)
			  (##sys#scan-buffer-line
			   buf 
			   buflen
			   bufindex
			   (lambda (pos2 next)
			     (let ((dest (##sys#make-string (fx- pos2 bufindex))))
			       (##core#inline "C_substring_copy" buf dest bufindex pos2 0)
			       (set! bufindex next)
			       (cond ((eq? pos2 next) ; no line-terminator encountered
				      (read-input)
				      (if (fx>= bufindex buflen)
					  (or str "")
					  (loop (if str (##sys#string-append str dest) dest)) ) )
				     (else 
				      (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
				      (if str (##sys#string-append str dest) dest)) ) ) ) ) )
			 (else
			  (read-input)
			  (if (fx< bufindex buflen)
			      (loop str)
			      #!eof) ) ) ) ) ) )
	     (output
	      (lambda (s)
		(let loop ((len (##sys#size s))
			   (offset 0))
		  (let* ((count (fxmin +output-chunk-size+ len))
			 (n (##net#send fd s offset count 0)) )
		    (cond ((eq? -1 n)
			   (cond ((eq? errno _ewouldblock)
				  (when tmw
				    (##sys#thread-block-for-timeout! 
				     ##sys#current-thread
				     (fx+ (##sys#fudge 16) tmw) ) )
				  (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
				  (yield) 
				  (when (##sys#slot ##sys#current-thread 13)
				    (##sys#signal-hook
				     #:network-error
				     "write operation timed out" fd) )
				  (loop len offset) )
				 (else
				  (##sys#update-errno)
				  (##sys#signal-hook 
				   #:network-error
				   (##sys#string-append "can not write to socket - " strerror) 
				   fd) ) ) )
			  ((fx< n len)
			   (loop (fx- len n) (fx+ offset n)) ) ) ) ) ) )
	     (out
	      (make-output-port
	       (if outbuf
		   (lambda (s)
		     (set! outbuf (##sys#string-append outbuf s))
		     (when (fx>= (##sys#size outbuf) outbufsize)
		       (output outbuf)
		       (set! outbuf "") ) )
		   (lambda (s) 
		     (when (fx> (##sys#size s) 0)
		       (output s)) ) )
	       (lambda ()
		 (unless oclosed
		   (set! oclosed #t)
		   (when (and outbuf (fx> (##sys#size outbuf) 0))
		     (output outbuf)
		     (set! outbuf "") )
		   (unless (##sys#slot data 2) (##net#shutdown fd _sd_send))
		   (when (and iclosed (eq? -1 (##net#close fd)))
		     (##sys#update-errno)
		     (##sys#signal-hook
		      #:network-error (##sys#string-append "can not close socket output port - " strerror) fd) ) ) )
	       (and outbuf
		    (lambda ()
		      (when (fx> (##sys#size outbuf) 0)
			(output outbuf)
			(set! outbuf "") ) ) ) ) ) )
	(##sys#setslot in 3 "(tcp)")
	(##sys#setslot out 3 "(tcp)")
	(##sys#setslot in 7 'socket)
	(##sys#setslot out 7 'socket)
	(##sys#setslot in 9 data)
	(##sys#setslot out 9 data)
	(values in out) ) ) ) )

(define (tcp-accept tcpl)
  (##sys#check-structure tcpl 'tcp-listener)
  (let ((fd (##sys#slot tcpl 1))
	(tma (tcp-accept-timeout)))
    (let loop ()
      (if (eq? 1 (##net#select fd))
	  (let ((fd (##net#accept fd #f #f)))
	    (when (eq? -1 fd)
	      (##sys#update-errno)
	      (##sys#signal-hook 
	       #:network-error 'tcp-accept (##sys#string-append "could not accept from listener - " strerror) 
	       tcpl) )
	    (##net#io-ports fd) )
	  (begin
	    (when tma
	      (##sys#thread-block-for-timeout! 
	       ##sys#current-thread
	       (fx+ (##sys#fudge 16) tma) ) )
	    (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
	    (yield)
	    (when (##sys#slot ##sys#current-thread 13)
	      (##sys#signal-hook
	       #:network-error
	       'tcp-accept
	       "accept operation timed out" fd) )
	    (loop) ) ) ) ) )

(define (tcp-accept-ready? tcpl)
  (##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)
  (let ((f (##net#select (##sys#slot tcpl 1))))
    (when (eq? -1 f)
      (##sys#update-errno)
      (##sys#signal-hook 
       #:network-error 'tcp-accept-ready? (##sys#string-append "can not check socket for input - " strerror) 
       tcpl) )
    (eq? 1 f) ) )

(define get-socket-error
  (foreign-lambda* int ((int socket))
    "int err, optlen;"
    "optlen = sizeof(err);"
    "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == -1)"
    "return(-1);"
    "return(err);"))

(define general-strerror (foreign-lambda c-string "strerror" int))

(define (tcp-connect host . more)
  (let ((port (:optional more #f))
	(tmc (tcp-connect-timeout)))
    (##sys#check-string host)
    (unless port
      (set!-values (host port) (##net#parse-host host "tcp"))
      (unless port (##sys#signal-hook #:network-error 'tcp-connect "no port specified" host)) )
    (##sys#check-exact port)
    (let ((addr (make-string _sockaddr_in_size))
	  (s (##net#socket _af_inet _sock_stream 0)) )
      (define (fail)
	(##net#close s)
	(##sys#update-errno)
	(##sys#signal-hook 
	 #:network-error 'tcp-connect (##sys#string-append "can not connect to socket - " strerror) 
	 host port) )
      (when (eq? -1 s)
	(##sys#update-errno)
	(##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "can not create socket - " strerror) host port) )
      (unless (##net#gethostaddr addr host port)
	(##sys#signal-hook #:network-error 'tcp-connect "can not find host address" host) )
      (unless (##net#make-nonblocking s)
	(##sys#update-errno)
	(##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "fcntl() failed - " strerror)) )
      (when (eq? -1 (##net#connect s addr _sockaddr_in_size))
	(if (eq? errno _einprogress)
	    (let loop ()
	      (let ((f (##net#select-write s)))
		(when (eq? f -1) (fail))
		(unless (eq? f 1)
		  (when tmc
		    (##sys#thread-block-for-timeout!
		     ##sys#current-thread
		     (fx+ (##sys#fudge 16) tmc) ) )
		  (##sys#thread-block-for-i/o! ##sys#current-thread s #:all)
		  (yield)
		  (when (##sys#slot ##sys#current-thread 13)
		    (##sys#signal-hook
		     #:network-error
		     'tcp-connect
		     "connect operation timed out" s) )
		  (loop) ) ) )
	    (fail) ) )
      (let ((err (get-socket-error s)))
	(cond ((= err -1) 
	       (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "getsockopt() failed - " strerror)))
	      ((> err 0) 
	       (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "can not create socket - " (general-strerror err))))))
      (##net#io-ports s) ) ) )

(define (##sys#tcp-port->fileno p)
  (##sys#slot (##sys#port-data p) 0) )

(define (tcp-addresses p)
  (let ((fd (##sys#tcp-port->fileno p)))
    (values 
     (or (##net#getsockname fd)
	 (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "can not compute local address - " strerror) p) )
     (or (##net#getpeername fd)
	 (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "can not compute remote address - " strerror) p) ) ) ) )

(define (tcp-port-numbers p)
 (let ((fd (##sys#tcp-port->fileno p)))
   (values
    (or (##net#getsockport fd)
        (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "can not compute local port - " strerror) p) )
    (or (##net#getpeerport fd)
        (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "can not compute remote port - " strerror) p) ) ) ) )

(define (tcp-listener-port tcpl)
  (##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port)
  (let* ((fd (##sys#slot tcpl 1))
	 (port (##net#getsockport fd)) )
    (when (eq? -1 port)
      (##sys#signal-hook
       #:network-error 'tcp-listener-port (##sys#string-append "can not obtain listener port - " strerror) 
       tcpl fd) )
    port) )

(define (tcp-abandon-port p)
  (##sys#check-port p 'tcp-abandon-port)
  (##sys#setislot
   (##sys#port-data p)
   (if (##sys#slot p 1) 2 1)
   #t) )

(define (tcp-listener-fileno l)
  (##sys#check-structure l 'tcp-listener 'tcp-listener-fileno)
  (##sys#slot l 1) )