~williewillus/r16

ref: bc7357c795b6e7d48c9ff8c82b803cfb4901922d r16/evaluator.rkt -rw-r--r-- 10.8 KiB
bc7357c7 — eutro Further evaluator cleanup 2 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
#lang racket

(require racket/contract racket/sandbox syntax/strip-context threading)

(provide
 definitions?
 run-result?
 (contract-out
  [run (string? definitions? predicate/c . -> . run-result?)]
  [run-result-stdout (run-result? . -> . string?)]
  [run-result-stderr (run-result? . -> . (or/c non-empty-string? #f))]
  [run-result-results (run-result? . -> . (listof any/c))]
  [run-result (string? (or/c non-empty-string? #f) (listof any/c) . -> . run-result?)]))

(define definitions? (cons/c (listof (cons/c symbol? any/c))
                             (listof module-path?)))

(define recursive-sandbox-call? (make-parameter #f))

;; in case it gets overridden, though sandbox-lib doesn't actually take this precaution
;; https://github.com/racket/racket/blob/6901f8d5511fd45516aa0a85ae070292e64226cc/pkgs/sandbox-lib/racket/sandbox.rkt#L705
(define ev
  (let ([eval-f (current-eval)])
    (lambda (expr)
      (parameterize ([current-eval eval-f])
        (eval expr)))))

(define (make-recursive-evaluator-namespace)
  (ev '(module recursive-trick racket))
  (dynamic-require ''recursive-trick #f)
  (module->namespace ''recursive-trick))

(define (init-evaluator)
  (parameterize ([sandbox-output 'string]
                 [sandbox-error-output 'string]
                 [sandbox-eval-limits '(30 20)]
                 [sandbox-propagate-exceptions #f]
                 [sandbox-make-environment-variables make-environment-variables])
    (make-evaluator 'racket)))

(define (code->exprs code)
  (parameterize ([read-accept-lang #t] [read-accept-reader #t])
    (sequence->list (in-producer read-syntax eof 'trick (open-input-string code)))))

(struct run-result (stdout stderr results) #:transparent)

(define (run code definitions pass-out?)
  (define (run-evaluation)
    ;; read and evaluate the code, yielding the results to be passed out
    ;; (to be called in the sandbox context)

    (recursive-sandbox-call? #t)

    (define exprs (code->exprs code))

    (define (not-module)
      ;; introduce definitions into the namespace dynamically
      (for ([mod (in-list (cdr definitions))])
        (namespace-require mod))
      (for ([def (in-list (car definitions))])
        (namespace-set-variable-value! (car def) (cdr def) #t))

      ;; evaluate `(begin exprs ...)' repl-style
      (if (null? exprs)
          null
          (let loop ([exprs exprs])
            (define expr #`(#%top-interaction . #,(car exprs)))
            (if (null? (cdr exprs))
                (call-with-values (thunk (ev expr)) list)
                (begin
                  (ev expr)
                  (loop (cdr exprs)))))))

    ;; there are two options for evaluating the code:
    ;; - the code is a series of top level expressions:
    ;;   - in this case, just evaluate them like `(begin exprs ...)'
    ;;     see `not-module' above
    ;; - the code is a module:
    ;;   - this case is a bit more complicated, since we want
    ;;     r16 definitions as well, see below
    (define raw-results
      (call/cc
       (lambda (return)
         ;; sorry for the imperative-style return
         (unless (= (length exprs) 1) (return (not-module)))

         (define (literal-identifier=? a b) ;; to match `module' better
           (or (free-identifier=? a b)
               (eq? (syntax-e a) (syntax-e b))))

         (syntax-case* (car exprs) (module) literal-identifier=?
           [(module modname lang body ...)
            (let ()
              (define varnames (map car (car definitions)))
              (define (eval-quote form) (cons '#%datum form))
              (define varvals (map (compose eval-quote cdr) (car definitions)))
              (define modules (cdr definitions))
              ;; define a module that provides all of the sandbox definitions
              ;; in addition to those of the requested lang
              (ev #`(module sandbox-language racket/base
                      ;; require and provide any defined modules
                      (provide (all-from-out #,@modules))
                      (require #,@modules)

                      ;; define and provide any defined variables
                      (provide #,@varnames)
                      (define-values (#,@varnames) (values #,@varvals))

                      ;; require and provide the lang of the module that was read
                      (#%provide (all-from lang))
                      (require lang)))

              ;; then evaluate the module with the new language
              (define trick-module
                #'(module modname 'sandbox-language
                    body ...))
              (ev (replace-context trick-module trick-module))

              ;; to actually pass any values out, `r16-main' can be provided,
              ;; otherwise the module is just instantiated for side-effects

              (define qmodname (syntax->datum #''modname))

              (define main
                (dynamic-require
                 qmodname 'r16-main
                 (thunk (dynamic-require qmodname #f))))

              (if (and (procedure? main)
                       (procedure-arity-includes? main 0))
                  (call-with-values main list)
                  (list main)))]

           [_ (not-module)]))))

    (define (pass-out-results results)
      (for/list ([result (in-list results)]
                 #:when (not (void? result)))
        (if (pass-out? result)
            result
            (~a result))))

    (apply values (pass-out-results raw-results)))

  (define-values (stdout results stderr)
    (if (recursive-sandbox-call?)
        (let ()
          (define stdout-port (open-output-string))
          (define stderr-port (open-output-string))
          (define results
            (parameterize ([current-output-port stdout-port]
                           [current-error-port stderr-port]
                           [current-namespace (make-recursive-evaluator-namespace)])
              (call-with-values run-evaluation list)))
          (values (get-output-string stdout-port)
                  results
                  (get-output-string stderr-port)))

        (let ()
          (define evaluator (init-evaluator))
          (define results
            (~> (thunk (call-in-sandbox-context evaluator run-evaluation))
                (call-with-values _ list)
                ;; call-in-sandbox-context returns void if there's an exception
                (filter-not void? _)))
          (define stdout (get-output evaluator))
          (define stderr (get-error-output evaluator))
          (kill-evaluator evaluator)
          (values stdout results stderr))))

  (run-result stdout (and (non-empty-string? stderr) stderr) results))

(module+ test
  (require rackunit)

  (define empty-defs '(()))
  (define (any? _ignored) #t)

  (test-case "Empty Test"
    (check-equal?
     (run "" empty-defs any?)
     (run-result "" #f '())))

  (test-case "Single Expr Test"
    (check-equal?
     (run "1" empty-defs any?)
     (run-result "" #f '(1)))
    (check-equal?
     (run (~s `(+ 1 2)) empty-defs any?)
     (run-result "" #f '(3)))
    (check-equal?
     (run (~s `(values 1 2 3)) empty-defs any?)
     (run-result "" #f '(1 2 3))))

  (test-case "Multiple Expr Test"
    (check-equal?
     (run "1 2 3" empty-defs any?)
     (run-result "" #f '(3)))
    (check-equal?
     (run (~s '(define x 100)
              'x)
          empty-defs any?)
     (run-result "" #f '(100))))

  (test-case "Stdio Test"
    (check-equal?
     (run (~s `(display "stdout test"))
          empty-defs any?)
     (run-result "stdout test" #f '()))
    (check-equal?
     (run (~s `(display "stderr test" (current-error-port)))
          empty-defs any?)
     (run-result "" "stderr test" '())))

  (test-case "Module Test"
    (check-equal?
     (run (~s `(module test racket
                 1
                 2
                 3))
          empty-defs any?)
     (run-result "1\n2\n3\n" #f '()))
    (check-equal?
     (run "#lang racket\
           1 2 3"
          empty-defs any?)
     (run-result "1\n2\n3\n" #f '()))
    (check-equal?
     (run (string-append
           "#lang racket\n"
           (~s `(provide r16-main)
               `(define r16-main 100)))
          empty-defs any?)
     (run-result "" #f '(100)))
    (check-equal?
     (run (string-append
           "#lang racket\n"
           (~s `(provide r16-main)
               `(define (r16-main) (values 1 2 3))))
          empty-defs any?)
     (run-result "" #f '(1 2 3))))

  (test-case "Binding Test"
    (define xv (box "box"))
    (let ()
      (define rr (run "x" `(((x . ,xv))) any?))
      (check-false (run-result-stderr rr))
      (check-equal? (~> rr run-result-results car) xv))
    (let ()
      (define rr
        (run (~s `(module test racket
                    (provide r16-main)
                    (define (r16-main) x)))
             `(((x . ,xv))) any?))
      (check-false (run-result-stderr rr))
      ;; not necessarily eq? unfortunately
      (check-equal? (~> rr run-result-results car) xv)))

  (define ((run-fn defs) expr)
    (apply values (run-result-results (run expr defs any?))))

  (test-case "Recursive Call Test"
    (check-equal?
     (run (~s `(run (~s `(+ 1 2 3))))
          `(((run . ,(run-fn empty-defs))))
          any?)
     (run-result "" #f '(6))))

  (require racket/draw)

  (test-case "Reused Instantation Test"
    ;; bitmap% IN the sandbox is still different to that outside
    (check-false
     (~> (run
          (~s `(require racket/draw)
              `(make-bitmap 1 1))
          empty-defs
          any?)
         run-result-results
         car
         (is-a? _ bitmap%)))

    (check-equal?
     (run
      (~s `(require racket/draw)
          `(define bmp
             (run (~s `(require racket/draw)
                      `(make-bitmap 1 1))))
          `(is-a? bmp bitmap%))
      `(((run . ,(run-fn empty-defs))))
      any?)
     (run-result "" #f '(#t)))

    (check-equal?
     (run
      (~s `(require racket/draw)
          `(define bmp
             (run (~s `(require racket/draw)
                      `(run (~s `(require racket/draw)
                                `(make-bitmap 1 1))))))
          `(is-a? bmp bitmap%))
      `(((run . ,(run-fn `(((run . ,(run-fn empty-defs))))))))
      any?)
     (run-result "" #f '(#t))))

  (test-case "Namespace Hygiene Test"
    (check-equal?
     (run (~s `(define x 'x-value)
              `(foil-namespace)
              `x)
          `(((foil-namespace
              .
              ,(thunk
                (run (~s `(for ([sym (in-list (namespace-mapped-symbols))])
                            (namespace-undefine-variable! sym)))
                     empty-defs any?)))))
          any?)
     (run-result "" #f '(x-value))))

  (test-case "Exn Test"
    (check-not-false
     (run-result-stderr
      (run (~s `(raise "err"))
           empty-defs any?)))
    (check-not-false
     (run-result-stderr
      (run (~s `(run (~s `(raise "err"))))
           `(((run . ,(run-fn empty-defs))))
           any?)))))