~ chicken-core (chicken-5) adcec284b2253dcf14fda00bd13300607b0905b2
commit adcec284b2253dcf14fda00bd13300607b0905b2
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 17:41:23 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 27e6be58..69c269ca 100644
--- a/NEWS
+++ b/NEWS
@@ -55,6 +55,12 @@
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 7cfb6c65..0fb7493d 100644
--- a/manual/Acknowledgements
+++ b/manual/Acknowledgements
@@ -42,13 +42,13 @@ Doug Quale, Imran Rafique, Eric Raible, Ivan 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,
+Oskar Schirmer, Vasilij Schneidermann, 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
diff --git a/posix-common.scm b/posix-common.scm
index 4bb21fbd..83f360d4 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -699,3 +699,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 63cef98c..54181fda 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -27,7 +27,7 @@
(declare
(unit posix)
- (uses scheduler irregex pathname ports)
+ (uses scheduler irregex pathname extras files ports lolevel)
(disable-interrupts)
(not inline ##sys#interrupt-hook ##sys#user-interrupt-hook))
@@ -84,6 +84,7 @@
(import chicken.bitwise
chicken.foreign
chicken.irregex
+ chicken.memory
chicken.pathname
chicken.ports
chicken.time)
@@ -130,10 +131,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
@@ -152,16 +149,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;
@@ -224,29 +215,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;
@@ -1447,43 +1417,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 9ad9eff7..14d4c70a 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -62,9 +62,9 @@
(declare
(unit posix)
- (uses scheduler data-structures irregex pathname ports)
+ (uses scheduler data-structures irregex extras pathname 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
@@ -80,14 +80,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 int C_pipefds[ 2 ];
static C_TLS time_t C_secs;
@@ -209,39 +203,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)))
@@ -707,6 +674,7 @@ EOF
chicken.data-structures
chicken.foreign
chicken.irregex
+ chicken.memory
chicken.pathname
chicken.ports
chicken.random
@@ -1167,74 +1135,44 @@ 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")
@@ -1283,7 +1221,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
diff --git a/rules.make b/rules.make
index 17e7da4a..29f4896e 100644
--- a/rules.make
+++ b/rules.make
@@ -717,6 +717,7 @@ posixunix.c: posixunix.scm \
chicken.bitwise.import.scm \
chicken.foreign.import.scm \
chicken.irregex.import.scm \
+ chicken.memory.import.scm \
chicken.pathname.import.scm \
chicken.ports.import.scm \
chicken.time.import.scm
@@ -724,6 +725,7 @@ posixwin.c: posixwin.scm \
chicken.bitwise.import.scm \
chicken.foreign.import.scm \
chicken.irregex.import.scm \
+ chicken.memory.import.scm \
chicken.pathname.import.scm \
chicken.ports.import.scm \
chicken.time.import.scm
Trap