Initial slave server

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))

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\" #<continuation-mark-set> (list (srcloc #f #f #f 7 2)))")
+                         #"#f")))
+ 
+ ; XXX handle
+ ; XXX port-closing-curry
+ ; XXX main
+ 
+ )
+
+