diff --git a/repl-server.rkt b/repl-server.rkt index 17d10f2..3292280 100644 --- a/repl-server.rkt +++ b/repl-server.rkt @@ -4,6 +4,8 @@ (require racket/tcp) (require racket/pretty) (require racket/match) +(require racket/class) +(require racket/port) (require "conversation.rkt") (require "ssh-numbers.rkt") @@ -19,8 +21,27 @@ (printf "Got API ~v\n" api) (semaphore-wait (make-semaphore 0))))) -(define (repl-channel handle) - (semaphore-wait (make-semaphore 0))) +(define (repl-channel-main oob-ch in out) + (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 s (tcp-listen 2322 4 #t "localhost")) @@ -30,20 +51,13 @@ (standard-thread (lambda () (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 (#"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 #"") + (values `(ok ,repl-channel-main #"") state)) (else - (values `(error ,SSH_OPEN_ADMINISTRATIVELY_PROHIBITED + (values `(error ,SSH_OPEN_UNKNOWN_CHANNEL_TYPE "Unknown channel type") state)))) 'no-state))) diff --git a/ssh-session.rkt b/ssh-session.rkt index 03db48b..3388b15 100644 --- a/ssh-session.rkt +++ b/ssh-session.rkt @@ -11,6 +11,7 @@ (require "host-key.rkt") +(require "functional-queue.rkt") (require "conversation.rkt") (require "standard-thread.rkt") (require "ordered-rpc.rkt") @@ -572,13 +573,15 @@ (update-channel conn (struct-copy ssh-channel ch [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) (update-channel conn (struct-copy ssh-channel ch [continuations (room-rpc (ssh-channel-room-handle ch) - (ssh-channel-continuations conn) + (ssh-channel-continuations ch) message k)]))) @@ -614,41 +617,41 @@ conn) (define (handle-msg-channel-open packet message 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))))))) + (match-define (ssh-msg-channel-open channel-type* + sender-channel + initial-window-size + maximum-packet-size + extra-request-data*) + message) + (define channel-type (bit-string->bytes channel-type*)) + (define extra-request-data (bit-string->bytes extra-request-data*)) + (app-request conn + `(open-channel ,(connection-username conn) ,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))))) (define (handle-msg-window-adjust packet message conn) (log-error "TODO: Unimplemented: handle-msg-window-adjust") @@ -671,8 +674,20 @@ conn) (define (handle-msg-channel-request packet message conn) - (log-error "TODO: Unimplemented: handle-msg-channel-request") - conn) + (match-define (ssh-msg-channel-request recipient-channel type* want-reply? data*) message) + (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 @@ -688,6 +703,13 @@ (write-message! message 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) (send (connection-session-room-handle conn) say message) conn) @@ -884,14 +906,59 @@ ;; 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) (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)) + (`(open-channel ,username ,channel-type ,extra-request-data) + (define-values (reply new-state) + (channel-open-callback username channel-type extra-request-data state)) + (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)))))))