From eab6803895a05a3ed92eea33b2c4ac1a4652e7ec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 24 Sep 2009 14:54:15 +0000 Subject: [PATCH] change sandbox to allow read from the planet directory; delay some path calculations in other libraries to avoid sandbox prohibitions (but the ones in Scribble seem like too much) svn: r16122 --- collects/dynext/compile-unit.ss | 2 +- collects/dynext/link-unit.ss | 14 ++++---- collects/dynext/private/dirs.ss | 4 +-- collects/scheme/sandbox.ss | 4 ++- collects/scribble/private/manual-bib.ss | 3 +- collects/scribble/private/manual-proc.ss | 5 +-- collects/scribble/private/manual-sprop.ss | 6 ++-- collects/scribble/private/manual-style.ss | 9 ++--- collects/scribble/private/on-demand.ss | 10 ++++++ collects/scribble/scheme.ss | 43 ++++++++++++----------- collects/setup/private/omitted-paths.ss | 15 ++++---- 11 files changed, 67 insertions(+), 48 deletions(-) create mode 100644 collects/scribble/private/on-demand.ss diff --git a/collects/dynext/compile-unit.ss b/collects/dynext/compile-unit.ss index 8e1e9a2b5d..ddc8783b7f 100644 --- a/collects/dynext/compile-unit.ss +++ b/collects/dynext/compile-unit.ss @@ -286,7 +286,7 @@ (lambda (s) ((current-make-compile-include-strings) s)) includes)) - ((current-make-compile-include-strings) include-dir) + ((current-make-compile-include-strings) (include-dir)) ((current-make-compile-input-strings) in) ((current-make-compile-output-strings) out))]) (unless quiet? diff --git a/collects/dynext/link-unit.ss b/collects/dynext/link-unit.ss index cf2849e587..5febbf779e 100644 --- a/collects/dynext/link-unit.ss +++ b/collects/dynext/link-unit.ss @@ -135,9 +135,9 @@ "-brtl" (lambda () (map (lambda (mz-exp) - (format "-bI:~a/~a" include-dir mz-exp)) + (format "-bI:~a/~a" (include-dir) mz-exp)) ((wrap-3m "mzscheme~a.exp")))) - (format "-bE:~a/ext.exp" include-dir) + (format "-bE:~a/ext.exp" (include-dir)) "-bnoentry")] [(parisc-hpux) (list "-b")] [(ppc-macosx ppc-darwin x86_64-macosx x86_86-darwin) mac-link-flags] @@ -186,7 +186,7 @@ "," "," "c0d32.obj" "cw32.lib" "import32.lib" (if (current-use-mzdyn) (list "," (path->string - (build-path std-library-dir + (build-path (std-library-dir) "bcc" "mzdynb.def"))) null)))) @@ -212,7 +212,7 @@ (define (make-win-link-libraries win-gcc? win-borland? unix?) (let* ([file (lambda (f) (path->string - (build-path std-library-dir + (build-path (std-library-dir) (cond [win-gcc? "gcc"] [win-borland? "bcc"] @@ -220,7 +220,7 @@ f)))] [dllfile (lambda (f) (path->string - (build-path std-library-dir f)))] + (build-path (std-library-dir) f)))] [filethunk (lambda (f) (lambda () (map file (f))))] @@ -263,7 +263,7 @@ (list (lambda () (if (current-use-mzdyn) (map (lambda (mz.o) - (path->string (build-path std-library-dir mz.o))) + (path->string (build-path (std-library-dir) mz.o))) ((wrap-3m "mzdyn~a.o"))) null)))])) @@ -369,7 +369,7 @@ ;; Generate DLL link information `("--dllname" ,(if (path? out) (path->string out) out) ,@(if (current-use-mzdyn) - `("--def" ,(path->string (build-path std-library-dir "gcc" "mzdyn.def"))) + `("--def" ,(path->string (build-path (std-library-dir) "gcc" "mzdyn.def"))) `()) "--base-file" ,basefile "--output-exp" ,(path->string expfile))] diff --git a/collects/dynext/private/dirs.ss b/collects/dynext/private/dirs.ss index 888d925889..1bebd11207 100644 --- a/collects/dynext/private/dirs.ss +++ b/collects/dynext/private/dirs.ss @@ -2,7 +2,7 @@ (module dirs mzscheme (require setup/dirs) - (define include-dir (find-include-dir)) - (define std-library-dir (find-lib-dir)) + (define include-dir find-include-dir) + (define std-library-dir find-lib-dir) (provide include-dir std-library-dir)) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index d63694396e..8336322b00 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -4,7 +4,8 @@ scheme/list scheme/string syntax/moddep - scheme/gui/dynamic) + scheme/gui/dynamic + planet/config) (provide gui? sandbox-init-hook @@ -843,6 +844,7 @@ [sandbox-path-permissions `(,@(map (lambda (p) `(read-bytecode ,p)) (current-library-collection-paths)) + (read-bytecode ,(PLANET-BASE-DIR)) (exists ,(find-system-path 'addon-dir)) ,@(compute-permissions allow) ,@(sandbox-path-permissions))] diff --git a/collects/scribble/private/manual-bib.ss b/collects/scribble/private/manual-bib.ss index e5c75b6959..2e5b70b1e3 100644 --- a/collects/scribble/private/manual-bib.ss +++ b/collects/scribble/private/manual-bib.ss @@ -3,6 +3,7 @@ "../decode.ss" "../struct.ss" "../basic.ss" + "on-demand.ss" (only-in "../core.ss" make-style) "manual-sprop.ss" "manual-utils.ss" @@ -64,7 +65,7 @@ (if date `(" " ,@(decode-content (list date)) ".") null) (if url `(" " ,(link url (tt url))) null))))) -(define bib-style (make-style "SBibliography" scheme-properties)) +(define-on-demand bib-style (make-style "SBibliography" scheme-properties)) (define (bibliography #:tag [tag "doc-bibliography"] . citations) (make-unnumbered-part diff --git a/collects/scribble/private/manual-proc.ss b/collects/scribble/private/manual-proc.ss index 47879aee7a..9b8f4bb53d 100644 --- a/collects/scribble/private/manual-proc.ss +++ b/collects/scribble/private/manual-proc.ss @@ -13,6 +13,7 @@ "manual-bind.ss" "manual-method.ss" "manual-ex.ss" + "on-demand.ss" scheme/string scheme/list (for-syntax scheme/base) @@ -26,9 +27,9 @@ ;; private: *defthing) ; XXX unknown contract -(define dots0 +(define-on-demand dots0 (make-element meta-color (list "..."))) -(define dots1 +(define-on-demand dots1 (make-element meta-color (list "...+"))) (define (make-openers n) diff --git a/collects/scribble/private/manual-sprop.ss b/collects/scribble/private/manual-sprop.ss index bb205fa8ff..349a73ce65 100644 --- a/collects/scribble/private/manual-sprop.ss +++ b/collects/scribble/private/manual-sprop.ss @@ -2,11 +2,13 @@ (require "../html-properties.ss" "../latex-properties.ss" - setup/main-collects) + "on-demand.ss" + setup/main-collects + scheme/promise) (provide scheme-properties) -(define scheme-properties +(define-on-demand scheme-properties (let ([abs (lambda (s) (path->main-collects-relative (build-path (collection-path "scribble") s)))]) (list (make-css-addition (abs "scheme.css")) diff --git a/collects/scribble/private/manual-style.ss b/collects/scribble/private/manual-style.ss index b8c293394b..a47424ae6b 100644 --- a/collects/scribble/private/manual-style.ss +++ b/collects/scribble/private/manual-style.ss @@ -6,6 +6,7 @@ "../scheme.ss" (only-in "../core.ss" make-style plain) "manual-utils.ss" + "on-demand.ss" scheme/list scheme/contract scheme/string) @@ -28,10 +29,10 @@ onscreen defterm filepath exec envvar Flag DFlag PFlag DPFlag math procedure indexed-file indexed-envvar idefterm pidefterm) +(provide void-const + undefined-const) (provide/contract [PLaneT element?] - [void-const element?] - [undefined-const element?] [hash-lang (-> element?)] [etc string?] [inset-flow (() () #:rest (listof pre-content?) . ->* . any/c)] ; XXX no docs and bad return contract @@ -152,9 +153,9 @@ (list (schememodfont "#lang")) `(part ,(doc-prefix '(lib "scribblings/guide/guide.scrbl") "hash-lang")))) -(define void-const +(define-on-demand void-const (schemeresultfont "#")) -(define undefined-const +(define-on-demand undefined-const (schemeresultfont "#")) (define (link url diff --git a/collects/scribble/private/on-demand.ss b/collects/scribble/private/on-demand.ss new file mode 100644 index 0000000000..038db1f18e --- /dev/null +++ b/collects/scribble/private/on-demand.ss @@ -0,0 +1,10 @@ +#lang scheme +(provide define-on-demand) + +(define-syntax-rule (define-on-demand id rhs) + (begin + (define val (delay rhs)) + (define-syntax (id stx) + (if (identifier? stx) + #'(force val) + (raise-syntax-error #f "bad syntax" stx))))) \ No newline at end of file diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index 9546eae08a..be6e34538a 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -3,6 +3,7 @@ "basic.ss" "search.ss" "private/manual-sprop.ss" + "private/on-demand.ss" mzlib/class mzlib/for syntax/modresolve @@ -57,27 +58,27 @@ (cons 'tt-chars scheme-properties) scheme-properties))) - (define output-color (make-scheme-style "ScmOut")) - (define input-color (make-scheme-style "ScmIn")) - (define input-background-color (make-scheme-style "ScmInBG")) - (define no-color (make-scheme-style "ScmPlain")) - (define reader-color (make-scheme-style "ScmRdr")) - (define result-color (make-scheme-style "ScmRes")) - (define keyword-color (make-scheme-style "ScmKw")) - (define comment-color (make-scheme-style "ScmCmt")) - (define paren-color (make-scheme-style "ScmPn")) - (define meta-color (make-scheme-style "ScmMeta")) - (define value-color (make-scheme-style "ScmVal")) - (define symbol-color (make-scheme-style "ScmSym")) - (define variable-color (make-scheme-style "ScmVar")) - (define opt-color (make-scheme-style "ScmOpt")) - (define error-color (make-scheme-style "ScmErr" #:tt? #f)) - (define syntax-link-color (make-scheme-style "ScmStxLink")) - (define value-link-color (make-scheme-style "ScmValLink")) - (define module-color (make-scheme-style "ScmMod")) - (define module-link-color (make-scheme-style "ScmModLink")) - (define block-color (make-scheme-style "ScmBlk")) - (define highlighted-color (make-scheme-style "highlighted" #:tt? #f)) + (define-on-demand output-color (make-scheme-style "ScmOut")) + (define-on-demand input-color (make-scheme-style "ScmIn")) + (define-on-demand input-background-color (make-scheme-style "ScmInBG")) + (define-on-demand no-color (make-scheme-style "ScmPlain")) + (define-on-demand reader-color (make-scheme-style "ScmRdr")) + (define-on-demand result-color (make-scheme-style "ScmRes")) + (define-on-demand keyword-color (make-scheme-style "ScmKw")) + (define-on-demand comment-color (make-scheme-style "ScmCmt")) + (define-on-demand paren-color (make-scheme-style "ScmPn")) + (define-on-demand meta-color (make-scheme-style "ScmMeta")) + (define-on-demand value-color (make-scheme-style "ScmVal")) + (define-on-demand symbol-color (make-scheme-style "ScmSym")) + (define-on-demand variable-color (make-scheme-style "ScmVar")) + (define-on-demand opt-color (make-scheme-style "ScmOpt")) + (define-on-demand error-color (make-scheme-style "ScmErr" #:tt? #f)) + (define-on-demand syntax-link-color (make-scheme-style "ScmStxLink")) + (define-on-demand value-link-color (make-scheme-style "ScmValLink")) + (define-on-demand module-color (make-scheme-style "ScmMod")) + (define-on-demand module-link-color (make-scheme-style "ScmModLink")) + (define-on-demand block-color (make-scheme-style "ScmBlk")) + (define-on-demand highlighted-color (make-scheme-style "highlighted" #:tt? #f)) (define current-keyword-list (make-parameter null)) diff --git a/collects/setup/private/omitted-paths.ss b/collects/setup/private/omitted-paths.ss index 4e560cb6c4..ffe46fea4f 100644 --- a/collects/setup/private/omitted-paths.ss +++ b/collects/setup/private/omitted-paths.ss @@ -9,7 +9,7 @@ (provide omitted-paths) -(require scheme/path scheme/list "../dirs.ss" "lib-roots.ss") +(require scheme/path scheme/list scheme/promise "../dirs.ss" "lib-roots.ss") ;; An entry for each collections root that holds a hash table. The hash table ;; maps a reversed list of subpath elements to the exploded omitted-paths @@ -19,11 +19,12 @@ ;; main collection tree (it is not used there for documentation, and there is ;; at least one place where it contains code: scribble/doc). (define roots - (map (lambda (p) - (list (explode-path (car p)) (make-hash) - ;; don't omit "doc" in the main tree - (not (equal? (find-collects-dir) (car p))))) - library-roots)) + (delay + (map (lambda (p) + (list (explode-path (car p)) (make-hash) + ;; don't omit "doc" in the main tree + (not (equal? (find-collects-dir) (car p))))) + library-roots))) ;; if `x' has `y' as a prefix, return the tail, ;; eg (relative-from '(1 2 3 4) '(1 2)) => '(3 4) @@ -89,7 +90,7 @@ [r (ormap (lambda (root+table) (let ([r (relative-from dir* (car root+table))]) (and r (cons (reverse r) root+table)))) - roots)] + (force roots))] [r (and r (apply accumulate-omitted get-info/full r))]) (unless r (error 'omitted-paths