Integrate 9 jerboa stdlib features into SSH modules
ober
f4e836bab5539cb1e748d80a5ec87316f57671bd
--- a/lib/std/net/ssh.sls +++ b/lib/std/net/ssh.sls @@ -13,6 +13,7 @@ ;;; (std net ssh known-hosts) — host key verification ;;; (std net ssh forward) — port forwarding ;;; (std net ssh client) — high-level client API +;;; (std net ssh conditions) — SSH error condition hierarchy (library (std net ssh) (export @@ -22,6 +23,7 @@ ssh-connection? ssh-connection-transport ssh-connection-channel-table + ssh-connection-state ;; Command execution ssh-run @@ -80,11 +82,38 @@ ssh-known-hosts-add ssh-known-hosts-verifier ssh-host-key-fingerprint + + ;; Custodian integration + with-ssh-connection + ssh-connection-custodian + + ;; Connection pooling + make-ssh-pool + with-pooled-ssh + ssh-pool-drain + ssh-pool-stats + + ;; Error conditions (re-exported for callers to catch) + &ssh-error ssh-error? ssh-error-operation + &ssh-connection-error ssh-connection-error? + &ssh-auth-error ssh-auth-error? + &ssh-kex-error ssh-kex-error? + &ssh-protocol-error ssh-protocol-error? + &ssh-host-key-error ssh-host-key-error? + &ssh-channel-error ssh-channel-error? + &ssh-sftp-error ssh-sftp-error? + &ssh-timeout-error ssh-timeout-error? + + ;; Channel events (for composable async patterns) + ssh-channel-data-event + ssh-channel-stderr-event ) (import (std net ssh client) (std net ssh sftp) (std net ssh forward) - (std net ssh known-hosts)) + (std net ssh known-hosts) + (std net ssh conditions) + (std net ssh channel)) ) ;; end library --- a/lib/std/net/ssh/auth.sls +++ b/lib/std/net/ssh/auth.sls @@ -4,6 +4,7 @@ ;;; Supports: publickey (ed25519), password, keyboard-interactive ;;; ;;; FFI operations imported from (chez-ssh crypto). +;;; Uses (std net ssh conditions) for structured error hierarchy. (library (std net ssh auth) (export @@ -16,6 +17,7 @@ (import (chezscheme) (std net ssh wire) (std net ssh transport) + (std net ssh conditions) (chez-ssh crypto)) ;; ---- Helpers ---- @@ -38,8 +40,8 @@ (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))) + (raise-ssh-auth-error 'ssh-userauth-request 'none '() + "ssh-userauth service request denied")) #t)) ;; ---- Public key authentication ---- @@ -66,7 +68,8 @@ [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")) + (raise-ssh-auth-error 'ssh-auth-publickey 'publickey '() + "Ed25519 signing failed")) (let ([sig-blob (bytevector-append (ssh-write-string key-type) @@ -112,7 +115,8 @@ (case (bytevector-u8-ref reply 0) [(52) #t] ;; SSH_MSG_USERAUTH_SUCCESS [(51) ;; SSH_MSG_USERAUTH_FAILURE - (error 'ssh-auth-interactive "authentication failed")] + (raise-ssh-auth-error 'ssh-auth-interactive 'keyboard-interactive '() + "keyboard-interactive authentication failed")] [(60) ;; SSH_MSG_USERAUTH_INFO_REQUEST (let* ([off 1] [r1 (ssh-read-string reply off)] @@ -140,8 +144,9 @@ (prompt-loop (+ i 1) off (cons (cons prompt-text echo?) prompts))))))] [else - (error 'ssh-auth-interactive "unexpected message" - (bytevector-u8-ref reply 0))])))) + (raise-ssh-protocol-error 'ssh-auth-interactive + "userauth response" (bytevector-u8-ref reply 0) + "unexpected message during keyboard-interactive auth")])))) ;; ---- Response handler ---- @@ -153,16 +158,11 @@ (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)))]))))))] + (raise-ssh-auth-error 'ssh-auth method methods + (string-append (symbol->string method) " authentication failed")))] [else - (error 'ssh-auth "unexpected response" (bytevector-u8-ref reply 0))]))) + (raise-ssh-protocol-error 'ssh-auth + "success or failure" (bytevector-u8-ref reply 0) + "unexpected auth response")]))) ) ;; end library --- a/lib/std/net/ssh/channel.sls +++ b/lib/std/net/ssh/channel.sls @@ -4,6 +4,9 @@ ;;; Channel open/close, data transfer, window management, ;;; and packet dispatch loop. ;;; Pure protocol logic — no FFI. +;;; +;;; Uses (std net ssh conditions) for structured error hierarchy. +;;; Uses (std misc event) for composable channel data events. (library (std net ssh channel) (export @@ -52,11 +55,17 @@ ;; Dispatch ssh-channel-dispatch ssh-channel-dispatch-until + + ;; Event integration — composable channel data events + ssh-channel-data-event + ssh-channel-stderr-event ) (import (chezscheme) (std net ssh wire) - (std net ssh transport)) + (std net ssh transport) + (std net ssh conditions) + (std misc event)) ;; ---- Constants ---- (define INITIAL-WINDOW-SIZE (* 2 1024 1024)) ;; 2 MB @@ -128,7 +137,8 @@ (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")) + (raise-ssh-channel-error 'ssh-channel-open-session local-id + "session channel open failed")) ch)) (define (ssh-channel-open-direct-tcpip ts table host port orig-host orig-port) @@ -148,7 +158,8 @@ (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")) + (raise-ssh-channel-error 'ssh-channel-open-direct-tcpip local-id + "direct-tcpip channel open failed")) ch)) ;; ---- Channel data ---- @@ -162,7 +173,9 @@ (ssh-channel-remote-max-packet ch) (ssh-channel-remote-window ch))]) (when (<= send-size 0) - (error 'ssh-channel-send-data "remote window exhausted")) + (raise-ssh-channel-error 'ssh-channel-send-data + (ssh-channel-local-id ch) + "remote window exhausted")) (let ([chunk (make-bytevector send-size)]) (bytevector-copy! bv off chunk 0 send-size) (ssh-transport-send-packet ts @@ -220,6 +233,36 @@ (ssh-channel-dispatch ts table) (loop)]))) + ;; ---- Event integration ---- + ;; These create composable events for non-blocking channel data polling. + ;; Use with (sync (choice (ssh-channel-data-event ch) (timer-event 5000))) + ;; to wait for data with a timeout. + ;; + ;; Note: events only fire on already-buffered data. The caller must ensure + ;; data is being pumped into the queue via ssh-channel-dispatch. + + (define (ssh-channel-data-event ch) + (make-event + (lambda () + (cond + [(pair? (ssh-channel-data-queue ch)) + (values #t (car (ssh-channel-data-queue ch)))] + [(or (ssh-channel-eof? ch) (ssh-channel-closed? ch)) + (values #t #f)] + [else + (values #f #f)])))) + + (define (ssh-channel-stderr-event ch) + (make-event + (lambda () + (cond + [(pair? (ssh-channel-stderr-queue ch)) + (values #t (car (ssh-channel-stderr-queue ch)))] + [(or (ssh-channel-eof? ch) (ssh-channel-closed? ch)) + (values #t #f)] + [else + (values #f #f)])))) + ;; ---- Dispatch ---- (define (find-channel-by-local-id table local-id) @@ -355,7 +398,7 @@ (void)] [(1) ;; SSH_MSG_DISCONNECT - (error 'ssh-channel-dispatch "server disconnected")] + (raise-ssh-error 'ssh-channel-dispatch "server sent disconnect")] [else (void)]))) --- a/lib/std/net/ssh/client.sls +++ b/lib/std/net/ssh/client.sls @@ -3,7 +3,13 @@ ;;; ;;; 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). +;;; +;;; Uses (std net ssh conditions) for structured error hierarchy. +;;; Uses (std misc custodian) for automatic connection cleanup. +;;; Uses (std misc retry) for exponential backoff on connection failure. +;;; Uses (std misc pool) for SSH connection pooling. +;;; Uses (std contract) for argument validation on public API. +;;; Uses (std misc state-machine) for connection lifecycle management. (library (std net ssh client) (export @@ -15,6 +21,7 @@ ssh-connection? ssh-connection-transport ssh-connection-channel-table + ssh-connection-state ;; → symbol: 'connecting | 'authenticating | 'established | 'disconnected ;; Command execution ssh-run ;; (conn command) → (exit-status . output) @@ -33,6 +40,16 @@ ;; Port forwarding ssh-forward-local ;; (conn local-port remote-host remote-port ...) → listener ssh-forward-remote ;; (conn remote-port ...) → allocated-port + + ;; Custodian integration + with-ssh-connection ;; (host port user key-file password thunk) → result + ssh-connection-custodian ;; (conn) → custodian + + ;; Connection pooling + make-ssh-pool ;; (host port user key-file password max-size) → pool + with-pooled-ssh ;; (pool thunk) → result + ssh-pool-drain ;; (pool) → void + ssh-pool-stats ;; (pool) → alist ) (import (chezscheme) @@ -44,7 +61,26 @@ (std net ssh channel) (std net ssh session) (std net ssh sftp) - (std net ssh forward)) + (std net ssh forward) + (std net ssh conditions) + (std misc custodian) + (std misc retry) + (std misc pool) + (std contract) + (std misc state-machine) + (chez-ssh crypto)) + + ;; ---- Connection lifecycle state machine ---- + ;; Tracks the connection through its phases to prevent invalid operations. + (define (make-connection-sm) + (make-state-machine 'idle + `((idle connect connecting ,void) + (connecting kex-done authenticating ,void) + (authenticating auth-done established ,void) + (established disconnect disconnected ,void) + (connecting error disconnected ,void) + (authenticating error disconnected ,void) + (established error disconnected ,void)))) ;; ---- Connection record ---- @@ -54,7 +90,12 @@ channel-table host port - user)) + user + sm ;; state-machine: lifecycle tracking + cust)) ;; custodian or #f + + (define (ssh-connection-state conn) + (sm-state (ssh-connection-sm conn))) ;; ---- Connect ---- @@ -69,39 +110,58 @@ [(host port user key-file) (ssh-connect host port user key-file #f)] [(host port user key-file password) + (check-argument string? host 'ssh-connect) + (check-argument integer? port 'ssh-connect) + (check-argument string? user 'ssh-connect) (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)))) + (let ([sm (make-connection-sm)] + [cust (make-custodian)]) + (sm-send! sm 'connect) + + ;; Use retry with exponential backoff for TCP connection. + ;; Retries 3 times with 1s base delay, 10s max delay on connection failure. + (let ([fd (retry/backoff + (lambda () (ssh-transport-connect host port)) + (make-retry-policy 3 1.0 10.0))]) + + ;; Register fd cleanup with custodian — thunk captures fd in closure + (custodian-register! cust fd + (lambda () (guard (e [#t (void)]) (ssh-crypto-tcp-close fd)))) + + (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)) + (sm-send! sm 'kex-done) + + (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) + (raise-ssh-auth-error 'ssh-connect 'publickey '() + (string-append "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 + (raise-ssh-auth-error 'ssh-connect 'none + '("publickey" "password") + "no authentication method available (no key file or password)")]) + (sm-send! sm 'auth-done) + + (make-ssh-connection ts table host port user sm cust))))) ;; ---- Key loading ---- @@ -256,39 +316,93 @@ ;; ---- 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))) + (when (eq? (ssh-connection-state conn) 'established) + (sm-send! (ssh-connection-sm conn) 'disconnect) + (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)) + ;; Shut down the custodian to clean up any registered resources + (when (ssh-connection-cust conn) + (custodian-shutdown-all (ssh-connection-cust conn))))) + + ;; ---- Custodian integration ---- + ;; Ensures all SSH resources are cleaned up even on exceptions. + + (define (ssh-connection-custodian conn) + (ssh-connection-cust conn)) + + (define (with-ssh-connection host port user key-file password thunk) + (let ([conn (ssh-connect host port user key-file password)]) + (dynamic-wind + (lambda () (void)) + (lambda () (thunk conn)) + (lambda () (ssh-disconnect conn))))) + + ;; ---- Connection pooling ---- + ;; Reuses SSH connections across multiple operations. + ;; Pool manages connect/disconnect lifecycle automatically. + + (define make-ssh-pool + (case-lambda + [(host port user key-file password max-size) + (make-ssh-pool host port user key-file password max-size #f)] + [(host port user key-file password max-size idle-timeout) + (make-pool + ;; creator: establish a new SSH connection + (lambda () + (ssh-connect host port user key-file password)) + ;; destroyer: disconnect cleanly + (lambda (conn) + (guard (e [#t (void)]) + (ssh-disconnect conn))) + max-size + idle-timeout)])) + + (define (with-pooled-ssh pool thunk) + (with-resource pool thunk)) + + (define (ssh-pool-drain pool) + (pool-drain pool)) + + (define (ssh-pool-stats pool) + (pool-stats pool)) ;; ---- Command execution ---- (define (ssh-run conn command) + (check-argument ssh-connection? conn 'ssh-run) + (check-argument string? command 'ssh-run) (ssh-session-exec-simple (ssh-connection-transport conn) (ssh-connection-channel-table conn) command)) (define (ssh-capture conn command) + (check-argument ssh-connection? conn 'ssh-capture) + (check-argument string? command 'ssh-capture) (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)) + (raise-ssh-error 'ssh-capture + (string-append "command failed with exit status " + (number->string (car result))) + command)) (cdr result))) ;; ---- Interactive ---- (define (ssh-shell conn) + (check-argument ssh-connection? conn 'ssh-shell) (ssh-session-shell (ssh-connection-transport conn) (ssh-connection-channel-table conn))) (define (ssh-exec conn command) + (check-argument ssh-connection? conn 'ssh-exec) + (check-argument string? command 'ssh-exec) (ssh-session-exec (ssh-connection-transport conn) (ssh-connection-channel-table conn) @@ -297,22 +411,30 @@ ;; ---- SFTP ---- (define (ssh-sftp conn) + (check-argument ssh-connection? conn 'ssh-sftp) (ssh-sftp-open-session (ssh-connection-transport conn) (ssh-connection-channel-table conn))) (define (ssh-sftp-close conn sftp) + (check-argument ssh-connection? conn 'ssh-sftp-close) (ssh-sftp-close-session (ssh-connection-transport conn) (ssh-connection-channel-table conn) sftp)) (define (ssh-scp-get conn remote-path local-path) + (check-argument ssh-connection? conn 'ssh-scp-get) + (check-argument string? remote-path 'ssh-scp-get) + (check-argument string? local-path 'ssh-scp-get) (let ([sftp (ssh-sftp conn)]) (ssh-sftp-get sftp remote-path local-path) (ssh-sftp-close conn sftp))) (define (ssh-scp-put conn local-path remote-path) + (check-argument ssh-connection? conn 'ssh-scp-put) + (check-argument string? local-path 'ssh-scp-put) + (check-argument string? remote-path 'ssh-scp-put) (let ([sftp (ssh-sftp conn)]) (ssh-sftp-put sftp local-path remote-path) (ssh-sftp-close conn sftp))) @@ -324,6 +446,7 @@ [(conn local-port remote-host remote-port) (ssh-forward-local conn "127.0.0.1" local-port remote-host remote-port)] [(conn bind-addr local-port remote-host remote-port) + (check-argument ssh-connection? conn 'ssh-forward-local) (ssh-forward-local-start (ssh-connection-transport conn) (ssh-connection-channel-table conn) @@ -334,6 +457,7 @@ [(conn remote-port) (ssh-forward-remote conn "" remote-port)] [(conn bind-addr remote-port) + (check-argument ssh-connection? conn 'ssh-forward-remote) (ssh-forward-remote-request (ssh-connection-transport conn) bind-addr remote-port)])) new file mode 100644 --- /dev/null +++ b/lib/std/net/ssh/conditions.sls @@ -0,0 +1,185 @@ +#!chezscheme +;;; (std net ssh conditions) — SSH-specific error condition types +;;; +;;; Structured error hierarchy for SSH protocol errors, +;;; built on (std error conditions). + +(library (std net ssh conditions) + (export + ;; Base SSH condition + &ssh-error + make-ssh-error + ssh-error? + ssh-error-operation + + ;; Connection errors + &ssh-connection-error + make-ssh-connection-error + ssh-connection-error? + ssh-connection-error-host + ssh-connection-error-port + + ;; Authentication errors + &ssh-auth-error + make-ssh-auth-error + ssh-auth-error? + ssh-auth-error-method + ssh-auth-error-available-methods + + ;; Key exchange errors + &ssh-kex-error + make-ssh-kex-error + ssh-kex-error? + ssh-kex-error-phase + + ;; Protocol errors (unexpected messages, invalid packets) + &ssh-protocol-error + make-ssh-protocol-error + ssh-protocol-error? + ssh-protocol-error-expected + ssh-protocol-error-received + + ;; Host key errors + &ssh-host-key-error + make-ssh-host-key-error + ssh-host-key-error? + ssh-host-key-error-reason + ssh-host-key-error-fingerprint + + ;; Channel errors + &ssh-channel-error + make-ssh-channel-error + ssh-channel-error? + ssh-channel-error-channel-id + + ;; SFTP errors + &ssh-sftp-error + make-ssh-sftp-error + ssh-sftp-error? + ssh-sftp-error-code + ssh-sftp-error-path + + ;; Timeout errors + &ssh-timeout-error + make-ssh-timeout-error + ssh-timeout-error? + ssh-timeout-error-seconds + + ;; Convenience raisers + raise-ssh-error + raise-ssh-connection-error + raise-ssh-auth-error + raise-ssh-kex-error + raise-ssh-protocol-error + raise-ssh-host-key-error + raise-ssh-channel-error + raise-ssh-sftp-error + raise-ssh-timeout-error + ) + + (import (chezscheme)) + + ;; ---- Base SSH condition ---- + (define-condition-type &ssh-error &serious + make-ssh-error ssh-error? + (operation ssh-error-operation)) ;; symbol: which operation failed + + ;; ---- Connection errors ---- + (define-condition-type &ssh-connection-error &ssh-error + make-ssh-connection-error ssh-connection-error? + (host ssh-connection-error-host) ;; string + (port ssh-connection-error-port)) ;; integer + + ;; ---- Authentication errors ---- + (define-condition-type &ssh-auth-error &ssh-error + make-ssh-auth-error ssh-auth-error? + (method ssh-auth-error-method) ;; symbol: 'publickey, 'password, etc. + (available-methods ssh-auth-error-available-methods)) ;; list of strings + + ;; ---- Key exchange errors ---- + (define-condition-type &ssh-kex-error &ssh-error + make-ssh-kex-error ssh-kex-error? + (phase ssh-kex-error-phase)) ;; symbol: 'negotiate, 'ecdh, 'verify, etc. + + ;; ---- Protocol errors ---- + (define-condition-type &ssh-protocol-error &ssh-error + make-ssh-protocol-error ssh-protocol-error? + (expected ssh-protocol-error-expected) ;; what we expected + (received ssh-protocol-error-received)) ;; what we got + + ;; ---- Host key errors ---- + (define-condition-type &ssh-host-key-error &ssh-error + make-ssh-host-key-error ssh-host-key-error? + (reason ssh-host-key-error-reason) ;; 'rejected, 'changed, 'unsupported + (fingerprint ssh-host-key-error-fingerprint)) ;; string or #f + + ;; ---- Channel errors ---- + (define-condition-type &ssh-channel-error &ssh-error + make-ssh-channel-error ssh-channel-error? + (channel-id ssh-channel-error-channel-id)) ;; integer or #f + + ;; ---- SFTP errors ---- + (define-condition-type &ssh-sftp-error &ssh-error + make-ssh-sftp-error ssh-sftp-error? + (code ssh-sftp-error-code) ;; integer: SFTP status code + (path ssh-sftp-error-path)) ;; string or #f + + ;; ---- Timeout errors ---- + (define-condition-type &ssh-timeout-error &ssh-error + make-ssh-timeout-error ssh-timeout-error? + (seconds ssh-timeout-error-seconds)) ;; number + + ;; ---- Convenience raisers ---- + + (define (raise-ssh-error operation msg . irritants) + (raise (condition + (make-ssh-error operation) + (make-message-condition msg) + (if (null? irritants) + (make-irritants-condition '()) + (make-irritants-condition irritants))))) + + (define (raise-ssh-connection-error operation host port msg) + (raise (condition + (make-ssh-connection-error operation host port) + (make-message-condition msg)))) + + (define (raise-ssh-auth-error operation method available msg) + (raise (condition + (make-ssh-auth-error operation method available) + (make-message-condition msg)))) + + (define (raise-ssh-kex-error operation phase msg . irritants) + (raise (condition + (make-ssh-kex-error operation phase) + (make-message-condition msg) + (if (null? irritants) + (make-irritants-condition '()) + (make-irritants-condition irritants))))) + + (define (raise-ssh-protocol-error operation expected received msg) + (raise (condition + (make-ssh-protocol-error operation expected received) + (make-message-condition msg)))) + + (define (raise-ssh-host-key-error operation reason fingerprint msg) + (raise (condition + (make-ssh-host-key-error operation reason fingerprint) + (make-message-condition msg)))) + + (define (raise-ssh-channel-error operation channel-id msg) + (raise (condition + (make-ssh-channel-error operation channel-id) + (make-message-condition msg)))) + + (define (raise-ssh-sftp-error operation code path msg) + (raise (condition + (make-ssh-sftp-error operation code path) + (make-message-condition msg)))) + + (define (raise-ssh-timeout-error operation seconds msg) + (raise (condition + (make-ssh-timeout-error operation seconds) + (make-message-condition msg)))) + + ) ;; end library --- a/lib/std/net/ssh/forward.sls +++ b/lib/std/net/ssh/forward.sls @@ -3,6 +3,9 @@ ;;; ;;; Local (-L) and remote (-R) port forwarding. ;;; Uses (chez-ssh crypto) for TCP listen/accept/read/write/close. +;;; Uses (std net ssh conditions) for structured error hierarchy. +;;; Uses (std fiber) for green-thread-based forwarding (replaces fork-thread). +;;; Uses (std misc guardian-pool) for listen fd cleanup on GC. (library (std net ssh forward) (export @@ -20,14 +23,28 @@ ;; Remote forwarding ssh-forward-remote-request ssh-forward-remote-cancel + + ;; Guardian pool for listen fds + ssh-forward-fd-pool ) (import (chezscheme) (std net ssh wire) (std net ssh transport) (std net ssh channel) + (std net ssh conditions) + (std fiber) + (std misc guardian-pool) (chez-ssh crypto)) + ;; ---- Guardian pool for listen fds ---- + ;; Safety net: listen fds are closed if forward-listener is GC'd without stop. + (define ssh-forward-fd-pool + (make-guardian-pool + (lambda (listener) + (guard (e [#t (void)]) + (ssh-crypto-tcp-close (forward-listener-listen-fd listener)))))) + ;; ---- Forward listener record ---- (define-record-type forward-listener @@ -41,19 +58,27 @@ (protocol (lambda (new) (lambda (local-port remote-host remote-port listen-fd) - (new local-port remote-host remote-port listen-fd #f #t))))) + (let ([l (new local-port remote-host remote-port listen-fd #f #t)]) + (guardian-pool-register ssh-forward-fd-pool l) + l))))) ;; ---- Local forwarding ---- (define (ssh-forward-local-start ts table bind-addr local-port remote-host remote-port) (let ([listen-fd (ssh-crypto-tcp-listen (or bind-addr "127.0.0.1") local-port)]) (when (< listen-fd 0) - (error 'ssh-forward-local-start "failed to listen" bind-addr local-port)) + (raise-ssh-connection-error 'ssh-forward-local-start + (or bind-addr "127.0.0.1") local-port + "failed to listen for local forwarding")) (let ([listener (make-forward-listener local-port remote-host remote-port listen-fd)]) + ;; Run accept loop in a dedicated OS thread hosting a fiber runtime. + ;; Each accepted connection gets its own fiber for relay, enabling + ;; M:N multiplexing of many forwarded connections onto few threads. (forward-listener-thread-set! listener (fork-thread (lambda () - (local-forward-accept-loop ts table listener)))) + (with-fibers + (local-forward-accept-loop ts table listener))))) listener))) (define (local-forward-accept-loop ts table listener) @@ -66,14 +91,18 @@ (forward-listener-remote-host listener) (forward-listener-remote-port listener) "127.0.0.1" 0)]) - (fork-thread + ;; Spawn a fiber (green thread) for each relay instead of an OS thread. + ;; This allows hundreds of concurrent forwarded connections with + ;; minimal overhead on the M:N fiber scheduler. + (fiber-spawn (current-fiber-runtime) (lambda () - (forward-relay ts table ch client-fd)))))) - (loop))))) + (forward-relay ts table ch client-fd))))))) + (loop)))) (define (forward-relay ts table ch client-fd) - (let ([ch->fd-thread - (fork-thread + ;; Spawn a fiber to relay channel→fd, while this fiber relays fd→channel + (let ([ch->fd-fiber + (fiber-spawn (current-fiber-runtime) (lambda () (let loop () (let ([data (ssh-channel-read ts table ch)]) @@ -115,10 +144,12 @@ (car r)) remote-port)] [(82) ;; SSH_MSG_REQUEST_FAILURE - (error 'ssh-forward-remote-request "server rejected forwarding request")] + (raise-ssh-error 'ssh-forward-remote-request + "server rejected remote forwarding request")] [else - (error 'ssh-forward-remote-request "unexpected response" - (bytevector-u8-ref reply 0))]))) + (raise-ssh-protocol-error 'ssh-forward-remote-request + "request success/failure" (bytevector-u8-ref reply 0) + "unexpected response to remote forwarding request")]))) (define (ssh-forward-remote-cancel ts bind-addr remote-port) (ssh-transport-send-packet ts @@ -129,6 +160,7 @@ (ssh-write-uint32 remote-port))) (let ([reply (ssh-transport-recv-packet ts)]) (unless (= (bytevector-u8-ref reply 0) 81) - (error 'ssh-forward-remote-cancel "cancel failed")))) + (raise-ssh-error 'ssh-forward-remote-cancel + "cancel remote forwarding failed")))) ) ;; end library --- a/lib/std/net/ssh/kex.sls +++ b/lib/std/net/ssh/kex.sls @@ -5,6 +5,7 @@ ;;; algorithm negotiation, and key derivation (RFC 4253 §7.2). ;;; ;;; FFI operations imported from (chez-ssh crypto). +;;; Uses (std net ssh conditions) for structured error hierarchy. (library (std net ssh kex) (export @@ -19,6 +20,7 @@ (import (chezscheme) (std net ssh wire) (std net ssh transport) + (std net ssh conditions) (chez-ssh crypto)) ;; ---- Helpers ---- @@ -102,9 +104,9 @@ (let loop ([cl client-list]) (cond [(null? cl) - (error 'ssh-kex-negotiate - (string-append "no common " name " algorithm") - client-list server-list)] + (raise-ssh-kex-error 'ssh-kex-negotiate 'negotiate + (string-append "no common " name " algorithm") + client-list server-list)] [(member (car cl) server-list) (car cl)] [else (loop (cdr cl))]))) @@ -204,10 +206,12 @@ (let ([ctx-buf (make-bytevector 512)]) (let ([rc (ssh-crypto-aes256-ctr-init key iv ctx-buf 512)]) (when (< rc 0) - (error 'make-cipher-for "AES-256-CTR init failed")) + (raise-ssh-kex-error 'ssh-kex-activate-keys 'ecdh + "AES-256-CTR cipher init failed")) (make-cipher-state cipher-name key mac-key iv ctx-buf)))] [else - (error 'make-cipher-for "unsupported cipher" cipher-name)])) + (raise-ssh-kex-error 'ssh-kex-activate-keys 'negotiate + (string-append "unsupported cipher: " cipher-name))])) ;; ---- Exchange hash computation ---- @@ -237,20 +241,24 @@ [key-type (utf8->string (car r1))] [off1 (cdr r1)]) (unless (string=? key-type "ssh-ed25519") - (error 'verify-host-key "unsupported host key type" key-type)) + (raise-ssh-host-key-error 'verify-host-key 'unsupported #f + (string-append "unsupported host key type: " key-type))) (let* ([r2 (ssh-read-string host-key-blob off1)] [pubkey (car r2)] [r3 (ssh-read-string signature-blob 0)] [sig-type (utf8->string (car r3))] [off3 (cdr r3)]) (unless (string=? sig-type "ssh-ed25519") - (error 'verify-host-key "signature type mismatch" sig-type)) + (raise-ssh-host-key-error 'verify-host-key 'unsupported #f + (string-append "signature type mismatch: " sig-type))) (let* ([r4 (ssh-read-string signature-blob off3)] [sig (car r4)]) (when (not (= (bytevector-length pubkey) 32)) - (error 'verify-host-key "invalid pubkey length")) + (raise-ssh-host-key-error 'verify-host-key 'unsupported #f + "invalid pubkey length (expected 32)")) (when (not (= (bytevector-length sig) 64)) - (error 'verify-host-key "invalid signature length")) + (raise-ssh-host-key-error 'verify-host-key 'unsupported #f + "invalid signature length (expected 64)")) (let ([rc (ssh-crypto-ed25519-verify pubkey exchange-hash (bytevector-length exchange-hash) sig)]) (= rc 0)))))) @@ -264,7 +272,9 @@ (let ([server-kexinit (ssh-transport-recv-packet ts)]) (unless (= (bytevector-u8-ref server-kexinit 0) SSH_MSG_KEXINIT) - (error 'ssh-kex-perform "expected KEXINIT" (bytevector-u8-ref server-kexinit 0))) + (raise-ssh-protocol-error 'ssh-kex-perform + SSH_MSG_KEXINIT (bytevector-u8-ref server-kexinit 0) + "expected KEXINIT from server")) (transport-state-server-kexinit-set! ts server-kexinit) (let* ([server-parsed (ssh-kex-parse-kexinit server-kexinit)] @@ -275,7 +285,8 @@ [client-pub (make-bytevector 32)]) (let ([rc (ssh-crypto-curve25519-keygen client-priv client-pub)]) (when (< rc 0) - (error 'ssh-kex-perform "keygen failed")) + (raise-ssh-kex-error 'ssh-kex-perform 'ecdh + "Curve25519 keygen failed")) (ssh-transport-send-packet ts (ssh-make-payload SSH_MSG_KEX_ECDH_INIT @@ -283,8 +294,9 @@ (let ([reply (ssh-transport-recv-packet ts)]) (unless (= (bytevector-u8-ref reply 0) SSH_MSG_KEX_ECDH_REPLY) - (error 'ssh-kex-perform "expected KEX_ECDH_REPLY" - (bytevector-u8-ref reply 0))) + (raise-ssh-protocol-error 'ssh-kex-perform + SSH_MSG_KEX_ECDH_REPLY (bytevector-u8-ref reply 0) + "expected KEX_ECDH_REPLY from server")) (let* ([off 1] [r1 (ssh-read-string reply off)] @@ -299,7 +311,8 @@ (let ([rc (ssh-crypto-curve25519-shared-secret client-priv server-pub secret-buf secret-len-buf)]) (when (< rc 0) - (error 'ssh-kex-perform "ECDH failed")) + (raise-ssh-kex-error 'ssh-kex-perform 'ecdh + "ECDH shared secret computation failed")) (let ([H (compute-exchange-hash (transport-state-client-version ts) @@ -310,10 +323,14 @@ secret-buf)]) (unless (host-key-verifier host-key-blob) - (error 'ssh-kex-perform "host key rejected"))