[Bug 3529949]: Defang 'file dirname ~' etc in safe interps

3 files changed, 43 insertions, 23 deletions

diff --git a/ChangeLog b/ChangeLog
index 2958fa0..9405ed9 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2012-05-28  Donal K. Fellows  <dkf@users.sf.net>
+
+	* library/safe.tcl (safe::AliasFileSubcommand): [Bug 3529949]: Made a
+	more sophisticated method for preventing information leakage; it
+	changes references to "~user" into "./~user", which is safe.
+
 2012-05-25  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/namespace.n, doc/Ensemble.3: [Bug 3528418]: Document what is
diff --git a/library/safe.tcl b/library/safe.tcl
index 52f6e85..4ad5c36 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -467,7 +467,8 @@ proc ::safe::InterpInit {
 
     ::interp expose $slave file
     foreach subcommand {dirname extension rootname tail} {
-	::interp alias $slave ::tcl::file::$subcommand {} file $subcommand
+	::interp alias $slave ::tcl::file::$subcommand {} \
+	    ::safe::AliasFileSubcommand $slave $subcommand
     }
     foreach subcommand {
 	atime attributes copy delete executable exists isdirectory isfile
@@ -675,6 +676,17 @@ proc ::safe::CheckFileName {slave file} {
     }
 }
 
+# AliasFileSubcommand handles selected subcommands of [file] in safe
+# interpreters that are *almost* safe. In particular, it just acts to
+# prevent discovery of what home directories exist.
+
+proc ::safe::AliasFileSubcommand {slave subcommand name} {
+    if {[string match ~* $name]} {
+	set name ./$name
+    }
+    tailcall $slave invokehidden tcl:file:$subcommand $name
+}
+
 # AliasGlob is the target of the "glob" alias in safe interpreters.
 
 proc ::safe::AliasGlob {slave args} {
@@ -761,6 +773,8 @@ proc ::safe::AliasGlob {slave args} {
     foreach opt [lrange $args $at end] {
 	if {![regexp $dirPartRE $opt -> thedir thefile]} {
 	    set thedir .
+	} elseif {[string match ~* $thedir]} {
+	    set thedir ./$thedir
 	}
 	if {$thedir eq "*" &&
 		($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} {
diff --git a/tests/safe.test b/tests/safe.test
index ae78da9..f270248 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -27,7 +27,7 @@ set ::auto_path [info library]
 # Force actual loading of the safe package because we use un exported (and
 # thus un-autoindexed) APIs in this test result arguments:
 catch {safe::interpConfigure}
-
+
 # testing that nested and statics do what is advertised (we use a static
 # package - Tcltest - but it might be absent if we're in standard tclsh)
 
@@ -700,50 +700,50 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup {
 } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
 
 ### ~ should have no special meaning in paths in safe interpreters
-test safe-16.1 {Bug 2913625: defang ~ in paths} -setup {
+test safe-16.1 {Bug 3529949: defang ~ in paths} -setup {
     set savedHOME $env(HOME)
     set env(HOME) /foo/bar
     set i [safe::interpCreate]
-} -constraints knownBug -body {
+} -body {
     $i eval {
 	set d [format %c 126]
-	list [file dirname $d] [file tail $d] \
-	    [file join [file dirname $d] [file tail $d]]
+	list [file join [file dirname $d] [file tail $d]]
     }
 } -cleanup {
     safe::interpDelete $i
     set env(HOME) $savedHOME
-} -result {~}
-test safe-16.2 {Bug 2913625: defang ~user in paths} -setup {
+} -result {./~}
+test safe-16.2 {Bug 3529949: defang ~user in paths} -setup {
     set i [safe::interpCreate]
     set user $tcl_platform(user)
-} -constraints knownBug -body {
+} -body {
     string map [list $user USER] [$i eval \
 	    "file join \[file dirname ~$user\] \[file tail ~$user\]"]
 } -cleanup {
     safe::interpDelete $i
-} -result {~USER}
-test safe-16.3 {Bug 2913625: defang ~ in globs} -setup {
+} -result {./~USER}
+test safe-16.3 {Bug 3529949: defang ~ in globs} -setup {
+    set syntheticHOME [makeDirectory foo]
+    makeFile {} bar $syntheticHOME
     set savedHOME $env(HOME)
-    set env(HOME) /
+    set env(HOME) $syntheticHOME
     set i [safe::interpCreate]
-} -constraints knownBug -body {
-    $i expose glob realglob
-    $i eval {realglob -nocomplain [join {~ / *} ""]}
+} -body {
+    ::safe::interpAddToAccessPath $i $syntheticHOME
+    $i eval {glob -nocomplain ~/*}
 } -cleanup {
     safe::interpDelete $i
     set env(HOME) $savedHOME
-} -result {~}
-test safe-16.4 {Bug 2913625: defang ~user in globs} -setup {
+    removeDirectory $syntheticHOME
+} -result {}
+test safe-16.4 {Bug 3529949: defang ~user in globs} -setup {
     set i [safe::interpCreate]
-    set user $tcl_platform(user)
-} -constraints knownBug -body {
-    $i expose glob realglob
-    string map [list $user USER] [$i eval [list\
-	realglob -directory ~$user *]]
+} -body {
+    ::safe::interpAddToAccessPath $i $~$tcl_platform(user)
+    $i eval [list glob -nocomplain ~$tcl_platform(user)/*]
 } -cleanup {
     safe::interpDelete $i
-} -result {~USER}
+} -result {}
 
 set ::auto_path $saveAutoPath
 # cleanup