diff --git a/NEWS b/NEWS
index c557b6a..d64c818 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,15 @@
4.11.1
+- Security fixes
+ - CVE-2016-6830: 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).
+ - CVE-2016-6831: Fix memory leak in process-execute and
+ process-spawn. If, during argument and environment list
+ processing, a list item isn't a string, an exception is thrown,
+ in which case previously malloc()ed strings weren't freed.
+
- Compiler:
- define-constant now correctly keeps symbol values quoted.
- Warnings are now emitted when using vector-{ref,set!} or one
diff --git a/posix-common.scm b/posix-common.scm
index 2830c10..9c415a4 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 a21d0b0..199902d 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 2f46aaf..cfca11c 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,46 @@ 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))
+ r)))))
(define-foreign-variable _shlcmd c-string "C_shlcmd")
@@ -1277,7 +1216,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