Leo Famulari <l...@famulari.name> writes:
> On Fri, Dec 16, 2016 at 02:33:19PM -0500, Leo Famulari wrote:
>> We fixed this bug in our guile-irregex package in commit fb73f07a0fe,
>> but our chez-irregex and chicken packages are still vulnerable.
>
> Also note that (I believe) our chicken package is vulnerable to
> CVE-2016-{6830,6831}:
>
> http://lists.nongnu.org/archive/html/chicken-announce/2016-08/msg00002.htmlThe attached patch is currently being tested on my computer, but I suspect it will work. See https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=834845.
From 3423ef38ecab794f9601aa8ac63c6974d9db62d4 Mon Sep 17 00:00:00 2001
From: Kei Kebreau <k...@openmailbox.org>
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 <k...@openmailbox.org> 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 #<<EOF
+
+ #include <signal.h>
+@@ -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 #<<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 @@
+
+ #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
signature.asc
Description: PGP signature
