From 3423ef38ecab794f9601aa8ac63c6974d9db62d4 Mon Sep 17 00:00:00 2001 From: Kei Kebreau Date: Thu, 22 Dec 2016 14:16:55 -0500 Subject: [PATCH] gnu: chicken: Fix CVE-2016-{6830,6831}. * gnu/packages/patches/chicken-CVE-2016-6830+CVE-2016-6831.patch: New file. * gnu/local.mk (dist_patch_DATA): Use it. * gnu/packages/scheme.scm (chicken)[source]: Use it. --- gnu/local.mk | 1 + .../chicken-CVE-2016-6830+CVE-2016-6831.patch | 426 +++++++++++++++++++++ gnu/packages/scheme.scm | 4 +- 3 files changed, 430 insertions(+), 1 deletion(-) create mode 100644 gnu/packages/patches/chicken-CVE-2016-6830+CVE-2016-6831.patch diff --git a/gnu/local.mk b/gnu/local.mk index ee8f1e591..81a216a39 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -497,6 +497,7 @@ dist_patch_DATA = \ %D%/packages/patches/calibre-drop-unrar.patch \ %D%/packages/patches/calibre-no-updates-dialog.patch \ %D%/packages/patches/cdparanoia-fpic.patch \ + %D%/packages/patches/chicken-CVE-2016-6830+CVE-2016-6831.patch \ %D%/packages/patches/chmlib-inttypes.patch \ %D%/packages/patches/clang-libc-search-path.patch \ %D%/packages/patches/clang-3.8-libc-search-path.patch \ diff --git a/gnu/packages/patches/chicken-CVE-2016-6830+CVE-2016-6831.patch b/gnu/packages/patches/chicken-CVE-2016-6830+CVE-2016-6831.patch new file mode 100644 index 000000000..45d5442e0 --- /dev/null +++ b/gnu/packages/patches/chicken-CVE-2016-6830+CVE-2016-6831.patch @@ -0,0 +1,426 @@ +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 diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm index 78f387faf..10e8b7c60 100644 --- a/gnu/packages/scheme.scm +++ b/gnu/packages/scheme.scm @@ -330,7 +330,9 @@ mashups, office (web agendas, mail clients, ...), etc.") version "/chicken-" version ".tar.gz")) (sha256 (base32 - "12ddyiikqknpr8h6llsxbg2fz75xnayvcnsvr1cwv8xnjn7jpp73")))) + "12ddyiikqknpr8h6llsxbg2fz75xnayvcnsvr1cwv8xnjn7jpp73")) + (patches + (search-patches "chicken-CVE-2016-6830+CVE-2016-6831.patch")))) (build-system gnu-build-system) (arguments `(#:modules ((guix build gnu-build-system) -- 2.11.0