Compare commits
4 Commits
main
...
cleanup-fo
| Author | SHA1 | Date |
|---|---|---|
Tony Garnock-Jones
|
11e0f87fbe | |
|
Tony Garnock-Jones
|
253ce502a2 | |
|
Tony Garnock-Jones
|
3c0603878f | |
|
Tony Garnock-Jones
|
9033cd307c |
|
|
@ -0,0 +1 @@
|
|||
compiled/
|
||||
941
OLD-session.rkt
941
OLD-session.rkt
|
|
@ -1,941 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (planet tonyg/bitsyntax))
|
||||
(require (planet vyzo/crypto:2:3))
|
||||
|
||||
(require racket/match)
|
||||
(require racket/class)
|
||||
(require racket/port)
|
||||
|
||||
(require "safe-io.rkt")
|
||||
(require "oakley-groups.rkt")
|
||||
|
||||
(require "ssh-host-key.rkt")
|
||||
|
||||
(require "functional-queue.rkt")
|
||||
(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)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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)
|
||||
|
||||
;; An AuthenticationState is one of
|
||||
;; - #f, for not-yet-authenticated
|
||||
;; - an (authenticated String String), recording successful completion
|
||||
;; of the authentication protocol after a request to be identified
|
||||
;; as the given username for the given service.
|
||||
;; TODO: When authentication is properly implemented, we will need
|
||||
;; intermediate states here too.
|
||||
(struct authenticated (username service) #: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
|
||||
authentication-state
|
||||
continuations
|
||||
channel-map
|
||||
is-server?
|
||||
local-id
|
||||
remote-id
|
||||
session-id) ;; starts off #f until initial keying
|
||||
#:transparent)
|
||||
|
||||
;; A CloseState is one of
|
||||
;; - 'neither, indicating that neither side has signalled closure
|
||||
;; - 'local, only the local end has signalled closure
|
||||
;; - 'remote, only the remote end has signalled closure
|
||||
;; - 'both, both ends have signalled closure.
|
||||
;; Represents local knowledge of the state of a shared shutdown state
|
||||
;; machine.
|
||||
;;
|
||||
;; 'neither
|
||||
;; / \
|
||||
;; \/ \/
|
||||
;; 'local 'remote
|
||||
;; \ /
|
||||
;; \/ \/
|
||||
;; 'both
|
||||
|
||||
;; 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
|
||||
eof-state ;; CloseState covering EOF signals
|
||||
close-state ;; CloseState covering CLOSE signals
|
||||
)
|
||||
#: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 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<PacketHandler> ]* -> 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<PacketHandler> ]* -> 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!/flush (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)
|
||||
(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))))))
|
||||
(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!/flush (ssh-msg-kexdh-reply host-key-bytes
|
||||
public-key-as-integer
|
||||
h-signature)
|
||||
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!/flush (ssh-msg-kexdh-init public-key-as-integer) 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!/flush local-algs 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!/flush (ssh-msg-newkeys) 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)
|
||||
(define service (bit-string->bytes (ssh-msg-service-request-service-name message)))
|
||||
(match service
|
||||
(#"ssh-userauth"
|
||||
(if (connection-authentication-state conn)
|
||||
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
|
||||
"Repeated authentication is not permitted")
|
||||
(begin
|
||||
(write-message!/flush (ssh-msg-service-accept service) conn)
|
||||
(oneshot-handler conn
|
||||
SSH_MSG_USERAUTH_REQUEST
|
||||
handle-msg-userauth-request))))
|
||||
(else
|
||||
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
|
||||
"Service ~v not supported"
|
||||
service))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; User authentication
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (handle-msg-userauth-request packet message conn)
|
||||
(define user-name (bit-string->bytes (ssh-msg-userauth-request-user-name message)))
|
||||
(define service-name (bit-string->bytes (ssh-msg-userauth-request-service-name message)))
|
||||
(cond
|
||||
((and (positive? (bytes-length user-name))
|
||||
(equal? service-name #"ssh-connection"))
|
||||
;; TODO: Actually implement client authentication
|
||||
(write-message!/flush (ssh-msg-userauth-success) conn)
|
||||
(start-connection-service
|
||||
(set-handlers (struct-copy connection conn
|
||||
[authentication-state (authenticated user-name service-name)])
|
||||
SSH_MSG_USERAUTH_REQUEST
|
||||
(lambda (packet message conn)
|
||||
;; RFC4252 section 5.1 page 6
|
||||
conn))))
|
||||
(else
|
||||
(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?
|
||||
'neither
|
||||
'neither
|
||||
))
|
||||
(values ch
|
||||
(struct-copy connection (send-initial-credit conn ch)
|
||||
[channel-map (hash-set (connection-channel-map conn) my-ref ch)])))
|
||||
|
||||
(define (send-initial-credit conn ch)
|
||||
(define remaining-window (ssh-channel-outbound-window ch))
|
||||
(if (and remaining-window
|
||||
(positive? remaining-window))
|
||||
(channel-notify conn ch (credit 'app remaining-window))
|
||||
conn))
|
||||
|
||||
(define (get-channel conn my-ref)
|
||||
(hash-ref (connection-channel-map conn) my-ref))
|
||||
|
||||
(define (update-channel conn ch)
|
||||
(struct-copy connection conn
|
||||
[channel-map (hash-set (connection-channel-map conn) (ssh-channel-my-ref ch) ch)]))
|
||||
|
||||
(define (discard-channel ch conn)
|
||||
(struct-copy connection conn
|
||||
[channel-map (hash-remove (connection-channel-map conn) (ssh-channel-my-ref ch))]))
|
||||
|
||||
;; CloseState Either<'local,'remote> -> CloseState
|
||||
(define (update-close-state old-state action)
|
||||
(define local? (case action ((local) #t) ((remote) #f)))
|
||||
(case old-state
|
||||
((neither) (if local? 'local 'remote))
|
||||
((local) (if local? 'local 'both))
|
||||
((remote) (if local? 'both 'remote))
|
||||
((both) 'both)))
|
||||
|
||||
(define (maybe-close-channel ch conn action)
|
||||
(define new-close-state (update-close-state (ssh-channel-close-state ch) action))
|
||||
(case action
|
||||
((local) (write-message!/flush (ssh-msg-channel-close (ssh-channel-your-ref ch))
|
||||
conn))
|
||||
((remote) (send (ssh-channel-room-handle ch) depart 'remote-closed)))
|
||||
(if (eq? new-close-state 'both)
|
||||
(discard-channel ch conn)
|
||||
(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 ch)
|
||||
message
|
||||
k)])))
|
||||
|
||||
(define (finish-channel-request ch conn txn message)
|
||||
(define-values (worklist new-continuations)
|
||||
(room-rpc-finish (ssh-channel-continuations ch) txn message))
|
||||
(let loop ((worklist worklist)
|
||||
(ch (struct-copy ssh-channel ch [continuations new-continuations]))
|
||||
(conn conn))
|
||||
(if (null? worklist)
|
||||
(update-channel conn ch)
|
||||
(let ((item (car worklist)))
|
||||
(define-values (new-ch new-conn) (item ch conn))
|
||||
(loop (cdr worklist) new-ch new-conn)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Connection service
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (start-connection-service conn)
|
||||
(set-handlers conn
|
||||
;; 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
|
||||
SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data
|
||||
SSH_MSG_CHANNEL_EOF handle-msg-channel-eof
|
||||
SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close
|
||||
SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request))
|
||||
|
||||
(define (handle-msg-global-request packet message conn)
|
||||
(log-error "TODO: Unimplemented: handle-msg-global-request")
|
||||
conn)
|
||||
|
||||
(define (handle-msg-channel-open packet message 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)
|
||||
(match-define (ssh-msg-channel-window-adjust recipient-channel count) message)
|
||||
(define ch (get-channel conn recipient-channel))
|
||||
(channel-notify conn ch (credit 'app count)))
|
||||
|
||||
(define (handle-msg-channel-data packet message conn)
|
||||
(match-define (ssh-msg-channel-data recipient-channel data*) message)
|
||||
(define data (bit-string->bytes data*))
|
||||
(define ch (get-channel conn recipient-channel))
|
||||
(channel-notify conn ch `(data ,data)))
|
||||
|
||||
(define (handle-msg-channel-extended-data packet message conn)
|
||||
(match-define (ssh-msg-channel-extended-data recipient-channel type-code data*) message)
|
||||
(define data (bit-string->bytes data*))
|
||||
(define ch (get-channel conn recipient-channel))
|
||||
(channel-notify conn ch `(extended-data ,type-code ,data)))
|
||||
|
||||
(define (handle-msg-channel-eof packet message conn)
|
||||
(define ch (get-channel conn (ssh-msg-channel-eof-recipient-channel message)))
|
||||
(update-channel (channel-notify conn ch `(eof))
|
||||
(struct-copy ssh-channel ch
|
||||
[eof-state (update-close-state (ssh-channel-eof-state ch)
|
||||
'remote)])))
|
||||
|
||||
(define (handle-msg-channel-close packet message conn)
|
||||
(define ch (get-channel conn (ssh-msg-channel-close-recipient-channel message)))
|
||||
(maybe-close-channel ch conn 'remote))
|
||||
|
||||
(define (handle-msg-channel-request packet message 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 recipient-channel))
|
||||
(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
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(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 (write-message!/flush message conn)
|
||||
(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)
|
||||
|
||||
(define (app-request conn message k)
|
||||
(struct-copy connection conn
|
||||
[continuations (room-rpc (connection-session-room-handle conn)
|
||||
(connection-continuations conn)
|
||||
message
|
||||
k)]))
|
||||
|
||||
(define (finish-app-request conn txn message)
|
||||
(define-values (worklist new-continuations)
|
||||
(room-rpc-finish (connection-continuations conn) txn message))
|
||||
(foldl (lambda (item conn) (item conn))
|
||||
(struct-copy connection conn [continuations new-continuations])
|
||||
worklist))
|
||||
|
||||
(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)
|
||||
(string->bytes/utf-8 (exn-message e))
|
||||
#"")
|
||||
conn)))
|
||||
|
||||
(define (bump-total amount conn)
|
||||
(struct-copy connection conn [total-transferred (+ (connection-total-transferred conn) amount)]))
|
||||
|
||||
(define io-room-message-handler
|
||||
(lambda (message)
|
||||
(lambda (conn)
|
||||
(match message
|
||||
((arrived 'read-thread)
|
||||
(send (connection-io-room-handle conn) say (credit 'read-thread 1))
|
||||
conn)
|
||||
((arrived _)
|
||||
conn)
|
||||
((and departure (departed who why))
|
||||
(if (zero? (hash-count (connection-channel-map conn)))
|
||||
;; No open or half-open channels. No point in complaining; just leave.
|
||||
#f
|
||||
;; At least one channel. Make more of a noise.
|
||||
(disconnect-with-error/local-info departure
|
||||
SSH_DISCONNECT_CONNECTION_LOST
|
||||
"I/O error")))
|
||||
((says _ amount 'output-byte-count)
|
||||
;; writer reporting bytes transferred
|
||||
(bump-total amount conn))
|
||||
((says _ (received-packet seq packet message transferred-count) _)
|
||||
(send (connection-io-room-handle conn) say (credit 'read-thread 1))
|
||||
(bump-total
|
||||
transferred-count
|
||||
(if (connection-discard-next-packet? conn)
|
||||
(struct-copy connection conn [discard-next-packet? #f])
|
||||
(dispatch-packet seq packet message conn))))))))
|
||||
|
||||
(define session-room-message-handler
|
||||
(lambda (message)
|
||||
(lambda (conn)
|
||||
(match message
|
||||
((arrived _)
|
||||
conn)
|
||||
((and departure (departed _ _))
|
||||
(disconnect-with-error/local-info
|
||||
departure
|
||||
SSH_DISCONNECT_BY_APPLICATION
|
||||
"Application disconnected"))
|
||||
((says _ (rpc-reply transaction message) _)
|
||||
;; TODO: not cap-secure. Introduce sealers, or indirect.
|
||||
(finish-app-request conn transaction message))))))
|
||||
|
||||
;; (K V A -> A) A Hash<K,V> -> A
|
||||
(define (hash-fold fn seed hash)
|
||||
(do ((pos (hash-iterate-first hash) (hash-iterate-next hash pos))
|
||||
(seed seed (fn (hash-iterate-key hash pos) (hash-iterate-value hash pos) seed)))
|
||||
((not pos) seed)))
|
||||
|
||||
(define (channel-events conn)
|
||||
(hash-fold (lambda (my-ref ch evt)
|
||||
(choice-evt evt
|
||||
(handle-evt (send (ssh-channel-room-handle ch) listen-evt)
|
||||
(channel-room-message-handler my-ref))))
|
||||
never-evt
|
||||
(connection-channel-map conn)))
|
||||
|
||||
(define (channel-room-message-handler my-ref)
|
||||
(lambda (message)
|
||||
(lambda (conn)
|
||||
(define ch (get-channel conn my-ref))
|
||||
(define your-ref (ssh-channel-your-ref ch))
|
||||
(match message
|
||||
((arrived _)
|
||||
conn)
|
||||
((departed _ _)
|
||||
(maybe-close-channel ch conn 'local))
|
||||
((says _ (credit _ amount) _)
|
||||
(write-message!/flush (ssh-msg-channel-window-adjust your-ref amount) conn)
|
||||
conn)
|
||||
((says _ `(data ,bits) _)
|
||||
(write-message!/flush (ssh-msg-channel-data your-ref bits) conn)
|
||||
conn)
|
||||
((says _ `(eof) _)
|
||||
(write-message!/flush (ssh-msg-channel-eof your-ref) conn)
|
||||
conn)
|
||||
((says _ (rpc-reply id m) _)
|
||||
(finish-channel-request ch conn id m))))))
|
||||
|
||||
(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!/flush algs conn)
|
||||
(loop (struct-copy connection conn [rekey-state (rekey-local algs)])))
|
||||
(let ((handler (sync (if (rekey-wait? rekey)
|
||||
(handle-evt (alarm-evt (* (rekey-wait-deadline rekey) 1000))
|
||||
(lambda (dummy)
|
||||
(lambda (conn)
|
||||
conn)))
|
||||
never-evt)
|
||||
(handle-evt (send (connection-io-room-handle conn) listen-evt)
|
||||
io-room-message-handler)
|
||||
(handle-evt (send (connection-session-room-handle conn) listen-evt)
|
||||
session-room-message-handler)
|
||||
(channel-events conn))))
|
||||
(define new-conn (handler conn))
|
||||
;; The handler is permitted to return #f to indicate that the session is to be
|
||||
;; gracefully shut down.
|
||||
(when new-conn
|
||||
(loop new-conn)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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 (ssh-session role in out)
|
||||
(define io-room (make-room (gensym 'ssh-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)
|
||||
#f
|
||||
(make-transaction-manager)
|
||||
(hash)
|
||||
(case role ((client) #f) ((server) #t))
|
||||
local-identification-string
|
||||
peer-identification-string
|
||||
#f))))
|
||||
|
||||
(join-room session-room 'app))
|
||||
|
|
@ -1,38 +0,0 @@
|
|||
#lang racket/base
|
||||
;; A box whose value can only be set once, that starts life with no
|
||||
;; value, and that supports an event waiting for a value to arrive.
|
||||
|
||||
(provide make-blocking-box
|
||||
blocking-box-evt
|
||||
blocking-box-value
|
||||
set-blocking-box!)
|
||||
|
||||
(struct blocking-box (thread set-ch get-ch))
|
||||
|
||||
(define (make-blocking-box)
|
||||
(define set-ch (make-channel))
|
||||
(define get-ch (make-channel))
|
||||
(blocking-box (thread/suspend-to-kill (lambda () (manager set-ch get-ch)))
|
||||
set-ch
|
||||
get-ch))
|
||||
|
||||
(define (manager s g)
|
||||
(define v (channel-get s))
|
||||
(let loop ()
|
||||
(sync s (channel-put-evt g v)) ;; ignore any future settings, answer all future gettings
|
||||
(loop)))
|
||||
|
||||
(define (blocking-box-evt b)
|
||||
(guard-evt
|
||||
(lambda ()
|
||||
;; Ensure the manager is running within our custodian:
|
||||
(thread-resume (blocking-box-thread b) (current-thread))
|
||||
(blocking-box-get-ch b))))
|
||||
|
||||
(define (blocking-box-value b)
|
||||
(sync (blocking-box-evt b)))
|
||||
|
||||
(define (set-blocking-box! b v)
|
||||
;; Ensure the manager is running within our custodian:
|
||||
(thread-resume (blocking-box-thread b) (current-thread))
|
||||
(channel-put (blocking-box-set-ch b) v))
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(define (load-in-background description module)
|
||||
(printf "Starting ~s...\n" description)
|
||||
(thread (lambda () (dynamic-require module #f))))
|
||||
|
||||
(define (wait-for-completion threads)
|
||||
(when (pair? threads)
|
||||
(apply sync (map (lambda (t)
|
||||
(handle-evt (thread-dead-evt t)
|
||||
(lambda (dummy)
|
||||
(wait-for-completion (remove t threads)))))
|
||||
threads))))
|
||||
|
||||
(wait-for-completion
|
||||
(list (load-in-background "DNS server" "../racket-dns/driver.rkt")
|
||||
(load-in-background "SSH server" "repl-server.rkt")))
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
#lang racket/base
|
||||
;; Reexport racket-matrix module contents.
|
||||
|
||||
(require marketplace/sugar-untyped)
|
||||
(require marketplace/drivers/tcp)
|
||||
(require marketplace/drivers/timer-untyped)
|
||||
(require marketplace/drivers/event-relay)
|
||||
|
||||
(provide (all-from-out marketplace/sugar-untyped))
|
||||
(provide (all-from-out marketplace/drivers/tcp))
|
||||
(provide (all-from-out marketplace/drivers/timer-untyped))
|
||||
(provide (all-from-out marketplace/drivers/event-relay))
|
||||
222
new-server.rkt
222
new-server.rkt
|
|
@ -14,22 +14,20 @@
|
|||
(require "ssh-channel.rkt")
|
||||
(require "ssh-message-types.rkt")
|
||||
(require "ssh-exceptions.rkt")
|
||||
(require "os2-support.rkt")
|
||||
(require "marketplace-support.rkt")
|
||||
|
||||
(define (main)
|
||||
(ground-vm
|
||||
(transition 'no-state
|
||||
(spawn (timer-driver 'timer-driver))
|
||||
;; PAPER NOTE: remove #:debug-name for presentation economy
|
||||
(spawn tcp-driver #:debug-name 'tcp-driver)
|
||||
(spawn tcp-spy #:debug-name 'tcp-spy)
|
||||
(spawn listener #:debug-name 'ssh-tcp-listener))))
|
||||
(ground-vm (timer-driver)
|
||||
(tcp-driver)
|
||||
(tcp-spy)
|
||||
(spawn #:debug-name 'ssh-tcp-listener #:child listener)))
|
||||
|
||||
(define listener
|
||||
(transition 'no-state
|
||||
(role (tcp-listener 2322)
|
||||
#:topic t
|
||||
#:on-presence (spawn (session-vm t) #:debug-name (debug-name 'ssh-session-vm t)))))
|
||||
(transition/no-state
|
||||
(endpoint #:subscriber (tcp-channel ? (tcp-listener 2322) ?)
|
||||
#:observer
|
||||
#:conversation r
|
||||
#:on-presence (session-vm r))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -45,59 +43,81 @@
|
|||
peer-identification-string)))
|
||||
|
||||
(define (spy marker)
|
||||
(role (or (topic-subscriber (wild) #:monitor? #t)
|
||||
(topic-publisher (wild) #:monitor? #t))
|
||||
[message
|
||||
(write `(,marker ,message))
|
||||
(newline)
|
||||
(flush-output)
|
||||
(void)]))
|
||||
(define (dump what message)
|
||||
(write `(,marker ,what ,message))
|
||||
(newline)
|
||||
(flush-output)
|
||||
(void))
|
||||
(list
|
||||
(endpoint #:subscriber (wild) #:everything
|
||||
#:role r
|
||||
#:on-presence (dump 'arrived r)
|
||||
#:on-absence (dump 'departed r)
|
||||
[message (dump 'message message)])
|
||||
(endpoint #:publisher (wild) #:everything
|
||||
#:role r
|
||||
#:on-presence (dump 'arrived r)
|
||||
#:on-absence (dump 'departed r)
|
||||
[message (dump 'message message)])))
|
||||
|
||||
(define-syntax-rule (wait-for topic-of-interest action ...)
|
||||
(role/fresh role-name topic-of-interest
|
||||
#:state state
|
||||
#:on-presence (sequence-actions (transition state)
|
||||
(delete-role role-name)
|
||||
action ...)))
|
||||
(define-syntax-rule (wait-as my-orientation topic action ...)
|
||||
(endpoint my-orientation topic #:observer
|
||||
#:let-name endpoint-name
|
||||
#:state state
|
||||
#:on-presence (begin (printf "WAIT ENDED: ~v\n" topic)
|
||||
(sequence-actions (transition state
|
||||
(delete-endpoint endpoint-name)
|
||||
action ...)))))
|
||||
|
||||
(define (session-vm new-connection-topic)
|
||||
(define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
|
||||
(define (session-vm new-conversation)
|
||||
(match-define (tcp-channel remote-addr local-addr _) new-conversation)
|
||||
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
||||
|
||||
(define (issue-identification-string)
|
||||
(at-meta-level (cout (bytes-append local-identification #"\r\n"))))
|
||||
(at-meta-level
|
||||
(send-message (tcp-channel local-addr remote-addr
|
||||
(bytes-append local-identification #"\r\n")))))
|
||||
|
||||
(define (read-handshake-and-become-reader)
|
||||
(transition 'handshake-is-stateless ;; but, crucially, the ssh-reader proper isn't!
|
||||
(at-meta-level
|
||||
(role in-topic
|
||||
#:name 'socket-reader
|
||||
#:state state
|
||||
(endpoint #:subscriber (tcp-channel remote-addr local-addr ?)
|
||||
#:name 'socket-reader
|
||||
#:state state
|
||||
[(tcp-channel _ _ (? eof-object?))
|
||||
(transition state (quit))]
|
||||
[(tcp-channel _ _ (? bytes? remote-identification))
|
||||
(check-remote-identification! remote-identification)
|
||||
(sequence-actions (transition state)
|
||||
;; First, set the incoming mode to bytes.
|
||||
(at-meta-level (cin (tcp-mode 'bytes)))
|
||||
;; Then initialise the reader, switching to packet-reading mode.
|
||||
(lambda (ignored-state) (ssh-reader new-connection-topic))
|
||||
;; Finally, spawn the remaining processes and issue the initial credit to the reader.
|
||||
(spawn (ssh-writer new-connection-topic)
|
||||
#:exit-signal? #t
|
||||
#:debug-name 'ssh-writer)
|
||||
;; Wait for the reader and writer get started, then tell
|
||||
;; the reader we are ready for a single packet and spawn
|
||||
;; the session manager.
|
||||
(wait-for (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)) #:monitor? #t)
|
||||
(wait-for (topic-publisher (outbound-packet (wild)) #:monitor? #t)
|
||||
(send-message (inbound-credit 1))
|
||||
(spawn (ssh-session local-identification
|
||||
remote-identification
|
||||
repl-boot
|
||||
'server)
|
||||
#:exit-signal? #t
|
||||
#:debug-name 'ssh-session))))]))))
|
||||
(begin
|
||||
(check-remote-identification! remote-identification)
|
||||
(sequence-actions (transition state)
|
||||
;; First, set the incoming mode to bytes.
|
||||
(at-meta-level
|
||||
(send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'bytes))))
|
||||
;; Then initialise the reader, switching to packet-reading mode.
|
||||
(lambda (ignored-state) (ssh-reader new-conversation))
|
||||
;; Finally, spawn the remaining processes and issue the initial credit to the reader.
|
||||
(spawn #:debug-name 'ssh-writer
|
||||
#:child (ssh-writer new-conversation)
|
||||
;; TODO: canary: #:exit-signal? #t
|
||||
)
|
||||
;; Wait for the reader and writer get started, then tell
|
||||
;; the reader we are ready for a single packet and spawn
|
||||
;; the session manager.
|
||||
(printf "BOO\n")
|
||||
(wait-as #:subscriber (inbound-packet (wild) (wild) (wild) (wild))
|
||||
(printf "YAY\n") (flush-output)
|
||||
(wait-as #:publisher (outbound-packet (wild))
|
||||
(printf "ALSO YAY\n") (flush-output)
|
||||
(send-message (inbound-credit 1))
|
||||
(spawn #:debug-name 'ssh-session
|
||||
#:pid session-pid
|
||||
#:child (ssh-session session-pid
|
||||
local-identification
|
||||
remote-identification
|
||||
repl-boot
|
||||
'server)
|
||||
;; TODO: canary: #:exit-signal? #t
|
||||
)))))]))))
|
||||
|
||||
(define (exn->outbound-packet reason)
|
||||
(outbound-packet (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code reason)
|
||||
|
|
@ -123,44 +143,43 @@
|
|||
(define (inert-exception-handler reason)
|
||||
inert-exception-handler)
|
||||
|
||||
(nested-vm #:debug-name (debug-name 'ssh-session-vm new-connection-topic)
|
||||
(transition 'no-state
|
||||
(spawn event-relay #:debug-name (debug-name 'session-event-relay))
|
||||
(spawn (timer-relay 'ssh-timer-relay) #:debug-name 'ssh-timer-relay)
|
||||
(spy 'SSH)
|
||||
(nested-vm #:debug-name (list 'ssh-session-vm new-conversation)
|
||||
(event-relay 'ssh-event-relay)
|
||||
(timer-relay 'ssh-timer-relay)
|
||||
(spy 'SSH)
|
||||
|
||||
(issue-identification-string)
|
||||
(issue-identification-string)
|
||||
|
||||
;; Expect identification string, then update (!) our inbound
|
||||
;; subscription handler to switch to packet mode.
|
||||
(at-meta-level (cin (tcp-mode 'lines)))
|
||||
(at-meta-level (cin (tcp-credit 1)))
|
||||
;; Expect identification string, then update (!) our inbound
|
||||
;; subscription handler to switch to packet mode.
|
||||
(at-meta-level
|
||||
(send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'lines)))
|
||||
(send-feedback (tcp-channel remote-addr local-addr (tcp-credit 1))))
|
||||
|
||||
(spawn (read-handshake-and-become-reader)
|
||||
#:exit-signal? #t
|
||||
#:debug-name 'ssh-reader)
|
||||
(spawn #:debug-name 'ssh-reader
|
||||
#:child (read-handshake-and-become-reader)
|
||||
;; TODO: canary: #:exit-signal? #t
|
||||
)
|
||||
|
||||
(spawn (transition active-exception-handler
|
||||
(role (topic-subscriber (exit-signal (wild) (wild)))
|
||||
#:state current-handler
|
||||
#:reason reason
|
||||
#:on-absence (current-handler reason)))))))
|
||||
;; TODO: canary:
|
||||
;; (spawn #:child
|
||||
;; (transition active-exception-handler
|
||||
;; (role (topic-subscriber (exit-signal (wild) (wild)))
|
||||
;; #:state current-handler
|
||||
;; #:reason reason
|
||||
;; #:on-absence (current-handler reason))))
|
||||
))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (repl-boot user-name)
|
||||
(transition 'no-repl-state
|
||||
(spawn event-relay #:debug-name (debug-name 'repl-event-relay))
|
||||
(spy 'APP)
|
||||
(at-meta-level
|
||||
(role (topic-subscriber (channel-message (channel-stream-name #t (wild)) (wild)))
|
||||
#:state state
|
||||
#:topic t
|
||||
#:on-presence (match t
|
||||
[(topic _ (channel-message (channel-stream-name _ cname) _) _)
|
||||
(transition state (spawn (repl-instance user-name cname)
|
||||
#:debug-name cname))])))))
|
||||
|
||||
(list
|
||||
(event-relay 'app-event-relay)
|
||||
(spy 'APP)
|
||||
(at-meta-level
|
||||
(endpoint #:subscriber (channel-message (channel-stream-name #t (wild)) (wild))
|
||||
#:conversation (channel-message (channel-stream-name _ cname) _)
|
||||
#:on-presence (spawn #:debug-name cname #:child (repl-instance user-name cname))))))
|
||||
|
||||
;; (repl-instance InputPort OutputPort InputPort OutputPort)
|
||||
(struct repl-instance-state (c2s-in ;; used by thread to read input from relay
|
||||
|
|
@ -193,9 +212,9 @@
|
|||
(define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out))))
|
||||
(transition state
|
||||
(ch-do send-feedback inbound-stream (channel-stream-ok))
|
||||
(role (topic-subscriber (cons (thread-dead-evt repl-thread) (wild)))
|
||||
(endpoint #:subscriber (cons (thread-dead-evt repl-thread) (wild))
|
||||
[_ (quit #:reason "REPL thread exited")])
|
||||
(role (topic-subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild)))
|
||||
(endpoint #:subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild))
|
||||
;; We're using peek-bytes-avail!-evt rather than
|
||||
;; read-bytes-avail!-evt because of potential overwriting
|
||||
;; of the buffer. The overwriting can happen when there's
|
||||
|
|
@ -204,22 +223,24 @@
|
|||
;; will overwrite its buffer next time it's synced on.
|
||||
#:state state
|
||||
[(cons _ (? eof-object?))
|
||||
(match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state)
|
||||
(close-input-port c2s-in)
|
||||
(close-output-port c2s-out)
|
||||
(close-input-port s2c-in)
|
||||
(close-output-port s2c-out)
|
||||
(transition state (quit))]
|
||||
(let ()
|
||||
(match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state)
|
||||
(close-input-port c2s-in)
|
||||
(close-output-port c2s-out)
|
||||
(close-input-port s2c-in)
|
||||
(close-output-port s2c-out)
|
||||
(transition state (quit)))]
|
||||
[(cons _ (? number? count))
|
||||
(transition state
|
||||
(ch-do send-message outbound-stream (channel-stream-data
|
||||
(read-bytes count s2c-in))))]))]
|
||||
[(or (channel-stream-data #"\4") ;; C-d a.k.a EOT
|
||||
(channel-stream-eof))
|
||||
(close-output-port (repl-instance-state-c2s-out state))
|
||||
;; ^ this signals the repl thread to exit.
|
||||
;; Now, wait for it to do so.
|
||||
(transition state)]
|
||||
(let ()
|
||||
(close-output-port (repl-instance-state-c2s-out state))
|
||||
;; ^ this signals the repl thread to exit.
|
||||
;; Now, wait for it to do so.
|
||||
(transition state))]
|
||||
[(channel-stream-data bs)
|
||||
(write-bytes bs (repl-instance-state-c2s-out state))
|
||||
(flush-output (repl-instance-state-c2s-out state))
|
||||
|
|
@ -234,7 +255,7 @@
|
|||
(define-values (s2c-in s2c-out) (make-pipe))
|
||||
(transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out)
|
||||
(at-meta-level
|
||||
(role (topic-subscriber (channel-message inbound-stream (wild)))
|
||||
(endpoint #:subscriber (channel-message inbound-stream (wild))
|
||||
#:state state
|
||||
#:on-presence (transition state
|
||||
(ch-do send-feedback inbound-stream (channel-stream-config
|
||||
|
|
@ -244,12 +265,13 @@
|
|||
[(channel-message _ body)
|
||||
(handle-channel-message state body)]))
|
||||
(at-meta-level
|
||||
(role (topic-publisher (channel-message outbound-stream (wild)))
|
||||
(endpoint #:publisher (channel-message outbound-stream (wild))
|
||||
[m
|
||||
(write `(channel outbound ,cname ,m)) (newline)
|
||||
(void)])))]
|
||||
(begin
|
||||
(write `(channel outbound ,cname ,m)) (newline)
|
||||
(void))])))]
|
||||
[type
|
||||
(transition 'no-instance-state
|
||||
(transition/no-state
|
||||
(at-meta-level (send-message
|
||||
(channel-message outbound-stream
|
||||
(channel-stream-open-failure
|
||||
|
|
|
|||
|
|
@ -1,80 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Issue requests in order, process them in any order (or in
|
||||
;; parallel), reassemble the ordering at the end.
|
||||
|
||||
;; What I'm doing here reminded me of the signal-notification
|
||||
;; mechanism from [1], but is actually quite different.
|
||||
;;
|
||||
;; [1] O. Shivers, "Automatic management of operating-system
|
||||
;; resources," in Proceedings of the Second ACM SIGPLAN International
|
||||
;; Conference on Functional Programming (ICFP '97), 1997, vol. 32,
|
||||
;; no. 8, pp. 274-279.
|
||||
|
||||
(require "functional-queue.rkt")
|
||||
(require "conversation.rkt")
|
||||
(require racket/class)
|
||||
|
||||
(provide make-transaction-manager
|
||||
|
||||
transaction-manager?
|
||||
open-transaction
|
||||
close-transaction!
|
||||
transaction-available?
|
||||
dequeue-transaction
|
||||
|
||||
transaction?
|
||||
transaction-context
|
||||
transaction-value
|
||||
|
||||
room-rpc
|
||||
room-rpc-finish)
|
||||
|
||||
(struct transaction-manager (queue) #:transparent)
|
||||
|
||||
(struct transaction (context
|
||||
[value* #:mutable]
|
||||
[ready? #:mutable]))
|
||||
|
||||
(define (make-transaction-manager)
|
||||
(transaction-manager (make-queue)))
|
||||
|
||||
(define (open-transaction manager context)
|
||||
(define txn (transaction context #f #f))
|
||||
(values txn (transaction-manager (enqueue (transaction-manager-queue manager) txn))))
|
||||
|
||||
(define (close-transaction! txn value)
|
||||
(when (transaction-ready? txn)
|
||||
(error 'close-transaction! "Attempt to close previously-closed transaction"))
|
||||
(set-transaction-value*! txn value)
|
||||
(set-transaction-ready?! txn #t)
|
||||
value)
|
||||
|
||||
(define (transaction-available? manager)
|
||||
(if (queue-empty? (transaction-manager-queue manager))
|
||||
#f
|
||||
(let-values (((txn rest) (dequeue (transaction-manager-queue manager))))
|
||||
(transaction-ready? txn))))
|
||||
|
||||
(define (dequeue-transaction manager)
|
||||
(let-values (((txn rest) (dequeue (transaction-manager-queue manager))))
|
||||
(values txn (transaction-manager rest))))
|
||||
|
||||
(define (transaction-value txn)
|
||||
(when (not (transaction-ready? txn))
|
||||
(error 'transaction-value "Attempt to extract value from unclosed transaction"))
|
||||
(transaction-value* txn))
|
||||
|
||||
(define (room-rpc handle manager message k)
|
||||
(define-values (txn new-manager) (open-transaction manager k))
|
||||
(send handle say (rpc-request (send handle reply-name) txn message))
|
||||
new-manager)
|
||||
|
||||
(define (room-rpc-finish manager txn message)
|
||||
(close-transaction! txn (lambda args (apply (transaction-context txn) message args)))
|
||||
(collect-ready-work '() manager))
|
||||
|
||||
(define (collect-ready-work work manager)
|
||||
(if (transaction-available? manager)
|
||||
(let-values (((txn rest) (dequeue-transaction manager)))
|
||||
(collect-ready-work (cons (transaction-value txn) work) rest))
|
||||
(values (reverse work) manager)))
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Reexport racket-matrix module contents.
|
||||
|
||||
(require "../racket-matrix/os2.rkt")
|
||||
(require "../racket-matrix/os2-event-relay.rkt")
|
||||
(require "../racket-matrix/os2-timer.rkt")
|
||||
(require "../racket-matrix/fake-tcp.rkt")
|
||||
|
||||
(provide (all-from-out "../racket-matrix/os2.rkt"))
|
||||
(provide (all-from-out "../racket-matrix/os2-event-relay.rkt"))
|
||||
(provide (all-from-out "../racket-matrix/os2-timer.rkt"))
|
||||
(provide (all-from-out "../racket-matrix/fake-tcp.rkt"))
|
||||
144
repl-server.rkt
144
repl-server.rkt
|
|
@ -1,144 +0,0 @@
|
|||
#lang racket/base
|
||||
;; (Temporary) example client and server
|
||||
|
||||
(require racket/tcp)
|
||||
(require racket/pretty)
|
||||
(require racket/match)
|
||||
(require racket/class)
|
||||
(require racket/port)
|
||||
(require racket/sandbox)
|
||||
|
||||
(require "ssh-service.rkt")
|
||||
(require "standard-thread.rkt")
|
||||
|
||||
(require "conversation.rkt")
|
||||
|
||||
(struct user-state (name master-sandbox master-namespace) #:transparent)
|
||||
|
||||
(define *user-states* (make-hash))
|
||||
|
||||
(define *login-limit* (make-semaphore 3))
|
||||
|
||||
(define *interaction* (make-room 'interaction))
|
||||
(spy-on *interaction*)
|
||||
|
||||
(define *interaction-handle* (make-parameter #f))
|
||||
|
||||
(define *prompt* "RacketSSH> ")
|
||||
|
||||
(define (->string/safe bs)
|
||||
(cond
|
||||
((string? bs) bs)
|
||||
((bytes? bs) (with-handlers ((exn:fail? (lambda (e) (bytes->string/latin-1 bs))))
|
||||
(bytes->string/utf-8 bs)))
|
||||
(else (call-with-output-string (lambda (p) (write bs p))))))
|
||||
|
||||
(define (dump-interactions handle)
|
||||
(display *prompt*)
|
||||
(let retry-without-prompt ()
|
||||
(sync (handle-evt (send handle listen-evt)
|
||||
(lambda (message)
|
||||
(display "\033[1G\033[2K") ;; clear current line
|
||||
(let loop ((message message))
|
||||
(when message
|
||||
(match message
|
||||
((arrived who) (printf "*** ~a arrived\n" (->string/safe who)))
|
||||
((departed who why) (printf "*** ~a departed (~a)\n"
|
||||
(->string/safe who)
|
||||
(->string/safe why)))
|
||||
((says who what #f)
|
||||
(printf " ~a: ~a\n" (->string/safe who) (->string/safe what)))
|
||||
((says who what topic)
|
||||
(printf " ~a (~a): ~a\n"
|
||||
(->string/safe who)
|
||||
(->string/safe topic)
|
||||
(->string/safe what))))
|
||||
(loop (send handle try-listen))))
|
||||
(dump-interactions handle)))
|
||||
(handle-evt (peek-string-evt 1 0 #f (current-input-port))
|
||||
(lambda (s)
|
||||
(cond
|
||||
((eof-object? s))
|
||||
((char-whitespace? (string-ref s 0))
|
||||
(read-string 1 (current-input-port))
|
||||
(retry-without-prompt))
|
||||
(else 'ready-to-read-something-real)))))))
|
||||
|
||||
(define (call-with-interaction-prompt-read handle thunk)
|
||||
(parameterize ((current-prompt-read (lambda ()
|
||||
(dump-interactions handle)
|
||||
(read-syntax "<ssh-session>" (current-input-port)))))
|
||||
(thunk)))
|
||||
|
||||
(define (help)
|
||||
(printf "This is RacketSSH, a secure REPL for Racket.\n")
|
||||
(printf "Definitions made are kept in a per-user environment.\n")
|
||||
(printf "Beyond core Racket,\n")
|
||||
(printf " (say <any>) - communicates its argument to other logged-in users\n")
|
||||
(printf " (help) - this help message\n")
|
||||
(printf "If the reader gets confused, try control-L to make it reprint the line\n")
|
||||
(printf "buffer, or ESC to clear the line buffer.\n"))
|
||||
|
||||
(define (say utterance)
|
||||
(printf " You: ~a\n" (->string/safe utterance))
|
||||
(send (*interaction-handle*) say utterance)
|
||||
(void))
|
||||
|
||||
(define (get-user-state username)
|
||||
(when (not (hash-has-key? *user-states* username))
|
||||
(let* ((sb (make-evaluator 'racket/base))
|
||||
(ns (call-in-sandbox-context sb current-namespace)))
|
||||
(parameterize ((current-namespace ns))
|
||||
(namespace-set-variable-value! 'help help)
|
||||
(namespace-set-variable-value! 'say say))
|
||||
(hash-set! *user-states* username
|
||||
(user-state username
|
||||
sb
|
||||
ns))))
|
||||
(hash-ref *user-states* username))
|
||||
|
||||
(define (repl-shell username in out)
|
||||
(define handle (join-room *interaction* username))
|
||||
(match-define (user-state _ master-sandbox master-namespace) (get-user-state username))
|
||||
(parameterize ((current-input-port in)
|
||||
(current-output-port out)
|
||||
(current-error-port out)
|
||||
(sandbox-input in)
|
||||
(sandbox-output out)
|
||||
(sandbox-error-output out)
|
||||
(sandbox-memory-limit 2) ;; megabytes
|
||||
(sandbox-eval-limits #f)
|
||||
(sandbox-namespace-specs (list (lambda () master-namespace))))
|
||||
(printf "Hello, ~a.\n" username)
|
||||
(printf "Type (help) for help.\n")
|
||||
(define slave-sandbox (make-evaluator '(begin)))
|
||||
;; ^^ uses master-namespace via sandbox-namespace-specs
|
||||
(slave-sandbox `(,*interaction-handle* ,handle))
|
||||
(parameterize ((current-namespace master-namespace)
|
||||
(current-eval slave-sandbox))
|
||||
(call-with-interaction-prompt-read handle read-eval-print-loop))
|
||||
(fprintf out "\nGoodbye!\n")
|
||||
(kill-evaluator slave-sandbox)
|
||||
(close-input-port in)
|
||||
(close-output-port out)))
|
||||
|
||||
(define (limited-repl-shell username in out)
|
||||
(call-with-semaphore *login-limit*
|
||||
(lambda () (repl-shell username in out))
|
||||
(lambda () (reject-login username in out))))
|
||||
|
||||
(define (reject-login username in out)
|
||||
(parameterize ((current-input-port in)
|
||||
(current-output-port out)
|
||||
(current-error-port out))
|
||||
(printf "Hello, ~a - unfortunately, the system is too busy to accept your\n" username)
|
||||
(printf "login right now. Please try again later.\n")
|
||||
(close-input-port in)
|
||||
(close-output-port out)))
|
||||
|
||||
(define (t-server)
|
||||
(define s (tcp-listen 2322 4 #t))
|
||||
(printf "Accepting...\n")
|
||||
(tcp-pty-ssh-server s limited-repl-shell #:prompt *prompt*))
|
||||
|
||||
(t-server)
|
||||
28
safe-io.rkt
28
safe-io.rkt
|
|
@ -1,28 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide read-line-limited)
|
||||
|
||||
;; Port Natural -> (or String EofObject)
|
||||
;; Uses Internet (CRLF) convention. Limit does not cover the CRLF
|
||||
;; bytes.
|
||||
(define (read-line-limited port limit)
|
||||
(let collect-chars ((acc '())
|
||||
(remaining limit))
|
||||
(let ((ch (read-char port)))
|
||||
(cond
|
||||
((eof-object? ch) (if (null? acc)
|
||||
ch
|
||||
(list->string (reverse acc))))
|
||||
((eqv? ch #\return) (let ((ch (read-char port)))
|
||||
(if (eqv? ch #\linefeed)
|
||||
(list->string (reverse acc))
|
||||
(error 'read-line-limited
|
||||
"Invalid character ~v after #\\return"
|
||||
ch))))
|
||||
((eqv? ch #\newline)
|
||||
;; Is this a good idea?
|
||||
(error 'read-line-limited "Bare #\\linefeed encountered"))
|
||||
((positive? remaining) (collect-chars (cons ch acc) (- remaining 1)))
|
||||
(else (error 'read-line-limited
|
||||
"Line too long (more than ~v bytes before CRLF)"
|
||||
limit))))))
|
||||
|
|
@ -3,12 +3,6 @@
|
|||
(require racket/set)
|
||||
(require racket/match)
|
||||
|
||||
(require "ssh-numbers.rkt")
|
||||
(require "ssh-message-types.rkt")
|
||||
(require "ssh-exceptions.rkt")
|
||||
|
||||
(require "os2-support.rkt")
|
||||
|
||||
(provide (struct-out ssh-channel)
|
||||
|
||||
(struct-out channel-name)
|
||||
|
|
|
|||
212
ssh-service.rkt
212
ssh-service.rkt
|
|
@ -1,212 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (planet tonyg/bitsyntax))
|
||||
|
||||
(require racket/tcp)
|
||||
(require racket/match)
|
||||
(require racket/class)
|
||||
(require racket/port)
|
||||
|
||||
(require "conversation.rkt")
|
||||
(require "ssh-numbers.rkt")
|
||||
(require "ssh-session.rkt")
|
||||
(require "standard-thread.rkt")
|
||||
(require "functional-queue.rkt")
|
||||
|
||||
(require "cook-port.rkt")
|
||||
|
||||
(provide channel-io-transfer-buffer-size
|
||||
|
||||
raw-ssh-server-session
|
||||
raw-ssh-server-session/session
|
||||
|
||||
pty-ssh-server-session
|
||||
pty-ssh-server-session-callback
|
||||
|
||||
tcp-pty-ssh-server)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Parameters
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define channel-io-transfer-buffer-size (make-parameter 4096))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Generic services
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (run-channel oob-ch app-out-port app-in-port in out handle)
|
||||
(define (close-in) (when (not (port-closed? in)) (close-input-port in)))
|
||||
(define (close-out) (when (not (port-closed? out)) (close-output-port out)))
|
||||
(define (close-ports)
|
||||
(close-in)
|
||||
(close-out)
|
||||
'closed)
|
||||
(let loop ((oob-queue (make-queue))
|
||||
(remaining-credit 0))
|
||||
(when (port-closed? app-in-port)
|
||||
;; The application has stopped listening. Ensure we stop sending, just as if an EOF
|
||||
;; was received from the remote.
|
||||
(close-out))
|
||||
(define finished-reading? (port-closed? in))
|
||||
(define finished-writing? (port-closed? out))
|
||||
(if (and finished-reading? finished-writing?)
|
||||
'closed
|
||||
(sync (handle-evt (alarm-evt (+ (current-inexact-milliseconds) 500))
|
||||
;; TODO: remove polling for port-closed when we get port-closed-evt
|
||||
(lambda (dummy)
|
||||
(loop oob-queue remaining-credit)))
|
||||
(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 remaining-credit)))))
|
||||
(if finished-reading?
|
||||
never-evt
|
||||
(if (positive? remaining-credit)
|
||||
(let ((buffer (make-bytes (min (channel-io-transfer-buffer-size)
|
||||
remaining-credit))))
|
||||
(handle-evt (read-bytes-avail!-evt buffer in)
|
||||
(lambda (count)
|
||||
(if (eof-object? count)
|
||||
(begin (send handle say `(eof))
|
||||
(close-in)
|
||||
(loop oob-queue remaining-credit))
|
||||
(let ((data (sub-bit-string buffer 0 (* 8 count))))
|
||||
(begin (send handle say `(data ,data))
|
||||
(loop oob-queue (- remaining-credit count))))))))
|
||||
never-evt))
|
||||
(handle-evt (send handle listen-evt)
|
||||
(match-lambda
|
||||
((arrived _)
|
||||
(loop oob-queue remaining-credit))
|
||||
((and departure (departed who why))
|
||||
(send handle depart departure)
|
||||
(close-ports))
|
||||
((says _ (credit _ amount) _)
|
||||
(loop oob-queue (+ remaining-credit amount)))
|
||||
((says _ `(data ,data) _)
|
||||
(when (not finished-writing?) (write-bytes data out))
|
||||
;; TODO: propagate backpressure through pipes
|
||||
(send handle say (credit 'session (bytes-length data)))
|
||||
(loop oob-queue remaining-credit))
|
||||
((says _ `(eof) _)
|
||||
(close-out)
|
||||
(loop oob-queue remaining-credit))
|
||||
((says _ (and notification `(notify ,type ,data)) _)
|
||||
(loop (enqueue oob-queue notification) remaining-credit))
|
||||
((says _ (rpc-request reply-to id message) _)
|
||||
(loop (enqueue oob-queue
|
||||
`(request ,message
|
||||
,(lambda (answer)
|
||||
(send handle say
|
||||
(rpc-reply id answer)
|
||||
reply-to))))
|
||||
remaining-credit))))))))
|
||||
|
||||
(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
|
||||
app-a2s
|
||||
app-s2a
|
||||
session-a2s
|
||||
session-s2a
|
||||
(join-room channel-room 'app))))
|
||||
(wait-for-members channel-room '(app))
|
||||
|
||||
(standard-thread (lambda ()
|
||||
(channel-main oob-ch app-s2a app-a2s)))
|
||||
|
||||
channel-room)
|
||||
|
||||
(define (raw-ssh-server-session handle channel-open-callback state)
|
||||
(let loop ((state state))
|
||||
(match (send handle listen)
|
||||
((arrived _)
|
||||
(loop state))
|
||||
((and departure (departed _ _))
|
||||
(send handle depart departure))
|
||||
((says _ (rpc-request reply-to id message) _)
|
||||
(match message
|
||||
(`(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)))))))
|
||||
|
||||
(define (raw-ssh-server-session/session handle session-callback)
|
||||
(raw-ssh-server-session handle
|
||||
(lambda (username channel-type extra-request-data state)
|
||||
(match channel-type
|
||||
(#"session"
|
||||
(define (start-session oob-ch in out)
|
||||
(session-callback username oob-ch in out))
|
||||
(values `(ok ,start-session #"") state))
|
||||
(else
|
||||
(values `(error ,SSH_OPEN_UNKNOWN_CHANNEL_TYPE
|
||||
"Unknown channel type")
|
||||
state))))
|
||||
'no-state))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; PTY-based/shell-like services
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (pty-ssh-server-session handle shell-callback #:prompt [prompt ""])
|
||||
(raw-ssh-server-session/session handle
|
||||
(pty-ssh-server-session-callback shell-callback
|
||||
#:prompt prompt)))
|
||||
|
||||
(define (pty-ssh-server-session-callback shell-callback #:prompt [prompt ""])
|
||||
(lambda (username oob-ch in out)
|
||||
(define (base-eh loop)
|
||||
(match-lambda
|
||||
(`(notify ,type ,data) ;; ignore notifications
|
||||
(log-debug (format "pty-ssh-server-session-callback: notification ~v ~v" type data))
|
||||
(loop))
|
||||
(`(request ,req ,k)
|
||||
(log-debug (format "pty-ssh-server-session-callback: ignored request ~v" req))
|
||||
(k 'error) ;; we don't support requests
|
||||
(loop))))
|
||||
|
||||
(define (start-shell in out)
|
||||
(define shell-thread (thread (lambda () (shell-callback username in out))))
|
||||
(let loop ()
|
||||
(sync (handle-evt oob-ch (base-eh loop))
|
||||
(handle-evt shell-thread void))))
|
||||
|
||||
(define (configure-shell in out)
|
||||
(let loop ()
|
||||
(sync (handle-evt oob-ch
|
||||
(match-lambda
|
||||
(`(request (#"pty-req" ,_) ,k)
|
||||
(k 'ok)
|
||||
(define-values (cooked-in cooked-out) (cook-io in out prompt))
|
||||
(configure-shell cooked-in cooked-out))
|
||||
(`(request (#"shell" ,_) ,k)
|
||||
(k 'ok)
|
||||
(start-shell in out))
|
||||
(other ((base-eh loop) other)))))))
|
||||
|
||||
(configure-shell in out)))
|
||||
|
||||
(define (tcp-pty-ssh-server server-socket shell-callback #:prompt [prompt ""])
|
||||
(let loop ()
|
||||
(define-values (i o) (tcp-accept server-socket))
|
||||
(standard-thread
|
||||
(lambda ()
|
||||
(pty-ssh-server-session (ssh-session 'server i o) shell-callback #:prompt prompt)))
|
||||
(loop)))
|
||||
242
ssh-session.rkt
242
ssh-session.rkt
|
|
@ -16,7 +16,7 @@
|
|||
(require "ssh-transport.rkt")
|
||||
(require "ssh-channel.rkt")
|
||||
|
||||
(require "os2-support.rkt")
|
||||
(require "marketplace-support.rkt")
|
||||
|
||||
(provide rekey-interval
|
||||
rekey-volume
|
||||
|
|
@ -495,10 +495,9 @@
|
|||
conn))))
|
||||
(lambda (conn)
|
||||
(transition conn
|
||||
(spawn (nested-vm #:debug-name 'ssh-application-vm
|
||||
((connection-application-boot conn) user-name))
|
||||
#:exit-signal? #t
|
||||
#:debug-name 'ssh-application-vm))))]
|
||||
;; TODO: canary for NESTED VM!: #:exit-signal? #t
|
||||
(nested-vm #:debug-name 'ssh-application-vm
|
||||
((connection-application-boot conn) user-name)))))]
|
||||
[else
|
||||
(transition conn
|
||||
(send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))]))
|
||||
|
|
@ -597,68 +596,70 @@
|
|||
[(remote)
|
||||
(case old-close-state
|
||||
[(neither local)
|
||||
(list (delete-role (list cname 'outbound))
|
||||
(delete-role (list cname 'inbound)))]
|
||||
(list (delete-endpoint (list cname 'outbound))
|
||||
(delete-endpoint (list cname 'inbound)))]
|
||||
[else (list)])])))]
|
||||
[else (transition conn)]))
|
||||
|
||||
(define (channel-roles cname initial-message-producer)
|
||||
(define (channel-endpoints cname initial-message-producer)
|
||||
(define inbound-stream-name (channel-stream-name #t cname))
|
||||
(define outbound-stream-name (channel-stream-name #f cname))
|
||||
(define (! conn message)
|
||||
(transition conn (send-message (outbound-packet message))))
|
||||
(list
|
||||
(role (topic-subscriber (channel-message outbound-stream-name (wild)))
|
||||
#:name (list cname 'outbound)
|
||||
#:state conn
|
||||
#:on-presence (transition conn
|
||||
(initial-message-producer inbound-stream-name outbound-stream-name))
|
||||
#:on-absence (maybe-close-channel cname conn 'local)
|
||||
(endpoint #:subscriber (channel-message outbound-stream-name (wild))
|
||||
#:name (list cname 'outbound)
|
||||
#:state conn
|
||||
#:on-presence (transition conn
|
||||
(initial-message-producer inbound-stream-name outbound-stream-name))
|
||||
#:on-absence (maybe-close-channel cname conn 'local)
|
||||
[(channel-message _ body)
|
||||
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
|
||||
(define remote-ref (ssh-channel-remote-ref ch))
|
||||
(match body
|
||||
[(channel-stream-data data-bytes)
|
||||
;; TODO: split data-bytes into packets if longer than max packet size
|
||||
(! conn (ssh-msg-channel-data remote-ref data-bytes))]
|
||||
[(channel-stream-extended-data type data-bytes)
|
||||
(! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))]
|
||||
[(channel-stream-eof)
|
||||
(! conn (ssh-msg-channel-eof remote-ref))]
|
||||
[(channel-stream-notify type data-bytes)
|
||||
(! conn (ssh-msg-channel-request remote-ref type #f data-bytes))]
|
||||
[(channel-stream-request type data-bytes)
|
||||
(! conn (ssh-msg-channel-request remote-ref type #t data-bytes))]
|
||||
[(channel-stream-open-failure reason description)
|
||||
(! (discard-channel cname conn)
|
||||
(ssh-msg-channel-open-failure remote-ref reason description #""))])])
|
||||
(role (topic-publisher (channel-message inbound-stream-name (wild)))
|
||||
#:name (list cname 'inbound)
|
||||
#:state conn
|
||||
(let ()
|
||||
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
|
||||
(define remote-ref (ssh-channel-remote-ref ch))
|
||||
(match body
|
||||
[(channel-stream-data data-bytes)
|
||||
;; TODO: split data-bytes into packets if longer than max packet size
|
||||
(! conn (ssh-msg-channel-data remote-ref data-bytes))]
|
||||
[(channel-stream-extended-data type data-bytes)
|
||||
(! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))]
|
||||
[(channel-stream-eof)
|
||||
(! conn (ssh-msg-channel-eof remote-ref))]
|
||||
[(channel-stream-notify type data-bytes)
|
||||
(! conn (ssh-msg-channel-request remote-ref type #f data-bytes))]
|
||||
[(channel-stream-request type data-bytes)
|
||||
(! conn (ssh-msg-channel-request remote-ref type #t data-bytes))]
|
||||
[(channel-stream-open-failure reason description)
|
||||
(! (discard-channel cname conn)
|
||||
(ssh-msg-channel-open-failure remote-ref reason description #""))]))])
|
||||
(endpoint #:publisher (channel-message inbound-stream-name (wild))
|
||||
#:name (list cname 'inbound)
|
||||
#:state conn
|
||||
[(channel-message _ body)
|
||||
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
|
||||
(define remote-ref (ssh-channel-remote-ref ch))
|
||||
(match body
|
||||
[(channel-stream-config maximum-packet-size extra-data)
|
||||
(if (channel-name-locally-originated? cname)
|
||||
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN.
|
||||
(! conn (ssh-msg-channel-open (channel-name-type cname)
|
||||
(ssh-channel-local-ref ch)
|
||||
0
|
||||
maximum-packet-size
|
||||
extra-data))
|
||||
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION.
|
||||
(! conn (ssh-msg-channel-open-confirmation remote-ref
|
||||
(ssh-channel-local-ref ch)
|
||||
0
|
||||
maximum-packet-size
|
||||
extra-data)))]
|
||||
[(channel-stream-credit count)
|
||||
(! conn (ssh-msg-channel-window-adjust remote-ref count))]
|
||||
[(channel-stream-ok)
|
||||
(! conn (ssh-msg-channel-success remote-ref))]
|
||||
[(channel-stream-fail)
|
||||
(! conn (ssh-msg-channel-failure remote-ref))])])))
|
||||
(let ()
|
||||
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
|
||||
(define remote-ref (ssh-channel-remote-ref ch))
|
||||
(match body
|
||||
[(channel-stream-config maximum-packet-size extra-data)
|
||||
(if (channel-name-locally-originated? cname)
|
||||
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN.
|
||||
(! conn (ssh-msg-channel-open (channel-name-type cname)
|
||||
(ssh-channel-local-ref ch)
|
||||
0
|
||||
maximum-packet-size
|
||||
extra-data))
|
||||
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION.
|
||||
(! conn (ssh-msg-channel-open-confirmation remote-ref
|
||||
(ssh-channel-local-ref ch)
|
||||
0
|
||||
maximum-packet-size
|
||||
extra-data)))]
|
||||
[(channel-stream-credit count)
|
||||
(! conn (ssh-msg-channel-window-adjust remote-ref count))]
|
||||
[(channel-stream-ok)
|
||||
(! conn (ssh-msg-channel-success remote-ref))]
|
||||
[(channel-stream-fail)
|
||||
(! conn (ssh-msg-channel-failure remote-ref))]))])))
|
||||
|
||||
(define (channel-notify conn ch inbound? body)
|
||||
(transition conn
|
||||
|
|
@ -670,11 +671,15 @@
|
|||
;; Connection service
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (respond-to-opened-outbound-channel conn cname)
|
||||
(if (and (ground? cname)
|
||||
(not (memf (ssh-channel-name=? cname) (connection-channels conn))))
|
||||
(transition (update-channel cname values conn)
|
||||
(channel-endpoints cname (lambda (inbound-stream outbound-stream)
|
||||
'())))
|
||||
(transition conn)))
|
||||
|
||||
(define (start-connection-service conn)
|
||||
(define arbitrary-locally-originated-stream
|
||||
(channel-stream-name (wild) (channel-name #t (wild) (wild))))
|
||||
(define arbitrary-locally-originated-traffic
|
||||
(channel-message arbitrary-locally-originated-stream (wild)))
|
||||
(sequence-actions
|
||||
(transition
|
||||
(set-handlers conn
|
||||
|
|
@ -694,20 +699,16 @@
|
|||
;; application. We are responding to channels appearing from the
|
||||
;; remote peer by virtue of our installation of the handler for
|
||||
;; SSH_MSG_CHANNEL_OPEN above.
|
||||
(role (set (topic-publisher arbitrary-locally-originated-traffic #:monitor? #t)
|
||||
(topic-subscriber arbitrary-locally-originated-traffic #:monitor? #t))
|
||||
#:state conn
|
||||
#:topic t
|
||||
#:on-presence
|
||||
(match t
|
||||
[(or (topic 'publisher (channel-message (channel-stream-name #f cname) _) #f)
|
||||
(topic 'subscriber (channel-message (channel-stream-name #t cname) _) #f))
|
||||
(if (and (ground? cname)
|
||||
(not (memf (ssh-channel-name=? cname) (connection-channels conn))))
|
||||
(transition (update-channel cname values conn)
|
||||
(channel-roles cname (lambda (inbound-stream outbound-stream)
|
||||
'())))
|
||||
(transition conn))]))))
|
||||
(endpoint #:publisher (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
|
||||
#:observer
|
||||
#:state conn
|
||||
#:conversation (channel-message (channel-stream-name #t cname) _)
|
||||
#:on-presence (respond-to-opened-outbound-channel conn cname))
|
||||
(endpoint #:subscriber (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
|
||||
#:observer
|
||||
#:state conn
|
||||
#:conversation (channel-message (channel-stream-name #f cname) _)
|
||||
#:on-presence (respond-to-opened-outbound-channel conn cname))))
|
||||
|
||||
(define (handle-msg-channel-open packet message conn)
|
||||
(match-define (ssh-msg-channel-open channel-type*
|
||||
|
|
@ -730,15 +731,15 @@
|
|||
(transition (update-channel cname
|
||||
(lambda (e) (struct-copy ssh-channel e [remote-ref remote-ref]))
|
||||
conn)
|
||||
(channel-roles cname
|
||||
(lambda (inbound-stream outbound-stream)
|
||||
(list (send-feedback
|
||||
(channel-message outbound-stream
|
||||
(channel-stream-config maximum-packet-size
|
||||
extra-request-data)))
|
||||
(send-feedback
|
||||
(channel-message outbound-stream
|
||||
(channel-stream-credit initial-window-size))))))))
|
||||
(channel-endpoints cname
|
||||
(lambda (inbound-stream outbound-stream)
|
||||
(list (send-feedback
|
||||
(channel-message outbound-stream
|
||||
(channel-stream-config maximum-packet-size
|
||||
extra-request-data)))
|
||||
(send-feedback
|
||||
(channel-message outbound-stream
|
||||
(channel-stream-credit initial-window-size))))))))
|
||||
|
||||
(define (handle-msg-channel-open-confirmation packet message conn)
|
||||
(match-define (ssh-msg-channel-open-confirmation local-ref
|
||||
|
|
@ -859,46 +860,45 @@
|
|||
SSH_MSG_DEBUG handle-msg-debug
|
||||
SSH_MSG_KEXINIT handle-msg-kexinit))
|
||||
|
||||
(define (ssh-session local-identification-string
|
||||
(define (ssh-session self-pid
|
||||
local-identification-string
|
||||
peer-identification-string
|
||||
application-boot
|
||||
session-role)
|
||||
(boot-specification
|
||||
(lambda (self-pid)
|
||||
(transition (connection #f
|
||||
base-packet-dispatcher
|
||||
0
|
||||
(rekey-in-seconds-or-bytes -1 -1 0)
|
||||
#f
|
||||
'()
|
||||
(case session-role ((client) #f) ((server) #t))
|
||||
local-identification-string
|
||||
peer-identification-string
|
||||
#f
|
||||
application-boot)
|
||||
(transition (connection #f
|
||||
base-packet-dispatcher
|
||||
0
|
||||
(rekey-in-seconds-or-bytes -1 -1 0)
|
||||
#f
|
||||
'()
|
||||
(case session-role ((client) #f) ((server) #t))
|
||||
local-identification-string
|
||||
peer-identification-string
|
||||
#f
|
||||
application-boot)
|
||||
|
||||
(role (topic-subscriber (timer-expired 'rekey-timer (wild)))
|
||||
#:state conn
|
||||
[(timer-expired 'rekey-timer now)
|
||||
(sequence-actions (transition conn)
|
||||
maybe-rekey)])
|
||||
(endpoint #:subscriber (timer-expired 'rekey-timer (wild))
|
||||
#:state conn
|
||||
[(timer-expired 'rekey-timer now)
|
||||
(sequence-actions (transition conn)
|
||||
maybe-rekey)])
|
||||
|
||||
(role (topic-subscriber (outbound-byte-credit (wild)))
|
||||
#:state conn
|
||||
[(outbound-byte-credit amount)
|
||||
(sequence-actions (transition conn)
|
||||
(bump-total amount)
|
||||
maybe-rekey)])
|
||||
(endpoint #:subscriber (outbound-byte-credit (wild))
|
||||
#:state conn
|
||||
[(outbound-byte-credit amount)
|
||||
(sequence-actions (transition conn)
|
||||
(bump-total amount)
|
||||
maybe-rekey)])
|
||||
|
||||
(role (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)))
|
||||
#:state conn
|
||||
[(inbound-packet sequence-number payload message transfer-size)
|
||||
(sequence-actions (transition conn)
|
||||
(lambda (conn)
|
||||
(if (connection-discard-next-packet? conn)
|
||||
(transition (struct-copy connection conn [discard-next-packet? #f]))
|
||||
(dispatch-packet sequence-number payload message conn)))
|
||||
(bump-total transfer-size)
|
||||
(send-message (inbound-credit 1))
|
||||
maybe-rekey)])))
|
||||
connection?))
|
||||
(endpoint #:subscriber (inbound-packet (wild) (wild) (wild) (wild))
|
||||
#:state conn
|
||||
[(inbound-packet sequence-number payload message transfer-size)
|
||||
(sequence-actions (transition conn)
|
||||
(lambda (conn)
|
||||
(if (connection-discard-next-packet? conn)
|
||||
(transition
|
||||
(struct-copy connection conn [discard-next-packet? #f]))
|
||||
(dispatch-packet sequence-number payload message conn)))
|
||||
(bump-total transfer-size)
|
||||
(send-message (inbound-credit 1))
|
||||
maybe-rekey)])))
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
(require "ssh-message-types.rkt")
|
||||
(require "ssh-exceptions.rkt")
|
||||
|
||||
(require "os2-support.rkt")
|
||||
(require "marketplace-support.rkt")
|
||||
|
||||
(provide (struct-out inbound-packet)
|
||||
(struct-out inbound-credit)
|
||||
|
|
@ -279,114 +279,122 @@
|
|||
|
||||
(struct ssh-reader-state (mode config sequence-number remaining-credit) #:prefab)
|
||||
|
||||
(define (ssh-reader new-connection-topic)
|
||||
(define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
|
||||
(define (ssh-reader new-conversation)
|
||||
(match-define (tcp-channel remote-addr local-addr _) new-conversation)
|
||||
(define packet-size-limit (default-packet-limit))
|
||||
|
||||
(define (issue-credit state)
|
||||
(match-define (ssh-reader-state _ (crypto-configuration _ desc _ _) _ message-credit) state)
|
||||
(when (positive? message-credit)
|
||||
(at-meta-level (cin (tcp-credit (supported-cipher-block-size desc))))))
|
||||
(at-meta-level
|
||||
(send-feedback (tcp-channel remote-addr local-addr
|
||||
(tcp-credit (supported-cipher-block-size desc)))))))
|
||||
|
||||
(transition (ssh-reader-state 'packet-header initial-crypto-configuration 0 0)
|
||||
(at-meta-level
|
||||
(role in-topic
|
||||
#:name 'socket-reader
|
||||
#:state (and state
|
||||
(ssh-reader-state mode
|
||||
(crypto-configuration cipher
|
||||
cipher-description
|
||||
hmac
|
||||
hmac-description)
|
||||
sequence-number
|
||||
remaining-credit))
|
||||
(endpoint #:subscriber (tcp-channel remote-addr local-addr ?)
|
||||
#:name 'socket-reader
|
||||
#:state (and state
|
||||
(ssh-reader-state mode
|
||||
(crypto-configuration cipher
|
||||
cipher-description
|
||||
hmac
|
||||
hmac-description)
|
||||
sequence-number
|
||||
remaining-credit))
|
||||
[(tcp-channel _ _ (? eof-object?))
|
||||
(transition state (quit))]
|
||||
[(tcp-channel _ _ (? bytes? encrypted-packet))
|
||||
(define block-size (supported-cipher-block-size cipher-description))
|
||||
(define first-block-size block-size)
|
||||
(define subsequent-block-size (if cipher block-size 1))
|
||||
(define decryptor (if cipher cipher values))
|
||||
(let ()
|
||||
(define block-size (supported-cipher-block-size cipher-description))
|
||||
(define first-block-size block-size)
|
||||
(define subsequent-block-size (if cipher block-size 1))
|
||||
(define decryptor (if cipher cipher values))
|
||||
|
||||
(define (check-hmac packet-length payload-length packet)
|
||||
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
|
||||
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
||||
(if (positive? mac-byte-count)
|
||||
(transition (struct-copy ssh-reader-state state
|
||||
[mode `(packet-hmac ,computed-hmac-bytes
|
||||
,mac-byte-count
|
||||
,packet-length
|
||||
,payload-length
|
||||
,packet)])
|
||||
(at-meta-level (cin (tcp-credit mac-byte-count))))
|
||||
(finish-packet 0 packet-length payload-length packet)))
|
||||
(define (check-hmac packet-length payload-length packet)
|
||||
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
|
||||
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
||||
(if (positive? mac-byte-count)
|
||||
(transition (struct-copy ssh-reader-state state
|
||||
[mode `(packet-hmac ,computed-hmac-bytes
|
||||
,mac-byte-count
|
||||
,packet-length
|
||||
,payload-length
|
||||
,packet)])
|
||||
(at-meta-level
|
||||
(send-feedback (tcp-channel remote-addr local-addr
|
||||
(tcp-credit mac-byte-count)))))
|
||||
(finish-packet 0 packet-length payload-length packet)))
|
||||
|
||||
(define (finish-packet mac-byte-count packet-length payload-length packet)
|
||||
(define bytes-read (+ packet-length mac-byte-count))
|
||||
(define payload (subbytes packet 5 (+ 5 payload-length)))
|
||||
(define new-credit (- remaining-credit 1))
|
||||
(define new-state (struct-copy ssh-reader-state state
|
||||
[mode 'packet-header]
|
||||
[sequence-number (+ sequence-number 1)]
|
||||
[remaining-credit new-credit]))
|
||||
(transition new-state
|
||||
(issue-credit new-state)
|
||||
(send-message
|
||||
(inbound-packet sequence-number payload (ssh-message-decode payload) bytes-read))))
|
||||
(define (finish-packet mac-byte-count packet-length payload-length packet)
|
||||
(define bytes-read (+ packet-length mac-byte-count))
|
||||
(define payload (subbytes packet 5 (+ 5 payload-length)))
|
||||
(define new-credit (- remaining-credit 1))
|
||||
(define new-state (struct-copy ssh-reader-state state
|
||||
[mode 'packet-header]
|
||||
[sequence-number (+ sequence-number 1)]
|
||||
[remaining-credit new-credit]))
|
||||
(transition new-state
|
||||
(issue-credit new-state)
|
||||
(send-message
|
||||
(inbound-packet sequence-number payload (ssh-message-decode payload) bytes-read))))
|
||||
|
||||
(match mode
|
||||
['packet-header
|
||||
(define decrypted-packet (decryptor encrypted-packet))
|
||||
(define first-block decrypted-packet)
|
||||
(define packet-length (integer-bytes->integer first-block #f #t 0 4))
|
||||
(check-packet-length! packet-length packet-size-limit subsequent-block-size)
|
||||
(define padding-length (bytes-ref first-block 4))
|
||||
(define payload-length (- packet-length padding-length 1))
|
||||
(define amount-of-packet-in-first-block
|
||||
(- (bytes-length first-block) 4)) ;; not incl length
|
||||
(define remaining-to-read (- packet-length amount-of-packet-in-first-block))
|
||||
(match mode
|
||||
['packet-header
|
||||
(define decrypted-packet (decryptor encrypted-packet))
|
||||
(define first-block decrypted-packet)
|
||||
(define packet-length (integer-bytes->integer first-block #f #t 0 4))
|
||||
(check-packet-length! packet-length packet-size-limit subsequent-block-size)
|
||||
(define padding-length (bytes-ref first-block 4))
|
||||
(define payload-length (- packet-length padding-length 1))
|
||||
(define amount-of-packet-in-first-block
|
||||
(- (bytes-length first-block) 4)) ;; not incl length
|
||||
(define remaining-to-read (- packet-length amount-of-packet-in-first-block))
|
||||
|
||||
(if (positive? remaining-to-read)
|
||||
(transition (struct-copy ssh-reader-state state
|
||||
[mode `(packet-body ,packet-length
|
||||
,payload-length
|
||||
,first-block)])
|
||||
(at-meta-level (cin (tcp-credit remaining-to-read))))
|
||||
(check-hmac packet-length payload-length first-block))]
|
||||
(if (positive? remaining-to-read)
|
||||
(transition (struct-copy ssh-reader-state state
|
||||
[mode `(packet-body ,packet-length
|
||||
,payload-length
|
||||
,first-block)])
|
||||
(at-meta-level
|
||||
(send-feedback (tcp-channel remote-addr local-addr
|
||||
(tcp-credit remaining-to-read)))))
|
||||
(check-hmac packet-length payload-length first-block))]
|
||||
|
||||
[`(packet-body ,packet-length ,payload-length ,first-block)
|
||||
(define decrypted-packet (decryptor encrypted-packet))
|
||||
(check-hmac packet-length payload-length (bytes-append first-block decrypted-packet))]
|
||||
[`(packet-body ,packet-length ,payload-length ,first-block)
|
||||
(define decrypted-packet (decryptor encrypted-packet))
|
||||
(check-hmac packet-length payload-length (bytes-append first-block decrypted-packet))]
|
||||
|
||||
[`(packet-hmac ,computed-hmac-bytes
|
||||
,mac-byte-count
|
||||
,packet-length
|
||||
,payload-length
|
||||
,main-packet)
|
||||
(define received-hmac-bytes encrypted-packet) ;; not really encrypted!
|
||||
(if (equal? computed-hmac-bytes received-hmac-bytes)
|
||||
(finish-packet mac-byte-count packet-length payload-length main-packet)
|
||||
(disconnect-with-error/local-info `((expected-hmac ,computed-hmac-bytes)
|
||||
(actual-hmac ,received-hmac-bytes))
|
||||
SSH_DISCONNECT_MAC_ERROR
|
||||
"Corrupt MAC"))])]))
|
||||
(role (topic-subscriber (inbound-credit (wild)))
|
||||
#:state state
|
||||
[`(packet-hmac ,computed-hmac-bytes
|
||||
,mac-byte-count
|
||||
,packet-length
|
||||
,payload-length
|
||||
,main-packet)
|
||||
(define received-hmac-bytes encrypted-packet) ;; not really encrypted!
|
||||
(if (equal? computed-hmac-bytes received-hmac-bytes)
|
||||
(finish-packet mac-byte-count packet-length payload-length main-packet)
|
||||
(disconnect-with-error/local-info `((expected-hmac ,computed-hmac-bytes)
|
||||
(actual-hmac ,received-hmac-bytes))
|
||||
SSH_DISCONNECT_MAC_ERROR
|
||||
"Corrupt MAC"))]))]))
|
||||
(endpoint #:subscriber (inbound-credit (wild))
|
||||
#:state state
|
||||
[(inbound-credit amount)
|
||||
(define new-state (struct-copy ssh-reader-state state
|
||||
[remaining-credit
|
||||
(+ amount (ssh-reader-state-remaining-credit state))]))
|
||||
(transition new-state
|
||||
(issue-credit new-state))])
|
||||
(role (topic-subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)))
|
||||
#:state state
|
||||
(let ()
|
||||
(define new-state (struct-copy ssh-reader-state state
|
||||
[remaining-credit
|
||||
(+ amount (ssh-reader-state-remaining-credit state))]))
|
||||
(transition new-state
|
||||
(issue-credit new-state)))])
|
||||
(endpoint #:subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild))
|
||||
#:state state
|
||||
[(? new-keys? nk)
|
||||
(transition (struct-copy ssh-reader-state state [config (apply-negotiated-options nk #f)]))])
|
||||
(role (topic-publisher (inbound-packet (wild) (wild) (wild) (wild))))))
|
||||
(endpoint #:publisher (inbound-packet (wild) (wild) (wild) (wild)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Encrypted Packet Output
|
||||
|
|
@ -394,49 +402,53 @@
|
|||
|
||||
(struct ssh-writer-state (config sequence-number) #:prefab)
|
||||
|
||||
(define (ssh-writer new-connection-topic)
|
||||
(define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
|
||||
(define (ssh-writer new-conversation)
|
||||
(match-define (tcp-channel remote-addr local-addr _) new-conversation)
|
||||
(transition (ssh-writer-state initial-crypto-configuration 0)
|
||||
(role (set (topic-subscriber (outbound-packet (wild)))
|
||||
(topic-publisher (outbound-byte-credit (wild))))
|
||||
#:state (and state
|
||||
(ssh-writer-state (crypto-configuration cipher
|
||||
cipher-description
|
||||
hmac
|
||||
hmac-description)
|
||||
sequence-number))
|
||||
(endpoint #:publisher (outbound-byte-credit (wild)))
|
||||
(endpoint #:subscriber (outbound-packet (wild))
|
||||
#:state (and state
|
||||
(ssh-writer-state (crypto-configuration cipher
|
||||
cipher-description
|
||||
hmac
|
||||
hmac-description)
|
||||
sequence-number))
|
||||
[(outbound-packet message)
|
||||
(define pad-block-size (supported-cipher-block-size cipher-description))
|
||||
(define encryptor (if cipher cipher values))
|
||||
(define payload (ssh-message-encode message))
|
||||
;; There must be at least 4 bytes of padding, and padding needs to
|
||||
;; make the packet length a multiple of pad-block-size.
|
||||
(define unpadded-length (+ 4 ;; length of length
|
||||
1 ;; length of length-of-padding indicator
|
||||
(bit-string-byte-count payload)))
|
||||
(define min-padded-length (+ unpadded-length 4))
|
||||
(define padded-length (round-up min-padded-length pad-block-size))
|
||||
(define padding-length (- padded-length unpadded-length))
|
||||
(define packet-length (- padded-length 4)) ;; the packet length does *not* include itself!
|
||||
(define packet (bit-string->bytes
|
||||
(bit-string (packet-length :: integer bits 32)
|
||||
(padding-length :: integer bits 8)
|
||||
(payload :: binary)
|
||||
((random-bytes padding-length) :: binary))))
|
||||
(define encrypted-packet (encryptor packet))
|
||||
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
|
||||
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
||||
(transition (struct-copy ssh-writer-state state [sequence-number (+ sequence-number 1)])
|
||||
(at-meta-level (cout encrypted-packet))
|
||||
(when (positive? mac-byte-count)
|
||||
(at-meta-level (cout computed-hmac-bytes)))
|
||||
(send-message (outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count))))])
|
||||
(role (topic-subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)))
|
||||
#:state state
|
||||
(let ()
|
||||
(define pad-block-size (supported-cipher-block-size cipher-description))
|
||||
(define encryptor (if cipher cipher values))
|
||||
(define payload (ssh-message-encode message))
|
||||
;; There must be at least 4 bytes of padding, and padding needs to
|
||||
;; make the packet length a multiple of pad-block-size.
|
||||
(define unpadded-length (+ 4 ;; length of length
|
||||
1 ;; length of length-of-padding indicator
|
||||
(bit-string-byte-count payload)))
|
||||
(define min-padded-length (+ unpadded-length 4))
|
||||
(define padded-length (round-up min-padded-length pad-block-size))
|
||||
(define padding-length (- padded-length unpadded-length))
|
||||
(define packet-length (- padded-length 4)) ;; the packet length does *not* include itself!
|
||||
(define packet (bit-string->bytes
|
||||
(bit-string (packet-length :: integer bits 32)
|
||||
(padding-length :: integer bits 8)
|
||||
(payload :: binary)
|
||||
((random-bytes padding-length) :: binary))))
|
||||
(define encrypted-packet (encryptor packet))
|
||||
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
|
||||
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
||||
(transition (struct-copy ssh-writer-state state [sequence-number (+ sequence-number 1)])
|
||||
(at-meta-level
|
||||
(send-message (tcp-channel local-addr remote-addr encrypted-packet)))
|
||||
(when (positive? mac-byte-count)
|
||||
(at-meta-level
|
||||
(send-message (tcp-channel local-addr remote-addr computed-hmac-bytes))))
|
||||
(send-message
|
||||
(outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count)))))])
|
||||
(endpoint #:subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild))
|
||||
#:state state
|
||||
[(? new-keys? nk)
|
||||
(transition
|
||||
(struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))])))
|
||||
|
|
|
|||
|
|
@ -1,48 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Standard Thread
|
||||
|
||||
(provide exit-status?
|
||||
exit-status-exception
|
||||
|
||||
current-thread-exit-status
|
||||
exit-status-evt
|
||||
|
||||
standard-thread)
|
||||
|
||||
(struct exit-status (thread
|
||||
[exception #:mutable]
|
||||
ready))
|
||||
|
||||
(define *current-thread-exit-status* (make-parameter #f))
|
||||
|
||||
(define (current-thread-exit-status)
|
||||
(define v (*current-thread-exit-status*))
|
||||
(if (exit-status? v)
|
||||
(if (eq? (current-thread) (exit-status-thread v))
|
||||
v
|
||||
(begin (*current-thread-exit-status* #f)
|
||||
#f))
|
||||
#f))
|
||||
|
||||
(define (exit-status-evt es)
|
||||
(wrap-evt (semaphore-peek-evt (exit-status-ready es))
|
||||
(lambda (dummy) es)))
|
||||
|
||||
(define (fill-exit-status! es exn)
|
||||
(set-exit-status-exception! es exn)
|
||||
(semaphore-post (exit-status-ready es)))
|
||||
|
||||
(define (call-capturing-exit-status thunk)
|
||||
(define es (exit-status (current-thread) #f (make-semaphore 0)))
|
||||
(parameterize ((*current-thread-exit-status* es))
|
||||
(with-handlers
|
||||
((exn? (lambda (e)
|
||||
(fill-exit-status! es e)
|
||||
(raise e))))
|
||||
(define result (thunk))
|
||||
(fill-exit-status! es #f)
|
||||
result)))
|
||||
|
||||
(define (standard-thread thunk)
|
||||
(thread (lambda ()
|
||||
(call-capturing-exit-status thunk))))
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "blocking-box.rkt")
|
||||
(require rackunit)
|
||||
|
||||
(define b (make-blocking-box))
|
||||
(set-blocking-box! b 1)
|
||||
(set-blocking-box! b 2)
|
||||
(set-blocking-box! b 3)
|
||||
(check-equal? (blocking-box-value b) 1)
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "ordered-rpc.rkt")
|
||||
(require rackunit)
|
||||
|
||||
(let ((tm0 (make-transaction-manager)))
|
||||
(define-values (t1 tm1) (open-transaction tm0 'a))
|
||||
(define-values (t2 tm2) (open-transaction tm1 'b))
|
||||
(define-values (t3 tm3) (open-transaction tm2 'c))
|
||||
|
||||
(check-equal? (transaction-available? tm3) #f)
|
||||
(close-transaction! t2 'second)
|
||||
(check-equal? (transaction-available? tm3) #f)
|
||||
(close-transaction! t1 'first)
|
||||
(check-equal? (transaction-available? tm3) #t)
|
||||
|
||||
(define-values (v1 tm4) (dequeue-transaction tm3))
|
||||
(check-equal? (transaction-context v1) 'a)
|
||||
(check-equal? (transaction-value v1) 'first)
|
||||
(check-equal? (transaction-available? tm4) #t)
|
||||
|
||||
(define-values (v2 tm5) (dequeue-transaction tm4))
|
||||
|
||||
(check-equal? (transaction-available? tm5) #f)
|
||||
(close-transaction! t3 'third)
|
||||
(check-equal? (transaction-available? tm5) #t)
|
||||
|
||||
(define-values (v3 tm6) (dequeue-transaction tm5))
|
||||
(check-equal? (transaction-available? tm6) #f)
|
||||
)
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "safe-io.rkt")
|
||||
(require rackunit)
|
||||
|
||||
(define (s str)
|
||||
(open-input-string str))
|
||||
|
||||
(check-equal? (read-line-limited (s "") 5) eof)
|
||||
(check-equal? (read-line-limited (s "abc") 5) "abc")
|
||||
(check-equal? (read-line-limited (s "abc\r\ndef") 5) "abc")
|
||||
(check-equal? (read-line-limited (s "abcxy\r\ndef") 5) "abcxy")
|
||||
|
||||
(check-exn #rx"read-line-limited: Invalid character #<eof> after #\\\\return"
|
||||
(lambda () (read-line-limited (s "abc\r") 5)))
|
||||
(check-exn #rx"read-line-limited: Invalid character #\\\\d after #\\\\return"
|
||||
(lambda () (read-line-limited (s "abc\rdef") 5)))
|
||||
|
||||
(check-exn #rx"Bare #\\\\linefeed encountered"
|
||||
(lambda () (read-line-limited (s "abc\ndef") 5)))
|
||||
|
||||
(check-exn #rx"Line too long \\(more than 5 bytes before CRLF\\)"
|
||||
(lambda () (read-line-limited (s "abcxyz\r\ndef") 5)))
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "standard-thread.rkt")
|
||||
(require "conversation.rkt")
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/class)
|
||||
|
||||
(define r (make-room))
|
||||
(define t1 (standard-thread (lambda ()
|
||||
(define h (join-room r))
|
||||
(error 'omg "t1 exiting"))))
|
||||
(define t2 (standard-thread (lambda ()
|
||||
(define h (join-room r))
|
||||
(+ 1 2))))
|
||||
(define t3 (standard-thread (lambda ()
|
||||
(define h (join-room r))
|
||||
(send h depart 'here-is-my-reason))))
|
||||
|
||||
(define h (join-room r))
|
||||
(let loop ((seen (set)) (count 0))
|
||||
(define m (send h listen))
|
||||
(write m)
|
||||
(newline)
|
||||
(match m
|
||||
((arrived who) (loop (set-add seen who) (+ count 1)))
|
||||
((departed _ _) (if (and (= count 1) (= (set-count seen) 3))
|
||||
'done
|
||||
(loop seen (- count 1))))
|
||||
(else (loop seen count))))
|
||||
Loading…
Reference in New Issue