path: root/dev-scheme/chicken/files/chicken-4.8.0.3-CVE-2013-2075_2.patch

From http://code.call-cc.org/cgi-bin/gitweb.cgi?p=chicken-core.git;a=commitdiff;h=556108092774086b6c86c2e27daf3f740ffec091

--- chicken-4.8.0.3/chicken.h
+++ chicken-4.8.0.3/chicken.h
@@ -1668,6 +1668,7 @@
 C_fctexport C_word C_fcall C_read_char(C_word port) C_regparm;
 C_fctexport C_word C_fcall C_peek_char(C_word port) C_regparm;
 C_fctexport C_word C_fcall C_execute_shell_command(C_word string) C_regparm;
+C_fctexport int C_fcall C_check_fd_ready(int fd) C_regparm;
 C_fctexport C_word C_fcall C_char_ready_p(C_word port) C_regparm;
 C_fctexport C_word C_fcall C_fudge(C_word fudge_factor) C_regparm;
 C_fctexport void C_fcall C_raise_interrupt(int reason) C_regparm;
--- chicken-4.8.0.3/posixunix.scm
+++ chicken-4.8.0.3/posixunix.scm
@@ -493,16 +493,7 @@
     "if(val == -1) C_return(0);"
     "C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);" ) )
 
-(define ##sys#file-select-one
-  (foreign-lambda* int ([int fd])
-    "fd_set in;"
-    "struct timeval tm;"
-    "FD_ZERO(&in);"
-    "FD_SET(fd, &in);"
-    "tm.tv_sec = tm.tv_usec = 0;"
-    "if(select(fd + 1, &in, NULL, NULL, &tm) == -1) C_return(-1);"
-    "else C_return(FD_ISSET(fd, &in) ? 1 : 0);" ) )
-
+(define ##sys#file-select-one (foreign-lambda int "C_check_fd_ready" int) )
 
 ;;; Lo-level I/O:
 
--- chicken-4.8.0.3/runtime.c
+++ chicken-4.8.0.3/runtime.c
@@ -60,6 +60,11 @@
 # define EOVERFLOW  0
 #endif
 
+/* TODO: Include sys/select.h? Windows doesn't seem to have it... */
+#ifdef HAVE_POSIX_POLL
+#  include <poll.h>
+#endif
+
 #if !defined(C_NONUNIX)
 
 # include <sys/types.h>
@@ -4036,20 +4041,39 @@
   return C_fix(n);
 }
 
+/*
+ * TODO: Implement something for Windows that supports selecting on
+ * arbitrary fds (there, select() only works on network sockets and
+ * poll() is not available at all).
+ */
+C_regparm int C_fcall C_check_fd_ready(int fd)
+{
+#ifdef HAVE_POSIX_POLL
+  struct pollfd ps;
+  ps.fd = fd;
+  ps.events = POLLIN;
+  return poll(&ps, 1, 0);
+#else
+  fd_set in;
+  struct timeval tm;
+  int rv;
+  FD_ZERO(&in);
+  FD_SET(fd, &in);
+  tm.tv_sec = tm.tv_usec = 0;
+  rv = select(fd + 1, &in, NULL, NULL, &tm);
+  if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
+  return rv;
+#endif
+}
 
 C_regparm C_word C_fcall C_char_ready_p(C_word port)
 {
-#if !defined(C_NONUNIX)
-  fd_set fs;
-  struct timeval to;
-  int fd = C_fileno(C_port_file(port));
-
-  FD_ZERO(&fs);
-  FD_SET(fd, &fs);
-  to.tv_sec = to.tv_usec = 0;
-  return C_mk_bool(C_select(fd + 1, &fs, NULL, NULL, &to) == 1);
-#else
+#if defined(C_NONUNIX)
+  /* The best we can currently do on Windows... */
   return C_SCHEME_TRUE;
+#else
+  int fd = C_fileno(C_port_file(port));
+  return C_mk_bool(C_check_fd_ready(fd) == 1);
 #endif
 }
 
--- chicken-4.8.0.3/tcp.scm
+++ chicken-4.8.0.3/tcp.scm
@@ -46,6 +46,7 @@
 # define fcntl(a, b, c)  0
 # define EWOULDBLOCK     0
 # define EINPROGRESS     0
