188 lines
No EOL
7.1 KiB
Scheme
188 lines
No EOL
7.1 KiB
Scheme
;; utils/ssh.scm - SSH operations for Home Lab Tool
|
|
;; Refactored using functional programming principles
|
|
|
|
(define-module (utils ssh)
|
|
#:use-module (ice-9 format)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (utils logging)
|
|
#:use-module (utils config)
|
|
#:use-module (io ssh)
|
|
#:use-module (io shell)
|
|
#:export (test-ssh-connection
|
|
run-remote-command
|
|
copy-file-to-remote
|
|
run-command-with-retry
|
|
with-ssh-connection))
|
|
|
|
;; Test SSH connectivity to a machine
|
|
(define (test-ssh-connection machine-name)
|
|
"Test SSH connectivity using functional composition"
|
|
(let ((ssh-config (get-ssh-config machine-name)))
|
|
(cond
|
|
((not ssh-config)
|
|
(log-error "No SSH configuration found for ~a" machine-name)
|
|
#f)
|
|
((assoc-ref ssh-config 'is-local)
|
|
(log-debug "Machine ~a is local, skipping SSH test" machine-name)
|
|
#t)
|
|
(else
|
|
(test-remote-ssh-connection machine-name ssh-config)))))
|
|
|
|
;; Helper: Test remote SSH connection
|
|
(define (test-remote-ssh-connection machine-name ssh-config)
|
|
"Test remote SSH connection with error handling"
|
|
(let* ((hostname (assoc-ref ssh-config 'hostname))
|
|
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
|
|
(user (assoc-ref ssh-config 'user))
|
|
(identity-file (assoc-ref ssh-config 'identity-file))
|
|
(target (make-ssh-target user (or ssh-alias hostname)))
|
|
(options (make-ssh-options identity-file 5))
|
|
(test-cmd (build-ssh-command target options "echo OK")))
|
|
|
|
(log-debug "Testing SSH connection to ~a (~a) as ~a using key ~a"
|
|
machine-name hostname user identity-file)
|
|
|
|
(catch #t
|
|
(lambda ()
|
|
(let ((result (execute-with-output test-cmd)))
|
|
(if (car result)
|
|
(begin
|
|
(log-debug "SSH connection to ~a successful" machine-name)
|
|
#t)
|
|
(begin
|
|
(log-warn "SSH connection to ~a failed" machine-name)
|
|
#f))))
|
|
(lambda (key . args)
|
|
(log-error "SSH test failed for ~a: ~a ~a" machine-name key args)
|
|
#f))))
|
|
|
|
;; Run a command on a remote machine
|
|
(define (run-remote-command machine-name command . args)
|
|
"Run command remotely using functional composition"
|
|
(let ((ssh-config (get-ssh-config machine-name))
|
|
(full-command (build-full-command command args)))
|
|
(cond
|
|
((not ssh-config)
|
|
(values #f "No SSH configuration found"))
|
|
((assoc-ref ssh-config 'is-local)
|
|
(execute-local-command full-command))
|
|
(else
|
|
(execute-remote-command machine-name ssh-config full-command)))))
|
|
|
|
;; Helper: Build full command string
|
|
(define (build-full-command command args)
|
|
"Build complete command string from command and arguments"
|
|
(if (null? args)
|
|
command
|
|
(format #f "~a ~a" command (string-join args " "))))
|
|
|
|
;; Helper: Execute command locally
|
|
(define (execute-local-command command)
|
|
"Execute command locally and return (success . output)"
|
|
(log-debug "Executing locally: ~a" command)
|
|
(let ((result (execute-with-output command)))
|
|
(values (car result) (cdr result))))
|
|
|
|
;; Helper: Execute command remotely
|
|
(define (execute-remote-command machine-name ssh-config command)
|
|
"Execute command remotely using SSH"
|
|
(let* ((hostname (assoc-ref ssh-config 'hostname))
|
|
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
|
|
(user (assoc-ref ssh-config 'user))
|
|
(identity-file (assoc-ref ssh-config 'identity-file))
|
|
(target (make-ssh-target user (or ssh-alias hostname)))
|
|
(options (make-ssh-options identity-file #f))
|
|
(ssh-cmd (build-ssh-command target options command)))
|
|
|
|
(log-debug "Executing remotely on ~a: ~a" machine-name command)
|
|
|
|
(catch #t
|
|
(lambda ()
|
|
(let ((result (execute-with-output ssh-cmd)))
|
|
(values (car result) (cdr result))))
|
|
(lambda (key . args)
|
|
(log-error "SSH command failed for ~a: ~a ~a" machine-name key args)
|
|
(values #f "")))))
|
|
|
|
;; Copy file to remote machine using scp
|
|
(define (copy-file-to-remote machine-name local-path remote-path)
|
|
"Copy file to remote machine using functional composition"
|
|
(let ((ssh-config (get-ssh-config machine-name)))
|
|
(cond
|
|
((not ssh-config)
|
|
(log-error "No SSH configuration found for ~a" machine-name)
|
|
#f)
|
|
((assoc-ref ssh-config 'is-local)
|
|
(copy-file-locally local-path remote-path))
|
|
(else
|
|
(copy-file-remotely machine-name ssh-config local-path remote-path)))))
|
|
|
|
;; Helper: Copy file locally
|
|
(define (copy-file-locally local-path remote-path)
|
|
"Copy file locally using cp command"
|
|
(log-debug "Copying locally: ~a -> ~a" local-path remote-path)
|
|
(let ((copy-cmd (format #f "cp '~a' '~a'" local-path remote-path)))
|
|
(execute-command copy-cmd)))
|
|
|
|
;; Helper: Copy file remotely
|
|
(define (copy-file-remotely machine-name ssh-config local-path remote-path)
|
|
"Copy file remotely using scp command"
|
|
(let* ((hostname (assoc-ref ssh-config 'hostname))
|
|
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
|
|
(user (assoc-ref ssh-config 'user))
|
|
(identity-file (assoc-ref ssh-config 'identity-file))
|
|
(target (make-ssh-target user (or ssh-alias hostname)))
|
|
(options (make-ssh-options identity-file #f))
|
|
(scp-cmd (format #f "scp ~a '~a' '~a:~a'" options local-path target remote-path)))
|
|
|
|
(log-debug "Copying to ~a: ~a -> ~a as ~a using key ~a"
|
|
machine-name local-path remote-path user identity-file)
|
|
|
|
(let ((success (execute-command scp-cmd)))
|
|
(if success
|
|
(begin
|
|
(log-debug "File copy successful")
|
|
#t)
|
|
(begin
|
|
(log-error "File copy failed")
|
|
#f)))))
|
|
|
|
;; Run command with retry logic
|
|
(define (run-command-with-retry machine-name command max-retries . args)
|
|
"Run command with retry logic using functional recursion"
|
|
(retry-command machine-name command max-retries 0 args))
|
|
|
|
;; Helper: Retry command implementation
|
|
(define (retry-command machine-name command max-retries current-retry args)
|
|
"Recursive retry implementation"
|
|
(call-with-values
|
|
(lambda () (apply run-remote-command machine-name command args))
|
|
(lambda (success output)
|
|
(cond
|
|
(success
|
|
(values #t output))
|
|
((< current-retry max-retries)
|
|
(log-warn "Command failed, retrying (~a/~a)..." (+ current-retry 1) max-retries)
|
|
(sleep 2)
|
|
(retry-command machine-name command max-retries (+ current-retry 1) args))
|
|
(else
|
|
(values #f output))))))
|
|
|
|
;; Execute a thunk with SSH connection context
|
|
(define (with-ssh-connection machine-name thunk)
|
|
"Execute thunk with SSH connection context using functional composition"
|
|
(cond
|
|
((test-ssh-connection machine-name)
|
|
(execute-with-ssh-context thunk machine-name))
|
|
(else
|
|
(log-error "Cannot establish SSH connection to ~a" machine-name)
|
|
#f)))
|
|
|
|
;; Helper: Execute thunk with error handling
|
|
(define (execute-with-ssh-context thunk machine-name)
|
|
"Execute thunk with proper error handling"
|
|
(catch #t
|
|
(lambda () (thunk))
|
|
(lambda (key . args)
|
|
(log-error "SSH operation failed: ~a ~a" key args)
|
|
#f))) |