#lang scheme

(require scheme/sandbox
         "define.ss")

(provide make-trusted-evaluator
         make-trusted-module-evaluator
         make-scribble-evaluator
         make-scribble-module-evaluator
         make-sandbox-namespace-specs)

;; Needed for legacy versions of scheme/sandbox
(define-if-unbound (call-with-trusted-sandbox-configuration thunk)
  (parameterize ([sandbox-propagate-breaks    #t]
                 [sandbox-override-collection-paths '()]
                 [sandbox-security-guard      (current-security-guard)]
                 [sandbox-make-inspector      current-inspector]
                 [sandbox-make-logger         current-logger]
                 [sandbox-eval-limits         #f])
    (thunk)))

(define make-trusted-evaluator
  (make-keyword-procedure
   (lambda (keys vals . args)
     (call-with-trusted-sandbox-configuration
      (lambda ()
        (keyword-apply make-evaluator keys vals args))))))

(define make-trusted-module-evaluator
  (make-keyword-procedure
   (lambda (keys vals . args)
     (call-with-trusted-sandbox-configuration
      (lambda ()
        (keyword-apply make-module-evaluator keys vals args))))))

(define make-scribble-evaluator
  (make-keyword-procedure
   (lambda (keys vals . args)
     (parameterize ([sandbox-output 'string]
                    [sandbox-error-output 'string])
       (keyword-apply make-trusted-evaluator keys vals args)))))

(define make-scribble-module-evaluator
  (make-keyword-procedure
   (lambda (keys vals . args)
     (parameterize ([sandbox-output 'string]
                    [sandbox-error-output 'string])
       (keyword-apply make-trusted-module-evaluator keys vals args)))))

(define (make-sandbox-namespace-specs make-ns . paths)

  (define parent
    (delay
      (let* ([ns (make-ns)])
        (parameterize ([current-namespace ns])
          (for ([path (in-list paths)])
            (dynamic-require path #f)))
        ns)))

  (define (make-child)
    (let* ([ns (make-ns)])
      (parameterize ([current-namespace ns])
        (for ([path (in-list paths)])
          (namespace-attach-module (force parent) path)))
      ns))

  (list make-child))