349 lines
14 KiB
Scheme
349 lines
14 KiB
Scheme
(module utils mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "posn.ss" "lang")
|
|
"private/run-status.ss"
|
|
"private/config.ss"
|
|
(prefix pc: (lib "pconvert.ss"))
|
|
(lib "pretty.ss")
|
|
(lib "list.ss")
|
|
(lib "string.ss")
|
|
(only "handin-server.ss" timeout-control))
|
|
|
|
(provide get-conf
|
|
|
|
unpack-submission
|
|
|
|
make-evaluator
|
|
make-evaluator/submission
|
|
evaluate-all
|
|
evaluate-submission
|
|
|
|
call-with-evaluator
|
|
call-with-evaluator/submission
|
|
reraise-exn-as-submission-problem
|
|
current-run-status
|
|
message
|
|
current-value-printer
|
|
|
|
coverage-enabled
|
|
|
|
check-proc
|
|
check-defined
|
|
look-for-tests
|
|
user-construct
|
|
test-history-enabled
|
|
|
|
timeout-control)
|
|
|
|
(define (unpack-submission str)
|
|
(let* ([base (make-object editor-stream-in-bytes-base% str)]
|
|
[stream (make-object editor-stream-in% base)]
|
|
[definitions-text (make-object text%)]
|
|
[interactions-text (make-object text%)])
|
|
(read-editor-version stream base #t)
|
|
(read-editor-global-header stream)
|
|
(send definitions-text read-from-file stream)
|
|
(send interactions-text read-from-file stream)
|
|
(read-editor-global-footer stream)
|
|
(values definitions-text interactions-text)))
|
|
|
|
;; Protection ---------------------------------------
|
|
|
|
(define ok-path-re
|
|
(regexp
|
|
(string-append
|
|
"^(?:"
|
|
(apply string-append
|
|
(cdr (apply append
|
|
(map (lambda (p)
|
|
(list "|" (regexp-quote (path->string p))))
|
|
(current-library-collection-paths)))))
|
|
")(?:/|$)")))
|
|
|
|
(define tight-security
|
|
(make-security-guard
|
|
(current-security-guard)
|
|
(lambda (what path modes)
|
|
(when (or (memq 'write modes)
|
|
(memq 'execute modes)
|
|
(memq 'delete modes)
|
|
(and path (not (regexp-match ok-path-re (path->string path)))))
|
|
(error what "file access denied (~a)" path)))
|
|
(lambda (what host port mode) (error what "network access denied"))))
|
|
|
|
(define null-input (open-input-string ""))
|
|
(define (safe-eval expr . more)
|
|
(parameterize ([current-security-guard tight-security]
|
|
[current-input-port null-input]
|
|
;; breaks: [current-code-inspector (make-inspector)]
|
|
)
|
|
(apply eval expr more)))
|
|
|
|
;; Execution ----------------------------------------
|
|
|
|
(define coverage-enabled (make-parameter #f))
|
|
|
|
(define modules-to-attach
|
|
(list '(lib "posn.ss" "lang")
|
|
'(lib "cache-image-snip.ss" "mrlib")))
|
|
|
|
(define (make-evaluation-namespace)
|
|
(let ([new-ns (make-namespace-with-mred)]
|
|
[orig-ns (current-namespace)])
|
|
(for-each (lambda (mod) (dynamic-require mod #f))
|
|
modules-to-attach)
|
|
(let ([modsyms
|
|
(map (lambda (mod) ((current-module-name-resolver) mod #f #f))
|
|
modules-to-attach)])
|
|
(parameterize ((current-namespace new-ns))
|
|
(for-each (lambda (ms) (namespace-attach-module orig-ns ms))
|
|
modsyms)))
|
|
new-ns))
|
|
|
|
(define (make-evaluator language teachpacks program-port)
|
|
(let ([coverage-enabled (coverage-enabled)]
|
|
[uncovered-expressions #f]
|
|
[ns (make-evaluation-namespace)]
|
|
[orig-ns (current-namespace)])
|
|
(parameterize ([current-namespace ns]
|
|
[read-case-sensitive #t]
|
|
[read-decimal-as-inexact #f]
|
|
[current-inspector (make-inspector)])
|
|
(parameterize ([current-eventspace (make-eventspace)])
|
|
(let ([ch (make-channel)]
|
|
[result-ch (make-channel)])
|
|
(queue-callback
|
|
(lambda ()
|
|
;; First read program and evaluate it as a module:
|
|
(with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))])
|
|
(let* ([body
|
|
(parameterize ([read-case-sensitive #t]
|
|
[read-decimal-as-inexact #f])
|
|
(let loop ([l null])
|
|
(let ([expr (read-syntax 'program program-port)])
|
|
(if (eof-object? expr)
|
|
(reverse l)
|
|
(loop (cons expr l))))))]
|
|
[body (append (if (and (pair? teachpacks)
|
|
(eq? 'begin (car teachpacks)))
|
|
(cdr teachpacks)
|
|
(map (lambda (tp)
|
|
`(,#'require
|
|
,(if (pair? tp)
|
|
tp `(file ,tp))))
|
|
teachpacks))
|
|
body)]
|
|
[body
|
|
(cond
|
|
[(and (symbol? language)
|
|
(memq language '(beginner
|
|
beginner-abbr
|
|
intermediate
|
|
intermediate-lambda
|
|
advanced)))
|
|
`(module m
|
|
(lib ,(case language
|
|
[(beginner) "htdp-beginner.ss"]
|
|
[(beginner-abbr) "htdp-beginner-abbr.ss"]
|
|
[(intermediate) "htdp-intermediate.ss"]
|
|
[(intermediate-lambda) "htdp-intermediate-lambda.ss"]
|
|
[(advanced) "htdp-advanced.ss"])
|
|
"lang")
|
|
,@body)]
|
|
[(or (and (pair? language) (eq? 'lib (car language)))
|
|
(symbol? language))
|
|
`(module m ,language ,@body)]
|
|
[(and (pair? language)
|
|
(eq? 'begin (car language)))
|
|
`(begin ,language ,@body)]
|
|
[else (error 'make-evaluator
|
|
"Bad language specification: ~e"
|
|
language)])])
|
|
(when coverage-enabled
|
|
(safe-eval '(require (lib "coverage.ss"
|
|
"handin-server" "private"))))
|
|
(safe-eval body)
|
|
(when (and (pair? body) (eq? 'module (car body))
|
|
(pair? (cdr body)) (symbol? (cadr body)))
|
|
(let ([mod (cadr body)])
|
|
(safe-eval `(require ,mod))
|
|
(current-namespace (module->namespace mod))))
|
|
(when coverage-enabled
|
|
(set! uncovered-expressions
|
|
(filter (lambda (x) (eq? 'program (syntax-source x)))
|
|
(safe-eval '(get-uncovered-expressions)
|
|
ns)))))
|
|
(channel-put result-ch 'ok))
|
|
;; Now wait for interaction expressions:
|
|
(let loop ()
|
|
(let ([expr (channel-get ch)])
|
|
(unless (eof-object? expr)
|
|
(with-handlers ([void (lambda (exn)
|
|
(channel-put result-ch
|
|
(cons 'exn exn)))])
|
|
(channel-put result-ch (cons 'val (safe-eval expr))))
|
|
(loop))))
|
|
(let loop ()
|
|
(channel-put result-ch '(exn . no-more-to-evaluate))
|
|
(loop))))
|
|
(let ([r (channel-get result-ch)])
|
|
(if (eq? r 'ok)
|
|
;; Initial program executed ok, so return an evaluator:
|
|
(lambda (expr . more)
|
|
(if (pair? more)
|
|
(case (car more)
|
|
[(uncovered-expressions) uncovered-expressions]
|
|
[else (error 'make-evaluator
|
|
"Bad arguments: ~e"
|
|
(cons expr more))])
|
|
(begin (channel-put ch expr)
|
|
(let ([r (channel-get result-ch)])
|
|
(if (eq? (car r) 'exn)
|
|
(raise (cdr r))
|
|
(cdr r))))))
|
|
;; Program didn't execute:
|
|
(raise (cdr r)))))))))
|
|
|
|
(define (open-input-text-editor/lines str)
|
|
(let ([inp (open-input-text-editor str)])
|
|
(port-count-lines! inp) inp))
|
|
|
|
(define (make-evaluator/submission language teachpacks str)
|
|
(let-values ([(defs interacts) (unpack-submission str)])
|
|
(make-evaluator language teachpacks (open-input-text-editor/lines defs))))
|
|
|
|
(define (evaluate-all source port eval)
|
|
(let loop ()
|
|
(let ([expr (parameterize ([read-case-sensitive #t]
|
|
[read-decimal-as-inexact #f])
|
|
(read-syntax source port))])
|
|
(unless (eof-object? expr)
|
|
(eval expr)
|
|
(loop)))))
|
|
|
|
(define (evaluate-submission str eval)
|
|
(let-values ([(defs interacts) (unpack-submission str)])
|
|
(evaluate-all 'handin (open-input-text-editor/lines defs) eval)))
|
|
|
|
(define (reraise-exn-as-submission-problem thunk)
|
|
(with-handlers ([void (lambda (exn)
|
|
(error
|
|
(if (exn? exn)
|
|
(exn-message exn)
|
|
(format "~s" exn))))])
|
|
(thunk)))
|
|
|
|
;; ----------------------------------------
|
|
;; Auto-test utils
|
|
|
|
(define (check-defined e id)
|
|
(with-handlers ([exn:fail:syntax? void]
|
|
[exn:fail:contract:variable?
|
|
(lambda (x)
|
|
(error
|
|
(format
|
|
"\"~a\" is not defined, but it must be defined for handin"
|
|
(exn:fail:contract:variable-id x))))])
|
|
(e #`(#,namespace-variable-value '#,id #t))))
|
|
|
|
(define (mk-args args)
|
|
(let loop ([l args])
|
|
(if (null? l)
|
|
""
|
|
(string-append " " (format "~e" (car l)) (loop (cdr l))))))
|
|
|
|
(define test-history-enabled (make-parameter #f))
|
|
(define test-history (make-parameter null))
|
|
|
|
(define (format-history one-test)
|
|
(if (test-history-enabled)
|
|
(format "(begin~a)"
|
|
(apply string-append
|
|
(map (lambda (s)
|
|
(format " ~a" s))
|
|
(reverse (test-history)))))
|
|
one-test))
|
|
|
|
(define (check-proc e result equal? f . args)
|
|
(let ([test (format "(~a~a)" f (mk-args args))])
|
|
(when (test-history-enabled)
|
|
(test-history (cons test (test-history))))
|
|
(current-run-status (format "running instructor-supplied test ~a"
|
|
(format-history test)))
|
|
(let-values ([(ok? val)
|
|
(with-handlers ([void
|
|
(lambda (x)
|
|
(error
|
|
(format "instructor-supplied test ~a failed with an error: ~e"
|
|
(format-history test)
|
|
(exn-message x))))])
|
|
(let ([val (e `(,f ,@(map value-converter args)))])
|
|
(values (or (eq? 'anything result)
|
|
(equal? val result))
|
|
val)))])
|
|
(unless ok?
|
|
(error
|
|
(format "instructor-supplied test ~a should have produced ~e, instead produced ~e"
|
|
(format-history test)
|
|
result
|
|
val)))
|
|
val)))
|
|
|
|
(define (user-construct e func . args)
|
|
(apply check-proc e func 'anything eq? args))
|
|
|
|
(define (look-for-tests t name count)
|
|
(let ([p (open-input-text-editor/lines t)])
|
|
(let loop ([found 0])
|
|
(let ([e (read p)])
|
|
(if (eof-object? e)
|
|
(when (found . < . count)
|
|
(error (format "found ~a test~a for ~a, need at least ~a test~a"
|
|
found
|
|
(if (= found 1) "" "s")
|
|
name
|
|
count
|
|
(if (= count 1) "" "s"))))
|
|
(loop (+ found
|
|
(if (and (pair? e)
|
|
(eq? (car e) name))
|
|
1
|
|
0))))))))
|
|
|
|
(define list-abbreviation-enabled (make-parameter #f))
|
|
|
|
(define (value-converter v)
|
|
(parameterize ([pc:booleans-as-true/false #t]
|
|
[pc:abbreviate-cons-as-list (list-abbreviation-enabled)]
|
|
[pc:constructor-style-printing #t])
|
|
(pc:print-convert v)))
|
|
|
|
(define (default-value-printer v)
|
|
(parameterize ([pretty-print-show-inexactness #t]
|
|
[pretty-print-.-symbol-without-bars #t]
|
|
[pretty-print-exact-as-decimal #t]
|
|
[pretty-print-columns +inf.0]
|
|
[read-case-sensitive #t])
|
|
(let ([p (open-output-string)])
|
|
(pretty-print (value-converter v) p)
|
|
(regexp-replace #rx"\n$" (get-output-string p) ""))))
|
|
(define current-value-printer (make-parameter default-value-printer))
|
|
|
|
(define (call-with-evaluator lang teachpacks program-port go)
|
|
(parameterize ([error-value->string-handler (lambda (v s)
|
|
((current-value-printer) v))]
|
|
[list-abbreviation-enabled (not (or (eq? lang 'beginner)
|
|
(eq? lang 'beginner-abbr)))])
|
|
(reraise-exn-as-submission-problem
|
|
(lambda ()
|
|
(let ([e (make-evaluator lang teachpacks program-port)])
|
|
(current-run-status "executing your code")
|
|
(go e))))))
|
|
|
|
(define (call-with-evaluator/submission lang teachpacks str go)
|
|
(let-values ([(defs interacts) (unpack-submission str)])
|
|
(call-with-evaluator lang teachpacks (open-input-text-editor/lines defs) go)))
|
|
|
|
)
|