More channel management, and steps toward a repl server
This commit is contained in:
Tony Garnock-Jones
parent
1ab7cecf97
commit
9290dbea34
|
|
@ -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))
|
||||
174
ssh-session.rkt
174
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<Uint32>
|
||||
type ;; String
|
||||
continuations ;; TransactionManager (see ordered-rpc.rkt)
|
||||
outbound-window ;; Maybe<Natural>
|
||||
outbound-packet-size ;; Maybe<Natural>
|
||||
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)))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue