~ chicken-core (chicken-5) 0d20426c6da0f116606574dadadaa878b96a68ea
commit 0d20426c6da0f116606574dadadaa878b96a68ea
Author: Christian Kellermann <ckeen@pestilenz.org>
AuthorDate: Sat Jul 23 21:23:50 2016 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Fri Aug 12 13:32:27 2016 +1200
Fix buffer overflow in posix execvp/execve wrapper
This fixes bug #1308 found by wasamasa. It turns out that we don't
check the number of arguments or the number of env entries before trying
to write them to the target string.
Instead of checking the argument count, this patch replaces the static
buffer with a dynamically allocated string and relies on errno being
set to E2BIG if the argument vector is too large.
Furthermore, this merges the process-execute and process-spawn
code from Windows and Unix some more to use more common code.
This should make it easier to tweak this code in the future.
This new version also fixes a memory leak which would be
triggered when the arg or env list contained non-string objects
or embedded NULs, or when the exec itself would fail.
Most C code in these procedures was rewritten to Scheme.
Signed-off-by: Peter Bex <peter@more-magic.net>
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index c557b6a0..b1a110de 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,11 @@
4.11.1
+- Security fixes
+ - Fix buffer overrun due to excessively long argument or
+ environment lists in process-execute and process-spawn (#1308).
+ This also removes unnecessary limitations on the length of
+ these lists (thanks to Vasilij Schneidermann).
+
- Compiler:
- define-constant now correctly keeps symbol values quoted.
- Warnings are now emitted when using vector-{ref,set!} or one
diff --git a/manual/Acknowledgements b/manual/Acknowledgements
index 8169b72c..42328214 100644
--- a/manual/Acknowledgements
+++ b/manual/Acknowledgements
@@ -42,18 +42,18 @@ Raikov, Santosh Rajan, Joel Reymont, "rivo", Chris Roberts, Eric
Rochester, Paul Romanchenko, Andreas Rottman, David Rush, Lars
Rustemeier, Daniel Sadilek, Otavio Salvador, Burton Samograd,
"Sandro", "satori", Aleksej Saushev, Oskar Schirmer, Reed Sheridan,
-Ronald Schröder, Spencer Schumann, Ivan Shcheklein, Alexander Shendi,
-Alex Shinn, Ivan Shmakov, "Shmul", Tony Sidaway, Jeffrey B. Siegal,
-Andrey Sidorenko, Michele Simionato, Iruata Souza, Volker Stolz, Jon
-Strait, Dorai Sitaram, Robert Skeels, Jason Songhurst, Clifford Stein,
-David Steiner, Sunnan, Zbigniew Szadkowski, Rick Taube, Nathan Thern,
-Mike Thomas, Minh Thu, Christian Tismer, Andre van Tonder, John Tobey,
-Henrik Tramberend, Vladimir Tsichevsky, James Ursetto, Neil van Dyke,
-Sam Varner, Taylor Venable, Sander Vesik, Jaques Vidrine, Panagiotis
-Vossos, Shawn Wagner, Peter Wang, Ed Watkeys, Brad Watson, Thomas
-Weidner, Göran Weinholt, Matthew Welland, Drake Wilson, Jörg
-Wittenberger, Peter Wright, Mark Wutka, Adam Young, Richard Zidlicky,
-Houman Zolfaghari and Florian Zumbiehl for bug-fixes, tips and
+Vasilij Schneidermann, Ronald Schröder, Spencer Schumann, Ivan
+Shcheklein, Alexander Shendi, Alex Shinn, Ivan Shmakov, "Shmul", Tony
+Sidaway, Jeffrey B. Siegal, Andrey Sidorenko, Michele Simionato, Iruata
+Souza, Volker Stolz, Jon Strait, Dorai Sitaram, Robert Skeels, Jason
+Songhurst, Clifford Stein, David Steiner, Sunnan, Zbigniew Szadkowski,
+Rick Taube, Nathan Thern, Mike Thomas, Minh Thu, Christian Tismer, Andre
+van Tonder, John Tobey, Henrik Tramberend, Vladimir Tsichevsky, James
+Ursetto, Neil van Dyke, Sam Varner, Taylor Venable, Sander Vesik, Jaques
+Vidrine, Panagiotis Vossos, Shawn Wagner, Peter Wang, Ed Watkeys, Brad
+Watson, Thomas Weidner, Göran Weinholt, Matthew Welland, Drake Wilson,
+Jörg Wittenberger, Peter Wright, Mark Wutka, Adam Young, Richard
+Zidlicky, Houman Zolfaghari and Florian Zumbiehl for bug-fixes, tips and
suggestions.
Special thanks to Brandon van Every for contributing the (now defunct)
diff --git a/posix-common.scm b/posix-common.scm
index 2830c104..9c415a46 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -25,7 +25,8 @@
(declare
- (hide ##sys#stat posix-error check-time-vector ##sys#find-files)
+ (hide ##sys#stat posix-error check-time-vector ##sys#find-files
+ list->c-string-buffer free-c-string-buffer call-with-exec-args)
(foreign-declare #<<EOF
#include <signal.h>
@@ -679,3 +680,65 @@ EOF
(if (fx= epid -1)
(posix-error #:process-error 'process-wait "waiting for child process failed" pid)
(values epid enorm ecode) ) ) ) ) ) )
+
+;; This can construct argv or envp for process-execute or process-run
+(define list->c-string-buffer
+ (let* ((c-string->allocated-pointer
+ (foreign-lambda* c-pointer ((scheme-object o))
+ "char *ptr = C_malloc(C_header_size(o)); \n"
+ "if (ptr != NULL) {\n"
+ " C_memcpy(ptr, C_data_pointer(o), C_header_size(o)); \n"
+ "}\n"
+ "C_return(ptr);")))
+ (lambda (string-list convert loc)
+ (##sys#check-list string-list loc)
+
+ (let* ((string-count (##sys#length string-list))
+ ;; NUL-terminated, so we must add one
+ (buffer (make-pointer-vector (add1 string-count) #f)))
+
+ (handle-exceptions exn
+ ;; Free to avoid memory leak, then reraise
+ (begin (free-c-string-buffer buffer) (signal exn))
+
+ (do ((sl string-list (cdr sl))
+ (i 0 (fx+ i 1)))
+ ((or (null? sl) (fx= i string-count))) ; Should coincide
+
+ (##sys#check-string (car sl) loc)
+ ;; This avoids embedded NULs and appends a NUL, so "cs" is
+ ;; safe to copy and use as-is in the pointer-vector.
+ (let* ((cs (##sys#make-c-string (convert (car sl)) loc))
+ (csp (c-string->allocated-pointer cs)))
+ (unless csp (error loc "Out of memory"))
+ (pointer-vector-set! buffer i csp)))
+
+ buffer)))))
+
+(define (free-c-string-buffer buffer-array)
+ (let ((size (pointer-vector-length buffer-array)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i size))
+ (and-let* ((s (pointer-vector-ref buffer-array i)))
+ (free s)))))
+
+(define call-with-exec-args
+ (let ((pathname-strip-directory pathname-strip-directory)
+ (nop (lambda (x) x)))
+ (lambda (loc filename argconv arglist envlist proc)
+ (let* ((stripped-filename (pathname-strip-directory filename))
+ (args (cons stripped-filename arglist)) ; Add argv[0]
+ (argbuf (list->c-string-buffer args argconv loc))
+ (envbuf #f))
+
+ (handle-exceptions exn
+ ;; Free to avoid memory leak, then reraise
+ (begin (free-c-string-buffer argbuf)
+ (when envbuf (free-c-string-buffer envbuf))
+ (signal exn))
+
+ ;; Envlist is never converted, so we always use nop here
+ (when envlist
+ (set! envbuf (list->c-string-buffer envlist nop loc)))
+
+ (proc (##sys#make-c-string filename loc) argbuf envbuf))))))
diff --git a/posixunix.scm b/posixunix.scm
index a21d0b03..199902db 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -27,7 +27,7 @@
(declare
(unit posix)
- (uses scheduler irregex extras files ports)
+ (uses scheduler irregex extras files ports lolevel)
(disable-interrupts)
(hide group-member _get-groups _ensure-groups posix-error ##sys#terminal-check)
(not inline ##sys#interrupt-hook ##sys#user-interrupt-hook))
@@ -88,10 +88,6 @@ static C_TLS int C_wait_status;
# define O_TEXT 0
#endif
-#ifndef ARG_MAX
-# define ARG_MAX 256
-#endif
-
#ifndef MAP_FILE
# define MAP_FILE 0
#endif
@@ -110,16 +106,10 @@ extern char **environ;
# define C_getenventry(i) (environ[ i ])
#endif
-#ifndef ENV_MAX
-# define ENV_MAX 1024
-#endif
-
#ifndef FILENAME_MAX
# define FILENAME_MAX 1024
#endif
-static C_TLS char *C_exec_args[ ARG_MAX ];
-static C_TLS char *C_exec_env[ ENV_MAX ];
static C_TLS struct utsname C_utsname;
static C_TLS struct flock C_flock;
static C_TLS DIR *temphandle;
@@ -199,29 +189,8 @@ static C_TLS struct stat C_statbuf;
#define C_lstat(fn) C_fix(lstat((char *)C_data_pointer(fn), &C_statbuf))
-static void C_fcall C_set_arg_string(char **where, int i, char *a, int len) {
- char *ptr;
- if(a != NULL) {
- ptr = (char *)C_malloc(len + 1);
- C_memcpy(ptr, a, len);
- ptr[ len ] = '\0';
- /* Can't barf() here, so the NUL byte check happens in Scheme */
- }
- else ptr = NULL;
- where[ i ] = ptr;
-}
-
-static void C_fcall C_free_arg_string(char **where) {
- while((*where) != NULL) C_free(*(where++));
-}
-
-#define C_set_exec_arg(i, a, len) C_set_arg_string(C_exec_args, i, a, len)
-#define C_free_exec_args() C_free_arg_string(C_exec_args)
-#define C_set_exec_env(i, a, len) C_set_arg_string(C_exec_env, i, a, len)
-#define C_free_exec_env() C_free_arg_string(C_exec_env)
-
-#define C_execvp(f) C_fix(execvp(C_data_pointer(f), C_exec_args))
-#define C_execve(f) C_fix(execve(C_data_pointer(f), C_exec_args, C_exec_env))
+#define C_u_i_execvp(f,a) C_fix(execvp(C_data_pointer(f), (char *const *)C_c_pointer_vector_or_null(a)))
+#define C_u_i_execve(f,a,e) C_fix(execve(C_data_pointer(f), (char *const *)C_c_pointer_vector_or_null(a), (char *const *)C_c_pointer_vector_or_null(e)))
#if defined(__FreeBSD__) || defined(C_MACOSX) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__sgi__) || defined(sgi) || defined(__DragonFly__) || defined(__SUNPRO_C)
static C_TLS int C_uw;
@@ -1591,43 +1560,15 @@ EOF
(exit 0)))
pid)))))
-(define process-execute
- ;; NOTE: We use c-string here instead of scheme-object.
- ;; Because set_exec_* make a copy, this implies a double copy.
- ;; At least it's secure, we can worry about performance later, if at all
- (let ([setarg (foreign-lambda void "C_set_exec_arg" int c-string int)]
- [freeargs (foreign-lambda void "C_free_exec_args")]
- [setenv (foreign-lambda void "C_set_exec_env" int c-string int)]
- [freeenv (foreign-lambda void "C_free_exec_env")]
- [pathname-strip-directory pathname-strip-directory] )
- (lambda (filename #!optional (arglist '()) envlist)
- (##sys#check-string filename 'process-execute)
- (##sys#check-list arglist 'process-execute)
- (let ([s (pathname-strip-directory filename)])
- (setarg 0 s (##sys#size s)) )
- (do ([al arglist (cdr al)]
- [i 1 (fx+ i 1)] )
- ((null? al)
- (setarg i #f 0)
- (when envlist
- (##sys#check-list envlist 'process-execute)
- (do ([el envlist (cdr el)]
- [i 0 (fx+ i 1)] )
- ((null? el) (setenv i #f 0))
- (let ([s (car el)])
- (##sys#check-string s 'process-execute)
- (setenv i s (##sys#size s)) ) ) )
- (let* ([prg (##sys#make-c-string filename 'process-execute)]
- [r (if envlist
- (##core#inline "C_execve" prg)
- (##core#inline "C_execvp" prg) )] )
- (when (fx= r -1)
- (freeargs)
- (freeenv)
- (posix-error #:process-error 'process-execute "cannot execute process" filename) ) ) )
- (let ([s (car al)])
- (##sys#check-string s 'process-execute)
- (setarg i s (##sys#size s)) ) ) ) ) )
+(define (process-execute filename #!optional (arglist '()) envlist)
+ (call-with-exec-args
+ 'process-execute filename (lambda (x) x) arglist envlist
+ (lambda (prg argbuf envbuf)
+ (let ((r (if envbuf
+ (##core#inline "C_u_i_execve" prg argbuf envbuf)
+ (##core#inline "C_u_i_execvp" prg argbuf))))
+ (when (fx= r -1)
+ (posix-error #:process-error 'process-execute "cannot execute process" filename))))))
(define-foreign-variable _wnohang int "WNOHANG")
(define-foreign-variable _wait-status int "C_wait_status")
diff --git a/posixwin.scm b/posixwin.scm
index 2f46aaff..194889e1 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -63,9 +63,9 @@
(declare
(unit posix)
- (uses scheduler irregex extras files ports)
+ (uses scheduler irregex extras files ports lolevel)
(disable-interrupts)
- (hide $quote-args-list $exec-setup $exec-teardown)
+ (hide quote-arg-string)
(not inline ##sys#interrupt-hook ##sys#user-interrupt-hook)
(foreign-declare #<<EOF
#ifndef WIN32_LEAN_AND_MEAN
@@ -81,14 +81,8 @@
#include <utime.h>
#include <winsock2.h>
-#define ARG_MAX 256
#define PIPE_BUF 512
-#ifndef ENV_MAX
-# define ENV_MAX 1024
-#endif
-static C_TLS char *C_exec_args[ ARG_MAX ];
-static C_TLS char *C_exec_env[ ENV_MAX ];
static C_TLS struct group *C_group;
static C_TLS int C_pipefds[ 2 ];
static C_TLS time_t C_secs;
@@ -218,39 +212,12 @@ readdir(DIR * dir)
#define C_lstat(fn) C_stat(fn)
-static void C_fcall
-C_set_arg_string(char **where, int i, char *dat, int len)
-{
- char *ptr;
- if (dat)
- {
- ptr = (char *)C_malloc(len + 1);
- C_memcpy(ptr, dat, len);
- ptr[ len ] = '\0';
- /* Can't barf() here, so the NUL byte check happens in Scheme */
- }
- else
- ptr = NULL;
- where[ i ] = ptr;
-}
-
-static void C_fcall
-C_free_arg_string(char **where) {
- while (*where) C_free(*(where++));
-}
-
-#define C_set_exec_arg(i, a, len) C_set_arg_string(C_exec_args, i, a, len)
-#define C_set_exec_env(i, a, len) C_set_arg_string(C_exec_env, i, a, len)
-
-#define C_free_exec_args() (C_free_arg_string(C_exec_args), C_SCHEME_TRUE)
-#define C_free_exec_env() (C_free_arg_string(C_exec_env), C_SCHEME_TRUE)
-
-#define C_execvp(f) C_fix(execvp(C_data_pointer(f), (const char *const *)C_exec_args))
-#define C_execve(f) C_fix(execve(C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env))
+#define C_u_i_execvp(f,a) C_fix(execvp(C_data_pointer(f), (const char *const *)C_c_pointer_vector_or_null(a)))
+#define C_u_i_execve(f,a,e) C_fix(execve(C_data_pointer(f), (const char *const *)C_c_pointer_vector_or_null(a), (const char *const *)C_c_pointer_vector_or_null(e)))
/* MS replacement for the fork-exec pair */
-#define C_spawnvp(m, f) C_fix(spawnvp(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args))
-#define C_spawnvpe(m, f) C_fix(spawnvpe(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env))
+#define C_u_i_spawnvp(m,f,a) C_fix(spawnvp(C_unfix(m), C_data_pointer(f), (const char *const *)C_c_pointer_vector_or_null(a)))
+#define C_u_i_spawnvpe(m,f,a,e) C_fix(spawnvpe(C_unfix(m), C_data_pointer(f), (const char *const *)C_c_pointer_vector_or_null(a), (const char *const *)C_c_pointer_vector_or_null(e)))
#define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))
#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
@@ -1161,74 +1128,45 @@ EOF
; Windows uses a commandline style for process arguments. Thus any
; arguments with embedded whitespace will parse incorrectly. Must
; string-quote such arguments.
-(define $quote-args-list
- (lambda (lst exactf)
- (if exactf
- lst
- (let ([needs-quoting?
- ; This is essentially (string-any char-whitespace? s) but we don't
- ; want a SRFI-13 dependency. (Do we?)
- (lambda (s)
- (let ([len (string-length s)])
- (let loop ([i 0])
- (cond
- [(fx= i len) #f]
- [(char-whitespace? (string-ref s i)) #t]
- [else (loop (fx+ i 1))]))))])
- (let loop ([ilst lst] [olst '()])
- (if (null? ilst)
- (##sys#fast-reverse olst)
- (let ([str (car ilst)])
- (loop
- (cdr ilst)
- (cons
- (if (needs-quoting? str) (string-append "\"" str "\"") str)
- olst)) ) ) ) ) ) ) )
-
-(define $exec-setup
- ;; NOTE: We use c-string here instead of scheme-object.
- ;; Because set_exec_* make a copy, this implies a double copy.
- ;; At least it's secure, we can worry about performance later, if at all
- (let ([setarg (foreign-lambda void "C_set_exec_arg" int c-string int)]
- [setenv (foreign-lambda void "C_set_exec_env" int c-string int)]
- [build-exec-argvec
- (lambda (loc lst argvec-setter idx)
- (if lst
- (begin
- (##sys#check-list lst loc)
- (do ([l lst (cdr l)]
- [i idx (fx+ i 1)] )
- ((null? l) (argvec-setter i #f 0))
- (let ([s (car l)])
- (##sys#check-string s loc)
- (argvec-setter i s (##sys#size s)) ) ) )
- (argvec-setter idx #f 0) ) )])
- (lambda (loc filename arglst envlst exactf)
- (##sys#check-string filename loc)
- (let ([s (pathname-strip-directory filename)])
- (setarg 0 s (##sys#size s)) )
- (build-exec-argvec loc (and arglst ($quote-args-list arglst exactf)) setarg 1)
- (build-exec-argvec loc envlst setenv 0)
- (##core#inline "C_flushall")
- (##sys#make-c-string filename loc) ) ) )
-
-(define ($exec-teardown loc msg filename res)
- (##sys#update-errno)
- (##core#inline "C_free_exec_args")
- (##core#inline "C_free_exec_env")
- (if (fx= res -1)
- (##sys#error loc msg filename)
- res ) )
-
-(define (process-execute filename #!optional arglst envlst exactf)
- (let ([prg ($exec-setup 'process-execute filename arglst envlst exactf)])
- ($exec-teardown 'process-execute "cannot execute process" filename
- (if envlst (##core#inline "C_execve" prg) (##core#inline "C_execvp" prg))) ) )
-
-(define (process-spawn mode filename #!optional arglst envlst exactf)
- (let ([prg ($exec-setup 'process-spawn filename arglst envlst exactf)])
- ($exec-teardown 'process-spawn "cannot spawn process" filename
- (if envlst (##core#inline "C_spawnvpe" mode prg) (##core#inline "C_spawnvp" mode prg))) ) )
+(define quote-arg-string
+ (let ((needs-quoting?
+ ;; This is essentially (string-any char-whitespace? s) but we
+ ;; don't want a SRFI-13 dependency. (Do we?)
+ (lambda (s)
+ (let ((len (string-length s)))
+ (let loop ((i 0))
+ (cond
+ ((fx= i len) #f)
+ ((char-whitespace? (string-ref s i)) #t)
+ (else (loop (fx+ i 1)))))))))
+ (lambda (str)
+ (if (needs-quoting? str) (string-append "\"" str "\"") str))))
+
+(define (process-execute filename #!optional (arglist '()) envlist exactf)
+ (let ((argconv (if exactf (lambda (x) x) quote-arg-string)))
+ (call-with-exec-args
+ 'process-execute filename argconv arglist envlist
+ (lambda (prg argbuf envbuf)
+ (##core#inline "C_flushall")
+ (let ((r (if envbuf
+ (##core#inline "C_u_i_execve" prg argbuf envbuf)
+ (##core#inline "C_u_i_execvp" prg argbuf))))
+ (when (fx= r -1)
+ (posix-error #:process-error 'process-execute "cannot execute process" filename)))))))
+
+(define (process-spawn mode filename #!optional (arglist '()) envlist exactf)
+ (let ((argconv (if exactf (lambda (x) x) quote-arg-string)))
+ (##sys#check-exact mode 'process-spawn)
+
+ (call-with-exec-args
+ 'process-spawn filename argconv arglist envlist
+ (lambda (prg argbuf envbuf)
+ (##core#inline "C_flushall")
+ (let ((r (if envbuf
+ (##core#inline "C_u_i_spawnvpe" mode prg argbuf envbuf)
+ (##core#inline "C_u_i_spawnvp" mode prg argbuf))))
+ (when (fx= r -1)
+ (posix-error #:process-error 'process-spawn "cannot spawn process" filename)))))))
(define-foreign-variable _shlcmd c-string "C_shlcmd")
@@ -1277,7 +1215,11 @@ EOF
; information for the system drives. i.e !C:=...
; For now any environment is ignored.
(lambda (loc cmd args env stdoutf stdinf stderrf #!optional exactf)
- (let ([cmdlin (string-intersperse ($quote-args-list (cons cmd args) exactf))])
+ (let* ((arglist (cons cmd args))
+ (cmdlin (string-intersperse
+ (if exactf
+ arglist
+ (map quote-arg-string arglist)))))
(let-location ([handle int -1]
[stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])
(let ([res
Trap