Add (std net ssh) — full SSH client from chez-ssh architecture split
ober
1f82f30516af6716686f53c0fabc810d26523fa0
--- a/docs/architecture-split.md +++ b/docs/architecture-split.md @@ -66,13 +66,16 @@ These are pure C glue — no logic beyond marshaling: | chez-yaml | Pure parser — no concurrency, no resource management, just string → data | | chez-r7rs | Standards compliance layer — must be stock Chez by definition | -### Should migrate logic to jerboa +### Migrated to jerboa (completed) + +| Library | FFI shim in chez-* | Logic in jerboa | +|---------|-------------------|----------------| +| **chez-ssh** | `(chez-ssh crypto)` — 21 FFI bindings for TCP, SHA-256, HMAC, Curve25519, ChaCha20-Poly1305, AES-256-CTR, Ed25519. `(chez-ssh)` — agent key management FFI | `(std net ssh)` — 10 modules: wire format, transport, kex, auth, channel, session, SFTP, known-hosts, port forwarding, high-level client (3,132 lines) | -These have significant application logic that would benefit from jerboa's stdlib: +### Should migrate logic to jerboa | Library | FFI shim stays in chez-* | Logic moves to jerboa | |---------|-------------------------|----------------------| -| **chez-ssh** | `chez_ssh_shim.c` + `chez_ssh_crypto.c` (Ed25519, key derivation, socket I/O) → stays as `chez-ssh` | SSH session management, SFTP client, channel multiplexing, key management, agent protocol → `(std net ssh)` using actors, custodians, channels, contracts | | **chez-https** | Could stay as-is (it's already pure Scheme over chez-ssl) — but connection pooling, retry, redirect following would benefit from jerboa | HTTP client with connection reuse, redirect following, retry → `(std net http)` using `(std misc pool)`, `(std misc retry)`, error conditions | ### Future libraries: where to put them --- a/docs/index.md +++ b/docs/index.md @@ -28,6 +28,10 @@ Updated 2026-03-22. - [protocols.md](protocols.md) — 9P2000 filesystem protocol, MessagePack serialization - [fiber.md](fiber.md) — Green threads / fibers with M:N scheduling +## Networking + +- `(std net ssh)` — Full SSH client: connect, exec, shell, SFTP, port forwarding (10 modules, 3,132 lines) + ## Language Features - [typing.md](typing.md) — Gradual type system: inference, refinements, GADTs, HKTs --- a/docs/pending.md +++ b/docs/pending.md @@ -4,7 +4,7 @@ Last updated: 2026-03-22. ## Current State -489 modules, ~120K lines, 2,900+ tests, 13 fuzz harnesses. Full Gerbil API surface on stock Chez Scheme. 15 chez-* companion libraries. A complete editor (jerboa-emacs) with TUI + Qt, Org-mode, LSP, Git. +500 modules, ~123K lines, 2,900+ tests, 13 fuzz harnesses. Full Gerbil API surface on stock Chez Scheme. 15 chez-* companion libraries. A complete editor (jerboa-emacs) with TUI + Qt, Org-mode, LSP, Git. --- @@ -27,16 +27,15 @@ Jerboa keeps thin `(std srfi srfi-N)` re-export wrappers for namespace/conflict ### Integrate Remaining chez-* Libraries -Four chez-* libraries are built and tested but not in jerboa's Makefile: +Three chez-* libraries are built and tested but not in jerboa's Makefile: | Library | Integration | |---------|------------| | **chez-qt** | Add to `CHEZ_EXT_LIBDIRS`, create `(std gui qt)` wrapper | -| **chez-ssh** | Add to `CHEZ_EXT_LIBDIRS`, create `(std net ssh)` wrapper | | **chez-scintilla** | Already used by jerboa-emacs; expose via `(std gui scintilla)` | | **chez-r7rs** | Add to library path for `(scheme base)` etc. | -All small — integration and wrappers only. +`chez-ssh` is done — protocol logic split into `(std net ssh ...)` (10 modules, 3,132 lines), FFI stays in `(chez-ssh crypto)`. ### Web Framework new file mode 100644 --- /dev/null +++ b/lib/std/net/ssh.sls @@ -0,0 +1,90 @@ +#!chezscheme +;;; (std net ssh) — SSH client for Jerboa +;;; +;;; Convenience re-export of the SSH client API. +;;; For low-level access, import individual modules: +;;; (std net ssh wire) — wire format primitives +;;; (std net ssh transport) — transport layer +;;; (std net ssh kex) — key exchange +;;; (std net ssh auth) — authentication +;;; (std net ssh channel) — channel multiplexing +;;; (std net ssh session) — exec/shell/pty +;;; (std net ssh sftp) — SFTP file operations +;;; (std net ssh known-hosts) — host key verification +;;; (std net ssh forward) — port forwarding +;;; (std net ssh client) — high-level client API + +(library (std net ssh) + (export + ;; Connection + ssh-connect + ssh-disconnect + ssh-connection? + ssh-connection-transport + ssh-connection-channel-table + + ;; Command execution + ssh-run + ssh-capture + + ;; Interactive + ssh-exec + ssh-shell + + ;; SFTP + ssh-sftp + ssh-sftp-close + ssh-scp-get + ssh-scp-put + ssh-sftp-open + ssh-sftp-close-handle + ssh-sftp-read + ssh-sftp-write + ssh-sftp-stat + ssh-sftp-fstat + ssh-sftp-setstat + ssh-sftp-remove + ssh-sftp-rename + ssh-sftp-mkdir + ssh-sftp-rmdir + ssh-sftp-list-directory + ssh-sftp-realpath + ssh-sftp-get + ssh-sftp-put + make-sftp-attrs + sftp-attrs? + sftp-attrs-size + sftp-attrs-uid + sftp-attrs-gid + sftp-attrs-permissions + sftp-attrs-atime + sftp-attrs-mtime + SSH_FXF_READ + SSH_FXF_WRITE + SSH_FXF_APPEND + SSH_FXF_CREAT + SSH_FXF_TRUNC + SSH_FXF_EXCL + + ;; Port forwarding + ssh-forward-local + ssh-forward-remote + ssh-forward-local-stop + forward-listener? + forward-listener-local-port + forward-listener-remote-host + forward-listener-remote-port + + ;; Host key verification + ssh-known-hosts-verify + ssh-known-hosts-add + ssh-known-hosts-verifier + ssh-host-key-fingerprint + ) + + (import (std net ssh client) + (std net ssh sftp) + (std net ssh forward) + (std net ssh known-hosts)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/net/ssh/auth.sls @@ -0,0 +1,168 @@ +#!chezscheme +;;; (std net ssh auth) — SSH user authentication (RFC 4252) +;;; +;;; Supports: publickey (ed25519), password, keyboard-interactive +;;; +;;; FFI operations imported from (chez-ssh crypto). + +(library (std net ssh auth) + (export + ssh-auth-publickey ;; (ts username seed-bv) → #t or error + ssh-auth-password ;; (ts username password) → #t or error + ssh-auth-interactive ;; (ts username response-callback) → #t or error + ssh-userauth-request ;; request ssh-userauth service + ) + + (import (chezscheme) + (std net ssh wire) + (std net ssh transport) + (chez-ssh crypto)) + + ;; ---- Helpers ---- + + (define (bytevector-append . bvs) + (let* ([total (apply + (map bytevector-length bvs))] + [result (make-bytevector total)]) + (let loop ([bvs bvs] [off 0]) + (unless (null? bvs) + (let ([bv (car bvs)]) + (bytevector-copy! bv 0 result off (bytevector-length bv)) + (loop (cdr bvs) (+ off (bytevector-length bv)))))) + result)) + + ;; ---- Service request ---- + + (define (ssh-userauth-request ts) + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_SERVICE_REQUEST + (ssh-write-string "ssh-userauth"))) + (let ([reply (ssh-transport-recv-packet ts)]) + (unless (= (bytevector-u8-ref reply 0) SSH_MSG_SERVICE_ACCEPT) + (error 'ssh-userauth-request "service request denied" + (bytevector-u8-ref reply 0))) + #t)) + + ;; ---- Public key authentication ---- + + (define (ssh-auth-publickey ts username seed-bv) + (let ([pubkey (make-bytevector 32)]) + (ssh-crypto-ed25519-derive-pubkey seed-bv pubkey) + + (let* ([key-type "ssh-ed25519"] + [pubkey-blob (bytevector-append + (ssh-write-string key-type) + (ssh-write-string pubkey))] + [session-id (transport-state-session-id ts)]) + + (let* ([sig-data (bytevector-append + (ssh-write-string session-id) + (ssh-write-byte SSH_MSG_USERAUTH_REQUEST) + (ssh-write-string username) + (ssh-write-string "ssh-connection") + (ssh-write-string "publickey") + (ssh-write-boolean #t) + (ssh-write-string key-type) + (ssh-write-string pubkey-blob))] + [sig (make-bytevector 64)] + [rc (ssh-crypto-ed25519-sign seed-bv sig-data (bytevector-length sig-data) sig)]) + (when (< rc 0) + (error 'ssh-auth-publickey "signing failed")) + + (let ([sig-blob (bytevector-append + (ssh-write-string key-type) + (ssh-write-string sig))]) + + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_USERAUTH_REQUEST + (ssh-write-string username) + (ssh-write-string "ssh-connection") + (ssh-write-string "publickey") + (ssh-write-boolean #t) + (ssh-write-string key-type) + (ssh-write-string pubkey-blob) + (ssh-write-string sig-blob))) + + (handle-auth-response ts 'publickey)))))) + + ;; ---- Password authentication ---- + + (define (ssh-auth-password ts username password) + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_USERAUTH_REQUEST + (ssh-write-string username) + (ssh-write-string "ssh-connection") + (ssh-write-string "password") + (ssh-write-boolean #f) + (ssh-write-string password))) + (handle-auth-response ts 'password)) + + ;; ---- Keyboard-interactive authentication ---- + + (define (ssh-auth-interactive ts username response-callback) + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_USERAUTH_REQUEST + (ssh-write-string username) + (ssh-write-string "ssh-connection") + (ssh-write-string "keyboard-interactive") + (ssh-write-string "") + (ssh-write-string ""))) + + (let loop () + (let ([reply (ssh-transport-recv-packet ts)]) + (case (bytevector-u8-ref reply 0) + [(52) #t] ;; SSH_MSG_USERAUTH_SUCCESS + [(51) ;; SSH_MSG_USERAUTH_FAILURE + (error 'ssh-auth-interactive "authentication failed")] + [(60) ;; SSH_MSG_USERAUTH_INFO_REQUEST + (let* ([off 1] + [r1 (ssh-read-string reply off)] + [name (utf8->string (car r1))] [off (cdr r1)] + [r2 (ssh-read-string reply off)] + [instruction (utf8->string (car r2))] [off (cdr r2)] + [r3 (ssh-read-string reply off)] + [_lang (car r3)] [off (cdr r3)] + [r4 (ssh-read-uint32 reply off)] + [num-prompts (car r4)] [off (cdr r4)]) + (let prompt-loop ([i 0] [off off] [prompts '()]) + (if (>= i num-prompts) + (let* ([prompts (reverse prompts)] + [responses (response-callback name instruction prompts)]) + (let ([parts (map (lambda (r) (ssh-write-string r)) responses)]) + (ssh-transport-send-packet ts + (apply ssh-make-payload SSH_MSG_USERAUTH_INFO_RESPONSE + (ssh-write-uint32 num-prompts) + parts))) + (loop)) + (let* ([r (ssh-read-string reply off)] + [prompt-text (utf8->string (car r))] [off (cdr r)] + [r2 (ssh-read-boolean reply off)] + [echo? (car r2)] [off (cdr r2)]) + (prompt-loop (+ i 1) off + (cons (cons prompt-text echo?) prompts))))))] + [else + (error 'ssh-auth-interactive "unexpected message" + (bytevector-u8-ref reply 0))])))) + + ;; ---- Response handler ---- + + (define (handle-auth-response ts method) + (let ([reply (ssh-transport-recv-packet ts)]) + (case (bytevector-u8-ref reply 0) + [(52) #t] ;; SSH_MSG_USERAUTH_SUCCESS + [(51) ;; SSH_MSG_USERAUTH_FAILURE + (let* ([off 1] + [r (ssh-read-name-list reply off)] + [methods (car r)]) + (error 'ssh-auth (string-append (symbol->string method) + " authentication failed; try: " + (apply string-append + (let loop ([ms methods] [acc '()]) + (cond + [(null? ms) (reverse acc)] + [(null? (cdr ms)) (reverse (cons (car ms) acc))] + [else (loop (cdr ms) + (cons ", " (cons (car ms) acc)))]))))))] + [else + (error 'ssh-auth "unexpected response" (bytevector-u8-ref reply 0))]))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/net/ssh/channel.sls @@ -0,0 +1,369 @@ +#!chezscheme +;;; (std net ssh channel) — SSH channel multiplexing (RFC 4254) +;;; +;;; Channel open/close, data transfer, window management, +;;; and packet dispatch loop. +;;; Pure protocol logic — no FFI. + +(library (std net ssh channel) + (export + ;; Channel record + make-ssh-channel + ssh-channel? + ssh-channel-local-id + ssh-channel-remote-id + ssh-channel-remote-id-set! + ssh-channel-local-window + ssh-channel-local-window-set! + ssh-channel-remote-window + ssh-channel-remote-window-set! + ssh-channel-remote-max-packet + ssh-channel-remote-max-packet-set! + ssh-channel-data-queue + ssh-channel-data-queue-set! + ssh-channel-stderr-queue + ssh-channel-stderr-queue-set! + ssh-channel-eof? + ssh-channel-eof?-set! + ssh-channel-closed? + ssh-channel-closed?-set! + ssh-channel-exit-status + ssh-channel-exit-status-set! + ssh-channel-exit-signal + ssh-channel-exit-signal-set! + + ;; Channel table (transport-level) + make-channel-table + channel-table-get + channel-table-put! + channel-table-remove! + channel-table-next-id + channel-table-alloc-id + + ;; Channel operations + ssh-channel-open-session + ssh-channel-open-direct-tcpip + ssh-channel-send-data + ssh-channel-send-eof + ssh-channel-close + ssh-channel-read + ssh-channel-read-stderr + + ;; Dispatch + ssh-channel-dispatch + ssh-channel-dispatch-until + ) + + (import (chezscheme) + (std net ssh wire) + (std net ssh transport)) + + ;; ---- Constants ---- + (define INITIAL-WINDOW-SIZE (* 2 1024 1024)) ;; 2 MB + (define MAX-PACKET-SIZE 32768) ;; 32 KB + + ;; ---- Channel record ---- + + (define-record-type ssh-channel + (fields + local-id + (mutable remote-id) + (mutable local-window) + (mutable remote-window) + (mutable remote-max-packet) + (mutable data-queue) + (mutable stderr-queue) + (mutable eof?) + (mutable closed?) + (mutable exit-status) + (mutable exit-signal)) + (protocol + (lambda (new) + (lambda (local-id) + (new local-id #f INITIAL-WINDOW-SIZE 0 0 '() '() #f #f #f #f))))) + + ;; ---- Channel table ---- + + (define-record-type channel-table + (fields + (mutable channels) + (mutable next-id)) + (protocol + (lambda (new) + (lambda () + (new '() 0))))) + + (define (channel-table-get table local-id) + (cond + [(assv local-id (channel-table-channels table)) => cdr] + [else #f])) + + (define (channel-table-put! table channel) + (channel-table-channels-set! table + (cons (cons (ssh-channel-local-id channel) channel) + (channel-table-channels table)))) + + (define (channel-table-remove! table local-id) + (channel-table-channels-set! table + (remp (lambda (p) (= (car p) local-id)) + (channel-table-channels table)))) + + (define (channel-table-alloc-id table) + (let ([id (channel-table-next-id table)]) + (channel-table-next-id-set! table (+ id 1)) + id)) + + ;; ---- Channel open ---- + + (define (ssh-channel-open-session ts table) + (let* ([local-id (channel-table-alloc-id table)] + [ch (make-ssh-channel local-id)]) + (channel-table-put! table ch) + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_CHANNEL_OPEN + (ssh-write-string "session") + (ssh-write-uint32 local-id) + (ssh-write-uint32 INITIAL-WINDOW-SIZE) + (ssh-write-uint32 MAX-PACKET-SIZE))) + (ssh-channel-dispatch-until ts table + (lambda () (or (ssh-channel-remote-id ch) (ssh-channel-closed? ch)))) + (when (ssh-channel-closed? ch) + (error 'ssh-channel-open-session "channel open failed")) + ch)) + + (define (ssh-channel-open-direct-tcpip ts table host port orig-host orig-port) + (let* ([local-id (channel-table-alloc-id table)] + [ch (make-ssh-channel local-id)]) + (channel-table-put! table ch) + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_CHANNEL_OPEN + (ssh-write-string "direct-tcpip") + (ssh-write-uint32 local-id) + (ssh-write-uint32 INITIAL-WINDOW-SIZE) + (ssh-write-uint32 MAX-PACKET-SIZE) + (ssh-write-string host) + (ssh-write-uint32 port) + (ssh-write-string orig-host) + (ssh-write-uint32 orig-port))) + (ssh-channel-dispatch-until ts table + (lambda () (or (ssh-channel-remote-id ch) (ssh-channel-closed? ch)))) + (when (ssh-channel-closed? ch) + (error 'ssh-channel-open-direct-tcpip "channel open failed")) + ch)) + + ;; ---- Channel data ---- + + (define (ssh-channel-send-data ts ch data) + (let ([bv (if (string? data) (string->utf8 data) data)]) + (let loop ([off 0]) + (when (< off (bytevector-length bv)) + (let* ([remaining (- (bytevector-length bv) off)] + [send-size (min remaining + (ssh-channel-remote-max-packet ch) + (ssh-channel-remote-window ch))]) + (when (<= send-size 0) + (error 'ssh-channel-send-data "remote window exhausted")) + (let ([chunk (make-bytevector send-size)]) + (bytevector-copy! bv off chunk 0 send-size) + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_CHANNEL_DATA + (ssh-write-uint32 (ssh-channel-remote-id ch)) + (ssh-write-string chunk))) + (ssh-channel-remote-window-set! ch + (- (ssh-channel-remote-window ch) send-size)) + (loop (+ off send-size)))))))) + + (define (ssh-channel-send-eof ts ch) + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_CHANNEL_EOF + (ssh-write-uint32 (ssh-channel-remote-id ch))))) + + (define (ssh-channel-close ts ch) + (unless (ssh-channel-closed? ch) + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_CHANNEL_CLOSE + (ssh-write-uint32 (ssh-channel-remote-id ch)))) + (ssh-channel-closed?-set! ch #t))) + + ;; ---- Channel read ---- + + (define (ssh-channel-read ts table ch) + (let loop () + (cond + [(pair? (ssh-channel-data-queue ch)) + (let ([data (car (ssh-channel-data-queue ch))]) + (ssh-channel-data-queue-set! ch (cdr (ssh-channel-data-queue ch))) + (let ([adjust (bytevector-length data)]) + (ssh-channel-local-window-set! ch + (+ (ssh-channel-local-window ch) adjust)) + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_CHANNEL_WINDOW_ADJUST + (ssh-write-uint32 (ssh-channel-remote-id ch)) + (ssh-write-uint32 adjust)))) + data)] + [(ssh-channel-eof? ch) #f] + [(ssh-channel-closed? ch) #f] + [else + (ssh-channel-dispatch ts table) + (loop)]))) + + (define (ssh-channel-read-stderr ts table ch) + (let loop () + (cond + [(pair? (ssh-channel-stderr-queue ch)) + (let ([data (car (ssh-channel-stderr-queue ch))]) + (ssh-channel-stderr-queue-set! ch (cdr (ssh-channel-stderr-queue ch))) + data)] + [(ssh-channel-eof? ch) #f] + [(ssh-channel-closed? ch) #f] + [else + (ssh-channel-dispatch ts table) + (loop)]))) + + ;; ---- Dispatch ---- + + (define (find-channel-by-local-id table local-id) + (channel-table-get table local-id)) + + (define (ssh-channel-dispatch ts table) + (let* ([pkt (ssh-transport-recv-packet ts)] + [msg-type (bytevector-u8-ref pkt 0)]) + (case msg-type + [(91) ;; SSH_MSG_CHANNEL_OPEN_CONFIRMATION + (let* ([off 1] + [r1 (ssh-read-uint32 pkt off)] + [local-id (car r1)] [off (cdr r1)] + [r2 (ssh-read-uint32 pkt off)] + [remote-id (car r2)] [off (cdr r2)] + [r3 (ssh-read-uint32 pkt off)] + [remote-window (car r3)] [off (cdr r3)] + [r4 (ssh-read-uint32 pkt off)] + [remote-max-packet (car r4)]) + (let ([ch (find-channel-by-local-id table local-id)]) + (when ch + (ssh-channel-remote-id-set! ch remote-id) + (ssh-channel-remote-window-set! ch remote-window) + (ssh-channel-remote-max-packet-set! ch remote-max-packet))))] + + [(92) ;; SSH_MSG_CHANNEL_OPEN_FAILURE + (let* ([off 1] + [r1 (ssh-read-uint32 pkt off)] + [local-id (car r1)]) + (let ([ch (find-channel-by-local-id table local-id)]) + (when ch + (ssh-channel-closed?-set! ch #t))))] + + [(93) ;; SSH_MSG_CHANNEL_WINDOW_ADJUST + (let* ([off 1] + [r1 (ssh-read-uint32 pkt off)] + [local-id (car r1)] [off (cdr r1)] + [r2 (ssh-read-uint32 pkt off)] + [adjust (car r2)]) + (let ([ch (find-channel-by-local-id table local-id)]) + (when ch + (ssh-channel-remote-window-set! ch + (+ (ssh-channel-remote-window ch) adjust)))))] + + [(94) ;; SSH_MSG_CHANNEL_DATA + (let* ([off 1] + [r1 (ssh-read-uint32 pkt off)] + [local-id (car r1)] [off (cdr r1)] + [r2 (ssh-read-string pkt off)] + [data (car r2)]) + (let ([ch (find-channel-by-local-id table local-id)]) + (when ch + (ssh-channel-data-queue-set! ch + (append (ssh-channel-data-queue ch) (list data))) + (ssh-channel-local-window-set! ch + (- (ssh-channel-local-window ch) (bytevector-length data))))))] + + [(95) ;; SSH_MSG_CHANNEL_EXTENDED_DATA + (let* ([off 1] + [r1 (ssh-read-uint32 pkt off)] + [local-id (car r1)] [off (cdr r1)] + [r2 (ssh-read-uint32 pkt off)] + [data-type (car r2)] [off (cdr r2)] + [r3 (ssh-read-string pkt off)] + [data (car r3)]) + (let ([ch (find-channel-by-local-id table local-id)]) + (when ch + (ssh-channel-stderr-queue-set! ch + (append (ssh-channel-stderr-queue ch) (list data))))))] + + [(96) ;; SSH_MSG_CHANNEL_EOF + (let* ([off 1] + [r1 (ssh-read-uint32 pkt off)] + [local-id (car r1)]) + (let ([ch (find-channel-by-local-id table local-id)]) + (when ch + (ssh-channel-eof?-set! ch #t))))] + + [(97) ;; SSH_MSG_CHANNEL_CLOSE + (let* ([off 1] + [r1 (ssh-read-uint32 pkt off)] + [local-id (car r1)]) + (let ([ch (find-channel-by-local-id table local-id)]) + (when ch + (ssh-channel-closed?-set! ch #t) + (unless (ssh-channel-eof? ch) + (ssh-channel-eof?-set! ch #t)))))] + + [(98) ;; SSH_MSG_CHANNEL_REQUEST + (let* ([off 1] + [r1 (ssh-read-uint32 pkt off)] + [local-id (car r1)] [off (cdr r1)] + [r2 (ssh-read-string pkt off)] + [req-type (utf8->string (car r2))] [off (cdr r2)] + [r3 (ssh-read-boolean pkt off)] + [want-reply (car r3)] [off (cdr r3)]) + (let ([ch (find-channel-by-local-id table local-id)]) + (when ch + (cond + [(string=? req-type "exit-status") + (let ([r (ssh-read-uint32 pkt off)]) + (ssh-channel-exit-status-set! ch (car r)))] + [(string=? req-type "exit-signal") + (let* ([r (ssh-read-string pkt off)] + [signal-name (utf8->string (car r))]) + (ssh-channel-exit-signal-set! ch signal-name))] + [else (void)]) + (when want-reply + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_CHANNEL_FAILURE + (ssh-write-uint32 (ssh-channel-remote-id ch))))))))] + + [(99) ;; SSH_MSG_CHANNEL_SUCCESS + (void)] + + [(100) ;; SSH_MSG_CHANNEL_FAILURE + (void)] + + [(80) ;; SSH_MSG_GLOBAL_REQUEST + (let* ([off 1] + [r1 (ssh-read-string pkt off)] + [_req-name (car r1)] [off (cdr r1)] + [r2 (ssh-read-boolean pkt off)] + [want-reply (car r2)]) + (when want-reply + (ssh-transport-send-packet ts + (ssh-make-payload SSH_MSG_REQUEST_FAILURE))))] + + [(2) ;; SSH_MSG_IGNORE + (void)] + + [(4) ;; SSH_MSG_DEBUG + (void)] + + [(1) ;; SSH_MSG_DISCONNECT + (error 'ssh-channel-dispatch "server disconnected")] + + [else + (void)]))) + + (define (ssh-channel-dispatch-until ts table pred) + (let loop () + (unless (pred) + (ssh-channel-dispatch ts table) + (loop)))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/net/ssh/client.sls @@ -0,0 +1,341 @@ +#!chezscheme +;;; (std net ssh client) — High-level SSH client API +;;; +;;; Provides ssh-connect, ssh-run, ssh-shell, ssh-sftp, ssh-forward-* +;;; as the primary user-facing interface. +;;; Pure protocol logic — all FFI goes through (chez-ssh crypto). + +(library (std net ssh client) + (export + ;; Connection + ssh-connect ;; (host #:port #:user #:key-file #:password ...) → ssh-connection + ssh-disconnect ;; (conn) → void + + ;; Connection record accessors + ssh-connection? + ssh-connection-transport + ssh-connection-channel-table + + ;; Command execution + ssh-run ;; (conn command) → (exit-status . output) + ssh-capture ;; (conn command) → output-string (errors on non-zero exit) + + ;; Interactive shell + ssh-shell ;; (conn) → channel + ssh-exec ;; (conn command) → channel + + ;; SFTP + ssh-sftp ;; (conn) → sftp-session + ssh-sftp-close ;; (conn sftp) → void + ssh-scp-get ;; (conn remote local) → void + ssh-scp-put ;; (conn local remote) → void + + ;; Port forwarding + ssh-forward-local ;; (conn local-port remote-host remote-port ...) → listener + ssh-forward-remote ;; (conn remote-port ...) → allocated-port + ) + + (import (chezscheme) + (std net ssh wire) + (std net ssh transport) + (std net ssh kex) + (std net ssh known-hosts) + (std net ssh auth) + (std net ssh channel) + (std net ssh session) + (std net ssh sftp) + (std net ssh forward)) + + ;; ---- Connection record ---- + + (define-record-type ssh-connection + (fields + transport + channel-table + host + port + user)) + + ;; ---- Connect ---- + + (define ssh-connect + (case-lambda + [(host) + (ssh-connect host 22 (or (getenv "USER") "root") #f #f)] + [(host port) + (ssh-connect host port (or (getenv "USER") "root") #f #f)] + [(host port user) + (ssh-connect host port user #f #f)] + [(host port user key-file) + (ssh-connect host port user key-file #f)] + [(host port user key-file password) + (ssh-connect-internal host port user key-file password)])) + + (define (ssh-connect-internal host port user key-file password) + (let ([fd (ssh-transport-connect host port)]) + + (let* ([client-ver (ssh-transport-send-version fd)] + [server-ver (ssh-transport-recv-version fd)] + [ts (make-transport-state fd server-ver client-ver)] + [table (make-channel-table)]) + + (let ([verifier (ssh-known-hosts-verifier host port)]) + (ssh-kex-perform ts verifier)) + + (ssh-userauth-request ts) + + (cond + [key-file + (let ([seed (load-ed25519-seed key-file)]) + (if seed + (ssh-auth-publickey ts user seed) + (if password + (ssh-auth-password ts user password) + (error 'ssh-connect "failed to load key file" key-file))))] + [(find-default-key) + => (lambda (seed) + (ssh-auth-publickey ts user seed))] + [password + (ssh-auth-password ts user password)] + [else + (error 'ssh-connect + "no authentication method available (no key file or password)")]) + + (make-ssh-connection ts table host port user)))) + + ;; ---- Key loading ---- + + (define (load-ed25519-seed path) + (guard (e [#t #f]) + (let* ([expanded (if (and (> (string-length path) 0) + (char=? (string-ref path 0) #\~)) + (string-append (or (getenv "HOME") "") + (substring path 1 (string-length path))) + path)] + [port (open-file-input-port expanded)] + [data (get-bytevector-all port)]) + (close-port port) + (if (eof-object? data) + #f + (parse-openssh-ed25519-seed data))))) + + (define (parse-openssh-ed25519-seed data) + (let ([text (if (bytevector? data) (utf8->string data) data)]) + (let* ([begin-marker "-----BEGIN OPENSSH PRIVATE KEY-----"] + [end-marker "-----END OPENSSH PRIVATE KEY-----"] + [begin-pos (string-search text begin-marker)] + [end-pos (and begin-pos (string-search text end-marker))]) + (if (not (and begin-pos end-pos)) + #f + (let* ([b64-start (+ begin-pos (string-length begin-marker))] + [b64-text (substring text b64-start end-pos)] + [b64-clean (list->string + (filter (lambda (c) (not (char-whitespace? c))) + (string->list b64-text)))] + [decoded (base64-decode-simple b64-clean)]) + (extract-ed25519-seed-from-decoded decoded)))))) + + (define (string-search haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) i] + [else (loop (+ i 1))])))) + + (define (extract-ed25519-seed-from-decoded bv) + (guard (e [#t #f]) + (let loop ([off 0]) + (let ([magic "openssh-key-v1"]) + (when (< (bytevector-length bv) 15) (error 'parse "too short")) + (let ([off 15]) + (let* ([r (read-ssh-string bv off)] [cipher (car r)] [off (cdr r)]) + (when (not (string=? (utf8->string cipher) "none")) + (error 'parse "encrypted key")) + (let* ([r (read-ssh-string bv off)] [off (cdr r)]) + (let* ([r (read-ssh-string bv off)] [off (cdr r)]) + (let* ([r (read-uint32 bv off)] [nkeys (car r)] [off (cdr r)]) + (let* ([r (read-ssh-string bv off)] [off (cdr r)]) + (let* ([r (read-ssh-string bv off)] + [priv-blob (car r)]) + (let* ([off 0] + [r (read-uint32 priv-blob off)] [off (cdr r)] + [r (read-uint32 priv-blob off)] [off (cdr r)] + [r (read-ssh-string priv-blob off)] + [kt (utf8->string (car r))] [off (cdr r)]) + (unless (string=? kt "ssh-ed25519") + (error 'parse "not ed25519")) + (let* ([r (read-ssh-string priv-blob off)] [off (cdr r)]) + (let* ([r (read-ssh-string priv-blob off)] + [privkey (car r)]) + (when (< (bytevector-length privkey) 32) + (error 'parse "privkey too short")) + (let ([seed (make-bytevector 32)]) + (bytevector-copy! privkey 0 seed 0 32) + seed))))))))))))))) + + (define (read-uint32 bv off) + (cons (bitwise-ior + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv off) 24) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ off 1)) 16) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ off 2)) 8) + (bytevector-u8-ref bv (+ off 3))) + (+ off 4))) + + (define (read-ssh-string bv off) + (let* ([r (read-uint32 bv off)] + [len (car r)] + [off (cdr r)] + [data (make-bytevector len)]) + (bytevector-copy! bv off data 0 len) + (cons data (+ off len)))) + + (define (base64-decode-simple s) + (let ([table (make-vector 128 -1)] + [chars "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"]) + (do ([i 0 (+ i 1)]) + ((>= i 64)) + (vector-set! table (char->integer (string-ref chars i)) i)) + (let ([vals (let loop ([i 0] [acc '()]) + (if (>= i (string-length s)) + (reverse acc) + (let ([c (string-ref s i)]) + (if (char=? c #\=) + (reverse acc) + (let ([v (and (< (char->integer c) 128) + (vector-ref table (char->integer c)))]) + (if (and v (>= v 0)) + (loop (+ i 1) (cons v acc)) + (loop (+ i 1) acc)))))))]) + (let* ([nvals (length vals)] + [nbytes (- (quotient (* nvals 3) 4) + (cond [(= (modulo nvals 4) 2) 1] + [(= (modulo nvals 4) 3) 0] + [else 0]))]) + (let loop ([vs vals] [acc '()]) + (cond + [(null? vs) + (u8-list->bytevector (reverse acc))] + [(>= (length vs) 4) + (let ([a (car vs)] [b (cadr vs)] [c (caddr vs)] [d (cadddr vs)]) + (loop (cddddr vs) + (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left c 6) d)) + (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left b 4) + (bitwise-arithmetic-shift-right c 2))) + (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left a 2) + (bitwise-arithmetic-shift-right b 4))) + acc)))))] + [(= (length vs) 3) + (let ([a (car vs)] [b (cadr vs)] [c (caddr vs)]) + (let ([acc (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left b 4) + (bitwise-arithmetic-shift-right c 2))) + (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left a 2) + (bitwise-arithmetic-shift-right b 4))) + acc))]) + (u8-list->bytevector (reverse acc))))] + [(= (length vs) 2) + (let ([a (car vs)] [b (cadr vs)]) + (let ([acc (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left a 2) + (bitwise-arithmetic-shift-right b 4))) + acc)]) + (u8-list->bytevector (reverse acc))))] + [else + (u8-list->bytevector (reverse acc))])))))) + + (define (find-default-key) + (let ([home (or (getenv "HOME") "")]) + (let loop ([files (list + (string-append home "/.ssh/id_ed25519"))]) + (cond + [(null? files) #f] + [(file-exists? (car files)) + (load-ed25519-seed (car files))] + [else (loop (cdr files))])))) + + ;; ---- Disconnect ---- + + (define (ssh-disconnect conn) + (guard (e [#t (void)]) + (ssh-transport-send-packet (ssh-connection-transport conn) + (ssh-make-payload SSH_MSG_DISCONNECT + (ssh-write-uint32 SSH_DISCONNECT_BY_APPLICATION) + (ssh-write-string "bye") + (ssh-write-string "")))) + (ssh-transport-close (ssh-connection-transport conn))) + + ;; ---- Command execution ---- + + (define (ssh-run conn command) + (ssh-session-exec-simple + (ssh-connection-transport conn) + (ssh-connection-channel-table conn) + command)) + + (define (ssh-capture conn command) + (let ([result (ssh-run conn command)]) + (unless (= (car result) 0) + (error 'ssh-capture + (string-append "command failed with exit status " + (number->string (car result))) + command)) + (cdr result))) + + ;; ---- Interactive ---- + + (define (ssh-shell conn) + (ssh-session-shell + (ssh-connection-transport conn) + (ssh-connection-channel-table conn))) + + (define (ssh-exec conn command) + (ssh-session-exec + (ssh-connection-transport conn) + (ssh-connection-channel-table conn) + command)) + + ;; ---- SFTP ---- + + (define (ssh-sftp conn) + (ssh-sftp-open-session + (ssh-connection-transport conn) + (ssh-connection-channel-table conn)))