syndicate-lang
/
racket-ssh-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Remove ill-thought-out break-on-departure feature.

This commit is contained in:
Tony Garnock-Jones 2011-10-26 19:10:23 -04:00
parent 5e0d17e48f
commit 6db845eda5
4 changed files with 55 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
conversation.rkt
View File

@ -40,7 +40,6 @@
(struct room-state (name ch members) #:transparent)
(struct binding (name ;; any
break-on-departure? ;; boolean
invisible? ;; boolean
in-ch ;; sync channel
out-ch ;; sync channel
@ -56,9 +55,8 @@
(room name ch))
(define (join-room room [name (gensym 'peer)]
#:break-on-departure? [break-on-departure? #f]
#:invisible? [invisible? #f])
(make-object membership% (room-ch room) name break-on-departure? invisible?))
(make-object membership% (room-ch room) name invisible?))
(define (wait-for-members room members)
(define handle (join-room room (gensym 'wait-for-members) #:invisible? #t))
@ -86,7 +84,6 @@
(class* object% ()
(init room-init)
(init name-init)
(init break-on-departure?-init)
(init invisible?-init)
(super-new)
@ -104,7 +101,7 @@
(set! connected #f)
(set! reason v)
v)))
(channel-put room `(join ,name ,break-on-departure?-init ,invisible?-init
(channel-put room `(join ,name ,invisible?-init
,out-ch ,in-ch ,disconnect-box
,(current-thread) ,(current-thread-exit-status)))
@ -150,40 +147,47 @@
(define (room-main state)
;;(write `(room-main ,state)) (newline)
(sync (foldl (lambda (b acc)
(choice-evt (let ((qb (binding-queue-box b)))
(if (queue-empty? (unbox qb))
acc
(choice-evt acc
(let-values (((first rest) (dequeue (unbox qb))))
(if (and (departed? first)
(binding-break-on-departure? b))
(begin (break-thread (binding-thread b))
never-evt)
(handle-evt (channel-put-evt
(binding-out-ch b)
first)
(lambda (dummy)
(define handler
(sync (foldl (lambda (b acc)
(choice-evt (let ((qb (binding-queue-box b)))
(if (queue-empty? (unbox qb))
acc
(choice-evt acc
(let-values (((first rest) (dequeue (unbox qb))))
(handle-evt (channel-put-evt (binding-out-ch b)
first)
(lambda (dummy)
(lambda (state)
(set-box! qb rest)
(room-main state))))))))
(handle-evt (binding-in-ch b)
(lambda (message)
(room-main (handle-binding-message state b message))))
(handle-evt (thread-dead-evt (binding-thread b))
(lambda (dummy)
(room-main (part state b (binding-death-reason b)))))))
(handle-evt (room-state-ch state)
(match-lambda
(`(join ,name ,break-on-departure? ,invisible?
,in-ch ,out-ch ,disconnect-box
,thread ,exit-status)
(room-main (join state name break-on-departure? invisible?
in-ch out-ch disconnect-box
thread exit-status)))
(unexpected (log-warning (format "room-main: unexpected message ~v"
unexpected))
(room-main state))))
(room-state-members state))))
state)))))))
(handle-evt (binding-in-ch b)
(thread-message-handler b))
(handle-evt (thread-dead-evt (binding-thread b))
(thread-death-handler b))))
(handle-evt (room-state-ch state) join-message-handler)
(room-state-members state))))
(room-main (handler state)))
(define (thread-message-handler b)
(lambda (message)
(lambda (state)
(handle-binding-message state b message))))
(define (thread-death-handler b)
(lambda (dummy)
(lambda (state)
(part state b (binding-death-reason b)))))
(define join-message-handler
(lambda (message)
(lambda (state)
(match message
(`(join ,name ,invisible? ,in-ch ,out-ch ,disconnect-box
,thread ,exit-status)
(join state name invisible? in-ch out-ch disconnect-box
thread exit-status))
(unexpected (log-warning (format "room-main: unexpected message ~v" unexpected))
state)))))
(define (binding-death-reason b)
(define es (binding-exit-status b))
@ -198,10 +202,10 @@
message))
state)))
(define (join state name break-on-departure? invisible?
(define (join state name invisible?
in-ch out-ch disconnect-box
thread exit-status)
(define b (binding name break-on-departure? invisible?
(define b (binding name invisible?
in-ch out-ch disconnect-box
(box (list->queue (membership-summary state)))
thread exit-status))

7
ssh-session.rkt
View File

@ -931,7 +931,7 @@
peer-identification-string
#f))))
(join-room session-room 'app #:break-on-departure? #t))
(join-room session-room 'app))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Session API
@ -1030,7 +1030,10 @@
(define (simple-ssh-server handle channel-open-callback state)
(let loop ((state state))
(match (send handle listen)
((arrived _) (loop state))
((arrived _)
(loop state))
((and departure (departed _ _))
(send handle depart departure))
((says _ (rpc-request reply-to id message) _)
(match message
(`(open-channel ,username ,channel-type ,extra-request-data)

9
ssh-transport.rkt
View File

@ -267,7 +267,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (ssh-reader in room)
(define handle (join-room room 'read-thread #:break-on-departure? #t))
(define handle (join-room room 'read-thread))
(define packet-size-limit (default-packet-limit))
(define (main-loop config sequence-number remaining-credit)
@ -322,12 +322,14 @@
(handle-evt (read-bytes-evt first-block-size in)
(lambda (encrypted)
(cond
((eof-object? encrypted)) ;; we gracefully exit
((eof-object? encrypted)
(send handle depart 'eof)) ;; we gracefully exit
(else (handle-packet-start (decryptor encrypted))))))
never-evt)
(handle-evt (send handle listen-evt)
(match-lambda
((arrived _) (wait-for-event))
((and departure (departed _ _)) (send handle depart departure))
((says _ (credit 'read-thread amount) _)
(main-loop config sequence-number (+ remaining-credit amount)))
((says _ (? new-keys? nk) _)
@ -345,7 +347,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (ssh-writer out room)
(define handle (join-room room 'write-thread #:break-on-departure? #t))
(define handle (join-room room 'write-thread))
(define (main-loop config sequence-number)
(match-define (crypto-configuration cipher cipher-description
@ -354,6 +356,7 @@
(match (send handle listen)
((arrived _)
(main-loop config sequence-number))
((and departure (departed _ _)) (send handle depart departure))
((says _ (? new-keys? nk) _)
(main-loop (apply-negotiated-options nk #t) sequence-number))
((says _ 'flush _)

5
test-conversation.rkt
View File

@ -21,11 +21,6 @@
(else (void)))
(loop))))
(standard-thread (lambda ()
(define handle (join-room r 'cascade #:break-on-departure? #t))
(define-values (i o) (make-pipe))
(sync (read-bytes-evt 128 i))))
(define (interaction i o)
(display "What is your name? > " o)
(flush-output o)