Historical interest only: marketplace-2014 implementation of SSH.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 

300 lines
12 KiB

#lang racket/base
;; (Temporary) example client and server
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
;;;
;;; This file is part of marketplace-ssh.
;;;
;;; marketplace-ssh is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; marketplace-ssh is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with marketplace-ssh. If not, see
;;; <http://www.gnu.org/licenses/>.
(require racket/set)
(require racket/match)
(require racket/contract)
(require (only-in racket/port peek-bytes-avail!-evt))
(require "cook-port.rkt")
(require "sandboxes.rkt")
(require "ssh-numbers.rkt")
(require "ssh-transport.rkt")
(require "ssh-session.rkt")
(require "ssh-channel.rkt")
(require "ssh-message-types.rkt")
(require "ssh-exceptions.rkt")
(require "marketplace-support.rkt")
(define (main)
(ground-vm (timer-driver)
(tcp-driver)
(tcp-spy)
(name-process 'ssh-tcp-listener (spawn listener))))
(define listener
(transition/no-state
(observe-publishers (tcp-channel ? (tcp-listener 2322) ?)
(match-conversation r
(on-presence (session-vm r))))))
;;---------------------------------------------------------------------------
(define (check-remote-identification! peer-identification-string)
(define required-peer-identification-regex #rx"^SSH-2\\.0-.*")
;; 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))
(error 'ssh-session
"Invalid peer identification string ~v"
peer-identification-string)))
(define (spy marker)
(define (dump what message)
(write `(,marker ,what ,message))
(newline)
(flush-output)
(void))
(list
(observe-publishers/everything (wild)
(match-interest-type i
(match-conversation c
(on-presence (dump 'arrived (role 'publisher c i)))
(on-absence (dump 'departed (role 'publisher c i)))
(on-message [message (dump 'message message)]))))
(observe-subscribers/everything (wild)
(match-interest-type i
(match-conversation c
(on-presence (dump 'arrived (role 'subscriber c i)))
(on-absence (dump 'departed (role 'subscriber c i)))
(on-message [message (dump 'feedback message)]))))))
(define-syntax-rule (wait-as my-orientation topic action ...)
(let-fresh (endpoint-name)
(build-endpoint endpoint-name
(role my-orientation topic 'observer)
(match-state state
(on-presence (sequence-actions (transition state
(delete-endpoint endpoint-name)
action ...)))))))
(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
(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
(name-endpoint 'socket-reader
(subscriber (tcp-channel remote-addr local-addr ?)
(match-state state
(on-message
[(tcp-channel _ _ (? eof-object?))
(transition state (quit))]
[(tcp-channel _ _ (? bytes? remote-identification))
(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.
(name-process 'ssh-writer
;; TODO: canary: #:exit-signal? #t
(spawn (ssh-writer new-conversation)))
;; 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-as 'subscriber (inbound-packet (wild) (wild) (wild) (wild))
(wait-as 'publisher (outbound-packet (wild))
(send-message (inbound-credit 1))
(name-process 'ssh-session
(spawn #:pid session-pid
;; TODO: canary: #:exit-signal? #t
(ssh-session session-pid
local-identification
remote-identification
repl-boot
'server)))))))])))))))
(define (exn->outbound-packet reason)
(outbound-packet (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code reason)
(string->bytes/utf-8 (exn-message reason))
#"")))
(define (disconnect-message-required? reason)
(and (exn:fail:contract:protocol? reason)
(not (exn:fail:contract:protocol-originated-at-peer? reason))))
(define (active-exception-handler reason)
;; This is kind of gross: because the absence handler gets invoked
;; several times in a row because of multiple flows intersecting
;; this role, we have to be careful to make the transmission of
;; the disconnection packet idempotent.
;; TODO: this is likely no longer true now we're using exit-signals %%%
(define interesting? (disconnect-message-required? reason))
(transition inert-exception-handler
(when interesting? (send-message (exn->outbound-packet reason)))
(yield state ;; gross
(transition state (at-meta-level (quit #f (and interesting? reason)))))))
(define (inert-exception-handler reason)
inert-exception-handler)
(spawn-vm #:debug-name (list 'ssh-session-vm new-conversation)
(event-relay 'ssh-event-relay)
(timer-relay 'ssh-timer-relay)
(spy 'SSH)
(issue-identification-string)
;; 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))))
(name-process 'ssh-reader
;; TODO: canary: #:exit-signal? #t
(spawn (read-handshake-and-become-reader)))
;; 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)
(list
(event-relay 'app-event-relay)
(spy 'APP)
(at-meta-level
(subscriber (channel-message (channel-stream-name #t (wild)) (wild))
(match-conversation (channel-message (channel-stream-name _ cname) _)
(on-presence (name-process cname (spawn (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
c2s-out ;; used by relay to feed input from remote to the thread
s2c-in ;; used by relay to feed output from thread to remote
s2c-out ;; used by thread to write output to relay
) #:prefab)
(define (repl-instance user-name cname)
(define inbound-stream (channel-stream-name #t cname))
(define outbound-stream (channel-stream-name #f cname))
(define (ch-do action-ctor stream body)
(at-meta-level (action-ctor (channel-message stream body))))
(define (handle-channel-message state body)
(match body
[(channel-stream-request #"pty-req" _)
(match-define (repl-instance-state old-in _ _ old-out) state)
(define-values (cooked-in cooked-out) (cook-io old-in old-out "> "))
(transition (struct-copy repl-instance-state state
[c2s-in cooked-in]
[s2c-out cooked-out])
(ch-do send-feedback inbound-stream (channel-stream-ok)))]
[(channel-stream-notify #"env" _)
;; Don't care
(transition state)]
[(channel-stream-request #"shell" _)
(match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state)
(define buffer-size 1024)
(define dummy-buffer (make-bytes buffer-size))
(define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out))))
(transition state
(ch-do send-feedback inbound-stream (channel-stream-ok))
(subscriber (cons (thread-dead-evt repl-thread) (wild))
(on-message [_ (quit #f "REPL thread exited")]))
(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
;; any latency between handling the event and the next
;; firing of the event, since the peek-bytes-avail!-evt
;; will overwrite its buffer next time it's synced on.
(match-state state
(on-message
[(cons _ (? eof-object?))
(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))
(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))
(transition state
(ch-do send-feedback inbound-stream (channel-stream-credit (bytes-length bs))))]
[m
(write `(channel inbound ,m)) (newline)
(transition state)]))
(match (channel-name-type cname)
[#"session"
(define-values (c2s-in c2s-out) (make-pipe))
(define-values (s2c-in s2c-out) (make-pipe))
(transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out)
(at-meta-level
(subscriber (channel-message inbound-stream (wild))
(match-state state
(on-presence (transition state
(ch-do send-feedback inbound-stream (channel-stream-config
(default-packet-limit)
#""))
(ch-do send-feedback inbound-stream (channel-stream-credit 1024))))
(on-message
[(channel-message _ body)
(handle-channel-message state body)]))))
(at-meta-level
(publisher (channel-message outbound-stream (wild))
(on-message [m (begin
(write `(channel outbound ,cname ,m)) (newline)
(void))]))))]
[type
(transition/no-state
(at-meta-level (send-message
(channel-message outbound-stream
(channel-stream-open-failure
SSH_OPEN_UNKNOWN_CHANNEL_TYPE
(bytes-append #"Unknown channel type " type))))))]))
;;---------------------------------------------------------------------------
;; TODO: module+
(main)