From 9290dbea34f2acbb0102b3864e4d75433e505d45 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 24 Oct 2011 18:36:08 -0400 Subject: [PATCH] More channel management, and steps toward a repl server --- repl-server.rkt | 54 +++++++++++++++ ssh-session.rkt | 174 ++++++++++++++++++++++++++++++++++++------------ 2 files changed, 186 insertions(+), 42 deletions(-) create mode 100644 repl-server.rkt diff --git a/repl-server.rkt b/repl-server.rkt new file mode 100644 index 0000000..17d10f2 --- /dev/null +++ b/repl-server.rkt @@ -0,0 +1,54 @@ +#lang racket/base +;; (Temporary) example client and server + +(require racket/tcp) +(require racket/pretty) +(require racket/match) + +(require "conversation.rkt") +(require "ssh-numbers.rkt") +(require "ssh-session.rkt") +(require "standard-thread.rkt") + +(define (t-client) + (let-values (((i o) (tcp-connect "localhost" + 2323 + ;;22 + ))) + (let ((api (ssh-session 'client i o))) + (printf "Got API ~v\n" api) + (semaphore-wait (make-semaphore 0))))) + +(define (repl-channel handle) + (semaphore-wait (make-semaphore 0))) + +(define (t-server) + (define s (tcp-listen 2322 4 #t "localhost")) + (printf "Accepting...\n") + (let loop () + (let-values (((i o) (tcp-accept s))) + (standard-thread + (lambda () + (simple-ssh-server (ssh-session 'server i o) + (lambda (channel-type extra-request-data state) + (match channel-type + (#"session" + (define channel-room (make-room 'channel)) + (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)) + (else + (values `(error ,SSH_OPEN_ADMINISTRATIVELY_PROHIBITED + "Unknown channel type") + state)))) + 'no-state))) + (loop)))) + +(if (getenv "clientmode") + (t-client) + (t-server)) diff --git a/ssh-session.rkt b/ssh-session.rkt index 3638dfa..29fda5c 100644 --- a/ssh-session.rkt +++ b/ssh-session.rkt @@ -16,12 +16,22 @@ (require "conversation.rkt") (require "standard-thread.rkt") +(require "ordered-rpc.rkt") (require "ssh-numbers.rkt") (require "ssh-message-types.rkt") (require "ssh-exceptions.rkt") (require "ssh-transport.rkt") +(provide required-peer-identification-regex + client-preamble-lines + client-identification-string + rekey-interval + rekey-volume + + ssh-session + simple-ssh-server) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Data definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -64,12 +74,28 @@ total-transferred rekey-state authentication-state + continuations + channel-map is-server? local-id remote-id session-id) ;; starts off #f until initial keying #:transparent) +;; A ChannelState is a (ssh-channel ...) TODO +;; Named ssh-channel to avoid conflicts with Racket's built-in +;; synchronous channels. +(struct ssh-channel (room-handle ;; RoomHandle + my-ref ;; Uint32 + your-ref ;; Maybe + type ;; String + continuations ;; TransactionManager (see ordered-rpc.rkt) + outbound-window ;; Maybe + outbound-packet-size ;; Maybe + inbound-window ;; Natural + ) + #:transparent) + ;; Generic inputs into the exchange-hash part of key ;; exchange. Diffie-Hellman uses these fields along with the host key, ;; the exchange values, and the shared secret to get the final hash. @@ -484,13 +510,32 @@ (write-message!/flush (ssh-msg-userauth-failure '(none) #f) conn) conn))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Channel management +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (allocate-channel conn room type your-ref outbound-window outbound-packet-size) + (define my-ref (hash-count (connection-channel-map conn))) + (define ch (ssh-channel (join-room room 'session) + my-ref + your-ref + type + (make-transaction-manager) + outbound-window + outbound-packet-size + 1048576 ;; TODO: parameterize? Make configurable by app? + )) + (values ch + (struct-copy connection conn + [channel-map (hash-set (connection-channel-map conn) my-ref ch)]))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Connection service ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (start-connection-service conn) (set-handlers conn - SSH_MSG_GLOBAL_REQUEST handle-msg-global-request + ;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request SSH_MSG_CHANNEL_OPEN handle-msg-channel-open SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-window-adjust SSH_MSG_CHANNEL_DATA handle-msg-channel-data @@ -504,8 +549,49 @@ conn) (define (handle-msg-channel-open packet message conn) - (log-error "TODO: Unimplemented: handle-msg-channel-open") - conn) + (match message + ((ssh-msg-channel-open channel-type* + sender-channel + initial-window-size + maximum-packet-size + extra-request-data*) + (define channel-type (bit-string->bytes channel-type*)) + (define extra-request-data (bit-string->bytes extra-request-data*)) + (app-request conn + `(open-channel ,channel-type ,extra-request-data) + (lambda (reply conn) + (match reply + (`(ok ,(? room? room) ,(? bytes? extra-reply-data)) + (let-values (((ch conn) (allocate-channel conn + room + channel-type + sender-channel + initial-window-size + maximum-packet-size))) + (write-message!/flush (ssh-msg-channel-open-confirmation + sender-channel + (ssh-channel-my-ref ch) + (ssh-channel-inbound-window ch) + (default-packet-limit) ;; TODO get from reader + extra-reply-data) + conn) + conn)) + (`(error ,reason-code ,description) + (write-message!/flush (ssh-msg-channel-open-failure + sender-channel + reason-code + (string->bytes/utf-8 description) + #"") + conn) + conn))) + (lambda (reason conn) + (write-message!/flush (ssh-msg-channel-open-failure + sender-channel + 0 + #"Internal error" + #"") + conn) + conn))))) (define (handle-msg-window-adjust packet message conn) (log-error "TODO: Unimplemented: handle-msg-window-adjust") @@ -545,6 +631,27 @@ (write-message! message conn) (flush-outbound-messages! conn)) +(define (app-notify conn message) + (send (connection-session-room-handle conn) say message) + conn) + +(define (app-request conn message k-ok k-error) + (define-values (transaction new-continuations) + (open-transaction (connection-continuations conn) (list k-ok k-error))) + (send (connection-session-room-handle conn) say (rpc-request 'session transaction message)) + (struct-copy connection conn [continuations new-continuations])) + +(define (finish-app-request conn txn context-extractor message-or-reason) + (close-transaction! txn (list context-extractor message-or-reason)) + (let loop ((conn conn)) + (if (transaction-available? (connection-continuations conn)) + (let-values (((txn rest) (dequeue-transaction (connection-continuations conn)))) + (match-define (list context-extractor message-or-reason) (transaction-value txn)) + (loop ((context-extractor (transaction-context txn)) + message-or-reason + (struct-copy connection conn [continuations rest])))) + conn))) + (define (maybe-send-disconnect-message! e conn) (when (not (exn:fail:contract:protocol-originated-at-peer? e)) (write-message!/flush (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code e) @@ -601,7 +708,14 @@ (disconnect-with-error/local-info departure SSH_DISCONNECT_BY_APPLICATION - "Application disconnected"))))))))) + "Application disconnected")) + ((says _ (rpc-reply transaction message) _) + ;; TODO: not cap-secure. Introduce sealers, or indirect. + (loop (finish-app-request conn transaction car message))) + ((says _ (rpc-error transaction reason) _) + ;; TODO: not cap-secure. Introduce sealers, or indirect. + (loop (finish-app-request conn transaction cadr reason))) + ))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Session choreography @@ -671,51 +785,27 @@ 0 (rekey-in-seconds-or-bytes -1 -1 0) #f + (make-transaction-manager) + (hash) (case role ((client) #f) ((server) #t)) local-identification-string peer-identification-string #f)))) - (make-object ssh-session% session-room)) + (join-room session-room 'app #:break-on-departure? #t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Session API ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define ssh-session% - (class* object% () - (init room-init) - - (super-new))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Test driver code -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require racket/tcp) -(require racket/pretty) - -(define (t-client) - (let-values (((i o) (tcp-connect "localhost" - 2323 - ;;22 - ))) - (let ((api (ssh-session 'client i o))) - (printf "Got API ~v\n" api) - (semaphore-wait (make-semaphore 0))))) - -(define (t-server) - (define s (tcp-listen 2322 4 #t "localhost")) - (printf "Accepting...\n") - (let loop () - (let-values (((i o) (tcp-accept s))) - (standard-thread - (lambda () - (let ((api (ssh-session 'server i o))) - (printf "Got API ~v\n" api) - (semaphore-wait (make-semaphore 0))))) - (loop)))) - -(if (getenv "servermode") - (t-server) - (t-client)) +(define (simple-ssh-server handle channel-open-callback state) + (let loop ((state state)) + (match (send handle listen) + ((arrived _) (loop state)) + ((says _ (rpc-request reply-to id message) _) + (match message + (`(open-channel ,channel-type ,extra-request-data) + (define-values (reply-body new-state) + (channel-open-callback channel-type extra-request-data state)) + (send handle say (rpc-reply id reply-body)) + (loop new-state)))))))