forked from syndicate-lang/marketplace-ssh-2014
First steps toward modernization and port to syndicate-rkt.
Switch from (planet vyzo/crypto) to crypto. Comment out most of the upper layers of the protocol. Switch to new syndicate/rkt. Unfortunately since I last ran this, the set of MUST-implement kex methods has changed and there's no overlap with my default SSH client :-)
This commit is contained in:
parent
5381a0b8d3
commit
3c07c96307
|
|
@ -1,66 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
||||||
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
||||||
|
|
||||||
;;; Provide AES CTR mode, since OpenSSL's EVP support for AES CTR mode
|
|
||||||
;;; is still ifdef'd out.
|
|
||||||
|
|
||||||
(provide start-aes-ctr
|
|
||||||
aes-ctr-process!)
|
|
||||||
|
|
||||||
(require ffi/unsafe)
|
|
||||||
(require ffi/unsafe/define)
|
|
||||||
(require openssl/libcrypto)
|
|
||||||
|
|
||||||
(define _AES_KEY-pointer _pointer)
|
|
||||||
|
|
||||||
(define AES_BLOCK_SIZE 16)
|
|
||||||
(define sizeof-AES_KEY 244) ;; TODO: figure out a good way to get this
|
|
||||||
;; from the header file or the library
|
|
||||||
;; itself
|
|
||||||
|
|
||||||
(define-ffi-definer define-crypto libcrypto
|
|
||||||
#:default-make-fail make-not-available)
|
|
||||||
|
|
||||||
(define-crypto AES_set_encrypt_key (_fun _pointer _int _AES_KEY-pointer -> _int))
|
|
||||||
;;(define-crypto AES_set_decrypt_key (_fun _pointer _int _AES_KEY-pointer -> _int))
|
|
||||||
|
|
||||||
(define-crypto AES_ctr128_encrypt
|
|
||||||
(_fun _pointer ;; in
|
|
||||||
_pointer ;; out
|
|
||||||
_long ;; length
|
|
||||||
_AES_KEY-pointer ;; key
|
|
||||||
_pointer ;; ivec, AES_BLOCK_SIZE bytes
|
|
||||||
_pointer ;; ecount_buf, AES_BLOCK_SIZE bytes
|
|
||||||
_pointer ;; int pointer, the "num" field of the ongoing state (??)
|
|
||||||
-> _void))
|
|
||||||
|
|
||||||
(struct aes-ctr-state (key ivec ecount num) #:transparent)
|
|
||||||
|
|
||||||
(define (start-aes-ctr key initialization-vector)
|
|
||||||
(let ((key-buffer (malloc sizeof-AES_KEY))
|
|
||||||
(ivec (make-bytes AES_BLOCK_SIZE))
|
|
||||||
(ecount (make-bytes AES_BLOCK_SIZE))
|
|
||||||
(num (make-bytes (ctype-sizeof _int))))
|
|
||||||
(AES_set_encrypt_key key
|
|
||||||
(* 8 (bytes-length key)) ;; measured in bits
|
|
||||||
key-buffer)
|
|
||||||
(bytes-copy! ivec 0 initialization-vector 0 AES_BLOCK_SIZE)
|
|
||||||
(bytes-fill! ecount 0)
|
|
||||||
(bytes-fill! num 0)
|
|
||||||
(aes-ctr-state key-buffer
|
|
||||||
ivec
|
|
||||||
ecount
|
|
||||||
num)))
|
|
||||||
|
|
||||||
(define (aes-ctr-process! state input-block)
|
|
||||||
(define block-length (bytes-length input-block))
|
|
||||||
(define output-block (make-bytes block-length))
|
|
||||||
(AES_ctr128_encrypt input-block
|
|
||||||
output-block
|
|
||||||
block-length
|
|
||||||
(aes-ctr-state-key state)
|
|
||||||
(aes-ctr-state-ivec state)
|
|
||||||
(aes-ctr-state-ecount state)
|
|
||||||
(aes-ctr-state-num state))
|
|
||||||
output-block)
|
|
||||||
|
|
@ -0,0 +1,9 @@
|
||||||
|
#lang racket/base
|
||||||
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||||
|
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||||
|
|
||||||
|
(provide (all-from-out crypto))
|
||||||
|
|
||||||
|
(require crypto)
|
||||||
|
(require crypto/all)
|
||||||
|
(use-all-factories!)
|
||||||
|
|
@ -1,77 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
||||||
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
||||||
|
|
||||||
(provide make-queue
|
|
||||||
queue?
|
|
||||||
enqueue
|
|
||||||
enqueue-all
|
|
||||||
dequeue
|
|
||||||
list->queue
|
|
||||||
queue->list
|
|
||||||
queue-length
|
|
||||||
queue-empty?
|
|
||||||
queue-append
|
|
||||||
queue-extract)
|
|
||||||
|
|
||||||
(struct queue (head tail) #:transparent)
|
|
||||||
|
|
||||||
(define (make-queue)
|
|
||||||
(queue '() '()))
|
|
||||||
|
|
||||||
(define (enqueue q v)
|
|
||||||
(queue (queue-head q)
|
|
||||||
(cons v (queue-tail q))))
|
|
||||||
|
|
||||||
(define (enqueue-all q v)
|
|
||||||
(queue (queue-head q)
|
|
||||||
(append (reverse v) (queue-tail q))))
|
|
||||||
|
|
||||||
(define (shuffle q)
|
|
||||||
(if (null? (queue-head q))
|
|
||||||
(queue (reverse (queue-tail q)) '())
|
|
||||||
q))
|
|
||||||
|
|
||||||
(define (dequeue q)
|
|
||||||
(let ((q1 (shuffle q)))
|
|
||||||
(values (car (queue-head q1))
|
|
||||||
(queue (cdr (queue-head q1)) (queue-tail q1)))))
|
|
||||||
|
|
||||||
(define (list->queue xs)
|
|
||||||
(queue xs '()))
|
|
||||||
|
|
||||||
(define (queue->list q)
|
|
||||||
(append (queue-head q) (reverse (queue-tail q))))
|
|
||||||
|
|
||||||
(define (queue-length q)
|
|
||||||
(+ (length (queue-head q))
|
|
||||||
(length (queue-tail q))))
|
|
||||||
|
|
||||||
(define (queue-empty? q)
|
|
||||||
(and (null? (queue-head q))
|
|
||||||
(null? (queue-tail q))))
|
|
||||||
|
|
||||||
(define (queue-append q1 q2)
|
|
||||||
(queue (append (queue-head q1)
|
|
||||||
(reverse (queue-tail q1))
|
|
||||||
(queue-head q2))
|
|
||||||
(queue-tail q2)))
|
|
||||||
|
|
||||||
(define (queue-extract q predicate [default-value #f])
|
|
||||||
(let search-head ((head (queue-head q))
|
|
||||||
(rejected-head-rev '()))
|
|
||||||
(cond
|
|
||||||
((null? head) (let search-tail ((tail (reverse (queue-tail q)))
|
|
||||||
(rejected-tail-rev '()))
|
|
||||||
(cond
|
|
||||||
((null? tail) (values default-value q))
|
|
||||||
((predicate (car tail)) (values (car tail)
|
|
||||||
(queue (queue-head q)
|
|
||||||
(append (reverse (cdr tail))
|
|
||||||
rejected-tail-rev))))
|
|
||||||
(else (search-tail (cdr tail) (cons (car tail) rejected-tail-rev))))))
|
|
||||||
((predicate (car head)) (values (car head)
|
|
||||||
(queue (append (reverse rejected-head-rev)
|
|
||||||
(cdr head))
|
|
||||||
(queue-tail q))))
|
|
||||||
(else (search-head (cdr head) (cons (car head) rejected-head-rev))))))
|
|
||||||
|
|
@ -9,11 +9,12 @@
|
||||||
"base"
|
"base"
|
||||||
|
|
||||||
"bitsyntax"
|
"bitsyntax"
|
||||||
"syndicate"
|
"crypto"
|
||||||
"preserves"
|
"preserves"
|
||||||
|
"syndicate"
|
||||||
|
|
||||||
))
|
))
|
||||||
|
|
||||||
;; (define build-deps '("rackunit-lib"))
|
(define build-deps '("rackunit-lib"))
|
||||||
|
|
||||||
(define pre-install-collection "private/install.rkt")
|
(define pre-install-collection "private/install.rkt")
|
||||||
|
|
|
||||||
|
|
@ -1,15 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
||||||
;;; SPDX-FileCopyrightText: Copyright © 2013-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
||||||
|
|
||||||
;;; Reexport racket-matrix module contents.
|
|
||||||
|
|
||||||
(require marketplace/sugar)
|
|
||||||
(require marketplace/drivers/tcp)
|
|
||||||
(require marketplace/drivers/timer)
|
|
||||||
(require marketplace/drivers/event-relay)
|
|
||||||
|
|
||||||
(provide (all-from-out marketplace/sugar))
|
|
||||||
(provide (all-from-out marketplace/drivers/tcp))
|
|
||||||
(provide (all-from-out marketplace/drivers/timer))
|
|
||||||
(provide (all-from-out marketplace/drivers/event-relay))
|
|
||||||
|
|
@ -1,12 +1,13 @@
|
||||||
#lang racket/base
|
#lang syndicate
|
||||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||||
;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||||
|
|
||||||
;;; (Temporary) example client and server
|
;;; (Temporary) example client and server
|
||||||
|
|
||||||
(require racket/set)
|
(require syndicate/drivers/timer)
|
||||||
(require racket/match)
|
(require syndicate/drivers/tcp)
|
||||||
(require racket/contract)
|
(require syndicate/dataspace)
|
||||||
|
|
||||||
(require (only-in racket/port peek-bytes-avail!-evt))
|
(require (only-in racket/port peek-bytes-avail!-evt))
|
||||||
(require "cook-port.rkt")
|
(require "cook-port.rkt")
|
||||||
(require "sandboxes.rkt")
|
(require "sandboxes.rkt")
|
||||||
|
|
@ -17,19 +18,16 @@
|
||||||
(require "ssh-channel.rkt")
|
(require "ssh-channel.rkt")
|
||||||
(require "ssh-message-types.rkt")
|
(require "ssh-message-types.rkt")
|
||||||
(require "ssh-exceptions.rkt")
|
(require "ssh-exceptions.rkt")
|
||||||
(require "marketplace-support.rkt")
|
|
||||||
|
|
||||||
(define (main)
|
(module+ main
|
||||||
(ground-vm (timer-driver)
|
(actor-system/dataspace (ds)
|
||||||
(tcp-driver)
|
(spawn-timer-driver ds)
|
||||||
(tcp-spy)
|
(spawn-tcp-driver ds)
|
||||||
(name-process 'ssh-tcp-listener (spawn listener))))
|
(spawn #:name 'ssh-tcp-listener
|
||||||
|
(at ds
|
||||||
(define listener
|
(during/spawn (Connection $conn (TcpInbound "0.0.0.0" 2322))
|
||||||
(transition/no-state
|
#:name (list 'ssh conn)
|
||||||
(observe-publishers (tcp-channel ? (tcp-listener 2322) ?)
|
(session ds conn))))))
|
||||||
(match-conversation r
|
|
||||||
(on-presence (session-vm r))))))
|
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
@ -44,242 +42,164 @@
|
||||||
"Invalid peer identification string ~v"
|
"Invalid peer identification string ~v"
|
||||||
peer-identification-string)))
|
peer-identification-string)))
|
||||||
|
|
||||||
(define (spy marker)
|
(define (session ground-ds conn)
|
||||||
(define (dump what message)
|
(define root-facet this-facet)
|
||||||
(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 ...)
|
(define update-input-handler
|
||||||
(let-fresh (endpoint-name)
|
(accept-connection conn
|
||||||
(build-endpoint endpoint-name
|
#:initial-credit #f
|
||||||
(role my-orientation topic 'observer)
|
#:on-data (lambda (input mode) (error 'session "Unexpected input"))))
|
||||||
(match-state state
|
|
||||||
(on-presence (sequence-actions (transition state
|
|
||||||
(delete-endpoint endpoint-name)
|
|
||||||
action ...)))))))
|
|
||||||
|
|
||||||
(define (session-vm new-conversation)
|
(define local-identification "SSH-2.0-RacketSSH_0.0")
|
||||||
(match-define (tcp-channel remote-addr local-addr _) new-conversation)
|
(send-line conn local-identification)
|
||||||
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
|
||||||
|
|
||||||
(define (issue-identification-string)
|
(send-lines-credit conn 1 (LineMode-crlf))
|
||||||
(at-meta-level
|
(update-input-handler
|
||||||
(send-message (tcp-channel local-addr remote-addr
|
#:on-data (lambda (remote-identification _mode)
|
||||||
(bytes-append local-identification #"\r\n")))))
|
(check-remote-identification! remote-identification)
|
||||||
|
|
||||||
(define (read-handshake-and-become-reader)
|
(define session-vm
|
||||||
(transition 'handshake-is-stateless ;; but, crucially, the ssh-reader proper isn't!
|
(actor-group [(on-stop
|
||||||
(at-meta-level
|
(stop-facet root-facet)
|
||||||
(name-endpoint 'socket-reader
|
(log-info "Session VM for ~a closed" conn))]
|
||||||
(subscriber (tcp-channel remote-addr local-addr ?)
|
(define conn-ds (dataspace #:name (gensym 'conn-ds)))
|
||||||
(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)
|
(spawn/link #:name 'reader
|
||||||
(outbound-packet (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code reason)
|
(ssh-reader conn-ds conn update-input-handler))
|
||||||
(string->bytes/utf-8 (exn-message reason))
|
(spawn/link #:name 'writer
|
||||||
#"")))
|
(ssh-writer conn-ds conn))
|
||||||
|
|
||||||
(define (disconnect-message-required? reason)
|
;; Wait for the reader and writer get started, then tell the reader
|
||||||
(and (exn:fail:contract:protocol? reason)
|
;; we are ready for a single packet and spawn the session manager.
|
||||||
(not (exn:fail:contract:protocol-originated-at-peer? reason))))
|
(react
|
||||||
|
(at conn-ds
|
||||||
|
(stop-when (asserted (Observe (:pattern (inbound-credit ,_)) _))
|
||||||
|
(send! conn-ds (inbound-credit 1))
|
||||||
|
|
||||||
(define (active-exception-handler reason)
|
(spawn/link
|
||||||
;; This is kind of gross: because the absence handler gets invoked
|
#:name 'session
|
||||||
;; several times in a row because of multiple flows intersecting
|
(ssh-session conn-ds
|
||||||
;; this role, we have to be careful to make the transmission of
|
ground-ds
|
||||||
;; the disconnection packet idempotent.
|
local-identification
|
||||||
;; TODO: this is likely no longer true now we're using exit-signals %%%
|
remote-identification
|
||||||
(define interesting? (disconnect-message-required? reason))
|
(lambda (user-name)
|
||||||
(transition inert-exception-handler
|
(error 'repl-boot "Would start session with ~a" user-name))
|
||||||
(when interesting? (send-message (exn->outbound-packet reason)))
|
'server)))))
|
||||||
(yield state ;; gross
|
|
||||||
(transition state (at-meta-level (quit #f (and interesting? reason)))))))
|
|
||||||
|
|
||||||
(define (inert-exception-handler reason)
|
(at conn-ds
|
||||||
inert-exception-handler)
|
(during $m
|
||||||
|
(on-start (log-info "++ ~v" m))
|
||||||
|
(on-stop (log-info "-- ~v" m)))
|
||||||
|
(when (message $m)
|
||||||
|
(log-info ">> ~v" m)))
|
||||||
|
|
||||||
(spawn-vm #:debug-name (list 'ssh-session-vm new-conversation)
|
(at conn-ds
|
||||||
(event-relay 'ssh-event-relay)
|
(when (asserted (protocol-error $reason-code $message _ $originated-at-peer?))
|
||||||
(timer-relay 'ssh-timer-relay)
|
(when (not originated-at-peer?)
|
||||||
(spy 'SSH)
|
(send! conn-ds
|
||||||
|
(outbound-packet (ssh-msg-disconnect reason-code
|
||||||
|
(string->bytes/utf-8 message)
|
||||||
|
#""))))
|
||||||
|
(actor-system-shutdown! session-vm)))))
|
||||||
|
|
||||||
(issue-identification-string)
|
(void))))
|
||||||
|
|
||||||
;; 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)
|
;; ;; (repl-instance InputPort OutputPort InputPort OutputPort)
|
||||||
(list
|
;; (struct repl-instance-state (c2s-in ;; used by thread to read input from relay
|
||||||
(event-relay 'app-event-relay)
|
;; c2s-out ;; used by relay to feed input from remote to the thread
|
||||||
(spy 'APP)
|
;; s2c-in ;; used by relay to feed output from thread to remote
|
||||||
(at-meta-level
|
;; s2c-out ;; used by thread to write output to relay
|
||||||
(subscriber (channel-message (channel-stream-name #t (wild)) (wild))
|
;; ) #:prefab)
|
||||||
(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)
|
;; (define (repl-instance user-name cname)
|
||||||
(struct repl-instance-state (c2s-in ;; used by thread to read input from relay
|
;; (define inbound-stream (channel-stream-name #t cname))
|
||||||
c2s-out ;; used by relay to feed input from remote to the thread
|
;; (define outbound-stream (channel-stream-name #f cname))
|
||||||
s2c-in ;; used by relay to feed output from thread to remote
|
;; (define (ch-do action-ctor stream body)
|
||||||
s2c-out ;; used by thread to write output to relay
|
;; (at-meta-level (action-ctor (channel-message stream body))))
|
||||||
) #:prefab)
|
;; (define (handle-channel-message state body)
|
||||||
|
;; (match body
|
||||||
(define (repl-instance user-name cname)
|
;; [(channel-stream-request #"pty-req" _)
|
||||||
(define inbound-stream (channel-stream-name #t cname))
|
;; (match-define (repl-instance-state old-in _ _ old-out) state)
|
||||||
(define outbound-stream (channel-stream-name #f cname))
|
;; (define-values (cooked-in cooked-out) (cook-io old-in old-out "> "))
|
||||||
(define (ch-do action-ctor stream body)
|
;; (transition (struct-copy repl-instance-state state
|
||||||
(at-meta-level (action-ctor (channel-message stream body))))
|
;; [c2s-in cooked-in]
|
||||||
(define (handle-channel-message state body)
|
;; [s2c-out cooked-out])
|
||||||
(match body
|
;; (ch-do send-feedback inbound-stream (channel-stream-ok)))]
|
||||||
[(channel-stream-request #"pty-req" _)
|
;; [(channel-stream-notify #"env" _)
|
||||||
(match-define (repl-instance-state old-in _ _ old-out) state)
|
;; ;; Don't care
|
||||||
(define-values (cooked-in cooked-out) (cook-io old-in old-out "> "))
|
;; (transition state)]
|
||||||
(transition (struct-copy repl-instance-state state
|
;; [(channel-stream-request #"shell" _)
|
||||||
[c2s-in cooked-in]
|
;; (match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state)
|
||||||
[s2c-out cooked-out])
|
;; (define buffer-size 1024)
|
||||||
(ch-do send-feedback inbound-stream (channel-stream-ok)))]
|
;; (define dummy-buffer (make-bytes buffer-size))
|
||||||
[(channel-stream-notify #"env" _)
|
;; (define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out))))
|
||||||
;; Don't care
|
;; (transition state
|
||||||
(transition state)]
|
;; (ch-do send-feedback inbound-stream (channel-stream-ok))
|
||||||
[(channel-stream-request #"shell" _)
|
;; (subscriber (cons (thread-dead-evt repl-thread) (wild))
|
||||||
(match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state)
|
;; (on-message [_ (quit #f "REPL thread exited")]))
|
||||||
(define buffer-size 1024)
|
;; (subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild))
|
||||||
(define dummy-buffer (make-bytes buffer-size))
|
;; ;; We're using peek-bytes-avail!-evt rather than
|
||||||
(define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out))))
|
;; ;; read-bytes-avail!-evt because of potential overwriting
|
||||||
(transition state
|
;; ;; of the buffer. The overwriting can happen when there's
|
||||||
(ch-do send-feedback inbound-stream (channel-stream-ok))
|
;; ;; any latency between handling the event and the next
|
||||||
(subscriber (cons (thread-dead-evt repl-thread) (wild))
|
;; ;; firing of the event, since the peek-bytes-avail!-evt
|
||||||
(on-message [_ (quit #f "REPL thread exited")]))
|
;; ;; will overwrite its buffer next time it's synced on.
|
||||||
(subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild))
|
;; (match-state state
|
||||||
;; We're using peek-bytes-avail!-evt rather than
|
;; (on-message
|
||||||
;; read-bytes-avail!-evt because of potential overwriting
|
;; [(cons _ (? eof-object?))
|
||||||
;; of the buffer. The overwriting can happen when there's
|
;; (let ()
|
||||||
;; any latency between handling the event and the next
|
;; (match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state)
|
||||||
;; firing of the event, since the peek-bytes-avail!-evt
|
;; (close-input-port c2s-in)
|
||||||
;; will overwrite its buffer next time it's synced on.
|
;; (close-output-port c2s-out)
|
||||||
(match-state state
|
;; (close-input-port s2c-in)
|
||||||
(on-message
|
;; (close-output-port s2c-out)
|
||||||
[(cons _ (? eof-object?))
|
;; (transition state (quit)))]
|
||||||
(let ()
|
;; [(cons _ (? number? count))
|
||||||
(match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state)
|
;; (transition state
|
||||||
(close-input-port c2s-in)
|
;; (ch-do send-message outbound-stream (channel-stream-data
|
||||||
(close-output-port c2s-out)
|
;; (read-bytes count s2c-in))))]))))]
|
||||||
(close-input-port s2c-in)
|
;; [(or (channel-stream-data #"\4") ;; C-d a.k.a EOT
|
||||||
(close-output-port s2c-out)
|
;; (channel-stream-eof))
|
||||||
(transition state (quit)))]
|
;; (let ()
|
||||||
[(cons _ (? number? count))
|
;; (close-output-port (repl-instance-state-c2s-out state))
|
||||||
(transition state
|
;; ;; ^ this signals the repl thread to exit.
|
||||||
(ch-do send-message outbound-stream (channel-stream-data
|
;; ;; Now, wait for it to do so.
|
||||||
(read-bytes count s2c-in))))]))))]
|
;; (transition state))]
|
||||||
[(or (channel-stream-data #"\4") ;; C-d a.k.a EOT
|
;; [(channel-stream-data bs)
|
||||||
(channel-stream-eof))
|
;; (write-bytes bs (repl-instance-state-c2s-out state))
|
||||||
(let ()
|
;; (flush-output (repl-instance-state-c2s-out state))
|
||||||
(close-output-port (repl-instance-state-c2s-out state))
|
;; (transition state
|
||||||
;; ^ this signals the repl thread to exit.
|
;; (ch-do send-feedback inbound-stream (channel-stream-credit (bytes-length bs))))]
|
||||||
;; Now, wait for it to do so.
|
;; [m
|
||||||
(transition state))]
|
;; (write `(channel inbound ,m)) (newline)
|
||||||
[(channel-stream-data bs)
|
;; (transition state)]))
|
||||||
(write-bytes bs (repl-instance-state-c2s-out state))
|
;; (match (channel-name-type cname)
|
||||||
(flush-output (repl-instance-state-c2s-out state))
|
;; [#"session"
|
||||||
(transition state
|
;; (define-values (c2s-in c2s-out) (make-pipe))
|
||||||
(ch-do send-feedback inbound-stream (channel-stream-credit (bytes-length bs))))]
|
;; (define-values (s2c-in s2c-out) (make-pipe))
|
||||||
[m
|
;; (transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out)
|
||||||
(write `(channel inbound ,m)) (newline)
|
;; (at-meta-level
|
||||||
(transition state)]))
|
;; (subscriber (channel-message inbound-stream (wild))
|
||||||
(match (channel-name-type cname)
|
;; (match-state state
|
||||||
[#"session"
|
;; (on-presence (transition state
|
||||||
(define-values (c2s-in c2s-out) (make-pipe))
|
;; (ch-do send-feedback inbound-stream (channel-stream-config
|
||||||
(define-values (s2c-in s2c-out) (make-pipe))
|
;; (default-packet-limit)
|
||||||
(transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out)
|
;; #""))
|
||||||
(at-meta-level
|
;; (ch-do send-feedback inbound-stream (channel-stream-credit 1024))))
|
||||||
(subscriber (channel-message inbound-stream (wild))
|
;; (on-message
|
||||||
(match-state state
|
;; [(channel-message _ body)
|
||||||
(on-presence (transition state
|
;; (handle-channel-message state body)]))))
|
||||||
(ch-do send-feedback inbound-stream (channel-stream-config
|
;; (at-meta-level
|
||||||
(default-packet-limit)
|
;; (publisher (channel-message outbound-stream (wild))
|
||||||
#""))
|
;; (on-message [m (begin
|
||||||
(ch-do send-feedback inbound-stream (channel-stream-credit 1024))))
|
;; (write `(channel outbound ,cname ,m)) (newline)
|
||||||
(on-message
|
;; (void))]))))]
|
||||||
[(channel-message _ body)
|
;; [type
|
||||||
(handle-channel-message state body)]))))
|
;; (transition/no-state
|
||||||
(at-meta-level
|
;; (at-meta-level (send-message
|
||||||
(publisher (channel-message outbound-stream (wild))
|
;; (channel-message outbound-stream
|
||||||
(on-message [m (begin
|
;; (channel-stream-open-failure
|
||||||
(write `(channel outbound ,cname ,m)) (newline)
|
;; SSH_OPEN_UNKNOWN_CHANNEL_TYPE
|
||||||
(void))]))))]
|
;; (bytes-append #"Unknown channel type " type))))))]))
|
||||||
[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)
|
|
||||||
|
|
|
||||||
|
|
@ -7,24 +7,24 @@
|
||||||
(provide dh:oakley-group-2
|
(provide dh:oakley-group-2
|
||||||
dh:oakley-group-14)
|
dh:oakley-group-14)
|
||||||
|
|
||||||
;;(require (planet vyzo/crypto))
|
(require "crypto.rkt")
|
||||||
(require (planet vyzo/crypto/dh))
|
|
||||||
(require (only-in net/base64 base64-decode))
|
(require (only-in net/base64 base64-decode))
|
||||||
|
|
||||||
(define dh:oakley-group-2
|
(define dh:oakley-group-2
|
||||||
(make-!dh
|
(datum->pk-parameters
|
||||||
1024
|
|
||||||
(base64-decode
|
(base64-decode
|
||||||
#"MIGHAoGBAP//////////yQ/aoiFowjTExmKLgNwc0SkCTgiKZ8x0Agu+pjsTmyJRSgh5jjQE
|
#"MIGHAoGBAP//////////yQ/aoiFowjTExmKLgNwc0SkCTgiKZ8x0Agu+pjsTmyJRSgh5jjQE
|
||||||
3e+VGbPNOkMbMCsKbfJfFDdP4TVtbVHCReSFtXZiXn7G9ExC6aY37WsL/1y29Aa37e44a/ta
|
3e+VGbPNOkMbMCsKbfJfFDdP4TVtbVHCReSFtXZiXn7G9ExC6aY37WsL/1y29Aa37e44a/ta
|
||||||
iZ+lrp8kEXxLH+ZJKGZR7OZTgf//////////AgEC")))
|
iZ+lrp8kEXxLH+ZJKGZR7OZTgf//////////AgEC")
|
||||||
|
'DHParameter))
|
||||||
|
|
||||||
(define dh:oakley-group-14
|
(define dh:oakley-group-14
|
||||||
(make-!dh
|
(datum->pk-parameters
|
||||||
2048
|
|
||||||
(base64-decode
|
(base64-decode
|
||||||
#"MIIBCAKCAQEA///////////JD9qiIWjCNMTGYouA3BzRKQJOCIpnzHQCC76mOxObIlFKCHmO
|
#"MIIBCAKCAQEA///////////JD9qiIWjCNMTGYouA3BzRKQJOCIpnzHQCC76mOxObIlFKCHmO
|
||||||
NATd75UZs806QxswKwpt8l8UN0/hNW1tUcJF5IW1dmJefsb0TELppjftawv/XLb0Brft7jhr
|
NATd75UZs806QxswKwpt8l8UN0/hNW1tUcJF5IW1dmJefsb0TELppjftawv/XLb0Brft7jhr
|
||||||
+1qJn6WunyQRfEsf5kkoZlHs5Fs9wgB8uKFjvwWY2kg2HFXTmmkWP6j9JM9fg2VdI9yjrZYc
|
+1qJn6WunyQRfEsf5kkoZlHs5Fs9wgB8uKFjvwWY2kg2HFXTmmkWP6j9JM9fg2VdI9yjrZYc
|
||||||
YvNWIIVSu57VKQdwlpZtZww1Tkq8mATxdGwIyhghfDKQXkYuNs474553LBgOhgObJ4Oi7Aei
|
YvNWIIVSu57VKQdwlpZtZww1Tkq8mATxdGwIyhghfDKQXkYuNs474553LBgOhgObJ4Oi7Aei
|
||||||
j7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqsqmj//////////wIBAg==")))
|
j7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqsqmj//////////wIBAg==")
|
||||||
|
'DHParameter))
|
||||||
|
|
|
||||||
|
|
@ -1,44 +1,39 @@
|
||||||
#lang racket/base
|
#lang syndicate
|
||||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||||
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||||
|
|
||||||
;;; Exceptions and error-raising and -handling utilities used in structuring SSH sessions.
|
;;; Error-raising and -handling utilities used in structuring SSH sessions.
|
||||||
|
|
||||||
(provide (struct-out exn:fail:contract:protocol)
|
(provide (struct-out protocol-error)
|
||||||
disconnect-with-error
|
disconnect-with-error
|
||||||
disconnect-with-error/local-info
|
disconnect-with-error/local-info
|
||||||
disconnect-with-error*)
|
disconnect-with-error*)
|
||||||
|
|
||||||
;; An exn:fail:contract:protocol, when thrown by the transport (TODO:
|
;; A `protocol-error`, when asserted, will cause a SSH_MSG_DISCONNECT
|
||||||
;; clarify scope of this behaviour) will cause a SSH_MSG_DISCONNECT to
|
;; to be sent to the remote party with the included reason code, using
|
||||||
;; be sent to the remote party with the included reason code, using
|
;; `message` as the description. The `local-info` field is useful
|
||||||
;; the exn-message as the description. The local-info field is useful
|
|
||||||
;; information for diagnosing problems known to the local stack that
|
;; information for diagnosing problems known to the local stack that
|
||||||
;; should not be transmitted to the remote party. For example, upon
|
;; should not be transmitted to the remote party. For example, upon
|
||||||
;; detection of a MAC failure, it might be useful to know the expected
|
;; detection of a MAC failure, it might be useful to know the expected
|
||||||
;; and actual MACs for debugging, but they should not be sent over the
|
;; and actual MACs for debugging, but they should not be sent over the
|
||||||
;; wire because we could be experiencing some kind of attack.
|
;; wire because we could be experiencing some kind of attack.
|
||||||
(struct exn:fail:contract:protocol exn:fail:contract
|
(struct protocol-error (reason-code message local-info originated-at-peer?) #:prefab)
|
||||||
(reason-code local-info originated-at-peer?)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
;; Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
|
;; DS Natural FormatString [Any ...] -> signalled protocol-error
|
||||||
(define (disconnect-with-error reason-code format-string . args)
|
(define (disconnect-with-error ds reason-code format-string . args)
|
||||||
(apply disconnect-with-error* #f '() reason-code format-string args))
|
(apply disconnect-with-error* ds #f '() reason-code format-string args))
|
||||||
|
|
||||||
;; Any Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
|
;; DS Any Natural FormatString [Any ...] -> signalled protocol-error
|
||||||
(define (disconnect-with-error/local-info local-info reason-code format-string . args)
|
(define (disconnect-with-error/local-info ds local-info reason-code format-string . args)
|
||||||
(apply disconnect-with-error* #f local-info reason-code format-string args))
|
(apply disconnect-with-error* ds #f local-info reason-code format-string args))
|
||||||
|
|
||||||
;; Boolean Any Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
|
;; DS Boolean Any Natural FormatString [Any ...] -> signalled protocol-error
|
||||||
(define (disconnect-with-error* originated-at-peer?
|
(define (disconnect-with-error* ds
|
||||||
|
originated-at-peer?
|
||||||
local-info
|
local-info
|
||||||
reason-code
|
reason-code
|
||||||
format-string
|
format-string
|
||||||
. args)
|
. args)
|
||||||
(let ((message (apply format format-string args)))
|
(define message (apply format format-string args))
|
||||||
(raise (exn:fail:contract:protocol message
|
(spawn (at ds (assert (protocol-error reason-code message local-info originated-at-peer?))))
|
||||||
(current-continuation-marks)
|
(error 'protocol-error "(~a) ~a: ~v" reason-code message local-info))
|
||||||
reason-code
|
|
||||||
local-info
|
|
||||||
originated-at-peer?))))
|
|
||||||
|
|
|
||||||
|
|
@ -6,8 +6,8 @@
|
||||||
(require racket/port)
|
(require racket/port)
|
||||||
(require net/base64)
|
(require net/base64)
|
||||||
|
|
||||||
(require (planet vyzo/crypto))
|
|
||||||
(require bitsyntax)
|
(require bitsyntax)
|
||||||
|
(require "crypto.rkt")
|
||||||
(require "asn1-ber.rkt")
|
(require "asn1-ber.rkt")
|
||||||
(require "ssh-message-types.rkt")
|
(require "ssh-message-types.rkt")
|
||||||
|
|
||||||
|
|
@ -22,7 +22,6 @@
|
||||||
pieces->public-key
|
pieces->public-key
|
||||||
|
|
||||||
host-key-algorithm->keys
|
host-key-algorithm->keys
|
||||||
host-key-algorithm->digest-type
|
|
||||||
host-key-signature
|
host-key-signature
|
||||||
verify-host-key-signature!
|
verify-host-key-signature!
|
||||||
|
|
||||||
|
|
@ -38,8 +37,8 @@
|
||||||
(define (bs->n bs) (bit-string->integer bs #t #t))
|
(define (bs->n bs) (bit-string->integer bs #t #t))
|
||||||
(define (n->bs n) (integer->bit-string n (* 8 (mpint-width n)) #t))
|
(define (n->bs n) (integer->bit-string n (* 8 (mpint-width n)) #t))
|
||||||
|
|
||||||
(define (private-key->pieces key)
|
;; (define (private-key->pieces key)
|
||||||
(bytes->private-key-pieces (private-key->bytes key)))
|
;; (bytes->private-key-pieces (private-key->bytes key)))
|
||||||
|
|
||||||
(define (bytes->private-key-pieces bs)
|
(define (bytes->private-key-pieces bs)
|
||||||
(match (asn1-ber-decode-all bs)
|
(match (asn1-ber-decode-all bs)
|
||||||
|
|
@ -76,65 +75,32 @@
|
||||||
|
|
||||||
(define (pieces->private-key p)
|
(define (pieces->private-key p)
|
||||||
(match p
|
(match p
|
||||||
((struct rsa-private-key (version n e d p q dmp1 dmq1 iqmp))
|
[(struct rsa-private-key (version n e d _p _q _dmp1 _dmq1 _iqmp))
|
||||||
(bytes->private-key pkey:rsa
|
(datum->pk-key (list 'rsa 'private n e d)
|
||||||
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs version))
|
'rkt-private)]
|
||||||
(0 2 ,(n->bs n))
|
[(struct dsa-private-key (version p q g y x))
|
||||||
(0 2 ,(n->bs e))
|
(datum->pk-key (list 'dsa 'private p q g y x)
|
||||||
(0 2 ,(n->bs d))
|
'rkt-private)]))
|
||||||
(0 2 ,(n->bs p))
|
|
||||||
(0 2 ,(n->bs q))
|
|
||||||
(0 2 ,(n->bs dmp1))
|
|
||||||
(0 2 ,(n->bs dmq1))
|
|
||||||
(0 2 ,(n->bs iqmp)))))))
|
|
||||||
((struct dsa-private-key (version p q g y x))
|
|
||||||
(bytes->private-key pkey:dsa
|
|
||||||
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs version))
|
|
||||||
(0 2 ,(n->bs p))
|
|
||||||
(0 2 ,(n->bs q))
|
|
||||||
(0 2 ,(n->bs g))
|
|
||||||
(0 2 ,(n->bs y))
|
|
||||||
(0 2 ,(n->bs x)))))))))
|
|
||||||
|
|
||||||
(define (public-key->pieces key)
|
(define (public-key->pieces key)
|
||||||
(match (asn1-ber-decode-all (public-key->bytes key))
|
(match (pk-key->datum key 'rkt-public)
|
||||||
(`(0 16 ((0 2 ,n-bytes)
|
[(list 'rsa 'public n e)
|
||||||
(0 2 ,e-bytes)))
|
(rsa-public-key n e)]
|
||||||
(rsa-public-key (bs->n n-bytes)
|
[(list 'dsa 'public p q g public-key-bytes)
|
||||||
(bs->n e-bytes)))
|
(dsa-public-key public-key-bytes p q g)]))
|
||||||
(`(0 16 ((0 2 ,public-key-bytes) ;; y
|
|
||||||
(0 2 ,p-bytes)
|
|
||||||
(0 2 ,q-bytes)
|
|
||||||
(0 2 ,g-bytes)))
|
|
||||||
(dsa-public-key (bs->n public-key-bytes)
|
|
||||||
(bs->n p-bytes)
|
|
||||||
(bs->n q-bytes)
|
|
||||||
(bs->n g-bytes)))))
|
|
||||||
|
|
||||||
(define (pieces->public-key p)
|
(define (pieces->public-key p)
|
||||||
(match p
|
(match p
|
||||||
((struct rsa-public-key (n e))
|
((struct rsa-public-key (n e))
|
||||||
(bytes->public-key pkey:rsa
|
(datum->pk-key (list 'rsa 'public n e) 'rkt-public))
|
||||||
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs n))
|
|
||||||
(0 2 ,(n->bs e)))))))
|
|
||||||
((struct dsa-public-key (y p q g))
|
((struct dsa-public-key (y p q g))
|
||||||
(bytes->public-key pkey:dsa
|
(datum->pk-key (list 'dsa 'public p q g y) 'rkt-public))))
|
||||||
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs y))
|
|
||||||
(0 2 ,(n->bs p))
|
|
||||||
(0 2 ,(n->bs q))
|
|
||||||
(0 2 ,(n->bs g)))))))))
|
|
||||||
|
|
||||||
(define (host-key-algorithm->keys host-key-alg)
|
(define (host-key-algorithm->keys host-key-alg)
|
||||||
(case host-key-alg
|
(case host-key-alg
|
||||||
((ssh-dss) (values host-key-dsa-private host-key-dsa-public))
|
((ssh-dss) (values host-key-dsa-private host-key-dsa-public))
|
||||||
(else (error 'host-key-algorithm->keys "Unsupported host-key-alg ~v" host-key-alg))))
|
(else (error 'host-key-algorithm->keys "Unsupported host-key-alg ~v" host-key-alg))))
|
||||||
|
|
||||||
(define (host-key-algorithm->digest-type host-key-alg)
|
|
||||||
(case host-key-alg
|
|
||||||
((ssh-rsa) digest:sha1)
|
|
||||||
((ssh-dss) digest:dss1)
|
|
||||||
(else (error 'host-key-algorithm->digest-type "Unsupported host-key-alg ~v" host-key-alg))))
|
|
||||||
|
|
||||||
(define (host-key-signature private-key host-key-alg exchange-hash)
|
(define (host-key-signature private-key host-key-alg exchange-hash)
|
||||||
(case host-key-alg
|
(case host-key-alg
|
||||||
((ssh-rsa)
|
((ssh-rsa)
|
||||||
|
|
@ -142,7 +108,7 @@
|
||||||
;; local-algorithm-list in ssh-transport.rkt.
|
;; local-algorithm-list in ssh-transport.rkt.
|
||||||
(error 'host-key-signature "ssh-rsa host key signatures unimplemented"))
|
(error 'host-key-signature "ssh-rsa host key signatures unimplemented"))
|
||||||
((ssh-dss)
|
((ssh-dss)
|
||||||
(match (asn1-ber-decode-all (sign private-key digest:dss1 exchange-hash))
|
(match (asn1-ber-decode-all (pk-sign private-key exchange-hash))
|
||||||
(`(0 16 ((0 2 ,r-bytes)
|
(`(0 16 ((0 2 ,r-bytes)
|
||||||
(0 2 ,s-bytes)))
|
(0 2 ,s-bytes)))
|
||||||
(bit-string (#"ssh-dss" :: (t:string))
|
(bit-string (#"ssh-dss" :: (t:string))
|
||||||
|
|
@ -167,7 +133,7 @@
|
||||||
(s :: big-endian integer bits 160) ]
|
(s :: big-endian integer bits 160) ]
|
||||||
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs r))
|
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs r))
|
||||||
(0 2 ,(n->bs s))))))))))
|
(0 2 ,(n->bs s))))))))))
|
||||||
(when (not (verify public-key digest:dss1 signature exchange-hash))
|
(when (not (pk-verify public-key exchange-hash signature))
|
||||||
(error 'verify-host-key-signature! "Signature mismatch")))))
|
(error 'verify-host-key-signature! "Signature mismatch")))))
|
||||||
|
|
||||||
(define (pieces->ssh-host-key pieces)
|
(define (pieces->ssh-host-key pieces)
|
||||||
|
|
@ -207,7 +173,8 @@
|
||||||
#"")))))
|
#"")))))
|
||||||
|
|
||||||
(define host-key-dsa-private (load-private-key "test-dsa-key"))
|
(define host-key-dsa-private (load-private-key "test-dsa-key"))
|
||||||
(define host-key-dsa-public (pkey->public-key host-key-dsa-private))
|
(define host-key-dsa-public (pk-key->public-only-key host-key-dsa-private))
|
||||||
|
|
||||||
(check-equal? (public-key->bytes (pieces->public-key (public-key->pieces host-key-dsa-public)))
|
(check-equal? (pk-key->datum (pieces->public-key (public-key->pieces host-key-dsa-public))
|
||||||
(public-key->bytes host-key-dsa-private))
|
'SubjectPublicKeyInfo)
|
||||||
|
(pk-key->datum host-key-dsa-private 'SubjectPublicKeyInfo))
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,23 +1,16 @@
|
||||||
#lang racket/base
|
#lang syndicate
|
||||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||||
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||||
|
|
||||||
(require bitsyntax)
|
(require bitsyntax)
|
||||||
(require (planet vyzo/crypto:2:3))
|
|
||||||
|
|
||||||
(require racket/set)
|
|
||||||
(require racket/match)
|
|
||||||
|
|
||||||
(require rackunit)
|
(require rackunit)
|
||||||
|
(require syndicate/drivers/tcp)
|
||||||
|
|
||||||
(require "aes-ctr.rkt")
|
(require "crypto.rkt")
|
||||||
|
|
||||||
(require "ssh-numbers.rkt")
|
(require "ssh-numbers.rkt")
|
||||||
(require "ssh-message-types.rkt")
|
(require "ssh-message-types.rkt")
|
||||||
(require "ssh-exceptions.rkt")
|
(require "ssh-exceptions.rkt")
|
||||||
|
|
||||||
(require "marketplace-support.rkt")
|
|
||||||
|
|
||||||
(provide (struct-out inbound-packet)
|
(provide (struct-out inbound-packet)
|
||||||
(struct-out inbound-credit)
|
(struct-out inbound-credit)
|
||||||
(struct-out outbound-packet)
|
(struct-out outbound-packet)
|
||||||
|
|
@ -103,56 +96,42 @@
|
||||||
0
|
0
|
||||||
0))
|
0))
|
||||||
|
|
||||||
(define (make-evp-cipher-entry name cipher)
|
(define (make-cipher-entry name cipher-spec key-length)
|
||||||
(list name
|
(list name
|
||||||
(supported-cipher name
|
(supported-cipher name
|
||||||
(lambda (enc? key iv)
|
(lambda (enc? key iv)
|
||||||
(let ((state ((if enc? cipher-encrypt cipher-decrypt)
|
(lambda (input)
|
||||||
cipher key iv #:padding #f)))
|
((if enc? encrypt decrypt)
|
||||||
(lambda (block)
|
cipher-spec key iv input #:pad #f)))
|
||||||
(cipher-update! state block))))
|
key-length
|
||||||
(cipher-key-length cipher)
|
(cipher-block-size cipher-spec)
|
||||||
(cipher-block-size cipher)
|
(cipher-iv-size cipher-spec))))
|
||||||
(cipher-iv-length cipher))))
|
|
||||||
|
|
||||||
(define (aes-ctr-cipher-factory enc? key iv)
|
|
||||||
(let ((state (start-aes-ctr key iv)))
|
|
||||||
(lambda (block)
|
|
||||||
(aes-ctr-process! state block))))
|
|
||||||
|
|
||||||
(define (make-aes-ctr-entry name key-length)
|
|
||||||
(list name
|
|
||||||
(supported-cipher name
|
|
||||||
aes-ctr-cipher-factory
|
|
||||||
key-length
|
|
||||||
16
|
|
||||||
16)))
|
|
||||||
|
|
||||||
(define supported-crypto-algorithms
|
(define supported-crypto-algorithms
|
||||||
(list
|
(list
|
||||||
(make-aes-ctr-entry 'aes128-ctr 16)
|
(make-cipher-entry 'aes128-ctr '(aes ctr) 16)
|
||||||
(make-aes-ctr-entry 'aes192-ctr 24)
|
(make-cipher-entry 'aes192-ctr '(aes ctr) 24)
|
||||||
(make-aes-ctr-entry 'aes256-ctr 32)
|
(make-cipher-entry 'aes256-ctr '(aes ctr) 32)
|
||||||
(make-evp-cipher-entry 'aes128-cbc cipher:aes-128-cbc)
|
(make-cipher-entry 'aes128-cbc '(aes cbc) 16)
|
||||||
(make-evp-cipher-entry 'aes192-cbc cipher:aes-192-cbc)
|
(make-cipher-entry 'aes192-cbc '(aes cbc) 24)
|
||||||
(make-evp-cipher-entry 'aes256-cbc cipher:aes-256-cbc)
|
(make-cipher-entry 'aes256-cbc '(aes cbc) 32)
|
||||||
(make-evp-cipher-entry '3des-cbc cipher:des-ede3)
|
(make-cipher-entry '3des-cbc '(des-ede3 cbc) 24)
|
||||||
)) ;; TODO: actually test these!
|
)) ;; TODO: actually test these!
|
||||||
|
|
||||||
(define (make-hmac-entry name digest key-length-or-false)
|
(define (make-hmac-entry name digest-spec key-length-or-false)
|
||||||
(let* ((digest-length (digest-size digest))
|
(let* ((digest-length (digest-size digest-spec))
|
||||||
(key-length (or key-length-or-false digest-length)))
|
(key-length (or key-length-or-false digest-length)))
|
||||||
(list name
|
(list name
|
||||||
(supported-hmac name
|
(supported-hmac name
|
||||||
(lambda (key)
|
(lambda (key)
|
||||||
(lambda (blob)
|
(lambda (blob)
|
||||||
(hmac digest key blob)))
|
(hmac digest-spec key blob)))
|
||||||
digest-length
|
digest-length
|
||||||
key-length))))
|
key-length))))
|
||||||
|
|
||||||
(define supported-hmac-algorithms
|
(define supported-hmac-algorithms
|
||||||
(list (make-hmac-entry 'hmac-md5 digest:md5 #f)
|
(list (make-hmac-entry 'hmac-md5 'md5 #f)
|
||||||
(make-hmac-entry 'hmac-sha1 digest:sha1 #f)))
|
(make-hmac-entry 'hmac-sha1 'sha1 #f)))
|
||||||
|
|
||||||
(define supported-compression-algorithms '(none)) ;; TODO: zlib, and zlib delayed
|
(define supported-compression-algorithms '(none)) ;; TODO: zlib, and zlib delayed
|
||||||
|
|
||||||
|
|
@ -161,7 +140,7 @@
|
||||||
(mac-names (map car supported-hmac-algorithms)))
|
(mac-names (map car supported-hmac-algorithms)))
|
||||||
(make-parameter
|
(make-parameter
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(ssh-msg-kexinit (random-bytes 16)
|
(ssh-msg-kexinit (crypto-random-bytes 16)
|
||||||
'(diffie-hellman-group14-sha1
|
'(diffie-hellman-group14-sha1
|
||||||
diffie-hellman-group1-sha1)
|
diffie-hellman-group1-sha1)
|
||||||
'(ssh-dss) ;; TODO: offer ssh-rsa. This will
|
'(ssh-dss) ;; TODO: offer ssh-rsa. This will
|
||||||
|
|
@ -190,7 +169,7 @@
|
||||||
null-hmac
|
null-hmac
|
||||||
null-hmac-description))
|
null-hmac-description))
|
||||||
|
|
||||||
(define (apply-negotiated-options nk is-outbound?)
|
(define (apply-negotiated-options conn-ds nk is-outbound?)
|
||||||
(match-define (new-keys is-server?
|
(match-define (new-keys is-server?
|
||||||
derive-key
|
derive-key
|
||||||
c2s-enc s2c-enc
|
c2s-enc s2c-enc
|
||||||
|
|
@ -208,7 +187,8 @@
|
||||||
(define cipher-description
|
(define cipher-description
|
||||||
(cond
|
(cond
|
||||||
((assq enc supported-crypto-algorithms) => cadr)
|
((assq enc supported-crypto-algorithms) => cadr)
|
||||||
(else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
(else (disconnect-with-error conn-ds
|
||||||
|
SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
||||||
"Could not find driver for encryption algorithm ~v"
|
"Could not find driver for encryption algorithm ~v"
|
||||||
enc))))
|
enc))))
|
||||||
(define cipher
|
(define cipher
|
||||||
|
|
@ -220,7 +200,8 @@
|
||||||
(define hmac-description
|
(define hmac-description
|
||||||
(cond
|
(cond
|
||||||
((assq mac supported-hmac-algorithms) => cadr)
|
((assq mac supported-hmac-algorithms) => cadr)
|
||||||
(else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
(else (disconnect-with-error conn-ds
|
||||||
|
SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
||||||
"Could not find driver for HMAC algorithm ~v"
|
"Could not find driver for HMAC algorithm ~v"
|
||||||
mac))))
|
mac))))
|
||||||
(define hmac
|
(define hmac
|
||||||
|
|
@ -240,7 +221,7 @@
|
||||||
(mac (bit-string->bytes (bit-string-append (integer->bit-string sequence-number 32 #t)
|
(mac (bit-string->bytes (bit-string-append (integer->bit-string sequence-number 32 #t)
|
||||||
packet))))
|
packet))))
|
||||||
|
|
||||||
(define (check-packet-length! actual-length limit block-size)
|
(define (check-packet-length! conn-ds actual-length limit block-size)
|
||||||
(when (> actual-length limit)
|
(when (> actual-length limit)
|
||||||
(log-warning (format "Packet of length ~v exceeded our limit of ~v"
|
(log-warning (format "Packet of length ~v exceeded our limit of ~v"
|
||||||
actual-length
|
actual-length
|
||||||
|
|
@ -250,7 +231,8 @@
|
||||||
;; exceed the packet size limit! (For example, sending a packet of
|
;; exceed the packet size limit! (For example, sending a packet of
|
||||||
;; length 65564 when I'm expecting a max of 65536.) So we actually
|
;; length 65564 when I'm expecting a max of 65536.) So we actually
|
||||||
;; enforce twice our actual limit.
|
;; enforce twice our actual limit.
|
||||||
(disconnect-with-error 0 ;; TODO: better reason code?
|
(disconnect-with-error conn-ds
|
||||||
|
0 ;; TODO: better reason code?
|
||||||
"Packet of length ~v is longer than packet limit ~v"
|
"Packet of length ~v is longer than packet limit ~v"
|
||||||
actual-length
|
actual-length
|
||||||
limit))
|
limit))
|
||||||
|
|
@ -259,7 +241,8 @@
|
||||||
;; the length-of-length, but the requirements for transmitted
|
;; the length-of-length, but the requirements for transmitted
|
||||||
;; chunks of data are that they be block-size multiples
|
;; chunks of data are that they be block-size multiples
|
||||||
;; *including* the length-of-length
|
;; *including* the length-of-length
|
||||||
(disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
|
(disconnect-with-error conn-ds
|
||||||
|
SSH_DISCONNECT_PROTOCOL_ERROR
|
||||||
"Packet of length ~v is not a multiple of block size ~v"
|
"Packet of length ~v is not a multiple of block size ~v"
|
||||||
actual-length
|
actual-length
|
||||||
block-size)))
|
block-size)))
|
||||||
|
|
@ -279,190 +262,125 @@
|
||||||
;; Encrypted Packet Input
|
;; Encrypted Packet Input
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(struct ssh-reader-state (mode config sequence-number remaining-credit) #:prefab)
|
(define (ssh-reader conn-ds conn update-input-handler)
|
||||||
|
|
||||||
(define (ssh-reader new-conversation)
|
|
||||||
(match-define (tcp-channel remote-addr local-addr _) new-conversation)
|
|
||||||
(define packet-size-limit (default-packet-limit))
|
(define packet-size-limit (default-packet-limit))
|
||||||
|
(define sequence-number 0)
|
||||||
|
(define remaining-credit 0)
|
||||||
|
|
||||||
(define (issue-credit state)
|
(define config initial-crypto-configuration)
|
||||||
(match-define (ssh-reader-state _ (crypto-configuration _ desc _ _) _ message-credit) state)
|
|
||||||
(when (positive? message-credit)
|
|
||||||
(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)
|
(define (current-cipher) (crypto-configuration-cipher config))
|
||||||
(at-meta-level
|
(define (block-size)
|
||||||
(name-endpoint 'socket-reader
|
(supported-cipher-block-size (crypto-configuration-cipher-description config)))
|
||||||
(subscriber (tcp-channel remote-addr local-addr ?)
|
(define (decrypt-chunk chunk) ((or (current-cipher) values) chunk))
|
||||||
(match-state (and state
|
(define (subsequent-block-size) (if (current-cipher) (block-size) 1))
|
||||||
(ssh-reader-state mode
|
(define (hmac) (crypto-configuration-hmac config))
|
||||||
(crypto-configuration cipher
|
|
||||||
cipher-description
|
|
||||||
hmac
|
|
||||||
hmac-description)
|
|
||||||
sequence-number
|
|
||||||
remaining-credit))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel _ _ (? eof-object?))
|
|
||||||
(transition state (quit))]
|
|
||||||
[(tcp-channel _ _ (? bytes? encrypted-packet))
|
|
||||||
(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 (issue-credit)
|
||||||
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
|
(when (positive? remaining-credit)
|
||||||
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
(send-bytes-credit conn (block-size))))
|
||||||
(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 (handle-packet-header encrypted-packet _mode)
|
||||||
(define bytes-read (+ packet-length mac-byte-count))
|
(define first-block (decrypt-chunk encrypted-packet))
|
||||||
(define payload (subbytes packet 5 (+ 5 payload-length)))
|
(define packet-length (integer-bytes->integer first-block #f #t 0 4))
|
||||||
(define new-credit (- remaining-credit 1))
|
(check-packet-length! conn-ds packet-length packet-size-limit (subsequent-block-size))
|
||||||
(define new-state (struct-copy ssh-reader-state state
|
(define padding-length (bytes-ref first-block 4))
|
||||||
[mode 'packet-header]
|
(define payload-length (- packet-length padding-length 1))
|
||||||
[sequence-number (+ sequence-number 1)]
|
(define amount-of-packet-in-first-block (- (bytes-length first-block) 4)) ;; not incl length
|
||||||
[remaining-credit new-credit]))
|
(define remaining-to-read (- packet-length amount-of-packet-in-first-block))
|
||||||
(transition new-state
|
(if (positive? remaining-to-read)
|
||||||
(issue-credit new-state)
|
(begin
|
||||||
(send-message
|
(send-bytes-credit conn remaining-to-read)
|
||||||
(inbound-packet sequence-number
|
(update-input-handler
|
||||||
payload
|
#:on-data (lambda (encrypted-packet _mode)
|
||||||
(ssh-message-decode payload)
|
(check-hmac packet-length
|
||||||
bytes-read))))
|
payload-length
|
||||||
|
(bytes-append first-block (decrypt-chunk encrypted-packet))))))
|
||||||
|
(check-hmac packet-length payload-length first-block)))
|
||||||
|
|
||||||
(match mode
|
(define (check-hmac packet-length payload-length packet)
|
||||||
['packet-header
|
(define computed-hmac-bytes (apply-hmac (hmac) sequence-number packet))
|
||||||
(define decrypted-packet (decryptor encrypted-packet))
|
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
||||||
(define first-block decrypted-packet)
|
(if (positive? mac-byte-count)
|
||||||
(define packet-length (integer-bytes->integer first-block #f #t 0 4))
|
(begin
|
||||||
(check-packet-length! packet-length packet-size-limit subsequent-block-size)
|
(send-bytes-credit conn mac-byte-count)
|
||||||
(define padding-length (bytes-ref first-block 4))
|
(update-input-handler
|
||||||
(define payload-length (- packet-length padding-length 1))
|
#:on-data (lambda (received-hmac-bytes _mode)
|
||||||
(define amount-of-packet-in-first-block
|
(if (equal? computed-hmac-bytes received-hmac-bytes)
|
||||||
(- (bytes-length first-block) 4)) ;; not incl length
|
(finish-packet mac-byte-count packet-length payload-length packet)
|
||||||
(define remaining-to-read (- packet-length amount-of-packet-in-first-block))
|
(disconnect-with-error/local-info conn-ds
|
||||||
|
`((expected-hmac ,computed-hmac-bytes)
|
||||||
|
(actual-hmac ,received-hmac-bytes))
|
||||||
|
SSH_DISCONNECT_MAC_ERROR
|
||||||
|
"Corrupt MAC")))))
|
||||||
|
(finish-packet 0 packet-length payload-length packet)))
|
||||||
|
|
||||||
(if (positive? remaining-to-read)
|
(define (finish-packet mac-byte-count packet-length payload-length packet)
|
||||||
(transition (struct-copy ssh-reader-state state
|
(define bytes-read (+ packet-length mac-byte-count))
|
||||||
[mode `(packet-body ,packet-length
|
(define payload (subbytes packet 5 (+ 5 payload-length)))
|
||||||
,payload-length
|
(update-input-handler #:on-data handle-packet-header)
|
||||||
,first-block)])
|
(send! conn-ds (inbound-packet sequence-number
|
||||||
(at-meta-level
|
payload
|
||||||
(send-feedback (tcp-channel remote-addr local-addr
|
(ssh-message-decode payload)
|
||||||
(tcp-credit remaining-to-read)))))
|
bytes-read))
|
||||||
(check-hmac packet-length payload-length first-block))]
|
(set! sequence-number (+ sequence-number 1))
|
||||||
|
(set! remaining-credit (- remaining-credit 1))
|
||||||
|
(issue-credit))
|
||||||
|
|
||||||
[`(packet-body ,packet-length ,payload-length ,first-block)
|
(update-input-handler
|
||||||
(define decrypted-packet (decryptor encrypted-packet))
|
#:on-eof (lambda () (stop-current-facet))
|
||||||
(check-hmac packet-length payload-length (bytes-append first-block
|
#:on-data handle-packet-header)
|
||||||
decrypted-packet))]
|
|
||||||
|
|
||||||
[`(packet-hmac ,computed-hmac-bytes
|
(at conn-ds
|
||||||
,mac-byte-count
|
(when (message (inbound-credit $amount))
|
||||||
,packet-length
|
(set! remaining-credit (+ remaining-credit amount))
|
||||||
,payload-length
|
(issue-credit))
|
||||||
,main-packet)
|
|
||||||
(define received-hmac-bytes encrypted-packet) ;; not really encrypted!
|
(when (message ($ nk (new-keys _ _ _ _ _ _ _ _)))
|
||||||
(if (equal? computed-hmac-bytes received-hmac-bytes)
|
(set! config (apply-negotiated-options conn-ds nk #f)))))
|
||||||
(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"))]))])))))
|
|
||||||
(subscriber (inbound-credit (wild))
|
|
||||||
(match-state state
|
|
||||||
(on-message
|
|
||||||
[(inbound-credit amount)
|
|
||||||
(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)))])))
|
|
||||||
(subscriber (new-keys (wild)
|
|
||||||
(wild)
|
|
||||||
(wild) (wild)
|
|
||||||
(wild) (wild)
|
|
||||||
(wild) (wild))
|
|
||||||
(match-state state
|
|
||||||
(on-message
|
|
||||||
[(? new-keys? nk)
|
|
||||||
(transition (struct-copy ssh-reader-state state
|
|
||||||
[config (apply-negotiated-options nk #f)]))])))
|
|
||||||
(publisher (inbound-packet (wild) (wild) (wild) (wild)))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Encrypted Packet Output
|
;; Encrypted Packet Output
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(struct ssh-writer-state (config sequence-number) #:prefab)
|
;; (struct ssh-writer-state (config sequence-number) #:prefab)
|
||||||
|
|
||||||
(define (ssh-writer new-conversation)
|
(define (ssh-writer conn-ds conn)
|
||||||
(match-define (tcp-channel remote-addr local-addr _) new-conversation)
|
(define config initial-crypto-configuration)
|
||||||
(transition (ssh-writer-state initial-crypto-configuration 0)
|
(define sequence-number 0)
|
||||||
(publisher (outbound-byte-credit (wild)))
|
|
||||||
(subscriber (outbound-packet (wild))
|
(define (block-size)
|
||||||
(match-state (and state
|
(supported-cipher-block-size (crypto-configuration-cipher-description config)))
|
||||||
(ssh-writer-state (crypto-configuration cipher
|
(define (encrypt-chunk chunk) ((or (crypto-configuration-cipher config) values) chunk))
|
||||||
cipher-description
|
(define (hmac) (crypto-configuration-hmac config))
|
||||||
hmac
|
|
||||||
hmac-description)
|
(at conn-ds
|
||||||
sequence-number))
|
(when (message (outbound-packet $message))
|
||||||
(on-message
|
(define pad-block-size (block-size))
|
||||||
[(outbound-packet message)
|
(define payload (ssh-message-encode message))
|
||||||
(let ()
|
;; There must be at least 4 bytes of padding, and padding needs to
|
||||||
(define pad-block-size (supported-cipher-block-size cipher-description))
|
;; make the packet length a multiple of pad-block-size.
|
||||||
(define encryptor (if cipher cipher values))
|
(define unpadded-length (+ 4 ;; length of length
|
||||||
(define payload (ssh-message-encode message))
|
1 ;; length of length-of-padding indicator
|
||||||
;; There must be at least 4 bytes of padding, and padding needs to
|
(bit-string-byte-count payload)))
|
||||||
;; make the packet length a multiple of pad-block-size.
|
(define min-padded-length (+ unpadded-length 4))
|
||||||
(define unpadded-length (+ 4 ;; length of length
|
(define padded-length (round-up min-padded-length pad-block-size))
|
||||||
1 ;; length of length-of-padding indicator
|
(define padding-length (- padded-length unpadded-length))
|
||||||
(bit-string-byte-count payload)))
|
(define packet-length (- padded-length 4))
|
||||||
(define min-padded-length (+ unpadded-length 4))
|
;; ^^ the packet length does *not* include itself!
|
||||||
(define padded-length (round-up min-padded-length pad-block-size))
|
(define packet (bit-string->bytes
|
||||||
(define padding-length (- padded-length unpadded-length))
|
(bit-string (packet-length :: integer bits 32)
|
||||||
(define packet-length (- padded-length 4))
|
(padding-length :: integer bits 8)
|
||||||
;; ^^ the packet length does *not* include itself!
|
(payload :: binary)
|
||||||
(define packet (bit-string->bytes
|
((crypto-random-bytes padding-length) :: binary))))
|
||||||
(bit-string (packet-length :: integer bits 32)
|
(define encrypted-packet (encrypt-chunk packet))
|
||||||
(padding-length :: integer bits 8)
|
(define computed-hmac-bytes (apply-hmac (hmac) sequence-number packet))
|
||||||
(payload :: binary)
|
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
||||||
((random-bytes padding-length) :: binary))))
|
(send-data conn encrypted-packet)
|
||||||
(define encrypted-packet (encryptor packet))
|
(send-data conn computed-hmac-bytes)
|
||||||
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
|
(send! conn-ds (outbound-byte-credit (+ (bytes-length encrypted-packet)
|
||||||
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
(bytes-length computed-hmac-bytes))))
|
||||||
(transition (struct-copy ssh-writer-state state
|
(set! sequence-number (+ sequence-number 1)))
|
||||||
[sequence-number (+ sequence-number 1)])
|
|
||||||
(at-meta-level
|
(when (message ($ nk (new-keys _ _ _ _ _ _ _ _)))
|
||||||
(send-message (tcp-channel local-addr remote-addr encrypted-packet)))
|
(set! config (apply-negotiated-options conn-ds nk #t)))))
|
||||||
(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)))))])))
|
|
||||||
(subscriber (new-keys (wild)
|
|
||||||
(wild)
|
|
||||||
(wild) (wild)
|
|
||||||
(wild) (wild)
|
|
||||||
(wild) (wild))
|
|
||||||
(match-state state
|
|
||||||
(on-message
|
|
||||||
[(? new-keys? nk)
|
|
||||||
(transition
|
|
||||||
(struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))])))))
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,12 @@
|
||||||
|
-----BEGIN DSA PRIVATE KEY-----
|
||||||
|
MIIBuwIBAAKBgQCEQ1YvOR7/MQByCPJt/FSO7NN7YO1VLqy7A95M07q6AaG5FZ2A
|
||||||
|
m9s8KZPlNFPrNhG8pRxxHhWgfBczoIObZi2saXeXQyTCUtHUejQBk+Xl31I+0SYU
|
||||||
|
/m5fIP3Q9UY3cR8LucsIQkJIcuLVpoMmtFA/EtxYs+roxm+wtMlgk/8HkQIVAObN
|
||||||
|
DEIjvgKwW9MKzRz8VXms/aDDAoGAeMnKQxj/iBSfQ3Wsd4ipCi3PdoLJ0+TJuiFG
|
||||||
|
0tmbxLxwC0YCR24YMeobva/SpSu6y48+2rjv9Wc9ZKwISbrdO6xrNgDJtoCZLGK+
|
||||||
|
C2DHEC3rBYFicOgpoysk/HsS/to3GtMnPyA2NJDR/cjUdgWBRg+4eAx1ZsVPjaJT
|
||||||
|
A5Z60tECgYAkhzk5oi/b3zxPEPoFYki2apR4mciJso/1mYvb6fpd+rzlihNrkFAA
|
||||||
|
LL+6uOofkyf32FIQhEN+JXDNMfaHreJkLPxGXIJ4FyUbrrZcxbmgJdh9NHd0L/mI
|
||||||
|
yIHlo+SImp1DLCEtRP1GwKv8Lm0/rFNpY/z5Os3qeXKw1swDvEMfywIVANtH4mhn
|
||||||
|
F6JfX/4/cJ4cpGlcgrWe
|
||||||
|
-----END DSA PRIVATE KEY-----
|
||||||
|
|
@ -1,138 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
||||||
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
||||||
|
|
||||||
(require "../aes-ctr.rkt")
|
|
||||||
(require rackunit)
|
|
||||||
(require bitsyntax)
|
|
||||||
|
|
||||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
|
||||||
(aes-ctr-process! x #"abcdefghijklmnop"))
|
|
||||||
#"\275XO-\317^<d\16(\262\257Fv}e" ;; = bd584f2dcf5e3c640e28b2af46767d65
|
|
||||||
)
|
|
||||||
|
|
||||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
|
||||||
(let* ((b1 (aes-ctr-process! x #"abcdef"))
|
|
||||||
(b2 (aes-ctr-process! x #"ghijklmnop")))
|
|
||||||
(list b1 b2)))
|
|
||||||
(list #"\275XO-\317^"
|
|
||||||
#"<d\16(\262\257Fv}e"))
|
|
||||||
|
|
||||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
|
||||||
(aes-ctr-process! x #"\275XO-\317^<d\16(\262\257Fv}e"))
|
|
||||||
#"abcdefghijklmnop")
|
|
||||||
|
|
||||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
|
||||||
(let* ((b1 (aes-ctr-process! x #"\275XO-\317^"))
|
|
||||||
(b2 (aes-ctr-process! x #"<d\16(\262\257Fv}e")))
|
|
||||||
(list b1 b2)))
|
|
||||||
(list #"abcdef"
|
|
||||||
#"ghijklmnop"))
|
|
||||||
|
|
||||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
|
||||||
(aes-ctr-process! x #"abcdefghijklmnopabcdefghijklmnop"))
|
|
||||||
#"\275XO-\317^<d\16(\262\257Fv}e!v\301\23\6@\330\305\314c\27\374\276\330 \342")
|
|
||||||
|
|
||||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
|
||||||
(aes-ctr-process! x
|
|
||||||
#"\275XO-\317^<d\16(\262\257Fv}e!v\301\23\6@\330\305\314c\27\374\276\330 \342"))
|
|
||||||
#"abcdefghijklmnopabcdefghijklmnop")
|
|
||||||
|
|
||||||
;; Test vectors from http://tools.ietf.org/html/draft-ietf-ipsec-ciph-aes-ctr-05
|
|
||||||
|
|
||||||
(define (hex-string->bytes str) ;; grumble
|
|
||||||
(define cleaned (regexp-replace* #rx"[^0-9a-fA-F]+" str ""))
|
|
||||||
(define bits (* (string-length cleaned) 4))
|
|
||||||
(define n (string->number cleaned 16))
|
|
||||||
(integer->bit-string n bits #t))
|
|
||||||
|
|
||||||
(define (test-enc description key ivec plaintext ciphertext)
|
|
||||||
(let ((state (start-aes-ctr (hex-string->bytes key)
|
|
||||||
(hex-string->bytes ivec))))
|
|
||||||
(check-equal? (aes-ctr-process! state (hex-string->bytes plaintext))
|
|
||||||
(hex-string->bytes ciphertext)
|
|
||||||
(format "test-enc ~v" description))))
|
|
||||||
|
|
||||||
;; Test Vector #1: Encrypting 16 octets using AES-CTR with 128-bit key
|
|
||||||
(test-enc 1
|
|
||||||
"AE 68 52 F8 12 10 67 CC 4B F7 A5 76 55 77 F3 9E"
|
|
||||||
"00 00 00 30 00 00 00 00 00 00 00 00 00 00 00 01"
|
|
||||||
"53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67"
|
|
||||||
"E4 09 5D 4F B7 A7 B3 79 2D 61 75 A3 26 13 11 B8")
|
|
||||||
|
|
||||||
;; Test Vector #2: Encrypting 32 octets using AES-CTR with 128-bit key
|
|
||||||
(test-enc 2
|
|
||||||
"7E 24 06 78 17 FA E0 D7 43 D6 CE 1F 32 53 91 63"
|
|
||||||
"00 6C B6 DB C0 54 3B 59 DA 48 D9 0B 00 00 00 01"
|
|
||||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
|
||||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F")
|
|
||||||
(string-append "51 04 A1 06 16 8A 72 D9 79 0D 41 EE 8E DA D3 88"
|
|
||||||
"EB 2E 1E FC 46 DA 57 C8 FC E6 30 DF 91 41 BE 28"))
|
|
||||||
|
|
||||||
;; Test Vector #3: Encrypting 36 octets using AES-CTR with 128-bit key
|
|
||||||
(test-enc 3
|
|
||||||
"76 91 BE 03 5E 50 20 A8 AC 6E 61 85 29 F9 A0 DC"
|
|
||||||
"00 E0 01 7B 27 77 7F 3F 4A 17 86 F0 00 00 00 01"
|
|
||||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
|
||||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F"
|
|
||||||
"20 21 22 23")
|
|
||||||
(string-append "C1 CF 48 A8 9F 2F FD D9 CF 46 52 E9 EF DB 72 D7"
|
|
||||||
"45 40 A4 2B DE 6D 78 36 D5 9A 5C EA AE F3 10 53"
|
|
||||||
"25 B2 07 2F"))
|
|
||||||
|
|
||||||
;; Test Vector #4: Encrypting 16 octets using AES-CTR with 192-bit key
|
|
||||||
(test-enc 4
|
|
||||||
"16 AF 5B 14 5F C9 F5 79 C1 75 F9 3E 3B FB 0E ED 86 3D 06 CC FD B7 85 15"
|
|
||||||
"00 00 00 48 36 73 3C 14 7D 6D 93 CB 00 00 00 01"
|
|
||||||
"53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67"
|
|
||||||
"4B 55 38 4F E2 59 C9 C8 4E 79 35 A0 03 CB E9 28")
|
|
||||||
|
|
||||||
;; Test Vector #5: Encrypting 32 octets using AES-CTR with 192-bit key
|
|
||||||
(test-enc 5
|
|
||||||
"7C 5C B2 40 1B 3D C3 3C 19 E7 34 08 19 E0 F6 9C 67 8C 3D B8 E6 F6 A9 1A"
|
|
||||||
"00 96 B0 3B 02 0C 6E AD C2 CB 50 0D 00 00 00 01"
|
|
||||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
|
||||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F")
|
|
||||||
(string-append "45 32 43 FC 60 9B 23 32 7E DF AA FA 71 31 CD 9F"
|
|
||||||
"84 90 70 1C 5A D4 A7 9C FC 1F E0 FF 42 F4 FB 00"))
|
|
||||||
|
|
||||||
;; Test Vector #6: Encrypting 36 octets using AES-CTR with 192-bit key
|
|
||||||
(test-enc 6
|
|
||||||
"02 BF 39 1E E8 EC B1 59 B9 59 61 7B 09 65 27 9B F5 9B 60 A7 86 D3 E0 FE"
|
|
||||||
"00 07 BD FD 5C BD 60 27 8D CC 09 12 00 00 00 01"
|
|
||||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
|
||||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F"
|
|
||||||
"20 21 22 23")
|
|
||||||
(string-append "96 89 3F C5 5E 5C 72 2F 54 0B 7D D1 DD F7 E7 58"
|
|
||||||
"D2 88 BC 95 C6 91 65 88 45 36 C8 11 66 2F 21 88"
|
|
||||||
"AB EE 09 35"))
|
|
||||||
|
|
||||||
;; Test Vector #7: Encrypting 16 octets using AES-CTR with 256-bit key
|
|
||||||
(test-enc 7
|
|
||||||
(string-append "77 6B EF F2 85 1D B0 6F 4C 8A 05 42 C8 69 6F 6C"
|
|
||||||
"6A 81 AF 1E EC 96 B4 D3 7F C1 D6 89 E6 C1 C1 04")
|
|
||||||
"00 00 00 60 DB 56 72 C9 7A A8 F0 B2 00 00 00 01"
|
|
||||||
"53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67"
|
|
||||||
"14 5A D0 1D BF 82 4E C7 56 08 63 DC 71 E3 E0 C0")
|
|
||||||
|
|
||||||
;; Test Vector #8: Encrypting 32 octets using AES-CTR with 256-bit key
|
|
||||||
(test-enc 8
|
|
||||||
(string-append "F6 D6 6D 6B D5 2D 59 BB 07 96 36 58 79 EF F8 86"
|
|
||||||
"C6 6D D5 1A 5B 6A 99 74 4B 50 59 0C 87 A2 38 84")
|
|
||||||
"00 FA AC 24 C1 58 5E F1 5A 43 D8 75 00 00 00 01"
|
|
||||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
|
||||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F")
|
|
||||||
(string-append "F0 5E 23 1B 38 94 61 2C 49 EE 00 0B 80 4E B2 A9"
|
|
||||||
"B8 30 6B 50 8F 83 9D 6A 55 30 83 1D 93 44 AF 1C"))
|
|
||||||
|
|
||||||
;; Test Vector #9: Encrypting 36 octets using AES-CTR with 256-bit key
|
|
||||||
(test-enc 9
|
|
||||||
(string-append "FF 7A 61 7C E6 91 48 E4 F1 72 6E 2F 43 58 1D E2"
|
|
||||||
"AA 62 D9 F8 05 53 2E DF F1 EE D6 87 FB 54 15 3D")
|
|
||||||
"00 1C C5 B7 51 A5 1D 70 A1 C1 11 48 00 00 00 01"
|
|
||||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
|
||||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F"
|
|
||||||
"20 21 22 23")
|
|
||||||
(string-append "EB 6C 52 82 1D 0B BB F7 CE 75 94 46 2A CA 4F AA"
|
|
||||||
"B4 07 DF 86 65 69 FD 07 F4 8C C0 B5 83 D6 07 1F"
|
|
||||||
"1E C0 E6 B8"))
|
|
||||||
Loading…
Reference in New Issue