forked from syndicate-lang/marketplace-ssh-2014
186 lines
7.4 KiB
Racket
186 lines
7.4 KiB
Racket
#lang syndicate
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
;;; (Temporary) example client and server
|
|
|
|
(require syndicate/drivers/racket-event)
|
|
(require syndicate/drivers/timer)
|
|
(require syndicate/drivers/tcp)
|
|
(require syndicate/driver-support)
|
|
(require syndicate/dataspace)
|
|
(require syndicate/pattern)
|
|
|
|
(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 "ssh-keys.rkt")
|
|
(require "schemas/gen/channel.rkt")
|
|
(require "schemas/gen/auth.rkt")
|
|
|
|
(module+ main
|
|
(standard-actor-system (ds)
|
|
(define spec (TcpLocal "0.0.0.0" 29418))
|
|
(at ds
|
|
(stop-on (asserted (StreamListenerError spec $message)))
|
|
(during/spawn (StreamConnection $source $sink spec)
|
|
#:name (list 'ssh source)
|
|
(session ds source sink (load-private-key "test-host-keys/ssh_host_ed25519_key"))))
|
|
))
|
|
|
|
;; (define host-key-ed25519-public (pk-key->public-only-key host-key-ed25519-private))
|
|
|
|
(define test-user-private (load-private-key "test-user-key"))
|
|
(define test-user-public (load-public-key "test-user-key.pub"))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(define (session ground-ds source sink host-private-key)
|
|
(on-stop (log-info "Session VM for ~a closed" source))
|
|
(actor-group
|
|
#:link? #t
|
|
(define conn-ds (dataspace #:name (gensym 'conn-ds)))
|
|
|
|
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
|
|
|
(spawn/link #:name 'reader (ssh-reader conn-ds ground-ds source))
|
|
(spawn/link #:name 'writer (ssh-writer conn-ds sink local-identification))
|
|
|
|
(on-stop (stop-actor-system))
|
|
|
|
(at conn-ds
|
|
(once
|
|
[(message (ssh-identification-line $remote-identification))
|
|
(cond
|
|
[(regexp-match #rx"^SSH-2\\.0-.*" remote-identification)
|
|
(send! (inbound-credit 1))
|
|
(spawn
|
|
#:name 'session
|
|
(ssh-session conn-ds
|
|
ground-ds
|
|
local-identification
|
|
remote-identification
|
|
'server
|
|
host-private-key))]
|
|
[else
|
|
(log-error "Invalid peer identification string ~v" remote-identification)
|
|
(stop-actor-system)])])
|
|
|
|
(define-syntax-rule (auth-method m p x)
|
|
(begin
|
|
(assert (SshAuthenticationMethodAcceptable m))
|
|
(during (Observe (:pattern (SshAuthenticationAcceptable m ,(DLit $r) ,_)) _)
|
|
(match (parse-SshAuthRequest r)
|
|
[p (assert (SshAuthenticationAcceptable m r x))]
|
|
[_ (assert (SshAuthenticationAcceptable m r #f))]))))
|
|
|
|
(auth-method (SshAuthMethod-none)
|
|
(SshAuthRequest-none username)
|
|
(equal? username "guest"))
|
|
(auth-method (SshAuthMethod-password)
|
|
(SshAuthRequest-password username password)
|
|
(and (equal? username "user")
|
|
(equal? password "password")))
|
|
(auth-method (SshAuthMethod-publickey)
|
|
(SshAuthRequest-publickey username key)
|
|
(and (equal? username "tonyg")
|
|
(equal? (->preserve key)
|
|
(public-key->pieces test-user-public))))
|
|
|
|
(during (SshAuthenticatedUser $user-name #"ssh-connection")
|
|
(run-repl-instance conn-ds user-name))
|
|
|
|
(on (asserted (protocol-error $reason-code $message _ $originated-at-peer?))
|
|
(when (not originated-at-peer?)
|
|
(send! (outbound-packet (ssh-msg-disconnect reason-code
|
|
(string->bytes/utf-8 message)
|
|
#""))))
|
|
(sync! conn-ds (stop-actor-system))))))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
|
|
(define (run-repl-instance conn-ds user-name)
|
|
(on-start (log-info "~s connected" user-name))
|
|
(on-stop (log-info "~s disconnected" user-name))
|
|
|
|
(at conn-ds
|
|
(assert (SshChannelTypeAvailable #"session"))
|
|
(during (StreamConnection $source $sink (SshChannelLocal #"session" _))
|
|
;; c2s-in used by repl to read input from channel
|
|
;; c2s-out used by channel to feed input from remote to the repl
|
|
;; s2c-in used by channel to feed output from repl to remote
|
|
;; s2c-out used by repl to write output to channel
|
|
(define-values (c2s-in c2s-out) (make-pipe))
|
|
(define-values (s2c-in s2c-out) (make-pipe))
|
|
(define-values (s2c-err-in s2c-err-out) (make-pipe))
|
|
(on-stop (close-input-port c2s-in)
|
|
(close-output-port c2s-out)
|
|
(close-input-port s2c-in)
|
|
(close-output-port s2c-out)
|
|
(close-input-port s2c-err-in)
|
|
(close-output-port s2c-err-out))
|
|
|
|
(define (handle-data data mode)
|
|
(match mode
|
|
[(Mode-bytes)
|
|
(write-bytes data c2s-out)
|
|
(flush-output c2s-out)
|
|
(send-bytes-credit source (bytes-length data))]
|
|
[(Mode-object (:parse (SshChannelObject-extended-data type-code)))
|
|
(match type-code
|
|
[SSH_EXTENDED_DATA_STDERR
|
|
(log-info "2> ~s" data)]
|
|
[_
|
|
(log-warning "Ignoring extended data type-code ~s: ~s" type-code data)])
|
|
(send-bytes-credit source (bytes-length data))]
|
|
[(Mode-object (:parse (SshChannelObject-request type want-reply)))
|
|
(define ok? (handle-request type))
|
|
(when want-reply
|
|
(define reply (if ok? (SshChannelObject-success) (SshChannelObject-failure)))
|
|
(send-data sink #"" (Mode-object reply)))]))
|
|
|
|
(define (handle-eof)
|
|
(close-output-port c2s-out))
|
|
|
|
(define (handle-request type)
|
|
(match type
|
|
[#"pty-req"
|
|
(define-values (cooked-c2s-in cooked-s2c-out) (cook-io c2s-in s2c-out "> "))
|
|
(set! c2s-in cooked-c2s-in)
|
|
(set! s2c-out cooked-s2c-out)
|
|
(set! s2c-err-out (cook-output s2c-err-out))
|
|
#t]
|
|
[#"env"
|
|
;; Don't care
|
|
;; TODO: care?
|
|
#t]
|
|
[#"shell"
|
|
(make-sink #:initial-source (port-source s2c-in)
|
|
#:on-connect (lambda (s) (send-credit s (CreditAmount-unbounded) (Mode-bytes)))
|
|
#:on-data (lambda (data _mode) (send-data sink data))
|
|
#:on-eof (lambda () (stop-current-facet)))
|
|
(make-sink #:initial-source (port-source s2c-err-in)
|
|
#:on-connect (lambda (s) (send-credit s (CreditAmount-unbounded) (Mode-bytes)))
|
|
#:on-data (lambda (data _mode)
|
|
(send-data sink data
|
|
(Mode-object (SshChannelObject-extended-data
|
|
SSH_EXTENDED_DATA_STDERR)))))
|
|
(linked-thread #:name 'repl
|
|
(lambda (_facet)
|
|
(repl-shell user-name c2s-in s2c-out s2c-err-out)))
|
|
#t]
|
|
[_
|
|
(log-warning "Unsupported channel request type ~s" type)
|
|
#f]))
|
|
|
|
(handle-connection source sink #:initial-credit #f #:on-data handle-data #:on-eof handle-eof)
|
|
(assert (SshChannelOpenResponse-ok sink #"")))))
|