summaryrefslogtreecommitdiffstats
path: root/development/chicken/patches/04_all_CVE-2013-2075_2.patch
diff options
context:
space:
mode:
Diffstat (limited to 'development/chicken/patches/04_all_CVE-2013-2075_2.patch')
-rw-r--r--development/chicken/patches/04_all_CVE-2013-2075_2.patch309
1 files changed, 309 insertions, 0 deletions
diff --git a/development/chicken/patches/04_all_CVE-2013-2075_2.patch b/development/chicken/patches/04_all_CVE-2013-2075_2.patch
new file mode 100644
index 0000000000..b85ea7c8b2
--- /dev/null
+++ b/development/chicken/patches/04_all_CVE-2013-2075_2.patch
@@ -0,0 +1,309 @@
+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) ) )))
generated by cgit v1.2.3 (git 2.32.0) at 2024-06-06 05:57:13 +0200