More channel management, and steps toward a repl server
This commit is contained in:
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 "conversation.rkt")
|
||||||
(require "standard-thread.rkt")
|
(require "standard-thread.rkt")
|
||||||
|
(require "ordered-rpc.rkt")
|
||||||
|
|
||||||
(require "ssh-numbers.rkt")
|
(require "ssh-numbers.rkt")
|
||||||
(require "ssh-message-types.rkt")
|
(require "ssh-message-types.rkt")
|
||||||
(require "ssh-exceptions.rkt")
|
(require "ssh-exceptions.rkt")
|
||||||
(require "ssh-transport.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
|
;; Data definitions
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
@ -64,12 +74,28 @@
|
||||||
total-transferred
|
total-transferred
|
||||||
rekey-state
|
rekey-state
|
||||||
authentication-state
|
authentication-state
|
||||||
|
continuations
|
||||||
|
channel-map
|
||||||
is-server?
|
is-server?
|
||||||
local-id
|
local-id
|
||||||
remote-id
|
remote-id
|
||||||
session-id) ;; starts off #f until initial keying
|
session-id) ;; starts off #f until initial keying
|
||||||
#:transparent)
|
#: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
|
;; Generic inputs into the exchange-hash part of key
|
||||||
;; exchange. Diffie-Hellman uses these fields along with the host key,
|
;; exchange. Diffie-Hellman uses these fields along with the host key,
|
||||||
;; the exchange values, and the shared secret to get the final hash.
|
;; 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)
|
(write-message!/flush (ssh-msg-userauth-failure '(none) #f) conn)
|
||||||
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
|
;; Connection service
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (start-connection-service conn)
|
(define (start-connection-service conn)
|
||||||
(set-handlers 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_OPEN handle-msg-channel-open
|
||||||
SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-window-adjust
|
SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-window-adjust
|
||||||
SSH_MSG_CHANNEL_DATA handle-msg-channel-data
|
SSH_MSG_CHANNEL_DATA handle-msg-channel-data
|
||||||
|
@ -504,8 +549,49 @@
|
||||||
conn)
|
conn)
|
||||||
|
|
||||||
(define (handle-msg-channel-open packet message conn)
|
(define (handle-msg-channel-open packet message conn)
|
||||||
(log-error "TODO: Unimplemented: handle-msg-channel-open")
|
(match message
|
||||||
conn)
|
((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)
|
(define (handle-msg-window-adjust packet message conn)
|
||||||
(log-error "TODO: Unimplemented: handle-msg-window-adjust")
|
(log-error "TODO: Unimplemented: handle-msg-window-adjust")
|
||||||
|
@ -545,6 +631,27 @@
|
||||||
(write-message! message conn)
|
(write-message! message conn)
|
||||||
(flush-outbound-messages! 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)
|
(define (maybe-send-disconnect-message! e conn)
|
||||||
(when (not (exn:fail:contract:protocol-originated-at-peer? e))
|
(when (not (exn:fail:contract:protocol-originated-at-peer? e))
|
||||||
(write-message!/flush (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code e)
|
(write-message!/flush (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code e)
|
||||||
|
@ -601,7 +708,14 @@
|
||||||
(disconnect-with-error/local-info
|
(disconnect-with-error/local-info
|
||||||
departure
|
departure
|
||||||
SSH_DISCONNECT_BY_APPLICATION
|
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
|
;; Session choreography
|
||||||
|
@ -671,51 +785,27 @@
|
||||||
0
|
0
|
||||||
(rekey-in-seconds-or-bytes -1 -1 0)
|
(rekey-in-seconds-or-bytes -1 -1 0)
|
||||||
#f
|
#f
|
||||||
|
(make-transaction-manager)
|
||||||
|
(hash)
|
||||||
(case role ((client) #f) ((server) #t))
|
(case role ((client) #f) ((server) #t))
|
||||||
local-identification-string
|
local-identification-string
|
||||||
peer-identification-string
|
peer-identification-string
|
||||||
#f))))
|
#f))))
|
||||||
|
|
||||||
(make-object ssh-session% session-room))
|
(join-room session-room 'app #:break-on-departure? #t))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Session API
|
;; Session API
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define ssh-session%
|
(define (simple-ssh-server handle channel-open-callback state)
|
||||||
(class* object% ()
|
(let loop ((state state))
|
||||||
(init room-init)
|
(match (send handle listen)
|
||||||
|
((arrived _) (loop state))
|
||||||
(super-new)))
|
((says _ (rpc-request reply-to id message) _)
|
||||||
|
(match message
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
(`(open-channel ,channel-type ,extra-request-data)
|
||||||
;; Test driver code
|
(define-values (reply-body new-state)
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
(channel-open-callback channel-type extra-request-data state))
|
||||||
|
(send handle say (rpc-reply id reply-body))
|
||||||
(require racket/tcp)
|
(loop new-state)))))))
|
||||||
(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))
|
|
||||||
|
|
Loading…
Reference in New Issue