diff --git a/collects/meta/drdr2/slave/slave.rkt b/collects/meta/drdr2/slave/slave.rkt new file mode 100644 index 0000000000..f76885cb0a --- /dev/null +++ b/collects/meta/drdr2/slave/slave.rkt @@ -0,0 +1,111 @@ +#lang racket/base +(require mzlib/thread + unstable/match + racket/match + racket/port + racket/sandbox) +(provide (all-defined-out)) + +(define (write-output-bytes obs op) + (define bs (get-output-bytes obs)) + (write (bytes-length bs) op) + (write-bytes bs op)) + +(define (handle-one-msg password log! ip op authenticated?) + (define (is-authenticated? x) authenticated?) + (match (with-handlers ([exn? (λ (x) x)]) (read ip)) + [(? is-authenticated? (list 'run (? number? timeout) (? path-string? command) (? string? arg) ...)) + (call-with-custodian-shutdown + (λ () + (define stdout-obs (open-output-bytes 'stdout)) + (define stderr-obs (open-output-bytes 'stderr)) + (define info (list* command arg)) + (log! "Running with timeout (~a) ~S" timeout info) + (define start-time (current-inexact-milliseconds)) + (define-values (sp stdout stdin stderr) (apply subprocess #f #f #f command arg)) + (close-output-port stdin) + + (define stdout-t + (thread (λ () (copy-port stdout stdout-obs)))) + (define stderr-t + (thread (λ () (copy-port stderr stderr-obs)))) + + (define exit-status + (sync + (handle-evt sp + (λ _ + (subprocess-status sp))) + (handle-evt (alarm-evt (+ start-time (* 1000 timeout))) + (λ _ + (subprocess-kill sp #f) + (subprocess-kill sp #t) + #f)))) + (define end-time (current-inexact-milliseconds)) + (log! "Finished running ~S, status was ~a" info exit-status) + + (thread-wait stdout-t) + (thread-wait stderr-t) + (close-input-port stdout) + (close-input-port stderr) + + (write (vector start-time end-time exit-status) op) + (write-output-bytes stdout-obs op) + (write-output-bytes stderr-obs op))) + authenticated?] + [(list 'auth (== password string=?)) + (log! "Authenticated") + (write #t op) + #t] + [(? eof-object?) + (log! "Master disconnect") + (void)] + [x + (log! "Illegal message: ~e" x) + (write #f op) + authenticated?])) + +(define (call-with-safe-read t) + (parameterize + ([read-case-sensitive #t] + [read-square-bracket-as-paren #t] + [read-curly-brace-as-paren #t] + [read-accept-box #f] + [read-accept-compiled #f] + [read-accept-bar-quote #f] + [read-accept-graph #f] + [read-decimal-as-inexact #t] + [read-accept-dot #f] + [read-accept-infix-dot #f] + [read-accept-quasiquote #f] + [read-accept-reader #f]) + (t))) + +(define (handle ip op password log!) + (call-with-safe-read + (λ () + (let loop ([authenticated? #f]) + (match (handle-one-msg password log! ip op authenticated?) + [(? void?) (void)] + [authenticated? (loop authenticated?)]))))) + +(define (port-closing-curry f . args) + (λ (ip op) + (dynamic-wind + void + (λ () (apply f ip op args)) + (λ () + (close-input-port ip) + (close-output-port op))))) + +(define (main) + ; commandline + (define port 4532) + (define *password* "foo") + ; XXX + (define (log! fmt . vals) + (apply printf fmt vals)) + ; XXX use ssl + (run-server + port + (port-closing-curry handle *password* log!) + #f)) \ No newline at end of file diff --git a/collects/meta/drdr2/tests/slave.rkt b/collects/meta/drdr2/tests/slave.rkt new file mode 100644 index 0000000000..db705a4ab0 --- /dev/null +++ b/collects/meta/drdr2/tests/slave.rkt @@ -0,0 +1,108 @@ +#lang racket +(require "../slave/slave.rkt" + tests/eli-tester) + +(define (test-handle-one-msg + password m authenticated? + expected-authenticated? expected-log expected-bs-rx) + (define-values (ip-read ip-write) (make-pipe)) + (define op (open-output-bytes)) + (define log empty) + (define (log! fmt . args) + (set! log (cons (apply format fmt args) log))) + (when m + (write m ip-write)) + (close-output-port ip-write) + + (define new-authenticated? + (handle-one-msg password log! ip-read op authenticated?)) + (define new-log + (reverse log)) + (define new-bs + (get-output-bytes op)) + + (test #:failure-prefix (format "~S" (list password m authenticated?)) + (test new-authenticated? => expected-authenticated? + new-log => expected-log + (regexp-match expected-bs-rx new-bs)))) + +(test + ; write-output-bytes + (local [(define obs1 (open-output-bytes)) + (define obs2 (open-output-bytes))] + (test + (display "123" obs1) + (write-output-bytes obs1 obs2) + (close-output-port obs1) + (close-output-port obs2) + (get-output-bytes obs2) => #"3123")) + + ; handle-one-msg + (test-handle-one-msg "foo" '(auth "foo") #t + #t '("Authenticated") #"#t") + + (test-handle-one-msg "foo" '(auth "foo") #f + #t '("Authenticated") #"#t") + + (test-handle-one-msg "foo" '(auth "bar") #t + #t '("Illegal message: '(auth \"bar\")") #"#f") + + (test-handle-one-msg "foo" '(auth "bar") #f + #f '("Illegal message: '(auth \"bar\")") #"#f") + + (test-handle-one-msg "foo" #f #f + (void) '("Master disconnect") #"") + + (test-handle-one-msg "foo" '(run 10 "/bin/echo" "foo") #f + #f '("Illegal message: '(run 10 \"/bin/echo\" \"foo\")") #"#f") + + (test-handle-one-msg "foo" '(run 10 "/bin/echo" "foo") #t + #t + '("Running with timeout (10) (\"/bin/echo\" \"foo\")" "Finished running (\"/bin/echo\" \"foo\"), status was 0") + #rx"#\\([0-9]+\\.[0-9]+ [0-9]+\\.[0-9]+ 0\\)4foo\n0") + + (test-handle-one-msg "foo" '(run 0 "/bin/echo" "foo") #t + #t + '("Running with timeout (0) (\"/bin/echo\" \"foo\")" "Finished running (\"/bin/echo\" \"foo\"), status was #f") + #rx"#\\([0-9]+\\.[0-9]+ [0-9]+\\.[0-9]+ #f\\)00") + + ; call-with-safe-read + (call-with-safe-read (λ () (read (open-input-string "(run 10 \"/bin/echo\" \"foo\")")))) + => + '(run 10 "/bin/echo" "foo") + + (call-with-safe-read (λ () (read (open-input-string "(auth \"foo\")")))) + => + '(auth "foo") + + (call-with-safe-read (λ () (read (open-input-string "")))) + => + eof + + (call-with-safe-read (λ () (read (open-input-string "(auth #&\"foo\")")))) + => + (error 'read "#& expressions not currently enabled") + + (call-with-safe-read (λ () (read (open-input-string "(auth #~\"foo\")")))) + => + (error 'read "#~~ compiled expressions not currently enabled") + + (call-with-safe-read (λ () (read (open-input-string "#0='(3 #0#)")))) + => + (error 'read "#..= expressions not currently enabled") + + ; call-with-safe-read + handle-one-msg + (call-with-safe-read + (λ () + (test-handle-one-msg "foo" `(auth ,(box "bar")) #f + #f + '("Illegal message: (exn:fail:read \"read: #& expressions not currently enabled\" # (list (srcloc #f #f #f 7 2)))") + #"#f"))) + + ; XXX handle + ; XXX port-closing-curry + ; XXX main + + ) + +