From 49952e580bd3285a8b5d90dc10d233d81f97c342 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 8 Jan 2011 16:37:58 -0600
Subject: [PATCH] adjust scribble's in-drracket html generator button to use
 the sandbox so user code cannot corrupt drracket.   related to PR 11601

---
 collects/scribble/tools/drracket-buttons.rkt | 82 +++++++++++++-------
 1 file changed, 53 insertions(+), 29 deletions(-)

diff --git a/collects/scribble/tools/drracket-buttons.rkt b/collects/scribble/tools/drracket-buttons.rkt
index c1f9184401..36f5eb1881 100644
--- a/collects/scribble/tools/drracket-buttons.rkt
+++ b/collects/scribble/tools/drracket-buttons.rkt
@@ -1,12 +1,13 @@
-#lang scheme/base
+#lang racket/base
 
-(require scheme/runtime-path
-         scheme/gui/base
-         scheme/class
+(require racket/runtime-path
+         racket/gui/base
+         racket/class
          mrlib/bitmap-label
-         scheme/system
+         racket/system
          setup/xref
-         net/sendurl)
+         net/sendurl
+         racket/sandbox)
 
 (provide drracket-buttons)
 
@@ -17,6 +18,8 @@
 
 (define-namespace-anchor anchor)
 
+(define original-error-display-handler (error-display-handler))
+
 (define (make-render-button label bmp mode suffix extra-cmdline)
   (list 
    label
@@ -25,30 +28,51 @@
      (let* ([t (send drs-frame get-definitions-text)]
             [fn (send t get-filename)])
        (if fn
-           (begin
+           (let ()
              (send t save-file fn)
-             (let-values ([(p) (open-output-string)]
-                          [(base name dir?) (split-path fn)])
-               (parameterize ([current-namespace (make-base-namespace)]
-                              [current-output-port p]
-                              [current-error-port p]
-                              [current-directory base]
-                              [current-command-line-arguments
-                               (list->vector 
-                                (append
-                                 extra-cmdline
-                                 (list "--quiet")
-                                 (list mode (if (path? fn) (path->string fn) fn))))])
-                 (namespace-attach-module (namespace-anchor->empty-namespace anchor) 'setup/xref)
-                 (dynamic-require 'scribble/run #f)
-                 (cond
-                   [(equal? suffix #".html")
-                    (send-url/file (path-replace-suffix fn suffix))]
-                   [else
-                    (system (format "open ~s" (path->string (path-replace-suffix fn suffix))))]))
-               (let ([s (get-output-string p)])
-                 (unless (equal? s "")
-                   (message-box "Scribble" s drs-frame)))))
+             (define p (open-output-string))
+             (define-values (base name dir?) (split-path fn))
+             (define sb 
+               (parameterize ([sandbox-security-guard (current-security-guard)])
+                 (make-evaluator 'racket/base)))
+             (define result
+               (call-in-sandbox-context
+                sb
+                (λ ()
+                  (with-handlers (((λ (x) #t) (λ (e) (list 'exn e))))
+                    (parameterize ([current-output-port p]
+                                   [current-error-port p]
+                                   [current-directory base]
+                                   [error-display-handler original-error-display-handler]
+                                   [current-command-line-arguments
+                                    (list->vector 
+                                     (append
+                                      extra-cmdline
+                                      (list "--quiet")
+                                      (list mode (if (path? fn) (path->string fn) fn))))])
+                      (namespace-attach-module (namespace-anchor->empty-namespace anchor) 'setup/xref)
+                      (dynamic-require 'scribble/run #f)
+                      (list 'normal))))))
+             (cond
+               [(eq? (list-ref result 0) 'exn)
+                (define exn (list-ref result 1))
+                (define sp (open-output-string))
+                (cond
+                  [(exn? exn)
+                   (fprintf sp "~a\n" (exn-message exn))
+                   (for ([x (in-list (continuation-mark-set->context (exn-continuation-marks exn)))])
+                     (fprintf sp "  ~s\n" x))]
+                  [else
+                   (fprintf sp "uncaught exn: ~s\n" exn)])
+                (message-box "Scribble HTML - DrRacket"
+                             (get-output-string sp))]
+               [(equal? suffix #".html")
+                (send-url/file (path-replace-suffix fn suffix))]
+               [else
+                (system (format "open ~s" (path->string (path-replace-suffix fn suffix))))])
+             (let ([s (get-output-string p)])
+               (unless (equal? s "")
+                 (message-box "Scribble" s drs-frame))))
            (message-box "Scribble" "Cannot render buffer without filename"))))))
 
 (define drracket-buttons