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

Channel requests and more channel driver logic.

This commit is contained in:
Tony Garnock-Jones 2011-10-25 16:45:15 -04:00
parent 038be62f03
commit f16e876f75
2 changed files with 136 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
repl-server.rkt
View File

@ -4,6 +4,8 @@
(require racket/tcp) (require racket/tcp)
(require racket/pretty) (require racket/pretty)
(require racket/match) (require racket/match)
(require racket/class)
(require racket/port)
(require "conversation.rkt") (require "conversation.rkt")
(require "ssh-numbers.rkt") (require "ssh-numbers.rkt")
@ -19,8 +21,27 @@
(printf "Got API ~v\n" api) (printf "Got API ~v\n" api)
(semaphore-wait (make-semaphore 0))))) (semaphore-wait (make-semaphore 0)))))
(define (repl-channel handle) (define (repl-channel-main oob-ch in out)
(semaphore-wait (make-semaphore 0))) (let loop ()
(sync (handle-evt oob-ch
(match-lambda
(`(notify ,type ,data)
(log-info (format "repl-channel: notify ~v ~v" type data))
(loop))
(`(request (#"shell" ,_) ,k)
(k 'ok)
(loop))
(`(request ,other ,k)
(log-info (format "repl-channel: request ~v" other))
(k 'error)
(loop))))
(handle-evt (read-line-evt in 'any)
(lambda (line)
(if (eof-object? line)
(begin (fprintf out "Goodbye\n" out)
'done)
(begin (fprintf out "You said ~s\n" line)
(loop))))))))
(define (t-server) (define (t-server)
(define s (tcp-listen 2322 4 #t "localhost")) (define s (tcp-listen 2322 4 #t "localhost"))
@ -30,20 +51,13 @@
(standard-thread (standard-thread
(lambda () (lambda ()
(simple-ssh-server (ssh-session 'server i o) (simple-ssh-server (ssh-session 'server i o)
(lambda (channel-type extra-request-data state) (lambda (username channel-type extra-request-data state)
(match channel-type (match channel-type
(#"session" (#"session"
(define channel-room (make-room 'channel)) (values `(ok ,repl-channel-main #"")
(spy-on channel-room)
(standard-thread (lambda ()
(repl-channel
(join-room channel-room 'repl
#:break-on-departure? #t))))
(wait-for-members channel-room '(repl))
(values `(ok ,channel-room #"")
state)) state))
(else (else
(values `(error ,SSH_OPEN_ADMINISTRATIVELY_PROHIBITED (values `(error ,SSH_OPEN_UNKNOWN_CHANNEL_TYPE
"Unknown channel type") "Unknown channel type")
state)))) state))))
'no-state))) 'no-state)))

153
ssh-session.rkt
View File

@ -11,6 +11,7 @@
(require "host-key.rkt") (require "host-key.rkt")
(require "functional-queue.rkt")
(require "conversation.rkt") (require "conversation.rkt")
(require "standard-thread.rkt") (require "standard-thread.rkt")
(require "ordered-rpc.rkt") (require "ordered-rpc.rkt")
@ -572,13 +573,15 @@
(update-channel conn (struct-copy ssh-channel ch (update-channel conn (struct-copy ssh-channel ch
[close-state new-close-state])))) [close-state new-close-state]))))
(define (channel-notify conn ch message)
(send (ssh-channel-room-handle ch) say message)
conn)
(define (channel-request conn ch message k) (define (channel-request conn ch message k)
(update-channel conn (update-channel conn
(struct-copy ssh-channel ch (struct-copy ssh-channel ch
[continuations (room-rpc (ssh-channel-room-handle ch) [continuations (room-rpc (ssh-channel-room-handle ch)
(ssh-channel-continuations conn) (ssh-channel-continuations ch)
message message
k)]))) k)])))
@ -614,41 +617,41 @@
conn) conn)
(define (handle-msg-channel-open packet message conn) (define (handle-msg-channel-open packet message conn)
(match message (match-define (ssh-msg-channel-open channel-type*
((ssh-msg-channel-open channel-type* sender-channel
sender-channel initial-window-size
initial-window-size maximum-packet-size
maximum-packet-size extra-request-data*)
extra-request-data*) message)
(define channel-type (bit-string->bytes channel-type*)) (define channel-type (bit-string->bytes channel-type*))
(define extra-request-data (bit-string->bytes extra-request-data*)) (define extra-request-data (bit-string->bytes extra-request-data*))
(app-request conn (app-request conn
`(open-channel ,channel-type ,extra-request-data) `(open-channel ,(connection-username conn) ,channel-type ,extra-request-data)
(lambda (reply conn) (lambda (reply conn)
(match reply (match reply
(`(ok ,(? room? room) ,(? bytes? extra-reply-data)) (`(ok ,(? room? room) ,(? bytes? extra-reply-data))
(let-values (((ch conn) (allocate-channel conn (let-values (((ch conn) (allocate-channel conn
room room
channel-type channel-type
sender-channel sender-channel
initial-window-size initial-window-size
maximum-packet-size))) maximum-packet-size)))
(write-message!/flush (ssh-msg-channel-open-confirmation (write-message!/flush (ssh-msg-channel-open-confirmation
sender-channel sender-channel
(ssh-channel-my-ref ch) (ssh-channel-my-ref ch)
(ssh-channel-inbound-window ch) (ssh-channel-inbound-window ch)
(default-packet-limit) ;; TODO get from reader (default-packet-limit) ;; TODO get from reader
extra-reply-data) extra-reply-data)
conn) conn)
conn)) conn))
(`(error ,reason-code ,description) (`(error ,reason-code ,description)
(write-message!/flush (ssh-msg-channel-open-failure (write-message!/flush (ssh-msg-channel-open-failure
sender-channel sender-channel
reason-code reason-code
(string->bytes/utf-8 description) (string->bytes/utf-8 description)
#"") #"")
conn) conn)
conn))))))) conn)))))
(define (handle-msg-window-adjust packet message conn) (define (handle-msg-window-adjust packet message conn)
(log-error "TODO: Unimplemented: handle-msg-window-adjust") (log-error "TODO: Unimplemented: handle-msg-window-adjust")
@ -671,8 +674,20 @@
conn) conn)
(define (handle-msg-channel-request packet message conn) (define (handle-msg-channel-request packet message conn)
(log-error "TODO: Unimplemented: handle-msg-channel-request") (match-define (ssh-msg-channel-request recipient-channel type* want-reply? data*) message)
conn) (define type (bit-string->bytes type*))
(define data (bit-string->bytes data*))
(define ch (get-channel conn (ssh-msg-channel-request-recipient-channel message)))
(if (not want-reply?)
(channel-notify conn ch `(notify ,type ,data))
(channel-request conn ch `(,type ,data)
(lambda (reply ch conn)
(define your-ref (ssh-channel-your-ref ch))
(write-message!/flush (match reply
('ok (ssh-msg-channel-success your-ref))
('error (ssh-msg-channel-failure your-ref)))
conn)
(values ch conn)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Session main loop ;; Session main loop
@ -688,6 +703,13 @@
(write-message! message conn) (write-message! message conn)
(flush-outbound-messages! conn)) (flush-outbound-messages! conn))
(define (connection-username conn)
(match (connection-authentication-state conn)
((authenticated username servicename)
username)
(else (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
"Not authenticated"))))
(define (app-notify conn message) (define (app-notify conn message)
(send (connection-session-room-handle conn) say message) (send (connection-session-room-handle conn) say message)
conn) conn)
@ -884,14 +906,59 @@
;; Session API ;; Session API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (run-channel oob-ch a2s-port s2a-port handle channel-thread)
(let loop ((oob-queue (make-queue)))
(sync (if (queue-empty? oob-queue)
never-evt
(let-values (((first rest) (dequeue oob-queue)))
(handle-evt (channel-put-evt oob-ch first)
(lambda (dummy) (loop rest)))))
(handle-evt (send handle listen-evt)
(match-lambda
((arrived _)
(loop oob-queue))
((says _ (and notification `(notify ,type ,data)) _)
(loop (enqueue oob-queue notification)))
((says _ (rpc-request reply-to id message) _)
(loop (enqueue oob-queue
`(request ,message
,(lambda (answer)
(send handle say
(rpc-reply id answer)
reply-to)))))))))))
(define (start-app-channel channel-main)
(define channel-room (make-room 'channel))
(spy-on channel-room)
(define oob-ch (make-channel))
(define-values (session-a2s app-a2s) (make-pipe))
(define-values (app-s2a session-s2a) (make-pipe))
(standard-thread (lambda ()
(run-channel oob-ch
session-a2s
session-s2a
(join-room channel-room 'app #:break-on-departure? #t)
(standard-thread (lambda ()
(channel-main oob-ch app-s2a app-a2s))))))
(wait-for-members channel-room '(app))
channel-room)
(define (simple-ssh-server handle channel-open-callback state) (define (simple-ssh-server handle channel-open-callback state)
(let loop ((state state)) (let loop ((state state))
(match (send handle listen) (match (send handle listen)
((arrived _) (loop state)) ((arrived _) (loop state))
((says _ (rpc-request reply-to id message) _) ((says _ (rpc-request reply-to id message) _)
(match message (match message
(`(open-channel ,channel-type ,extra-request-data) (`(open-channel ,username ,channel-type ,extra-request-data)
(define-values (reply-body new-state) (define-values (reply new-state)
(channel-open-callback channel-type extra-request-data state)) (channel-open-callback username channel-type extra-request-data state))
(send handle say (rpc-reply id reply-body)) (match reply
(`(ok ,(? procedure? channel-main) ,(? bit-string? extra-reply-data))
(send handle say
(rpc-reply id `(ok ,(start-app-channel channel-main) ,extra-reply-data))
reply-to))
((and err `(error ,_ ,_))
(send handle say (rpc-reply id err) reply-to)))
(loop new-state))))))) (loop new-state)))))))