+# define EAGAIN          0
 # define typecorrect_getsockopt(socket, level, optname, optval, optlen)	\
     getsockopt(socket, level, optname, (char *)optval, optlen)
 #else
@@ -111,6 +112,7 @@
 (define ##net#recv (foreign-lambda int "recv" int scheme-pointer int int))
 (define ##net#shutdown (foreign-lambda int "shutdown" int int))
 (define ##net#connect (foreign-lambda int "connect" int scheme-pointer int))
+(define ##net#check-fd-ready (foreign-lambda int "C_check_fd_ready" int))
 
 (define ##net#send
   (foreign-lambda* 
@@ -177,30 +179,6 @@
      if((se = getservbyname(serv, proto)) == NULL) C_return(0);
      else C_return(ntohs(se->s_port));") )     
 
-(define ##net#select
-  (foreign-lambda* int ((int fd))
-    "fd_set in;
-     struct timeval tm;
-     int rv;
-     FD_ZERO(&in);
-     FD_SET(fd, &in);
-     tm.tv_sec = tm.tv_usec = 0;
-     rv = select(fd + 1, &in, NULL, NULL, &tm);
-     if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
-     C_return(rv);") )
-
-(define ##net#select-write
-  (foreign-lambda* int ((int fd))
-    "fd_set out;
-     struct timeval tm;
-     int rv;
-     FD_ZERO(&out);
-     FD_SET(fd, &out);
-     tm.tv_sec = tm.tv_usec = 0;
-     rv = select(fd + 1, NULL, &out, NULL, &tm);
-     if(rv > 0) { rv = FD_ISSET(fd, &out) ? 1 : 0; }
-     C_return(rv);") )
-
 (define ##net#gethostaddr
   (foreign-lambda* bool ((scheme-pointer saddr) (c-string host) (unsigned-short port))
     "struct hostent *he = gethostbyname(host);"
@@ -212,13 +190,6 @@
     "addr->sin_addr = *((struct in_addr *)he->h_addr);"
     "C_return(1);") )
 
-(define (yield)
-  (##sys#call-with-current-continuation
-   (lambda (return)
-     (let ((ct ##sys#current-thread))
-       (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
-       (##sys#schedule) ) ) ) )
-
 (define ##net#parse-host
   (let ((substring substring))
     (lambda (host proto)
@@ -343,7 +314,9 @@
 	     (outbufsize (tbs))
 	     (outbuf (and outbufsize (fx> outbufsize 0) ""))
 	     (tmr (tcp-read-timeout))
+             (dlr (and tmr (+ (current-milliseconds) tmr)))
 	     (tmw (tcp-write-timeout))
+             (dlw (and tmw (+ (current-milliseconds) tmw)))
 	     (read-input
 	      (lambda ()
 		(let loop ()
@@ -351,12 +324,11 @@
 		    (cond ((eq? -1 n)
 			   (cond ((or (eq? errno _ewouldblock) 
 				      (eq? errno _eagain))
-				  (when tmr
-				    (##sys#thread-block-for-timeout! 
-				     ##sys#current-thread
-				     (+ (current-milliseconds) tmr) ) )
+				  (when dlr
+				    (##sys#thread-block-for-timeout!
+                                     ##sys#current-thread dlr) )
 				  (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
-				  (yield)
+                                  (##sys#thread-yield!)
 				  (when (##sys#slot ##sys#current-thread 13)
 				    (##sys#signal-hook
 				     #:network-timeout-error
@@ -386,7 +358,7 @@
 		       c) ) )
 	       (lambda ()
 		 (or (fx< bufindex buflen)
-		     (let ((f (##net#select fd)))
+		     (let ((f (##net#check-fd-ready fd)))
 		       (when (eq? f -1)
 			 (##sys#update-errno)
 			 (##sys#signal-hook
@@ -469,12 +441,11 @@
 		    (cond ((eq? -1 n)
 			   (cond ((or (eq? errno _ewouldblock)
 				      (eq? errno _eagain))
-				  (when tmw
+				  (when dlw
 				    (##sys#thread-block-for-timeout! 
-				     ##sys#current-thread
-				     (+ (current-milliseconds) tmw) ) )
-				  (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
-				  (yield) 
+				     ##sys#current-thread dlw) )
+                                  (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
+                                  (##sys#thread-yield!)
 				  (when (##sys#slot ##sys#current-thread 13)
 				    (##sys#signal-hook
 				     #:network-timeout-error
@@ -528,38 +499,29 @@
 
 (define (tcp-accept tcpl)
   (##sys#check-structure tcpl 'tcp-listener)
-  (let ((fd (##sys#slot tcpl 1))
-	(tma (tcp-accept-timeout)))
+  (let* ((fd (##sys#slot tcpl 1))
+         (tma (tcp-accept-timeout))
+         (dla (and tma (+ tma (current-milliseconds)))))
     (let loop ()
-      (if (eq? 1 (##net#select fd))
-	  (let ((fd (##net#accept fd #f #f)))
-	    (cond ((not (eq? -1 fd)) (##net#io-ports fd))
-		  ((eq? errno _eintr)
-		   (##sys#dispatch-interrupt loop))
-		  (else
-		   (##sys#update-errno)
-		   (##sys#signal-hook 
-		    #:network-error
-		    'tcp-accept
-		    (##sys#string-append "could not accept from listener - " strerror)
-		    tcpl))))
-	  (begin
-	    (when tma
-	      (##sys#thread-block-for-timeout! 
-	       ##sys#current-thread
-	       (+ (current-milliseconds) tma) ) )
-	    (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
-	    (yield)
-	    (when (##sys#slot ##sys#current-thread 13)
-	      (##sys#signal-hook
-	       #:network-timeout-error
-	       'tcp-accept
-	       "accept operation timed out" tma fd) )
-	    (loop) ) ) ) ) )
+      (when dla
+        (##sys#thread-block-for-timeout! ##sys#current-thread dla) )
+      (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
+      (##sys#thread-yield!)
+      (if (##sys#slot ##sys#current-thread 13)
+	  (##sys#signal-hook
+	   #:network-timeout-error
+	   'tcp-accept
+	   "accept operation timed out" tma fd) )
+      (let ((fd (##net#accept fd #f #f)))
+	(cond ((not (eq? -1 fd)) (##net#io-ports fd))
+	      ((eq? errno _eintr)
+	       (##sys#dispatch-interrupt loop))
+	      (else
+	       (network-error 'tcp-accept "could not accept from listener" tcpl)))) ) ) )
 
 (define (tcp-accept-ready? tcpl)
   (##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)
-  (let ((f (##net#select (##sys#slot tcpl 1))))
+  (let ((f (##net#check-fd-ready (##sys#slot tcpl 1))))
     (when (eq? -1 f)
       (##sys#update-errno)
       (##sys#signal-hook 
@@ -578,8 +540,9 @@
 (define general-strerror (foreign-lambda c-string "strerror" int))
 
 (define (tcp-connect host . more)
-  (let ((port (optional more #f))
-	(tmc (tcp-connect-timeout)))
+  (let* ((port (optional more #f))
+         (tmc (tcp-connect-timeout))
+         (dlc (and tmc (+ (current-milliseconds) tmc))))
     (##sys#check-string host)
     (unless port
       (set!-values (host port) (##net#parse-host host "tcp"))
@@ -606,23 +569,9 @@
       (let loop ()
 	(when (eq? -1 (##net#connect s addr _sockaddr_in_size))
 	  (cond ((eq? errno _einprogress)
-		 (let loop2 ()
-		   (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
-			  (+ (current-milliseconds) tmc) ) )
-		       (##sys#thread-block-for-i/o! ##sys#current-thread s #:all)
-		       (yield)
-		       (when (##sys#slot ##sys#current-thread 13)
-			 (##net#close s)
-			 (##sys#signal-hook
-			  #:network-timeout-error
-			  'tcp-connect
-			  "connect operation timed out" tmc s) )
-		       (loop2) ) ) ))
+		 (when dlc
+		   (##sys#thread-block-for-timeout! ##sys#current-thread dlc))
+		 (##sys#thread-block-for-i/o! ##sys#current-thread s #:all))
 		((eq? errno _eintr)
 		 (##sys#dispatch-interrupt loop))
 		(else (fail) ) )))