suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

allow writes to temp dir in protected mode

Browse Source 
svn: r1439
This commit is contained in:
Matthew Flatt 2005-11-29 17:49:59 +00:00
parent e35276ff82
commit 6967a8fa64
2 changed files with 56 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/slideshow/doc.txt
View File

@ -36,7 +36,13 @@ On in DrScheme:
When you use the "Slideshow" executable or "slideshow" command-line
program, however, the slide program is prevented from writing to
the filesystem or creating network connections.
the filesystem or creating network connections, except that writes
to the system temporary directory are allowed.
(The system temporary directory is determined by calling
`find-system-path' with 'temp-dir; file writes are checked by
expanding the file path to resolve all symbolic links, and then
checking that the path starts with the tempoary-directory path.)
Slideshow Overview

48
collects/slideshow/start.ss
View File

@ -4,15 +4,58 @@
(lib "mred.ss" "mred")
(lib "class.ss"))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Path utilities
(define (resolve-path/complete p base)
(let ([p2 (resolve-path p)])
(if (complete-path? p2)
p2
(path->complete-path p2 base))))
(define (normal-path p)
(let loop ([p (simplify-path (expand-path (path->complete-path p)))])
(let-values ([(base name dir?) (split-path p)])
(if (path? base)
(let ([base (loop base)])
(let ([p (build-path base name)])
(resolve-path/complete p base)))
(resolve-path/complete p base)))))
(define (same-path? a b)
(let-values ([(abase aname adir?) (split-path a)]
[(bbase bname bdir?) (split-path b)])
(and (equal? aname bname)
(or (equal? abase bbase)
(and (path? abase)
(path? bbase)
(same-path? abase bbase))))))
(define (sub-path? a b)
(let-values ([(abase aname adir?) (split-path a)]
[(bbase bname bdir?) (split-path b)])
(or (and (equal? aname bname)
(or (and (not abase) (not bbase))
(and (path? abase)
(path? bbase)
(same-path? abase bbase))))
(and (path? abase)
(sub-path? abase b)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Loader with security guard
(define (load-content content)
(unless (trust-me?)
(current-security-guard
(make-security-guard (current-security-guard)
(lambda (who what mode)
(when (memq 'write mode)
(unless (sub-path? (normal-path what)
(normal-path (find-system-path 'temp-dir)))
(error 'slideshow
"slide program attempted to write to filesystem: ~e"
what))
what)))
(when (memq 'execute mode)
(error 'slideshow
"slide program attempted to execute external code: ~e"
@ -26,6 +69,9 @@
(when (file-to-load)
(load-content (string->path (file-to-load))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Run tutorial
(unless (most-recent-slide)
(let ([link (lambda (label thunk)
(clickback (colorize