aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/library/safe.tcl
blob: e923cc630d049d06d75f32fc0d28d8625c10a05f (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
# safe.tcl --
#
# This file provide a safe loading/sourcing mechanism for safe interpreters.
# It implements a virtual path mecanism to hide the real pathnames from the
# slave. It runs in a master interpreter and sets up data structure and
# aliases that will be invoked when used from a slave interpreter.
# 
# See the safe.n man page for details.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) safe.tcl 1.21 97/08/13 15:37:22

#
# The implementation is based on namespaces. These naming conventions
# are followed:
# Private procs starts with uppercase.
# Public  procs are exported and starts with lowercase
#

# Needed utilities package
package require opt 0.1;

# Create the safe namespace
namespace eval ::safe {

    # Exported API:
    namespace export interp \
	    interpAddToAccessPath interpFindInAccessPath \
	    setLogCmd ;

# Proto/dummy declarations for auto_mkIndex
proc ::safe::interpCreate {} {}
proc ::safe::interpInit {} {}
proc ::safe::interpConfigure {} {}
proc ::safe::interpDelete {} {}


    # Interface/entry point function and front end for "Create"
    ::tcl::OptProc interpCreate {
	{?slave? -name {} "name of the slave (optional)"}
	{-accessPath -list {} "access path for the slave"}
	{-noStatics "prevent loading of statically linked pkgs"}
	{-nestedLoadOk "allow nested loading"}
	{-deleteHook -script {} "delete hook"}
    } {
	InterpCreate $slave $accessPath \
		[expr {!$noStatics}] $nestedLoadOk $deleteHook;
    }

    # Interface/entry point function and front end for "Init"
    ::tcl::OptProc interpInit {
	{slave -name {} "name of the slave"}
	{-accessPath -list {} "access path for the slave"}
	{-noStatics "prevent loading of statically linked pkgs"}
	{-nestedLoadOk "allow nested loading"}
	{-deleteHook -script {} "delete hook"}
    } {
	InterpInit $slave $accessPath \
		[expr {!$noStatics}] $nestedLoadOk $deleteHook;
    }

    # Interface/entry point function and front end for "Configure"
    ::tcl::OptProc interpConfigure {
	{slave -name {} "name of the slave"}
	{-accessPath -list {} "access path for the slave"}
	{-noStatics "prevent loading of statically linked pkgs"}
	{-nestedLoadOk "allow nested loading"}
	{-deleteHook -script {} "delete hook"}
    } {
	# Check that at least one flag was given:
	if {[string match "*-*" $Args]} {
	    # reconfigure everything (because otherwise you can't
	    # change -noStatics for instance)
	    InterpConfigure $slave $accessPath \
		    [expr {!$noStatics}] $nestedLoadOk $deleteHook;
	    # auto_reset the slave (to completly synch the new access_path)
	    if {[catch {::interp eval $slave {auto_reset}} msg]} {
		Log $slave "auto_reset failed: $msg";
	    }
	} else {
	    # none was given, lets return current values instead
	    set res {}
	    lappend res [list -accessPath [Set [PathListName $slave]]]
	    if {![Set [StaticsOkName $slave]]} {
		lappend res "-noStatics"
	    }
	    if {[Set [NestedOkName $slave]]} {
		lappend res "-nestedLoadOk"
	    }
	    lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
	    join $res
	}
    }


    #
    # safe::InterpCreate : doing the real job
    #
    # This procedure creates a safe slave and initializes it with the
    # safe base aliases.
    # NB: slave name must be simple alphanumeric string, no spaces,
    # no (), no {},...  {because the state array is stored as part of the name}
    #
    # Returns the slave name.
    #
    # Optional Arguments : 
    # + slave name : if empty, generated name will be used
    # + access_path: path list controlling where load/source can occur,
    #                if empty: the master auto_path will be used.
    # + staticsok  : flag, if 0 :no static package can be loaded (load {} Xxx)
    #                      if 1 :static packages are ok.
    # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
    #                      if 1 : multiple levels are ok.
    
    # use the full name and no indent so auto_mkIndex can find us
    proc ::safe::InterpCreate {
	slave 
	access_path
	staticsok
	nestedok
	deletehook
    } {
	# Create the slave.
	if {[string compare "" $slave]} {
	    ::interp create -safe $slave;
	} else {
	    # empty argument: generate slave name
	    set slave [::interp create -safe];
	}
	Log $slave "Created" NOTICE;

	# Initialize it. (returns slave name)
	InterpInit $slave $access_path $staticsok $nestedok $deletehook;
    }


    #
    # InterpConfigure (was setAccessPath) :
    #    Sets up slave virtual auto_path and corresponding structure
    #    within the master. Also sets the tcl_library in the slave
    #    to be the first directory in the path.
    #    Nb: If you change the path after the slave has been initialized
    #    you probably need to call "auto_reset" in the slave in order that it
    #    gets the right auto_index() array values.

    proc ::safe::InterpConfigure {slave access_path staticsok\
	    nestedok deletehook} {

	# determine and store the access path if empty
	if {[string match "" $access_path]} {
	    set access_path [uplevel #0 set auto_path];
	    # Make sure that tcl_library is in auto_path
	    # and at the first position (needed by setAccessPath)
	    set where [lsearch -exact $access_path [info library]];
	    if {$where == -1} {
		# not found, add it.
		set access_path [concat [list [info library]] $access_path];
		Log $slave "tcl_library was not in auto_path,\
			added it to slave's access_path" NOTICE;
	    } elseif {$where != 0} {
		# not first, move it first
		set access_path [concat [list [info library]]\
			[lreplace $access_path $where $where]];
		Log $slave "tcl_libray was not in first in auto_path,\
			moved it to front of slave's access_path" NOTICE;
	    
	    }

	    # Add 1st level sub dirs (will searched by auto loading from tcl
	    # code in the slave using glob and thus fail, so we add them
	    # here so by default it works the same).
	    set access_path [AddSubDirs $access_path];
	}

	Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
		nestedok=$nestedok deletehook=($deletehook)" NOTICE;

	# clear old autopath if it existed
	set nname [PathNumberName $slave];
	if {[Exists $nname]} {
	    set n [Set $nname];
	    for {set i 0} {$i<$n} {incr i} {
		Unset [PathToken $i $slave];
	    }
	}

	# build new one
	set slave_auto_path {}
	set i 0;
	foreach dir $access_path {
	    Set [PathToken $i $slave] $dir;
	    lappend slave_auto_path "\$[PathToken $i]";
	    incr i;
	}
	Set $nname $i;
	Set [PathListName $slave] $access_path;
	Set [VirtualPathListName $slave] $slave_auto_path;

	Set [StaticsOkName $slave] $staticsok
	Set [NestedOkName $slave] $nestedok
	Set [DeleteHookName $slave] $deletehook

	SyncAccessPath $slave;
    }

    #
    #
    # FindInAccessPath:
    #    Search for a real directory and returns its virtual Id
    #    (including the "$")
proc ::safe::interpFindInAccessPath {slave path} {
	set access_path [GetAccessPath $slave];
	set where [lsearch -exact $access_path $path];
	if {$where == -1} {
	    return -code error "$path not found in access path $access_path";
	}
	return "\$[PathToken $where]";
    }

    #
    # addToAccessPath:
    #    add (if needed) a real directory to access path
    #    and return its virtual token (including the "$").
proc ::safe::interpAddToAccessPath {slave path} {
	# first check if the directory is already in there
	if {![catch {interpFindInAccessPath $slave $path} res]} {
	    return $res;
	}
	# new one, add it:
	set nname [PathNumberName $slave];
	set n [Set $nname];
	Set [PathToken $n $slave] $path;

	set token "\$[PathToken $n]";

	Lappend [VirtualPathListName $slave] $token;
	Lappend [PathListName $slave] $path;
	Set $nname [expr $n+1];

	SyncAccessPath $slave;

	return $token;
    }

    # This procedure applies the initializations to an already existing
    # interpreter. It is useful when you want to install the safe base
    # aliases into a preexisting safe interpreter.
    proc ::safe::InterpInit {
	slave 
	access_path
	staticsok
	nestedok
	deletehook
    } {

	# Configure will generate an access_path when access_path is
	# empty.
	InterpConfigure $slave $access_path $staticsok $nestedok $deletehook;

	# These aliases let the slave load files to define new commands

	# NB we need to add [namespace current], aliases are always
	# absolute paths.
	::interp alias $slave source {} [namespace current]::AliasSource $slave
	::interp alias $slave load {} [namespace current]::AliasLoad $slave

	# This alias lets the slave have access to a subset of the 'file'
	# command functionality.

	AliasSubset $slave file file dir.* join root.* ext.* tail \
		path.* split

	# This alias interposes on the 'exit' command and cleanly terminates
	# the slave.

	::interp alias $slave exit {} [namespace current]::interpDelete $slave

	# The allowed slave variables already have been set
	# by Tcl_MakeSafe(3)


	# Source init.tcl into the slave, to get auto_load and other
	# procedures defined:

	# We don't try to use the -rsrc on the mac because it would get
	# confusing if you would want to customize init.tcl
	# for a given set of safe slaves, on all the platforms
	# you just need to give a specific access_path and
	# the mac should be no exception. As there is no
	# obvious full "safe ressources" design nor implementation
	# for the mac, safe interps there will just don't
	# have that ability. (A specific app can still reenable
	# that using custom aliases if they want to).
	# It would also make the security analysis and the Safe Tcl security
	# model platform dependant and thus more error prone.

	if {[catch {::interp eval $slave\
		{source [file join $tcl_library init.tcl]}}\
		msg]} {
	    Log $slave "can't source init.tcl ($msg)";
	    error "can't source init.tcl into slave $slave ($msg)"
	}

	return $slave
    }


    # Add (only if needed, avoid duplicates) 1 level of
    # sub directories to an existing path list.
    # Also removes non directories from the returned list.
    proc AddSubDirs {pathList} {
	set res {}
	foreach dir $pathList {
	    if {[file isdirectory $dir]} {
		# check that we don't have it yet as a children
		# of a previous dir
		if {[lsearch -exact $res $dir]<0} {
		    lappend res $dir;
		}
		foreach sub [glob -nocomplain -- [file join $dir *]] {
		    if {    ([file isdirectory $sub])
		         && ([lsearch -exact $res $sub]<0) } {
			# new sub dir, add it !
	                lappend res $sub;
	            }
		}
	    }
	}
	return $res;
    }

    # This procedure deletes a safe slave managed by Safe Tcl and
    # cleans up associated state:

    proc ::safe::interpDelete {slave} {

        Log $slave "About to delete" NOTICE;

	# If the slave has a cleanup hook registered, call it.
	# check the existance because we might be called to delete an interp
	# which has not been registered with us at all
	set hookname [DeleteHookName $slave];
	if {[Exists $hookname]} {
	    set hook [Set $hookname];
	    if {![::tcl::Lempty $hook]} {
		# remove the hook now, otherwise if the hook
		# calls us somehow, we'll loop
		Unset $hookname;
		if {[catch {eval $hook $slave} err]} {
		    Log $slave "Delete hook error ($err)";
		}
	    }
	}

	# Discard the global array of state associated with the slave, and
	# delete the interpreter.

	set statename [InterpStateName $slave];
	if {[Exists $statename]} {
	    Unset $statename;
	}

	# if we have been called twice, the interp might have been deleted
	# already
	if {[::interp exists $slave]} {
	    ::interp delete $slave;
	    Log $slave "Deleted" NOTICE;
	}

	return
    }

    # Set (or get) the loging mecanism 

proc ::safe::setLogCmd {args} {
    variable Log;
    if {[llength $args] == 0} {
	return $Log;
    } else {
	if {[llength $args] == 1} {
	    set Log [lindex $args 0];
	} else {
	    set Log $args
	}
    }
}

    # internal variable
    variable Log {}

    # ------------------- END OF PUBLIC METHODS ------------



    #
    # sets the slave auto_path to the master recorded value.
    # also sets tcl_library to the first token of the virtual path.
    #
    proc SyncAccessPath {slave} {
	set slave_auto_path [Set [VirtualPathListName $slave]];
	::interp eval $slave [list set auto_path $slave_auto_path];
	Log $slave \
		"auto_path in $slave has been set to $slave_auto_path"\
		NOTICE;
	::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]];
    }

    # base name for storing all the slave states
    # the array variable name for slave foo is thus "Sfoo"
    # and for sub slave {foo bar} "Sfoo bar" (spaces are handled
    # ok everywhere (or should))
    # We add the S prefix to avoid that a slave interp called Log
    # would smash our Log variable.
    proc InterpStateName {slave} {
	return "S$slave";
    }

    # returns the virtual token for directory number N
    # if the slave argument is given, 
    # it will return the corresponding master global variable name
    proc PathToken {n {slave ""}} {
	if {[string compare "" $slave]} {
	    return "[InterpStateName $slave](access_path,$n)";
	} else {
	    # We need to have a ":" in the token string so
	    # [file join] on the mac won't turn it into a relative
	    # path.
	    return "p(:$n:)";
	}
    }
    # returns the variable name of the complete path list
    proc PathListName {slave} {
	return "[InterpStateName $slave](access_path)";
    }
    # returns the variable name of the complete path list
    proc VirtualPathListName {slave} {
	return "[InterpStateName $slave](access_path_slave)";
    }
    # returns the variable name of the number of items
    proc PathNumberName {slave} {
	return "[InterpStateName $slave](access_path,n)";
    }
    # returns the staticsok flag var name
    proc StaticsOkName {slave} {
	return "[InterpStateName $slave](staticsok)";
    }
    # returns the nestedok flag var name
    proc NestedOkName {slave} {
	return "[InterpStateName $slave](nestedok)";
    }
    # Run some code at the namespace toplevel
    proc Toplevel {args} {
	namespace eval [namespace current] $args;
    }
    # set/get values
    proc Set {args} {
	eval Toplevel set $args;
    }
    # lappend on toplevel vars
    proc Lappend {args} {
	eval Toplevel lappend $args;
    }
    # unset a var/token (currently just an global level eval)
    proc Unset {args} {
	eval Toplevel unset $args;
    }
    # test existance 
    proc Exists {varname} {
	Toplevel info exists $varname;
    }
    # short cut for access path getting
    proc GetAccessPath {slave} {
	Set [PathListName $slave]
    }
    # short cut for statics ok flag getting
    proc StaticsOk {slave} {
	Set [StaticsOkName $slave]
    }
    # short cut for getting the multiples interps sub loading ok flag
    proc NestedOk {slave} {
	Set [NestedOkName $slave]
    }
    # interp deletion storing hook name
    proc DeleteHookName {slave} {
	return [InterpStateName $slave](cleanupHook)
    }

    #
    # translate virtual path into real path
    #
    proc TranslatePath {slave path} {
	# somehow strip the namespaces 'functionality' out (the danger
	# is that we would strip valid macintosh "../" queries... :
	if {[regexp {(::)|(\.\.)} $path]} {
	    error "invalid characters in path $path";
	}
	set n [expr [Set [PathNumberName $slave]]-1];
	for {} {$n>=0} {incr n -1} {
	    # fill the token virtual names with their real value
	    set [PathToken $n] [Set [PathToken $n $slave]];
	}
	# replaces the token by their value
	subst -nobackslashes -nocommands $path;
    }


    # Log eventually log an error
    # to enable error logging, set Log to {puts stderr} for instance
    proc Log {slave msg {type ERROR}} {
	variable Log;
	if {[info exists Log] && [llength $Log]} {
	    eval $Log [list "$type for slave $slave : $msg"];
	}
    }

    
    # file name control (limit access to files/ressources that should be
    # a valid tcl source file)
    proc CheckFileName {slave file} {
	# limit what can be sourced to .tcl
	# and forbid files with more than 1 dot and
	# longer than 14 chars
	set ftail [file tail $file];
	if {[string length $ftail]>14} {
	    error "$ftail: filename too long";
	}
	if {[regexp {\..*\.} $ftail]} {
	    error "$ftail: more than one dot is forbidden";
	}
	if {[string compare $ftail "tclIndex"] && \
		[string compare [string tolower [file extension $ftail]]\
		".tcl"]} {
	    error "$ftail: must be a *.tcl or tclIndex";
	}

	if {![file exists $file]} {
	    # don't tell the file path
	    error "no such file or directory";
	}

	if {![file readable $file]} {
	    # don't tell the file path
	    error "not readable";
	}

    }


    # AliasSource is the target of the "source" alias in safe interpreters.

    proc AliasSource {slave args} {

	set argc [llength $args];
	# Allow only "source filename"
	# (and not mac specific -rsrc for instance - see comment in ::init
	# for current rationale)
	if {$argc != 1} {
	    set msg "wrong # args: should be \"source fileName\""
	    Log $slave "$msg ($args)";
	    return -code error $msg;
	}
	set file [lindex $args 0]
	
	# get the real path from the virtual one.
	if {[catch {set file [TranslatePath $slave $file]} msg]} {
	    Log $slave $msg;
	    return -code error "permission denied"
	}
	
	# check that the path is in the access path of that slave
	if {[catch {FileInAccessPath $slave $file} msg]} {
	    Log $slave $msg;
	    return -code error "permission denied"
	}

	# do the checks on the filename :
	if {[catch {CheckFileName $slave $file} msg]} {
	    Log $slave "$file:$msg";
	    return -code error $msg;
	}

	# passed all the tests , lets source it:
	if {[catch {::interp invokehidden $slave source $file} msg]} {
	    Log $slave $msg;
	    return -code error "script error";
	}
	return $msg
    }

    # AliasLoad is the target of the "load" alias in safe interpreters.

    proc AliasLoad {slave file args} {

	set argc [llength $args];
	if {$argc > 2} {
	    set msg "load error: too many arguments";
	    Log $slave "$msg ($argc) {$file $args}";
	    return -code error $msg;
	}

	# package name (can be empty if file is not).
	set package [lindex $args 0];

	# Determine where to load. load use a relative interp path
	# and {} means self, so we can directly and safely use passed arg.
	set target [lindex $args 1];
	if {[string length $target]} {
	    # we will try to load into a sub sub interp
	    # check that we want to authorize that.
	    if {![NestedOk $slave]} {
		Log $slave "loading to a sub interp (nestedok)\
			disabled (trying to load $package to $target)";
		return -code error "permission denied (nested load)";
	    }
	    
	}

	# Determine what kind of load is requested
	if {[string length $file] == 0} {
	    # static package loading
	    if {[string length $package] == 0} {
		set msg "load error: empty filename and no package name";
		Log $slave $msg;
		return -code error $msg;
	    }
	    if {![StaticsOk $slave]} {
		Log $slave "static packages loading disabled\
			(trying to load $package to $target)";
		return -code error "permission denied (static package)";
	    }
	} else {
	    # file loading

	    # get the real path from the virtual one.
	    if {[catch {set file [TranslatePath $slave $file]} msg]} {
		Log $slave $msg;
		return -code error "permission denied"
	    }

	    # check the translated path
	    if {[catch {FileInAccessPath $slave $file} msg]} {
		Log $slave $msg;
		return -code error "permission denied (path)"
	    }
	}

	if {[catch {::interp invokehidden\
		$slave load $file $package $target} msg]} {
	    Log $slave $msg;
	    return -code error $msg
	}

	return $msg
    }

    # FileInAccessPath raises an error if the file is not found in
    # the list of directories contained in the (master side recorded) slave's
    # access path.

    # the security here relies on "file dirname" answering the proper
    # result.... needs checking ?
    proc FileInAccessPath {slave file} {

	set access_path [GetAccessPath $slave];

	if {[file isdirectory $file]} {
	    error "\"$file\": is a directory"
	}
	set parent [file dirname $file]
	if {[lsearch -exact $access_path $parent] == -1} {
	    error "\"$file\": not in access_path";
	}
    }

    # This procedure enables access from a safe interpreter to only a subset of
    # the subcommands of a command:

    proc Subset {slave command okpat args} {
	set subcommand [lindex $args 0]
	if {[regexp $okpat $subcommand]} {
	    return [eval {$command $subcommand} [lrange $args 1 end]]
	}
	set msg "not allowed to invoke subcommand $subcommand of $command";
	Log $slave $msg;
	error $msg;
    }

    # This procedure installs an alias in a slave that invokes "safesubset"
    # in the master to execute allowed subcommands. It precomputes the pattern
    # of allowed subcommands; you can use wildcards in the pattern if you wish
    # to allow subcommand abbreviation.
    #
    # Syntax is: AliasSubset slave alias target subcommand1 subcommand2...

    proc AliasSubset {slave alias target args} {
	set pat ^(; set sep ""
	foreach sub $args {
	    append pat $sep$sub
	    set sep |
	}
	append pat )\$
	::interp alias $slave $alias {}\
		[namespace current]::Subset $slave $target $pat
    }

}