#lang racket/base (require (planet tonyg/bitsyntax)) (require (planet vyzo/crypto:2:3)) ;; (require (planet vyzo/crypto/util)) ;; hex, unhex ;; (require racket/port) (require racket/match) (require racket/class) ;; (require rackunit) ;; (require "aes-ctr.rkt") (require "safe-io.rkt") (require "oakley-groups.rkt") (require "host-key.rkt") (require "conversation.rkt") (require "standard-thread.rkt") (require "ssh-numbers.rkt") (require "ssh-message-types.rkt") (require "ssh-exceptions.rkt") (require "ssh-transport.rkt") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Data definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; A RekeyState is one of ;; - a (rekey-wait Number Number), representing a time or ;; transfer-amount by which rekeying should be started ;; - a (rekey-local SshMsgKexinit), when we've sent our local ;; algorithm list and are waiting for the other party to send theirs ;; - a (rekey-in-progress KeyExchangeState), when both our local ;; algorithm list has been sent and the remote one has arrived and the ;; actual key exchange has begun (struct rekey-wait (deadline threshold-bytes) #:transparent) (struct rekey-local (local-algorithms) #:transparent) (struct rekey-in-progress (state) #:transparent) ;; A PacketDispatcher is a Hashtable mapping Byte to PacketHandler. ;; A PacketHandler is a (Bytes DecodedPacket ConnectionState -> ConnectionState). ;; The raw received bytes of the packet are given because sometimes ;; cryptographic operations on the received bytes are mandated by the ;; protocol. ;; A ConnectionState is a (connection StreamState StreamState ;; PacketDispatcher ... TODO fix this) representing the complete state ;; of the SSH transport, authentication, and connection layers. (struct connection (io-room-handle session-room-handle discard-next-packet? dispatch-table total-transferred rekey-state is-server? local-id remote-id session-id) ;; starts off #f until initial keying #: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. (struct exchange-hash-info (client-id server-id client-kexinit-bytes server-kexinit-bytes) #:transparent) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parameters ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define identification-recogniser #rx"^SSH-") (define (identification-line? str) (regexp-match identification-recogniser str)) (define required-peer-identification-regex (make-parameter #rx"^SSH-2\\.0-.*")) (define client-preamble-lines (make-parameter '())) (define client-identification-string (make-parameter "SSH-2.0-RacketSSH_0.0")) (define rekey-interval (make-parameter 5)) ;;3600)) (define rekey-volume (make-parameter 1000000000)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Packet dispatch and handling ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Bytes -> Byte ;; Retrieves the packet type byte from a packet. (define (encoded-packet-msg-type encoded-packet) (bytes-ref encoded-packet 0)) ;; PacketDispatcher [ Byte Maybe ]* -> PacketDispatcher ;; Adds or removes handlers to or from the given PacketDispatcher. (define (extend-packet-dispatcher core-dispatcher . key-value-pairs) (let loop ((d core-dispatcher) (key-value-pairs key-value-pairs)) (cond ((null? key-value-pairs) d) ((null? (cdr key-value-pairs)) (error 'extend-packet-dispatcher "Must call extend-packet-dispatcher with matched key/value pairs")) (else (loop (let ((packet-type-number (car key-value-pairs)) (packet-handler-or-false (cadr key-value-pairs))) (if packet-handler-or-false (hash-set d packet-type-number packet-handler-or-false) (hash-remove d packet-type-number))) (cddr key-value-pairs)))))) ;; ConnectionState [ Byte Maybe ]* -> ConnectionState ;; Installs (or removes) PacketHandlers in the given connection state; ;; see extend-packet-dispatcher. (define (set-handlers conn . key-value-pairs) (struct-copy connection conn [dispatch-table (apply extend-packet-dispatcher (connection-dispatch-table conn) key-value-pairs)])) ;; ConnectionState Byte PacketHandler -> ConnectionState ;; Installs a PacketHandler that removes the installed dispatch entry ;; and then delegates to its argument. (define (oneshot-handler conn packet-type-number packet-handler) (set-handlers conn packet-type-number (lambda (packet message conn) (packet-handler packet message (set-handlers conn packet-type-number #f))))) (define (dispatch-packet seq packet message conn) (define packet-type-number (encoded-packet-msg-type packet)) (if (and (not (rekey-wait? (connection-rekey-state conn))) (or (not (ssh-msg-type-transport-layer? packet-type-number)) (= packet-type-number SSH_MSG_SERVICE_REQUEST) (= packet-type-number SSH_MSG_SERVICE_ACCEPT))) ;; We're in the middle of some phase of an active key-exchange, ;; and received a packet that's for a higher layer than the ;; transport layer, or one of the forbidden types given at the ;; send of RFC4253 section 7.1. (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR "Packets of type ~v forbidden while in key-exchange" packet-type-number) ;; We're either idling, or it's a permitted packet type while ;; performing key exchange. Look it up in the dispatch table. (let ((handler (hash-ref (connection-dispatch-table conn) packet-type-number #f))) (if handler (handler packet message conn) (begin (write-message! (ssh-msg-unimplemented seq) conn) conn))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Handlers for core transport packet types ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PacketHandler for handling SSH_MSG_DISCONNECT. (define (handle-msg-disconnect packet message conn) (disconnect-with-error* #t '() (ssh-msg-disconnect-reason-code message) "Received SSH_MSG_DISCONNECT with reason code ~a and message ~s" (ssh-msg-disconnect-reason-code message) (bytes->string/utf-8 (bit-string->bytes (ssh-msg-disconnect-description message))))) ;; PacketHandler for handling SSH_MSG_IGNORE. (define (handle-msg-ignore packet message conn) conn) ;; PacketHandler for handling SSH_MSG_UNIMPLEMENTED. (define (handle-msg-unimplemented packet message conn) (disconnect-with-error/local-info `((offending-sequence-number ,(ssh-msg-unimplemented-sequence-number message))) SSH_DISCONNECT_PROTOCOL_ERROR "Disconnecting because of received SSH_MSG_UNIMPLEMENTED.")) ;; PacketHandler for handling SSH_MSG_DEBUG. (define (handle-msg-debug packet message conn) ;; TODO: use Racket log API. (log-debug (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message)) conn) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Key Exchange ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (rekey-in-seconds-or-bytes delta-seconds delta-bytes total-transferred) (rekey-wait (+ (current-seconds) delta-seconds) (+ total-transferred delta-bytes))) (define (time-to-rekey? rekey conn) (and (rekey-wait? rekey) (or (>= (current-seconds) (rekey-wait-deadline rekey)) (>= (connection-total-transferred conn) (rekey-wait-threshold-bytes rekey))))) ;; (SshMsgKexinit -> Symbol) SshMsgKexinit SshMsgKexinit -> Symbol ;; Computes the name of the "best" algorithm choice at the given ;; getter, using the rules from the RFC and the client and server ;; algorithm precedence lists. (define (best-result getter client-algs server-algs) (define client-list0 (getter client-algs)) (define server-list (getter server-algs)) (let loop ((client-list client-list0)) (cond ((null? client-list) (disconnect-with-error/local-info `((client-list ,client-list0) (server-list ,server-list)) SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Could not agree on a suitable algorithm for ~v" getter)) ((memq (car client-list) server-list) (car client-list)) (else (loop (cdr client-list)))))) ;; ExchangeHashInfo Bytes Natural Natural Natural -> Bytes ;; Computes the session ID as defined by SSH's DH key exchange method. (define (dh-exchange-hash hash-info host-key e f k) (let ((block-to-hash (bit-string->bytes (bit-string ((string->bytes/utf-8 (exchange-hash-info-client-id hash-info)) :: (t:string)) ((string->bytes/utf-8 (exchange-hash-info-server-id hash-info)) :: (t:string)) ((exchange-hash-info-client-kexinit-bytes hash-info) :: (t:string)) ((exchange-hash-info-server-kexinit-bytes hash-info) :: (t:string)) (host-key :: (t:string)) (e :: (t:mpint)) (f :: (t:mpint)) (k :: (t:mpint)))))) ;;(pretty-print `((block-to-hash ,(hex block-to-hash)))) (sha1 block-to-hash))) ;; ExchangeHashInfo Symbol Symbol ConnectionState ;; (Bytes Bytes Symbol ConnectionState -> ConnectionState) ;; -> ConnectionState ;; Performs the server's half of the Diffie-Hellman key exchange protocol. (define (perform-server-key-exchange hash-info kex-alg host-key-alg conn finish) (case kex-alg ((diffie-hellman-group14-sha1 diffie-hellman-group1-sha1) (define group (if (eq? kex-alg 'diffie-hellman-group14-sha1) dh:oakley-group-14 dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2 (define-values (private-key public-key) (generate-key group)) (define public-key-as-integer (bit-string->integer public-key #t #f)) (oneshot-handler conn SSH_MSG_KEXDH_INIT (lambda (packet message conn) (define e (ssh-msg-kexdh-init-e message)) (define e-width (mpint-width e)) (define e-as-bytes (integer->bit-string e (* 8 e-width) #t)) (define shared-secret (compute-key private-key e-as-bytes)) (define hash-alg sha1) (define-values (host-key-private host-key-public) (host-key-algorithm->keys host-key-alg)) (define host-key-bytes (pieces->ssh-host-key (public-key->pieces host-key-public))) (define exchange-hash (dh-exchange-hash hash-info host-key-bytes e public-key-as-integer (bit-string->integer shared-secret #t #f))) (define h-signature (host-key-signature host-key-private host-key-alg exchange-hash)) (write-message! (ssh-msg-kexdh-reply host-key-bytes public-key-as-integer h-signature) conn) (flush-outbound-messages! conn) (finish shared-secret exchange-hash hash-alg conn)))) (else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Bad key-exchange algorithm ~v" kex-alg)))) ;; ExchangeHashInfo Symbol Symbol ConnectionState ;; (Bytes Bytes Symbol ConnectionState -> ConnectionState) ;; -> ConnectionState ;; Performs the client's half of the Diffie-Hellman key exchange protocol. (define (perform-client-key-exchange hash-info kex-alg host-key-alg conn finish) (case kex-alg ((diffie-hellman-group14-sha1 diffie-hellman-group1-sha1) (define group (if (eq? kex-alg 'diffie-hellman-group14-sha1) dh:oakley-group-14 dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2 (define-values (private-key public-key) (generate-key group)) (define public-key-as-integer (bit-string->integer public-key #t #f)) (write-message! (ssh-msg-kexdh-init public-key-as-integer) conn) (flush-outbound-messages! conn) (oneshot-handler conn SSH_MSG_KEXDH_REPLY (lambda (packet message conn) (define f (ssh-msg-kexdh-reply-f message)) (define f-width (mpint-width f)) (define f-as-bytes (integer->bit-string f (* 8 f-width) #t)) (define shared-secret (compute-key private-key f-as-bytes)) (define hash-alg sha1) (define host-key-bytes (ssh-msg-kexdh-reply-host-key message)) (define host-public-key (pieces->public-key (ssh-host-key->pieces host-key-bytes))) (define exchange-hash (dh-exchange-hash hash-info host-key-bytes public-key-as-integer f (bit-string->integer shared-secret #t #f))) (verify-host-key-signature! host-public-key host-key-alg exchange-hash (ssh-msg-kexdh-reply-h-signature message)) (finish shared-secret exchange-hash hash-alg conn)))) (else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Bad key-exchange algorithm ~v" kex-alg)))) ;; PacketHandler for handling SSH_MSG_KEXINIT. (define (handle-msg-kexinit packet message conn) (define rekey (connection-rekey-state conn)) (when (rekey-in-progress? rekey) (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR "Received SSH_MSG_KEXINIT during ongoing key exchange")) (define local-algs (if (rekey-local? rekey) (rekey-local-local-algorithms rekey) ((local-algorithm-list)))) (define encoded-local-algs (ssh-message-encode local-algs)) (define remote-algs message) (define encoded-remote-algs packet) (when (rekey-wait? rekey) (write-message! local-algs conn) (flush-outbound-messages! conn)) (define is-server? (connection-is-server? conn)) (define c (if is-server? remote-algs local-algs)) (define s (if is-server? local-algs remote-algs)) (define kex-alg (best-result ssh-msg-kexinit-kex_algorithms c s)) (define host-key-alg (best-result ssh-msg-kexinit-server_host_key_algorithms c s)) (define c2s-enc (best-result ssh-msg-kexinit-encryption_algorithms_client_to_server c s)) (define s2c-enc (best-result ssh-msg-kexinit-encryption_algorithms_server_to_client c s)) (define c2s-mac (best-result ssh-msg-kexinit-mac_algorithms_client_to_server c s)) (define s2c-mac (best-result ssh-msg-kexinit-mac_algorithms_server_to_client c s)) (define c2s-zip (best-result ssh-msg-kexinit-compression_algorithms_client_to_server c s)) (define s2c-zip (best-result ssh-msg-kexinit-compression_algorithms_server_to_client c s)) ;; Ignore languages. ;; Don't check the reserved field here, either. TODO: should we? (define (guess-matches? chosen-value getter) (let ((remote-choices (getter remote-algs))) (and (pair? remote-choices) ;; not strictly necessary because of ;; the error behaviour of ;; best-result. (eq? (car remote-choices) ;; the remote peer's guess for this parameter chosen-value)))) (define should-discard-first-kex-packet (and (ssh-msg-kexinit-first_kex_packet_follows remote-algs) ;; They've already transmitted their guess. Does their guess match ;; what we've actually selected? (not (and (guess-matches? kex-alg ssh-msg-kexinit-kex_algorithms) (guess-matches? host-key-alg ssh-msg-kexinit-server_host_key_algorithms) (guess-matches? c2s-enc ssh-msg-kexinit-encryption_algorithms_client_to_server) (guess-matches? s2c-enc ssh-msg-kexinit-encryption_algorithms_server_to_client) (guess-matches? c2s-mac ssh-msg-kexinit-mac_algorithms_client_to_server) (guess-matches? s2c-mac ssh-msg-kexinit-mac_algorithms_server_to_client) (guess-matches? c2s-zip ssh-msg-kexinit-compression_algorithms_client_to_server) (guess-matches? s2c-zip ssh-msg-kexinit-compression_algorithms_server_to_client))))) (define (continue-after-discard conn) ((if is-server? perform-server-key-exchange perform-client-key-exchange) (if is-server? (exchange-hash-info (connection-remote-id conn) (connection-local-id conn) encoded-remote-algs encoded-local-algs) (exchange-hash-info (connection-local-id conn) (connection-remote-id conn) encoded-local-algs encoded-remote-algs)) kex-alg host-key-alg conn continue-after-key-exchange)) (define (continue-after-key-exchange shared-secret exchange-hash hash-alg conn) (define session-id (if (connection-session-id conn) (connection-session-id conn) ;; don't overwrite existing ID exchange-hash)) (define k-h-prefix (bit-string ((bit-string->integer shared-secret #t #f) :: (t:mpint)) (exchange-hash :: binary))) (define (derive-key kind needed-bytes-or-false) (let extend ((key (hash-alg (bit-string->bytes (bit-string (k-h-prefix :: binary) (kind :: binary) (session-id :: binary)))))) (cond ((eq? #f needed-bytes-or-false) key) ((>= (bytes-length key) needed-bytes-or-false) (subbytes key 0 needed-bytes-or-false)) (else (extend (bytes-append key (hash-alg (bit-string->bytes (bit-string (k-h-prefix :: binary) (key :: binary)))))))))) (oneshot-handler (struct-copy connection conn [session-id session-id]) ;; just in case it changed SSH_MSG_NEWKEYS (lambda (newkeys-packet newkeys-message conn) ;; First, send our SSH_MSG_NEWKEYS, ;; incrementing the various counters, and then ;; apply the new algorithms. (write-message! (ssh-msg-newkeys) conn) (flush-outbound-messages! conn) (send (connection-io-room-handle conn) say (new-keys (connection-is-server? conn) derive-key c2s-enc s2c-enc c2s-mac s2c-mac c2s-zip s2c-zip)) (set-handlers (struct-copy connection conn [rekey-state (rekey-in-seconds-or-bytes (rekey-interval) (rekey-volume) (connection-total-transferred conn))]) SSH_MSG_SERVICE_REQUEST handle-msg-service-request)))) (if should-discard-first-kex-packet (struct-copy connection (continue-after-discard conn) [discard-next-packet? #t]) (continue-after-discard conn))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Service request manager ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (handle-msg-service-request packet message conn) (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE "%%%")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Session main loop ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (write-message! message conn) (send (connection-io-room-handle conn) say message)) (define (flush-outbound-messages! conn) (send (connection-io-room-handle conn) say 'flush)) (define (maybe-send-disconnect-message! e conn) (when (not (exn:fail:contract:protocol-originated-at-peer? e)) (write-message! (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code e) (string->bytes/utf-8 (exn-message e)) #"") conn) (flush-outbound-messages! conn))) (define (bump-total amount conn) (struct-copy connection conn [total-transferred (+ (connection-total-transferred conn) amount)])) (define (run-ssh-session conn) (with-handlers ((exn:fail:contract:protocol? (lambda (e) (maybe-send-disconnect-message! e conn) (raise e)))) (let loop ((conn conn)) (define rekey (connection-rekey-state conn)) (if (time-to-rekey? rekey conn) (let ((algs ((local-algorithm-list)))) (write-message! algs conn) (flush-outbound-messages! conn) (loop (struct-copy connection conn [rekey-state (rekey-local algs)]))) (sync (if (rekey-wait? rekey) (handle-evt (alarm-evt (+ (current-inexact-milliseconds) (* (rekey-wait-deadline rekey) 1000))) (lambda (dummy) (loop conn))) never-evt) (handle-evt (send (connection-io-room-handle conn) listen-evt) (match-lambda ((arrived 'read-thread) (send (connection-io-room-handle conn) say (credit 'read-thread 1)) (loop conn)) ((arrived _) (loop conn)) ((and departure (departed who why)) (disconnect-with-error/local-info departure SSH_DISCONNECT_CONNECTION_LOST "I/O error")) ((says _ amount 'output-byte-count) ;; writer reporting bytes transferred (loop (bump-total amount conn))) ((says _ (received-packet seq packet message transferred-count) _) (send (connection-io-room-handle conn) say (credit 'read-thread 1)) (loop (bump-total transferred-count (if (connection-discard-next-packet? conn) (struct-copy connection conn [discard-next-packet? #f]) (dispatch-packet seq packet message conn))))))) (handle-evt (send (connection-session-room-handle conn) listen-evt) (match-lambda ((arrived _) (loop conn)) ((and departure (departed who why)) (disconnect-with-error/local-info departure SSH_DISCONNECT_BY_APPLICATION "Application disconnected"))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Session choreography ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (send-preamble-and-identification! out) (let ((my-id (client-identification-string))) (for-each (lambda (line) (when (identification-line? line) (error 'ssh-session "Client preamble includes forbidden line ~v" line)) (display line out) (display "\r\n" out)) (client-preamble-lines)) (display my-id out) (display "\r\n" out) (flush-output out) my-id)) ;; Port -> String (define (read-preamble-and-identification! in) (let ((line (read-line-limited in 253))) ;; 255 incl CRLF (when (eof-object? line) (error 'ssh-session "EOF while reading connection preamble")) (if (identification-line? line) line (read-preamble-and-identification! in)))) ;; PacketDispatcher. Handles the core transport message types. (define base-packet-dispatcher (hasheq SSH_MSG_DISCONNECT handle-msg-disconnect SSH_MSG_IGNORE handle-msg-ignore SSH_MSG_UNIMPLEMENTED handle-msg-unimplemented SSH_MSG_DEBUG handle-msg-debug SSH_MSG_KEXINIT handle-msg-kexinit)) (define (spy-on room) (define handle (join-room room (gensym 'spy) #:invisible? #t)) (define (loop) (write (list (room-name room) (send handle listen))) (newline) (flush-output) (loop)) (thread loop)) (define (wait-for-members room members) (define handle (join-room room (gensym 'wait-for-members) #:invisible? #t)) (let loop ((remaining-members members)) (if (null? remaining-members) #t (match (send handle listen) ((arrived who) (loop (remove who remaining-members))) ((departed who _) (if (member who members) (error 'wait-for-members "Waited-for member exited") (loop remaining-members))) (_ (loop remaining-members))))) (send handle depart)) (define (ssh-session role in out) (define io-room (make-room (gensym 'ssh-session-io-room))) (spy-on io-room) (define session-room (make-room (gensym 'ssh-session-room))) (spy-on session-room) (define local-identification-string (send-preamble-and-identification! out)) (define peer-identification-string (read-preamble-and-identification! in)) ;; Each identification string is both a cleartext indicator that ;; we've reached some notion of the right place and also input to ;; the hash function used during D-H key exchange. (when (not (regexp-match (required-peer-identification-regex) peer-identification-string)) (display "Invalid identification\r\n" out) (flush-output out) (error 'ssh-session "Invalid peer identification string ~v" peer-identification-string)) (standard-thread (lambda () (ssh-reader in io-room))) (standard-thread (lambda () (ssh-writer out io-room))) (wait-for-members io-room '(read-thread write-thread)) (standard-thread (lambda () (run-ssh-session (connection (join-room io-room 'session) (join-room session-room 'session) #f base-packet-dispatcher 0 (rekey-in-seconds-or-bytes -1 -1 0) (case role ((client) #f) ((server) #t)) local-identification-string peer-identification-string #f)))) (make-object ssh-session% session-room)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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))