geir/home-lab
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

regressed lab-tool to 0.10-dev to make it again

Browse source
This commit is contained in:
Geir Okkenhaug Jerstad 2025-07-04 19:31:48 +02:00
parent 646c8bbc20
commit 2fdf7e4b0c
31 changed files with 732 additions and 635 deletions
Download patch file Download diff file Expand all files Collapse all files

53
packages/lab-tool/core/commands.scm Normal file
View file

@ -0,0 +1,53 @@
;; core/commands.scm - Pure command building logic
(define-module (core commands)
#:use-module (ice-9 format)
#:use-module (core config)
#:use-module (deploy ssh-strategy)
#:use-module (deploy executor)
#:export (build-flake-update-command
deploy-to-machine
list-available-machines))
;; Pure function to build flake update command
(define (build-flake-update-command . flake-path-override)
"Build a command to update flake inputs"
(let ((flake-path (if (null? flake-path-override)
(get-flake-path)
(car flake-path-override))))
(format #f "nix flake update ~a" flake-path)))
;; Command to deploy to a specific machine
(define (deploy-to-machine machine-name . options)
"Deploy to a specific machine using centralized configuration"
(let* ((ssh-config (get-ssh-config machine-name))
(deploy-options (if (null? options) '() (car options)))
(deploy-plan (build-ssh-deploy-commands machine-name deploy-options)))
(if ssh-config
(begin
(display (format #f "Deploying to machine: ~a\n" machine-name))
(display (format #f "SSH Config: ~a\n" ssh-config))
;; Execute the deployment
(execute-deploy-commands deploy-plan))
(begin
(display (format #f "Error: Unknown machine '~a'\n" machine-name))
(display "Available machines:\n")
(list-available-machines)
#f))))
;; Command to list available machines
(define (list-available-machines)
"List all available machines for deployment"
(let ((machines (get-all-hosts)))
(display "Available machines:\n")
(for-each (lambda (machine)
(let ((ssh-config (get-ssh-config machine)))
(if ssh-config
(display (format #f " ~a - ~a@~a\n"
machine
(assoc-ref ssh-config 'user)
(assoc-ref ssh-config 'hostname))))))
machines)
machines))

81
packages/lab-tool/core/config.scm Normal file
View file

@ -0,0 +1,81 @@
;; core/config.scm - Pure config data and accessors
(define-module (core config)
#:use-module (srfi srfi-1) ; for fold
#:export (default-config
get-config-value
host-configs
get-host-config
get-all-hosts
validate-host-name
get-ssh-config
get-flake-path
get-ssh-key))
;; Declarative configuration (source of truth)
(define default-config
'((ssh-user . "sma")
(ssh-key . "~/.ssh/id_ed25519_admin")
(flake-path . "~/Projects/home-lab")
(hosts . ((congenital-optimist (hostname . "congenital-optimist"))
(sleeper-service (hostname . "sleeper-service"))
(grey-area (hostname . "grey-area"))
(reverse-proxy (hostname . "reverse-proxy"))
(little-rascal (hostname . "little-rascal"))))
(deployment . ((default-mode . "boot")
(timeout . 300)
(retry-count . 3)))
(monitoring . ((interval . 30)
(timeout . 10)))
(mcp . ((port . 3001)
(host . "localhost")
(log-level . "info")))))
;; Accessors (pure, no mutation, no IO)
(define (get-config-value path . default)
(let ((result (fold (lambda (key acc)
(if (and acc (list? acc))
(assoc-ref acc key)
#f))
default-config path)))
(if result
result
(if (null? default) #f (car default)))))
(define (host-configs)
(get-config-value '(hosts)))
(define (get-host-config host-name)
(let ((host-symbol (if (symbol? host-name)
host-name
(string->symbol host-name))))
(assoc-ref (host-configs) host-symbol)))
(define (get-all-hosts)
(map (lambda (host-entry)
(symbol->string (car host-entry)))
(host-configs)))
(define (validate-host-name host-name)
(let ((hosts (get-all-hosts)))
(if (member host-name hosts)
#t
#f)))
(define (get-ssh-config host-name)
(let ((host-config (get-host-config host-name))
(ssh-user (get-config-value '(ssh-user) "sma"))
(ssh-key (get-config-value '(ssh-key) "~/.ssh/id_ed25519_admin")))
(if host-config
(let ((hostname (assoc-ref host-config 'hostname)))
`((hostname . ,hostname)
(user . ,ssh-user)
(ssh-user . ,ssh-user)
(identity-file . ,ssh-key)))
#f)))
(define (get-flake-path)
(get-config-value '(flake-path) "~/Projects/home-lab"))
(define (get-ssh-key)
(get-config-value '(ssh-key) "~/.ssh/id_ed25519_admin"))

18
packages/lab-tool/default.nix
View file

@ -12,8 +12,8 @@
nixos-rebuild,
}:
stdenv.mkDerivation {
pname = "lab-tool";
version = "0.2.0";
pname = "lab";
version = "0.1.0-dev";
src = ./.;
@ -29,7 +29,7 @@ stdenv.mkDerivation {
buildPhase = ''
# Compile Guile modules for better performance
mkdir -p $out/share/guile/site/3.0
cp -r . $out/share/guile/site/3.0/lab-tool/
cp -r . $out/share/guile/site/3.0/lab/
# Compile .scm files to .go files
for file in $(find . -name "*.scm"); do
@ -44,18 +44,18 @@ stdenv.mkDerivation {
# Create the main lab executable
cat > $out/bin/lab << EOF
#!/usr/bin/env bash
export GUILE_LOAD_PATH="$out/share/guile/site/3.0/lab-tool:${guile-ssh}/share/guile/site/3.0:${guile-json}/share/guile/site/3.0:${guile-git}/share/guile/site/3.0:${guile-gcrypt}/share/guile/site/3.0:\$GUILE_LOAD_PATH"
export GUILE_LOAD_COMPILED_PATH="$out/share/guile/site/3.0/lab-tool:${guile-ssh}/lib/guile/3.0/site-ccache:${guile-json}/lib/guile/3.0/site-ccache:${guile-git}/lib/guile/3.0/site-ccache:${guile-gcrypt}/lib/guile/3.0/site-ccache:\$GUILE_LOAD_COMPILED_PATH"
exec ${guile_3_0}/bin/guile "$out/share/guile/site/3.0/lab-tool/main.scm" "\$@"
export GUILE_LOAD_PATH="$out/share/guile/site/3.0/lab:${guile-ssh}/share/guile/site/3.0:${guile-json}/share/guile/site/3.0:${guile-git}/share/guile/site/3.0:${guile-gcrypt}/share/guile/site/3.0:$GUILE_LOAD_PATH"
export GUILE_LOAD_COMPILED_PATH="$out/share/guile/site/3.0/lab:${guile-ssh}/lib/guile/3.0/site-ccache:${guile-json}/lib/guile/3.0/site-ccache:${guile-git}/lib/guile/3.0/site-ccache:${guile-gcrypt}/lib/guile/3.0/site-ccache:$GUILE_LOAD_COMPILED_PATH"
exec ${guile_3_0}/bin/guile "$out/share/guile/site/3.0/lab/main.scm" "$@"
EOF
chmod +x $out/bin/lab
# Create MCP server executable
cat > $out/bin/lab-mcp-server << EOF
#!/usr/bin/env bash
export GUILE_LOAD_PATH="$out/share/guile/site/3.0/lab-tool:${guile-ssh}/share/guile/site/3.0:${guile-json}/share/guile/site/3.0:${guile-git}/share/guile/site/3.0:${guile-gcrypt}/share/guile/site/3.0:\$GUILE_LOAD_PATH"
export GUILE_LOAD_COMPILED_PATH="$out/share/guile/site/3.0/lab-tool:${guile-ssh}/lib/guile/3.0/site-ccache:${guile-json}/lib/guile/3.0/site-ccache:${guile-git}/lib/guile/3.0/site-ccache:${guile-gcrypt}/lib/guile/3.0/site-ccache:\$GUILE_LOAD_COMPILED_PATH"
exec ${guile_3_0}/bin/guile -L "$out/share/guile/site/3.0/lab-tool" -c "(use-modules (mcp server)) (run-mcp-server)"
export GUILE_LOAD_PATH="$out/share/guile/site/3.0/lab:${guile-ssh}/share/guile/site/3.0:${guile-json}/share/guile/site/3.0:${guile-git}/share/guile/site/3.0:${guile-gcrypt}/share/guile/site/3.0:$GUILE_LOAD_PATH"
export GUILE_LOAD_COMPILED_PATH="$out/share/guile/site/3.0/lab:${guile-ssh}/lib/guile/3.0/site-ccache:${guile-json}/lib/guile/3.0/site-ccache:${guile-git}/lib/guile/3.0/site-ccache:${guile-gcrypt}/lib/guile/3.0/site-ccache:$GUILE_LOAD_COMPILED_PATH"
exec ${guile_3_0}/bin/guile -L "$out/share/guile/site/3.0/lab" -c "(use-modules (mcp server)) (run-mcp-server)"
EOF
chmod +x $out/bin/lab-mcp-server

0
packages/lab-tool/deploy/default.scm Normal file
View file

70
packages/lab-tool/deploy/executor.scm Normal file
View file

@ -0,0 +1,70 @@
;; deploy/executor.scm - Impure execution layer
(define-module (deploy executor)
#:use-module (ice-9 format)
#:use-module (ice-9 popen)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1)
#:use-module (core config)
#:export (execute-command
execute-ssh-command
execute-deploy-commands
run-with-timeout))
;; Execute a single command locally
(define (execute-command cmd)
"Execute a command locally and return (exit-code . output)"
(let* ((port (open-input-pipe cmd))
(output (get-string-all port))
(exit-code (close-pipe port)))
(cons exit-code output)))
;; Execute a command over SSH
(define (execute-ssh-command ssh-config cmd)
"Execute a command over SSH using centralized SSH key configuration"
(let* ((hostname (assoc-ref ssh-config 'hostname))
(user (assoc-ref ssh-config 'user))
(ssh-key (get-ssh-key))
(ssh-cmd (format #f "ssh -i ~a -o BatchMode=yes ~a@~a '~a'"
ssh-key user hostname cmd)))
(execute-command ssh-cmd)))
;; Execute deployment commands in sequence
(define (execute-deploy-commands deploy-plan)
"Execute deployment commands from a deployment plan"
(let ((rsync-cmd (assoc-ref deploy-plan 'rsync))
(rebuild-cmd (assoc-ref deploy-plan 'rebuild))
(ssh-config (assoc-ref deploy-plan 'ssh-config)))
(display "Starting deployment...\n")
;; Step 1: Rsync flake to remote
(display "Step 1: Syncing flake to remote host...\n")
(display (format #f "Running: ~a\n" rsync-cmd))
(let ((rsync-result (execute-command rsync-cmd)))
(if (= (car rsync-result) 0)
(begin
(display "Rsync completed successfully\n")
;; Step 2: Run nixos-rebuild on remote
(display "Step 2: Running nixos-rebuild on remote host...\n")
(display (format #f "Running: ~a\n" rebuild-cmd))
(let ((rebuild-result (execute-ssh-command ssh-config rebuild-cmd)))
(if (= (car rebuild-result) 0)
(begin
(display "Deployment completed successfully!\n")
(display (cdr rebuild-result))
#t)
(begin
(display "nixos-rebuild failed:\n")
(display (cdr rebuild-result))
#f))))
(begin
(display "Rsync failed:\n")
(display (cdr rsync-result))
#f)))))
;; Run command with timeout (placeholder for future implementation)
(define (run-with-timeout cmd timeout)
"Run command with timeout - simplified version"
(execute-command cmd))

71
packages/lab-tool/deploy/ssh-strategy.scm Normal file
View file

@ -0,0 +1,71 @@
;; deploy/ssh-strategy.scm - Pure SSH deployment strategy
(define-module (deploy ssh-strategy)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (core config)
#:use-module (core commands)
#:export (build-ssh-deploy-commands
build-rsync-command
build-nixos-rebuild-command
build-ssh-key-check-command
get-deploy-options))
;; Pure function to get deploy options with defaults
(define (get-deploy-options options)
"Extract deployment options with sensible defaults"
`((dry-run . ,(or (assoc-ref options 'dry-run) #f))
(boot . ,(or (assoc-ref options 'boot) #f))
(test . ,(or (assoc-ref options 'test) #f))
(switch . ,(or (assoc-ref options 'switch) #f))
(timeout . ,(or (assoc-ref options 'timeout) 300))))
;; Pure function to build SSH key check command
(define (build-ssh-key-check-command host-config)
"Build SSH key check command to verify connectivity"
(let ((hostname (assoc-ref host-config 'hostname))
(user (assoc-ref host-config 'user))
(ssh-key (get-ssh-key)))
(format #f "ssh -i ~a -o BatchMode=yes -o ConnectTimeout=5 ~a@~a 'echo \"SSH key check successful\"'"
ssh-key user hostname)))
;; Pure function to build rsync command
(define (build-rsync-command flake-path host-config)
"Build rsync command to sync flake to remote host using /tmp"
(let ((hostname (assoc-ref host-config 'hostname))
(user (assoc-ref host-config 'user))
(ssh-key (get-ssh-key)))
(format #f "rsync -av --delete -e 'ssh -i ~a -o BatchMode=yes' ~a/ ~a@~a:/tmp/flake/"
ssh-key flake-path user hostname)))
;; Pure function to build nixos-rebuild command
(define (build-nixos-rebuild-command hostname options)
"Build nixos-rebuild command for remote execution using /tmp/flake"
(let ((mode (cond
((assoc-ref options 'dry-run) "dry-run")
((assoc-ref options 'boot) "boot")
((assoc-ref options 'test) "test")
((assoc-ref options 'switch) "switch")
(else "switch"))))
(format #f "sudo nixos-rebuild ~a --flake /tmp/flake#~a" mode hostname)))
;; Pure function to build complete SSH deployment commands
(define (build-ssh-deploy-commands host-name options)
"Build all commands needed for SSH deployment strategy"
(let* ((host-config (get-host-config host-name))
(flake-path (get-flake-path))
(deploy-opts (get-deploy-options options)))
(if host-config
(let* ((hostname (assoc-ref host-config 'hostname))
(user (get-config-value '(ssh-user) "sma"))
(ssh-config `((hostname . ,hostname)
(user . ,user)))
(ssh-check-cmd (build-ssh-key-check-command ssh-config))
(rsync-cmd (build-rsync-command flake-path ssh-config))
(rebuild-cmd (build-nixos-rebuild-command hostname deploy-opts)))
`((ssh-check . ,ssh-check-cmd)
(rsync . ,rsync-cmd)
(rebuild . ,rebuild-cmd)
(ssh-config . ,ssh-config)
(options . ,deploy-opts)))
#f)))

1
packages/lab-tool/health/checks.scm Normal file
View file

@ -0,0 +1 @@
;; health/checks.scm - Pure health check logic

1
packages/lab-tool/health/monitor.scm Normal file
View file

@ -0,0 +1 @@
;; health/monitor.scm - Impure health monitoring

1
packages/lab-tool/io/rsync.scm Normal file
View file

@ -0,0 +1 @@
;; io/rsync.scm - Impure rsync execution helpers

0
packages/lab-tool/config/config.scm → packages/lab-tool/lab-old/config/config.scm
View file

0
packages/lab-tool/config/lab-auto-update.service → packages/lab-tool/lab-old/config/lab-auto-update.service
View file

1
packages/lab-tool/lab-old/io/shell.scm Normal file
View file

@ -0,0 +1 @@
;; backup of old io/shell.scm

1
packages/lab-tool/lab-old/io/ssh.scm Normal file
View file

@ -0,0 +1 @@
;; backup of old io/ssh.scm

1
packages/lab-tool/lab-old/lab/auto-update.scm Normal file
View file

@ -0,0 +1 @@
;; backup of old lab/auto-update.scm

1
packages/lab-tool/lab-old/lab/core.scm Normal file
View file

@ -0,0 +1 @@
;; backup of old lab/core.scm

1
packages/lab-tool/lab-old/lab/deploy-rs.scm Normal file
View file

@ -0,0 +1 @@
;; backup of old lab/deploy-rs.scm

1
packages/lab-tool/lab-old/lab/deployment.scm Normal file
View file

@ -0,0 +1 @@
;; backup of old lab/deployment.scm

1
packages/lab-tool/lab-old/lab/machines.scm Normal file
View file

@ -0,0 +1 @@
;; backup of old lab/machines.scm

1
packages/lab-tool/lab-old/lab/monitoring.scm Normal file
View file

@ -0,0 +1 @@
;; backup of old lab/monitoring.scm

1
packages/lab-tool/lab-old/lab/ssh-deploy.scm Normal file
View file

@ -0,0 +1 @@
;; backup of old lab/ssh-deploy.scm

78
packages/lab-tool/lab-old/main.scm Normal file
View file

@ -0,0 +1,78 @@
;; backup of old main.scm
;; ...existing code...
#!/usr/bin/env guile
!#
;; Home Lab Tool - Main Entry Point
;; K.I.S.S Refactored Implementation
;; Load path is set by the wrapper script in default.nix
;; No need to add current directory when running from Nix
(use-modules (ice-9 match)
(ice-9 format)
(utils config)
(utils logging)
(lab core)
(lab machines)
(lab deployment)
(lab auto-update))
;; Initialize logging
(set-log-level! 'info)
;; Pure function: Command help text
(define (get-help-text)
"Pure function returning help text"
"Home Lab Tool - SSH + Rsync Edition
USAGE: lab <command> [args...]
COMMANDS:
status Show infrastructure status
machines List all machines
deploy <machine> [options] Deploy configuration to machine using SSH + rsync + nixos-rebuild
Options: --dry-run, --boot, --test, --use-deploy-rs
deploy-all [options] Deploy to all machines using SSH + rsync + nixos-rebuild
update Update flake inputs
auto-update Perform automatic system update with health checks
auto-update-status Show auto-update service status and logs
health [machine] Check machine health (all if no machine specified)
ssh <machine> SSH to machine (using sma user)
test-rollback <machine> Test deployment with rollback (uses deploy-rs)
help Show this help
EXAMPLES:
lab status
lab machines
lab deploy little-rascal # Deploy with SSH + rsync (default)
lab deploy little-rascal --dry-run # Test deployment without applying
lab deploy little-rascal --boot # Deploy but only activate on next boot
lab deploy little-rascal --test # Deploy but don't make permanent
lab deploy little-rascal --use-deploy-rs # Use deploy-rs instead of SSH method
lab deploy-all # Deploy to all machines
lab deploy-all --dry-run # Test deployment to all machines
lab update # Update flake inputs
lab test-rollback sleeper-service # Test rollback functionality (deploy-rs)
lab ssh sleeper-service # SSH to machine as sma user
SSH + Rsync Features (Default):
- Fast: Only syncs changed files with rsync
- Simple: Uses standard nixos-rebuild workflow
- Reliable: Same command workflow as manual deployment
- Flexible: Supports boot, test, and switch modes
Deploy-rs Features (Optional with --use-deploy-rs):
- Automatic rollback on deployment failure
- Health checks after deployment
- Magic rollback for network connectivity issues
- Atomic deployments with safety guarantees
This implementation uses SSH + rsync + nixos-rebuild by default:
- Fast: Efficient file synchronization
- Simple: Standard NixOS deployment workflow
- Consistent: Same user (sma) for all operations
- Flexible: Multiple deployment modes available"
;; ...existing code...

69
packages/lab-tool/lab-old/utils/config.scm Normal file
View file

@ -0,0 +1,69 @@
;; utils/config.scm - Declarative configuration for Home Lab Tool
(define-module (utils config)
#:export (default-config
get-config-value
host-configs
get-host-config
get-all-hosts
validate-host-name
get-ssh-config))
;; Declarative configuration (source of truth)
(define default-config
'((ssh-user . "sma")
(hosts . ((congenital-optimist (hostname . "congenital-optimist"))
(sleeper-service (hostname . "sleeper-service"))
(grey-area (hostname . "grey-area"))
(reverse-proxy (hostname . "reverse-proxy"))
(little-rascal (hostname . "little-rascal"))))
(deployment . ((default-mode . "boot")
(timeout . 300)
(retry-count . 3)))
(monitoring . ((interval . 30)
(timeout . 10)))
(mcp . ((port . 3001)
(host . "localhost")
(log-level . "info")))))
;; Accessors (pure, no mutation, no IO)
(define (get-config-value path . default)
(let ((result (fold (lambda (key acc)
(if (and acc (list? acc))
(assoc-ref acc key)
#f))
default-config path)))
(if result
result
(if (null? default) #f (car default)))))
(define (host-configs)
(get-config-value '(hosts)))
(define (get-host-config host-name)
(let ((host-symbol (if (symbol? host-name)
host-name
(string->symbol host-name))))
(assoc-ref (host-configs) host-symbol)))
(define (get-all-hosts)
(map (lambda (host-entry)
(symbol->string (car host-entry)))
(host-configs)))
(define (validate-host-name host-name)
(let ((hosts (get-all-hosts)))
(if (member host-name hosts)
#t
#f)))
(define (get-ssh-config host-name)
(let ((host-config (get-host-config host-name))
(ssh-user (get-config-value '(ssh-user) "sma")))
(if host-config
(let ((hostname (assoc-ref host-config 'hostname)))
`((hostname . ,hostname)
(user . ,ssh-user)
(ssh-user . ,ssh-user)
(identity-file . "~/.ssh/id_ed25519_admin")))
#f)))

0
packages/lab-tool/utils/json.scm → packages/lab-tool/lab-old/utils/json.scm
View file

0
packages/lab-tool/utils/logging.scm → packages/lab-tool/lab-old/utils/logging.scm
View file

188
packages/lab-tool/lab-old/utils/ssh.scm Normal file
View file

@ -0,0 +1,188 @@
;; 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)))

330
packages/lab-tool/main.scm
View file

@ -1,332 +1,8 @@
#!/usr/bin/env guile
!#
;; Home Lab Tool - Main Entry Point
;; K.I.S.S Refactored Implementation
;; Home Lab Tool - Entrypoint
;; Load path is set by the wrapper script in default.nix
;; No need to add current directory when running from Nix
(use-modules (main runner))
(use-modules (ice-9 match)
(ice-9 format)
(utils config)
(utils logging)
(lab core)
(lab machines)
(lab deployment)
(lab auto-update))
;; Initialize logging
(set-log-level! 'info)
;; Pure function: Command help text
(define (get-help-text)
"Pure function returning help text"
"Home Lab Tool - SSH + Rsync Edition
USAGE: lab <command> [args...]
COMMANDS:
status Show infrastructure status
machines List all machines
deploy <machine> [options] Deploy configuration to machine using SSH + rsync + nixos-rebuild
Options: --dry-run, --boot, --test, --use-deploy-rs
deploy-all [options] Deploy to all machines using SSH + rsync + nixos-rebuild
update Update flake inputs
auto-update Perform automatic system update with health checks
auto-update-status Show auto-update service status and logs
health [machine] Check machine health (all if no machine specified)
ssh <machine> SSH to machine (using sma user)
test-rollback <machine> Test deployment with rollback (uses deploy-rs)
help Show this help
EXAMPLES:
lab status
lab machines
lab deploy little-rascal # Deploy with SSH + rsync (default)
lab deploy little-rascal --dry-run # Test deployment without applying
lab deploy little-rascal --boot # Deploy but only activate on next boot
lab deploy little-rascal --test # Deploy but don't make permanent
lab deploy little-rascal --use-deploy-rs # Use deploy-rs instead of SSH method
lab deploy-all # Deploy to all machines
lab deploy-all --dry-run # Test deployment to all machines
lab update # Update flake inputs
lab test-rollback sleeper-service # Test rollback functionality (deploy-rs)
lab ssh sleeper-service # SSH to machine as sma user
SSH + Rsync Features (Default):
- Fast: Only syncs changed files with rsync
- Simple: Uses standard nixos-rebuild workflow
- Reliable: Same command workflow as manual deployment
- Flexible: Supports boot, test, and switch modes
Deploy-rs Features (Optional with --use-deploy-rs):
- Automatic rollback on deployment failure
- Health checks after deployment
- Magic rollback for network connectivity issues
- Atomic deployments with safety guarantees
This implementation uses SSH + rsync + nixos-rebuild by default:
- Fast: Efficient file synchronization
- Simple: Standard NixOS deployment workflow
- Consistent: Same user (sma) for all operations
- Flexible: Multiple deployment modes available"
;; Pure function: Format machine list
(define (format-machine-list machines)
"Pure function to format machine list for display"
(if (null? machines)
"No machines configured"
(string-join
(map (lambda (machine) (format #f " - ~a" machine)) machines)
"\n")))
;; Pure function: Format status info
(define (format-status-info machines config)
"Pure function to format infrastructure status"
(format #f "Infrastructure Status:
Total machines: ~a
Home lab root: ~a
~a"
(length machines)
(get-config-value '(homelab-root))
(format-machine-list machines)))
;; Command implementations
(define (cmd-status)
"Show infrastructure status"
(log-info "Checking infrastructure status...")
(let* ((machines (list-machines))
(status (get-infrastructure-status))
(config (get-current-config))
(status-text (format-status-info machines config)))
(display status-text)
(newline)
(for-each (lambda (machine-status)
(let ((machine (assoc-ref machine-status 'machine))
(status (assoc-ref machine-status 'status)))
(format #t " ~a: ~a\n" machine status)))
status)
(log-success "Status check complete")))
(define (cmd-machines)
"List all configured machines"
(log-info "Listing configured machines...")
(let* ((machines (list-machines))
(machine-list (format-machine-list machines)))
(format #t "Configured Machines:\n~a\n" machine-list)
(log-success "Machine list complete")))
(define (cmd-deploy machine-name . args)
"Deploy configuration to machine using deploy-rs"
(let* ((options (parse-deploy-options args)))
(log-info "Deploying to machine: ~a using deploy-rs" machine-name)
(if (validate-machine-name machine-name)
(let ((result (deploy-machine machine-name "default" options)))
(if result
(log-success "Deploy-rs deployment to ~a completed successfully" machine-name)
(log-error "Deploy-rs deployment to ~a failed" machine-name)))
(begin
(log-error "Invalid machine: ~a" machine-name)
(log-info "Available machines: ~a" (string-join (get-all-machines) ", "))))))
(define (cmd-ssh machine-name)
"SSH to machine using sma user"
(log-info "Connecting to machine: ~a as sma user" machine-name)
(if (validate-machine-name machine-name)
(let ((ssh-config (get-ssh-config machine-name)))
(if ssh-config
(let ((hostname (assoc-ref ssh-config 'hostname))
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
(ssh-user (assoc-ref ssh-config 'ssh-user))
(is-local (assoc-ref ssh-config 'is-local)))
(if is-local
(begin
(log-info "Machine ~a is local - switching to sma user locally" machine-name)
(system "sudo -u sma -i"))
(let ((target (format #f "~a@~a" (or ssh-user "sma") (or ssh-alias hostname))))
(log-info "Connecting to ~a via SSH..." target)
(system (format #f "ssh ~a" target)))))
(log-error "No SSH configuration found for ~a" machine-name)))
(log-error "Invalid machine: ~a" machine-name)))
(define (cmd-test-modules)
"Test the modular implementation"
(log-info "Testing modular implementation...")
;; Test pure functions
(use-modules (utils config accessor))
(let* ((config (get-current-config))
(machines (get-all-machines-pure config))
(blue-color (get-color 'blue)))
(format #t "\n=== Modular Implementation Test ===\n")
(format #t "Pure config access: ~a machines\n" (length machines))
(format #t "Pure color function: ~ablue text~a\n" blue-color (get-color 'reset))
(format #t "\n✅ All pure functions working correctly!\n\n")
(log-success "Modular implementation test complete")))
(define (cmd-update)
"Update flake inputs"
(log-info "Updating flake inputs...")
(let ((result (update-flake '())))
(if result
(log-success "Flake update complete")
(log-error "Flake update failed"))))
(define (cmd-deploy-all)
"Deploy to all machines using deploy-rs"
(log-info "Deploying to all machines using deploy-rs...")
(let ((result (deploy-all-machines '())))
(if result
(log-success "All deploy-rs deployments completed successfully")
(log-error "Some deploy-rs deployments failed"))))
(define (cmd-health args)
"Check machine health"
(let ((machine-name (if (null? args) #f (car args))))
(if machine-name
;; Check specific machine
(if (validate-machine-name machine-name)
(let ((health (check-machine-health machine-name)))
(format #t "Health check for ~a:\n" machine-name)
(format #t " SSH: ~a\n" (assoc-ref health 'ssh-connectivity))
(format #t " Status: ~a\n" (assoc-ref health 'status))
(format #t " Services: ~a configured\n" (assoc-ref health 'services-configured)))
(log-error "Invalid machine: ~a" machine-name))
;; Check all machines
(let ((results (discover-machines)))
(format #t "Health Summary:\n")
(for-each (lambda (health)
(let ((machine (assoc-ref health 'machine))
(status (assoc-ref health 'status)))
(format #t " ~a: ~a\n" machine status)))
results)))))
(define (cmd-auto-update)
"Perform automatic system update"
(log-info "Starting automatic system update...")
(let ((result (auto-update-system '((auto-reboot . #t)))))
(if result
(log-success "Automatic update completed successfully")
(log-error "Automatic update failed"))))
(define (cmd-auto-update-status)
"Show auto-update status and logs"
(auto-update-status))
;; Parse deployment options from command line arguments
(define (parse-deploy-options args)
"Parse deployment options from command line arguments"
(let ((options '()))
(for-each
(lambda (arg)
(cond
((string=? arg "--dry-run")
(set! options (cons '(dry-run . #t) options)))
((string=? arg "--skip-checks")
(set! options (cons '(skip-checks . #t) options)))
(else
(log-warn "Unknown option: ~a" arg))))
args)
options))
(define (cmd-test-rollback machine-name)
"Test deployment with rollback functionality"
(log-info "Testing rollback deployment for machine: ~a" machine-name)
(if (validate-machine-name machine-name)
(let ((options '((test-rollback . #t))))
(let ((result (deploy-with-rollback machine-name options)))
(if result
(log-success "Rollback test completed for ~a" machine-name)
(log-error "Rollback test failed for ~a" machine-name))))
(log-error "Invalid machine: ~a" machine-name)))
;; Main command dispatcher
(define (dispatch-command command args)
"Dispatch command with appropriate handler"
(match command
('help
(display (get-help-text)))
('status
(cmd-status))
('machines
(cmd-machines))
('deploy
(if (null? args)
(begin
(log-error "deploy command requires machine name")
(format #t "Usage: lab deploy <machine> [options]\n")
(format #t "Options: --dry-run, --skip-checks\n"))
(apply cmd-deploy args)))
('deploy-all
(cmd-deploy-all))
('test-rollback
(if (null? args)
(begin
(log-error "test-rollback command requires machine name")
(format #t "Usage: lab test-rollback <machine>\n"))
(cmd-test-rollback (car args))))
('update
(cmd-update))
('auto-update
(cmd-auto-update))
('auto-update-status
(cmd-auto-update-status))
('health
(cmd-health args))
('ssh
(if (null? args)
(begin
(log-error "ssh command requires machine name")
(format #t "Usage: lab ssh <machine>\n"))
(cmd-ssh (car args))))
('test-modules
(cmd-test-modules))
('test-rollback
(if (null? args)
(begin
(log-error "test-rollback command requires machine name")
(format #t "Usage: lab test-rollback <machine>\n"))
(cmd-test-rollback (car args))))
(_
(log-error "Unknown command: ~a" command)
(format #t "Use 'lab help' for available commands\n")
(exit 1))))
;; Main entry point
(define (main args)
"Main entry point for lab tool"
(log-info "Home Lab Tool - Deploy-rs Edition")
(let* ((parsed-cmd (if (> (length args) 1) (cdr args) '("help")))
(command (string->symbol (car parsed-cmd)))
(cmd-args (cdr parsed-cmd)))
(catch #t
(lambda () (dispatch-command command cmd-args))
(lambda (key . error-args)
(log-error "Command failed: ~a ~a" key error-args)
(exit 1))))
(log-debug "Command execution complete"))
;; Run main function if script is executed directly
(when (and (defined? 'command-line) (not (null? (command-line))))
(main (command-line))))
(main)

1
packages/lab-tool/main/cli.scm Normal file
View file

@ -0,0 +1 @@
;; main/cli.scm - Pure CLI parsing

1
packages/lab-tool/main/dispatcher.scm Normal file
View file

@ -0,0 +1 @@
;; main/dispatcher.scm - Pure command dispatch

96
packages/lab-tool/main/runner.scm Normal file
View file

@ -0,0 +1,96 @@
;; main/runner.scm - Main entrypoint for lab-tool
(define-module (main runner)
#:use-module (core config)
#:use-module (core commands)
#:use-module (deploy ssh-strategy)
#:use-module (deploy executor)
#:use-module (srfi srfi-1)
#:use-module (ice-9 format)
#:export (main))
;; Helper function to join strings
(define (string-join strings separator)
"Join a list of strings with separator"
(if (null? strings)
""
(fold (lambda (str acc)
(if (string=? acc "")
str
(string-append acc separator str)))
""
strings)))
;; Parse command line arguments
(define (parse-args args)
"Parse command line arguments into command and options"
(if (< (length args) 2)
'(help)
(let ((command (cadr args))
(remaining (cddr args)))
(case (string->symbol command)
((update) `(update))
((deploy)
(if (null? remaining)
'(deploy-help)
`(deploy ,(car remaining) ,@(cdr remaining))))
((list) `(list))
((help) `(help))
(else `(help))))))
;; Handle update command
(define (handle-update)
"Handle flake update command"
(display "Updating flake inputs...\n")
(display (build-flake-update-command))
(newline))
;; Handle deploy command
(define (handle-deploy host-name . options)
"Handle deployment to a specific host"
(if (validate-host-name host-name)
(let* ((deploy-options '()) ; TODO: Parse options from command line
(result (deploy-to-machine host-name deploy-options)))
(if result
(display "Deployment completed successfully!\n")
(display "Deployment failed!\n")))
(begin
(display (format #f "Invalid host name: ~a\n" host-name))
(display "Valid hosts: ")
(display (string-join (get-all-hosts) ", "))
(newline)
#f)))
;; Handle list command
(define (handle-list)
"Handle list hosts command"
(list-available-machines))
;; Show help
(define (show-help)
"Show help message"
(display "Usage: lab-tool <command> [options]\n")
(display "\nCommands:\n")
(display " update Update flake inputs\n")
(display " deploy <host> Deploy to specified host\n")
(display " list List all hosts\n")
(display " help Show this help message\n")
(display "\nHosts:\n")
(for-each (lambda (host)
(display " ")
(display host)
(newline))
(get-all-hosts)))
;; Simple functional main: handles commands
(define (main)
(let* ((args (command-line))
(parsed (parse-args args)))
(case (car parsed)
((update) (handle-update))
((deploy) (apply handle-deploy (cdr parsed)))
((list) (handle-list))
((deploy-help)
(display "Usage: lab-tool deploy <host> [options]\n")
(show-help))
(else (show-help)))))

150
packages/lab-tool/utils/config.scm
View file

@ -1,150 +0,0 @@
;; utils/config.scm - Configuration management for Home Lab Tool
(define-module (utils config)
#:use-module (ice-9 format)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1)
#:use-module (utils logging)
#:use-module (utils json)
#:export (load-config
get-config-value
machine-configs
get-machine-config
get-all-machines
validate-machine-name
get-homelab-root
get-ssh-config
get-current-config))
;; Default configuration
(define default-config
`((homelab-root . "/home/geir/Home-lab")
(machines . ((congenital-optimist
(type . remote)
(hostname . "congenital-optimist.tail807ea.ts.net")
(ssh-alias . "congenital-optimist.tail807ea.ts.net")
(ssh-user . "sma")
(services . (workstation development)))
(sleeper-service
(type . remote)
(hostname . "sleeper-service.tail807ea.ts.net")
(ssh-alias . "sleeper-service.tail807ea.ts.net")
(ssh-user . "sma")
(services . (nfs zfs storage)))
(grey-area
(type . remote)
(hostname . "grey-area.tail807ea.ts.net")
(ssh-alias . "grey-area.tail807ea.ts.net")
(ssh-user . "sma")
(services . (ollama forgejo git)))
(reverse-proxy
(type . remote)
(hostname . "reverse-proxy.tail807ea.ts.net")
(ssh-alias . "reverse-proxy.tail807ea.ts.net")
(ssh-user . "sma")
(services . (nginx proxy ssl)))
(little-rascal
(type . remote)
(hostname . "little-rascal.tail807ea.ts.net")
(ssh-alias . "little-rascal.tail807ea.ts.net")
(ssh-user . "sma")
(services . (development niri desktop ai-tools)))))
(deployment . ((default-mode . "boot")
(timeout . 300)
(retry-count . 3)))
(monitoring . ((interval . 30)
(timeout . 10)))
(mcp . ((port . 3001)
(host . "localhost")
(log-level . "info")))))
;; Current loaded configuration
(define current-config default-config)
;; Load configuration from file or use defaults
(define (load-config . args)
(let ((config-file (if (null? args)
(string-append (getenv "HOME") "/.config/homelab/config.json")
(car args))))
(if (file-exists? config-file)
(begin
(log-debug "Loading configuration from ~a" config-file)
(catch #t
(lambda ()
(let ((json-data (call-with-input-file config-file get-string-all)))
(set! current-config (json-string->scm-safe json-data))
(log-info "Configuration loaded successfully")))
(lambda (key . args)
(log-warn "Failed to load config file, using defaults: ~a" key)
(set! current-config default-config))))
(begin
(log-debug "No config file found, using defaults")
(set! current-config default-config)))
current-config))
;; Get a configuration value by path
(define (get-config-value path . default)
(let ((result (fold (lambda (key acc)
(if (and acc (list? acc))
(assoc-ref acc key)
#f))
current-config path)))
(if result
result
(if (null? default) #f (car default)))))
;; Get machine configurations
(define (machine-configs)
(get-config-value '(machines)))
;; Get configuration for a specific machine
(define (get-machine-config machine-name)
(let ((machine-symbol (if (symbol? machine-name)
machine-name
(string->symbol machine-name))))
(assoc-ref (machine-configs) machine-symbol)))
;; Get list of all machine names
(define (get-all-machines)
(map (lambda (machine-entry)
(symbol->string (car machine-entry)))
(machine-configs)))
;; Validate that a machine name exists
(define (validate-machine-name machine-name)
(let ((machines (get-all-machines)))
(if (member machine-name machines)
#t
(begin
(log-error "Unknown machine: ~a" machine-name)
(log-error "Available machines: ~a" (string-join machines ", "))
#f))))
;; Get home lab root directory
(define (get-homelab-root)
(get-config-value '(homelab-root) "/home/geir/Home-lab"))
;; Get SSH configuration for a machine
(define (get-ssh-config machine-name)
(let ((machine-config (get-machine-config machine-name)))
(if machine-config
(let ((type (assoc-ref machine-config 'type))
(hostname (assoc-ref machine-config 'hostname))
(ssh-alias (assoc-ref machine-config 'ssh-alias))
(ssh-user (assoc-ref machine-config 'ssh-user)))
`((type . ,type)
(hostname . ,hostname)
(ssh-alias . ,ssh-alias)
(user . ,ssh-user)
(ssh-user . ,ssh-user) ; Keep both for compatibility
(identity-file . "~/.ssh/id_ed25519_admin") ; Default SSH key for sma user
(is-local . ,(eq? type 'local))))
#f)))
;; Get current configuration
(define (get-current-config)
"Get current loaded configuration"
current-config)
;; Initialize configuration on module load
(load-config)

149
packages/lab-tool/utils/ssh.scm
View file

@ -1,149 +0,0 @@
;; utils/ssh.scm - SSH operations for Home Lab Tool
;; Fallback implementation using shell commands instead of guile-ssh
(define-module (utils ssh)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (utils logging)
#:use-module (utils config)
#: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)
(let ((ssh-config (get-ssh-config machine-name)))
(if (not ssh-config)
(begin
(log-error "No SSH configuration found for ~a" machine-name)
#f)
(if (assoc-ref ssh-config 'is-local)
(begin
(log-debug "Machine ~a is local, skipping SSH test" machine-name)
#t)
(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)))
(log-debug "Testing SSH connection to ~a (~a) as ~a using key ~a" machine-name hostname user identity-file)
(catch #t
(lambda ()
(let* ((target (if user (format #f "~a@~a" user hostname) hostname))
(key-arg (if identity-file (format #f "-i ~a" identity-file) ""))
(test-cmd (if ssh-alias
(format #f "ssh -o ConnectTimeout=5 -o BatchMode=yes ~a ~a echo OK" key-arg ssh-alias)
(format #f "ssh -o ConnectTimeout=5 -o BatchMode=yes ~a ~a echo OK" key-arg target)))
(port (open-pipe* OPEN_READ "/bin/sh" "-c" test-cmd))
(output (get-string-all port))
(status (close-pipe port)))
(if (zero? status)
(begin
(log-debug "SSH connection to ~a successful" machine-name)
#t)
(begin
(log-warn "SSH connection to ~a failed (exit: ~a)" machine-name status)
#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)
(let ((ssh-config (get-ssh-config machine-name))
(full-command (if (null? args)
command
(format #f "~a ~a" command (string-join args " ")))))
(if (not ssh-config)
(values #f "No SSH configuration found")
(if (assoc-ref ssh-config 'is-local)
;; Local execution
(begin
(log-debug "Executing locally: ~a" full-command)
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" full-command))
(output (get-string-all port))
(status (close-pipe port)))
(values (zero? status) output)))
;; Remote execution
(let ((ssh-alias (assoc-ref ssh-config 'ssh-alias))
(hostname (assoc-ref ssh-config 'hostname))
(user (assoc-ref ssh-config 'user))
(identity-file (assoc-ref ssh-config 'identity-file)))
(log-debug "Testing SSH connection to ~a (~a) as ~a using key ~a" machine-name hostname user identity-file)
(catch #t
(lambda ()
(let* ((target (if user (format #f "~a@~a" user (or ssh-alias hostname)) (or ssh-alias hostname)))
(key-arg (if identity-file (format #f "-i ~a" identity-file) ""))
(ssh-cmd (format #f "ssh ~a ~a '~a'" key-arg target full-command))
(port (open-pipe* OPEN_READ "/bin/sh" "-c" ssh-cmd))
(output (get-string-all port))
(status (close-pipe port)))
(values (zero? status) output)))
(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)
(let ((ssh-config (get-ssh-config machine-name)))
(if (not ssh-config)
(begin
(log-error "No SSH configuration found for ~a" machine-name)
#f)
(if (assoc-ref ssh-config 'is-local)
;; Local copy
(begin
(log-debug "Copying locally: ~a -> ~a" local-path remote-path)
(let* ((copy-cmd (format #f "cp '~a' '~a'" local-path remote-path))
(status (system copy-cmd)))
(zero? status)))
;; Remote copy
(let ((ssh-alias (assoc-ref ssh-config 'ssh-alias))
(hostname (assoc-ref ssh-config 'hostname))
(user (assoc-ref ssh-config 'user))
(identity-file (assoc-ref ssh-config 'identity-file)))
(log-debug "Copying to ~a: ~a -> ~a as ~a using key ~a" machine-name local-path remote-path user identity-file)
(let* ((target (if user (format #f "~a@~a" user (or ssh-alias hostname)) (or ssh-alias hostname)))
(key-arg (if identity-file (format #f "-i ~a" identity-file) ""))
(scp-cmd (format #f "scp ~a '~a' '~a:~a'" key-arg local-path target remote-path))
(status (system scp-cmd)))
(if (zero? status)
(begin
(log-debug "File copy successful")
#t)
(begin
(log-error "File copy failed (exit: ~a)" status)
#f))))))))
;; Run command with retry logic
(define (run-command-with-retry machine-name command max-retries . args)
(let loop ((retries 0))
(call-with-values
(lambda () (apply run-remote-command machine-name command args))
(lambda (success output)
(if success
(values #t output)
(if (< retries max-retries)
(begin
(log-warn "Command failed, retrying (~a/~a)..." (+ retries 1) max-retries)
(sleep 2)
(loop (+ retries 1)))
(values #f output)))))))
;; Execute a thunk with SSH connection context
(define (with-ssh-connection machine-name thunk)
(if (test-ssh-connection machine-name)
(catch #t
(lambda () (thunk))
(lambda (key . args)
(log-error "SSH operation failed: ~a ~a" key args)
#f))
(begin
(log-error "Cannot establish SSH connection to ~a" machine-name)
#f))))
;; Ensure file ends with a newline and all parentheses are closed