forked from syndicate-lang/marketplace-ssh-2014
55 lines
1.8 KiB
Racket
55 lines
1.8 KiB
Racket
#lang racket/base
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
;;; Sandbox management and use.
|
|
|
|
(require racket/match)
|
|
(require racket/sandbox)
|
|
(require (only-in racket/exn exn->string))
|
|
|
|
(provide repl-shell)
|
|
|
|
(struct user-state (name primary-sandbox primary-namespace) #:transparent)
|
|
|
|
(define *user-states* (make-hash))
|
|
|
|
(define (get-user-state username)
|
|
(when (not (hash-has-key? *user-states* username))
|
|
(let* ((sb (make-evaluator 'racket/base))
|
|
(ns (call-in-sandbox-context sb current-namespace)))
|
|
(hash-set! *user-states* username
|
|
(user-state username
|
|
sb
|
|
ns))))
|
|
(hash-ref *user-states* username))
|
|
|
|
(define (repl-shell username in out [err out])
|
|
(match-define (user-state _ primary-sandbox primary-namespace) (get-user-state username))
|
|
(parameterize ((current-input-port in)
|
|
(current-output-port out)
|
|
(current-error-port err)
|
|
(sandbox-input in)
|
|
(sandbox-output out)
|
|
(sandbox-error-output err)
|
|
(sandbox-memory-limit 2) ;; megabytes
|
|
(sandbox-eval-limits #f)
|
|
(sandbox-namespace-specs (list (lambda () primary-namespace))))
|
|
(printf "Hello, ~a.\n" username)
|
|
(define secondary-sandbox (make-evaluator '(begin)))
|
|
;; ^^ uses primary-namespace via sandbox-namespace-specs
|
|
(parameterize ((current-namespace primary-namespace)
|
|
(current-eval secondary-sandbox))
|
|
(let restart ()
|
|
(with-handlers ([exn?
|
|
(lambda (e)
|
|
(fprintf err "~a" (exn->string e))
|
|
(flush-output err)
|
|
(restart))])
|
|
(read-eval-print-loop))))
|
|
(fprintf out "\nGoodbye!\n")
|
|
(kill-evaluator secondary-sandbox)
|
|
(close-input-port in)
|
|
(close-output-port out)
|
|
(close-output-port err)))
|