79 lines
2.8 KiB
Racket
79 lines
2.8 KiB
Racket
#lang racket/base
|
|
;; (Temporary) example client and server
|
|
|
|
(require racket/set)
|
|
(require racket/match)
|
|
|
|
(require "ssh-numbers.rkt")
|
|
(require "ssh-transport.rkt")
|
|
(require "ssh-message-types.rkt")
|
|
(require "ssh-exceptions.rkt")
|
|
(require "os2-support.rkt")
|
|
|
|
(define server-addr (tcp-listener 2322))
|
|
|
|
(define (connection-handler local-addr remote-addr)
|
|
(nested-vm
|
|
(list 'ssh-session-vm remote-addr)
|
|
(transition 'running
|
|
(at-meta-level
|
|
(send-message (tcp-channel local-addr remote-addr #"SSH-2.0-RacketSSH_0.0\r\n")))
|
|
(at-meta-level (send-tcp-mode remote-addr local-addr 'lines))
|
|
(at-meta-level (send-tcp-credit remote-addr local-addr 1))
|
|
(at-meta-level
|
|
(role 'identification-handler (topic-subscriber %%%
|
|
|
|
(spawn (ssh-reader local-addr remote-addr) #:debug-name 'ssh-reader)
|
|
(spawn (ssh-writer local-addr remote-addr) #:debug-name 'ssh-writer)
|
|
(yield #:state state
|
|
(transition state (send-message (inbound-credit 1))))
|
|
(role 'crash-listener
|
|
(set (topic-subscriber (wild) #:virtual? #t)
|
|
(topic-publisher (wild) #:virtual? #t))
|
|
#:state state
|
|
#:reason reason
|
|
#:on-absence
|
|
;; This is kind of gross: because the absence handler gets
|
|
;; invoked several times in a row because of multiple flows
|
|
;; intersecting this role, we have to be careful to make the
|
|
;; transmission of the disconnection packet idempotent.
|
|
(if (eq? state 'running)
|
|
(if (and (exn:fail:contract:protocol? reason)
|
|
(not (exn:fail:contract:protocol-originated-at-peer? reason)))
|
|
(transition 'error-packet-sent
|
|
(send-message (outbound-packet (ssh-msg-disconnect
|
|
(exn:fail:contract:protocol-reason-code reason)
|
|
(string->bytes/utf-8 (exn-message reason))
|
|
#"")))
|
|
(yield #:state state
|
|
(transition state (at-meta-level (kill)))))
|
|
(transition state (at-meta-level (kill #:reason reason))))
|
|
state)
|
|
[msg
|
|
(write (list 'SSH msg))
|
|
(newline)
|
|
(flush-output)
|
|
state]))))
|
|
|
|
(ground-vm
|
|
(transition 'no-state
|
|
(spawn (timer-driver 'timer-driver))
|
|
(spawn tcp-driver #:debug-name 'tcp-driver)
|
|
(spawn tcp-spy #:debug-name 'tcp-spy)
|
|
|
|
(spawn (transition 'no-state
|
|
(role 'connection-waiter (topic-subscriber (tcp-channel (wild) server-addr (wild))
|
|
#:virtual? #t)
|
|
#:state state
|
|
#:topic t
|
|
#:on-presence (match t
|
|
[(topic 'publisher (tcp-channel remote-addr (== server-addr) _) #t)
|
|
;; Ignore virtual flows. They just mean there's
|
|
;; someone willing to supply connections to us
|
|
;; at some point in the future.
|
|
state]
|
|
[(topic 'publisher (tcp-channel remote-addr (== server-addr) _) #f)
|
|
(transition state
|
|
(spawn (connection-handler server-addr remote-addr)
|
|
#:debug-name (list 'ssh-session-vm remote-addr)))]))))))
|