The following patch was adapted for CHICKEN Scheme by Kei Kebreau based on: https://lists.nongnu.org/archive/html/chicken-hackers/2016-07/txtSWHYeFeG0R.txt diff -r -u a/NEWS b/NEWS --- a/NEWS 2016-12-22 14:06:40.016494788 -0500 +++ b/NEWS 2016-12-22 14:06:49.216803605 -0500 @@ -27,6 +27,12 @@ - The signal handling code can no longer trigger "stack overflow" or "recursion too deep or circular data encountered" errors (#1283). +- 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: - Specializations on implicit "or" types like "number" or "boolean" now work, removing the requirement for the inferred types to match diff -r -u a/posix-common.scm b/posix-common.scm --- a/posix-common.scm 2016-12-22 14:06:40.024495057 -0500 +++ b/posix-common.scm 2016-12-22 14:06:55.961030020 -0500 @@ -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 #< @@ -679,3 +680,65 @@ (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 = 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 -r -u a/posixunix.scm b/posixunix.scm --- a/posixunix.scm 2016-12-22 14:06:39.976493446 -0500 +++ b/posixunix.scm 2016-12-22 14:06:55.961030020 -0500 @@ -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 @@ # 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 @@ # 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 @@ #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 @@ (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 -r -u a/posixwin.scm b/posixwin.scm --- a/posixwin.scm 2016-12-22 14:06:40.016494788 -0500 +++ b/posixwin.scm 2016-12-22 14:06:55.961030020 -0500 @@ -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 #< #include -#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 @@ #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 @@ ; 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 @@ ; 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