Compare commits
4 commits
59d287a543
...
2fdf7e4b0c
| Author | SHA1 | Date | |
|---|---|---|---|
| 2fdf7e4b0c | |||
| 646c8bbc20 | |||
| 043817f7d5 | |||
| 3599f278a7 |
37 changed files with 1270 additions and 761 deletions
95
packages/lab-tool/REFACTOR_PLAN.md
Normal file
95
packages/lab-tool/REFACTOR_PLAN.md
Normal file
|
|
@ -0,0 +1,95 @@
|
|||
# Lab Tool Refactoring Plan - Functional Programming Approach
|
||||
|
||||
## Current Problems
|
||||
- Deep nested parentheses causing syntax errors
|
||||
- Functions doing too many things
|
||||
- Hard to debug and maintain
|
||||
- Mixed pure/impure logic
|
||||
|
||||
## New Structure
|
||||
|
||||
```
|
||||
lab-tool/
|
||||
├── core/
|
||||
│ ├── config.scm # Pure config access
|
||||
│ ├── machine.scm # Pure machine data structures
|
||||
│ └── commands.scm # Pure command building
|
||||
├── io/
|
||||
│ ├── ssh.scm # Pure SSH command building
|
||||
│ ├── rsync.scm # Pure rsync command building
|
||||
│ └── shell.scm # Impure shell execution
|
||||
├── deploy/
|
||||
│ ├── ssh-strategy.scm # Pure deployment strategy
|
||||
│ ├── deploy-rs-strategy.scm # Pure deploy-rs strategy
|
||||
│ └── executor.scm # Impure deployment execution
|
||||
├── health/
|
||||
│ ├── checks.scm # Pure health check logic
|
||||
│ └── monitor.scm # Impure health monitoring
|
||||
└── main/
|
||||
├── cli.scm # Pure CLI parsing
|
||||
├── dispatcher.scm # Pure command dispatch
|
||||
└── runner.scm # Impure main execution
|
||||
```
|
||||
|
||||
## Functional Principles
|
||||
|
||||
### 1. Single Responsibility Functions
|
||||
```scheme
|
||||
;; Instead of one complex function doing everything:
|
||||
(define (deploy-complex machine options) ...)
|
||||
|
||||
;; Break into focused functions:
|
||||
(define (build-rsync-command source dest ssh-config) ...)
|
||||
(define (build-nixos-rebuild-command flake-path machine mode) ...)
|
||||
(define (execute-command command) ...)
|
||||
(define (compose-ssh-deployment rsync-cmd rebuild-cmd) ...)
|
||||
```
|
||||
|
||||
### 2. Pure vs Impure Separation
|
||||
```scheme
|
||||
;; Pure: No side effects, testable
|
||||
(define (make-ssh-target user hostname)
|
||||
(format #f "~a@~a" user hostname))
|
||||
|
||||
;; Impure: Clear side effects
|
||||
(define (execute-ssh-command ssh-config command)
|
||||
(system (build-ssh-command ssh-config command)))
|
||||
```
|
||||
|
||||
### 3. Function Composition
|
||||
```scheme
|
||||
;; Instead of deep nesting:
|
||||
(let ((config (get-ssh-config machine))
|
||||
(command (build-command ...))
|
||||
(result (execute (format ...))))
|
||||
(if (success? result) ...))
|
||||
|
||||
;; Use composition:
|
||||
(-> machine
|
||||
get-ssh-config
|
||||
(build-deployment-commands flake-path)
|
||||
execute-deployment
|
||||
handle-result)
|
||||
```
|
||||
|
||||
### 4. Error Handling as Values
|
||||
```scheme
|
||||
;; Instead of exceptions in nested calls:
|
||||
(catch #t (lambda () (complex-nested-operation)) error-handler)
|
||||
|
||||
;; Return result types:
|
||||
(define (safe-ssh-connect machine)
|
||||
(if (valid-config? machine)
|
||||
`(success . ,(make-connection machine))
|
||||
`(error . "Invalid SSH config")))
|
||||
```
|
||||
|
||||
## Implementation Steps
|
||||
|
||||
1. **Extract SSH utilities** (no more parentheses hell)
|
||||
2. **Create pure command builders**
|
||||
3. **Separate execution layer**
|
||||
4. **Build composable deployment strategies**
|
||||
5. **Clean CLI interface**
|
||||
|
||||
This will make debugging much easier - each small function can be tested independently!
|
||||
53
packages/lab-tool/core/commands.scm
Normal file
53
packages/lab-tool/core/commands.scm
Normal 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
81
packages/lab-tool/core/config.scm
Normal 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"))
|
||||
|
|
@ -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
0
packages/lab-tool/deploy/default.scm
Normal file
70
packages/lab-tool/deploy/executor.scm
Normal file
70
packages/lab-tool/deploy/executor.scm
Normal 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
71
packages/lab-tool/deploy/ssh-strategy.scm
Normal 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
1
packages/lab-tool/health/checks.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; health/checks.scm - Pure health check logic
|
||||
1
packages/lab-tool/health/monitor.scm
Normal file
1
packages/lab-tool/health/monitor.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; health/monitor.scm - Impure health monitoring
|
||||
1
packages/lab-tool/io/rsync.scm
Normal file
1
packages/lab-tool/io/rsync.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; io/rsync.scm - Impure rsync execution helpers
|
||||
36
packages/lab-tool/io/shell.scm
Normal file
36
packages/lab-tool/io/shell.scm
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
;; io/shell.scm - Impure shell execution functions
|
||||
|
||||
(define-module (io shell)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (utils logging)
|
||||
#:export (execute-command
|
||||
execute-with-output
|
||||
test-command))
|
||||
|
||||
;; Impure function: Execute command and return success/failure
|
||||
(define (execute-command command)
|
||||
"Execute shell command, return true if successful"
|
||||
(log-debug "Executing: ~a" command)
|
||||
(let ((status (system command)))
|
||||
(zero? status)))
|
||||
|
||||
;; Impure function: Execute command and capture output
|
||||
(define (execute-with-output command)
|
||||
"Execute command and return (success . output) pair"
|
||||
(log-debug "Executing with output: ~a" command)
|
||||
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" command))
|
||||
(output (get-string-all port))
|
||||
(status (close-pipe port))
|
||||
(success (zero? status)))
|
||||
(log-debug "Command ~a: exit=~a" (if success "succeeded" "failed") status)
|
||||
(cons success output)))
|
||||
|
||||
;; Impure function: Test if command succeeds (no output)
|
||||
(define (test-command command)
|
||||
"Test if command succeeds, return boolean"
|
||||
(log-debug "Testing command: ~a" command)
|
||||
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" command))
|
||||
(output (get-string-all port))
|
||||
(status (close-pipe port)))
|
||||
(zero? status)))
|
||||
37
packages/lab-tool/io/ssh.scm
Normal file
37
packages/lab-tool/io/ssh.scm
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
;; io/ssh.scm - Pure SSH command building functions
|
||||
|
||||
(define-module (io ssh)
|
||||
#:use-module (ice-9 format)
|
||||
#:export (make-ssh-target
|
||||
build-ssh-command
|
||||
build-rsync-command
|
||||
make-ssh-options))
|
||||
|
||||
;; Pure function: Build SSH target string
|
||||
(define (make-ssh-target user hostname)
|
||||
"Build SSH target string from user and hostname"
|
||||
(if user
|
||||
(format #f "~a@~a" user hostname)
|
||||
hostname))
|
||||
|
||||
;; Pure function: Build SSH options string
|
||||
(define (make-ssh-options identity-file timeout)
|
||||
"Build SSH options string"
|
||||
(let ((opts '()))
|
||||
(when identity-file
|
||||
(set! opts (cons (format #f "-i ~a" identity-file) opts)))
|
||||
(when timeout
|
||||
(set! opts (cons (format #f "-o ConnectTimeout=~a" timeout) opts)))
|
||||
(set! opts (cons "-o BatchMode=yes" opts))
|
||||
(string-join (reverse opts) " ")))
|
||||
|
||||
;; Pure function: Build SSH command
|
||||
(define (build-ssh-command target options command)
|
||||
"Build complete SSH command string"
|
||||
(format #f "ssh ~a ~a '~a'" options target command))
|
||||
|
||||
;; Pure function: Build rsync command
|
||||
(define (build-rsync-command source-path target dest-path ssh-options)
|
||||
"Build rsync command with SSH transport"
|
||||
(format #f "rsync -avz --delete -e 'ssh ~a' ~a/ ~a:~a/"
|
||||
ssh-options source-path target dest-path))
|
||||
1
packages/lab-tool/lab-old/io/shell.scm
Normal file
1
packages/lab-tool/lab-old/io/shell.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; backup of old io/shell.scm
|
||||
1
packages/lab-tool/lab-old/io/ssh.scm
Normal file
1
packages/lab-tool/lab-old/io/ssh.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; backup of old io/ssh.scm
|
||||
1
packages/lab-tool/lab-old/lab/auto-update.scm
Normal file
1
packages/lab-tool/lab-old/lab/auto-update.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; backup of old lab/auto-update.scm
|
||||
1
packages/lab-tool/lab-old/lab/core.scm
Normal file
1
packages/lab-tool/lab-old/lab/core.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; backup of old lab/core.scm
|
||||
1
packages/lab-tool/lab-old/lab/deploy-rs.scm
Normal file
1
packages/lab-tool/lab-old/lab/deploy-rs.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; backup of old lab/deploy-rs.scm
|
||||
1
packages/lab-tool/lab-old/lab/deployment.scm
Normal file
1
packages/lab-tool/lab-old/lab/deployment.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; backup of old lab/deployment.scm
|
||||
1
packages/lab-tool/lab-old/lab/machines.scm
Normal file
1
packages/lab-tool/lab-old/lab/machines.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; backup of old lab/machines.scm
|
||||
1
packages/lab-tool/lab-old/lab/monitoring.scm
Normal file
1
packages/lab-tool/lab-old/lab/monitoring.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; backup of old lab/monitoring.scm
|
||||
1
packages/lab-tool/lab-old/lab/ssh-deploy.scm
Normal file
1
packages/lab-tool/lab-old/lab/ssh-deploy.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; backup of old lab/ssh-deploy.scm
|
||||
78
packages/lab-tool/lab-old/main.scm
Normal file
78
packages/lab-tool/lab-old/main.scm
Normal 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
69
packages/lab-tool/lab-old/utils/config.scm
Normal 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)))
|
||||
188
packages/lab-tool/lab-old/utils/ssh.scm
Normal file
188
packages/lab-tool/lab-old/utils/ssh.scm
Normal 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)))
|
||||
140
packages/lab-tool/lab/deploy-rs.scm
Normal file
140
packages/lab-tool/lab/deploy-rs.scm
Normal file
|
|
@ -0,0 +1,140 @@
|
|||
;; lab/deploy-rs.scm - Deploy-rs based deployment operations (extracted)
|
||||
|
||||
(define-module (lab deploy-rs)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (utils logging)
|
||||
#:use-module (utils config)
|
||||
#:export (deploy-machine-deploy-rs
|
||||
deploy-all-machines-deploy-rs
|
||||
deploy-with-rollback
|
||||
option-ref))
|
||||
|
||||
;; Helper function for option handling
|
||||
(define (option-ref options key default)
|
||||
"Get option value with default fallback"
|
||||
(let ((value (assoc-ref options key)))
|
||||
(if value value default)))
|
||||
|
||||
;; Main deployment function using deploy-rs
|
||||
(define (deploy-machine-deploy-rs machine-name . args)
|
||||
"Deploy configuration to machine using deploy-rs (impure - has side effects)"
|
||||
(let* ((mode (if (null? args) "default" (car args)))
|
||||
(options (if (< (length args) 2) '() (cadr args)))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(skip-checks (option-ref options 'skip-checks #f)))
|
||||
|
||||
(if (not (validate-machine-name machine-name))
|
||||
#f
|
||||
(begin
|
||||
(log-info "Starting deploy-rs deployment: ~a" machine-name)
|
||||
(execute-deploy-rs machine-name mode options)))))
|
||||
|
||||
;; Execute deploy-rs deployment
|
||||
(define (execute-deploy-rs machine-name mode options)
|
||||
"Execute deployment using deploy-rs with automatic rollback"
|
||||
(let* ((homelab-root (get-homelab-root))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(skip-checks (option-ref options 'skip-checks #f))
|
||||
(auto-rollback (option-ref options 'auto-rollback #t))
|
||||
(magic-rollback (option-ref options 'magic-rollback #t)))
|
||||
|
||||
(log-info "Deploying ~a using deploy-rs..." machine-name)
|
||||
|
||||
(if dry-run
|
||||
(begin
|
||||
(log-info "DRY RUN: Would execute deploy-rs for ~a" machine-name)
|
||||
(log-info "Command would be: deploy '.#~a'" machine-name)
|
||||
#t)
|
||||
(let* ((deploy-cmd (build-deploy-command machine-name skip-checks auto-rollback magic-rollback))
|
||||
(start-time (current-time)))
|
||||
|
||||
(log-info "Deploy command: ~a" deploy-cmd)
|
||||
(log-info "Executing deployment with automatic rollback protection...")
|
||||
|
||||
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" deploy-cmd))
|
||||
(output (get-string-all port))
|
||||
(status (close-pipe port))
|
||||
(elapsed (- (current-time) start-time)))
|
||||
|
||||
(if (zero? status)
|
||||
(begin
|
||||
(log-success "Deploy-rs deployment completed successfully in ~as" elapsed)
|
||||
(log-info "Deployment output:")
|
||||
(log-info "~a" output)
|
||||
#t)
|
||||
(begin
|
||||
(log-error "Deploy-rs deployment failed (exit: ~a)" status)
|
||||
(log-error "Error output:")
|
||||
(log-error "~a" output)
|
||||
(log-info "Deploy-rs automatic rollback should have been triggered")
|
||||
#f)))))))
|
||||
|
||||
;; Build deploy-rs command with options
|
||||
(define (build-deploy-command machine-name skip-checks auto-rollback magic-rollback)
|
||||
"Build the deploy-rs command with appropriate flags"
|
||||
(let ((base-cmd (format #f "cd ~a && deploy '.#~a'" (get-homelab-root) machine-name))
|
||||
(flags '()))
|
||||
|
||||
;; Add flags based on options
|
||||
(when skip-checks
|
||||
(set! flags (cons "--skip-checks" flags)))
|
||||
|
||||
(when auto-rollback
|
||||
(set! flags (cons "--auto-rollback=true" flags)))
|
||||
|
||||
(when magic-rollback
|
||||
(set! flags (cons "--magic-rollback=true" flags)))
|
||||
|
||||
;; Combine command with flags
|
||||
(if (null? flags)
|
||||
base-cmd
|
||||
(format #f "~a ~a" base-cmd (string-join (reverse flags) " ")))))
|
||||
|
||||
;; Deploy to all machines
|
||||
(define (deploy-all-machines-deploy-rs . args)
|
||||
"Deploy to all machines using deploy-rs"
|
||||
(let* ((options (if (null? args) '() (car args)))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(machines (get-all-machines)))
|
||||
|
||||
(log-info "Starting deployment to all machines (~a total)" (length machines))
|
||||
|
||||
(let ((results
|
||||
(map (lambda (machine)
|
||||
(log-info "Deploying to ~a..." machine)
|
||||
(let ((result (deploy-machine-deploy-rs machine "default" options)))
|
||||
(if result
|
||||
(log-success "✓ ~a deployed successfully" machine)
|
||||
(log-error "✗ ~a deployment failed" machine))
|
||||
(cons machine result)))
|
||||
machines)))
|
||||
|
||||
;; Summary
|
||||
(let ((successful (filter cdr results))
|
||||
(failed (filter (lambda (r) (not (cdr r))) results)))
|
||||
(log-info "Deployment summary:")
|
||||
(log-info " Successful: ~a/~a machines" (length successful) (length machines))
|
||||
(when (not (null? failed))
|
||||
(log-error " Failed: ~a" (string-join (map car failed) ", ")))
|
||||
|
||||
;; Return true if all succeeded
|
||||
(= (length successful) (length machines))))))
|
||||
|
||||
;; Deploy with explicit rollback testing
|
||||
(define (deploy-with-rollback machine-name . args)
|
||||
"Deploy with explicit rollback capability testing"
|
||||
(let* ((options (if (null? args) '() (car args)))
|
||||
(test-rollback (option-ref options 'test-rollback #f)))
|
||||
|
||||
(log-info "Deploying ~a with rollback testing..." machine-name)
|
||||
|
||||
(if test-rollback
|
||||
(begin
|
||||
(log-info "Testing rollback mechanism (deploy will be reverted)")
|
||||
;; Deploy with magic rollback disabled to test manual rollback
|
||||
(let ((modified-options (cons '(magic-rollback . #f) options)))
|
||||
(execute-deploy-rs machine-name "default" modified-options)))
|
||||
(execute-deploy-rs machine-name "default" options))))
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
;; lab/deployment.scm - Deploy-rs based deployment operations
|
||||
;; lab/deployment.scm - Unified deployment operations (SSH + rsync by default)
|
||||
|
||||
(define-module (lab deployment)
|
||||
#:use-module (ice-9 format)
|
||||
|
|
@ -7,162 +7,60 @@
|
|||
#:use-module (srfi srfi-1)
|
||||
#:use-module (utils logging)
|
||||
#:use-module (utils config)
|
||||
#:use-module (lab ssh-deploy)
|
||||
#:use-module (lab deploy-rs)
|
||||
#:export (deploy-machine
|
||||
update-flake
|
||||
deploy-all-machines
|
||||
deploy-with-rollback
|
||||
option-ref))
|
||||
|
||||
;; Helper function for option handling
|
||||
;; Helper function for option handling (re-exported from ssh-deploy)
|
||||
(define (option-ref options key default)
|
||||
"Get option value with default fallback"
|
||||
(let ((value (assoc-ref options key)))
|
||||
(if value value default)))
|
||||
|
||||
;; Main deployment function using deploy-rs
|
||||
;; Main deployment function - SSH by default, deploy-rs optional
|
||||
(define (deploy-machine machine-name . args)
|
||||
"Deploy configuration to machine using deploy-rs (impure - has side effects)"
|
||||
"Deploy configuration to machine using SSH + rsync (default) or deploy-rs (optional)"
|
||||
(let* ((mode (if (null? args) "default" (car args)))
|
||||
(options (if (< (length args) 2) '() (cadr args)))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(skip-checks (option-ref options 'skip-checks #f)))
|
||||
(use-deploy-rs (option-ref options 'use-deploy-rs #f)))
|
||||
|
||||
(if (not (validate-machine-name machine-name))
|
||||
#f
|
||||
(if use-deploy-rs
|
||||
(begin
|
||||
(log-info "Starting deploy-rs deployment: ~a" machine-name)
|
||||
(execute-deploy-rs machine-name mode options)))))
|
||||
|
||||
;; Execute deploy-rs deployment
|
||||
(define (execute-deploy-rs machine-name mode options)
|
||||
"Execute deployment using deploy-rs with automatic rollback"
|
||||
(let* ((homelab-root (get-homelab-root))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(skip-checks (option-ref options 'skip-checks #f))
|
||||
(auto-rollback (option-ref options 'auto-rollback #t))
|
||||
(magic-rollback (option-ref options 'magic-rollback #t)))
|
||||
|
||||
(log-info "Deploying ~a using deploy-rs..." machine-name)
|
||||
|
||||
(if dry-run
|
||||
(log-info "Using deploy-rs deployment method")
|
||||
(deploy-machine-deploy-rs machine-name mode options))
|
||||
(begin
|
||||
(log-info "DRY RUN: Would execute deploy-rs for ~a" machine-name)
|
||||
(log-info "Command would be: deploy '.#~a'" machine-name)
|
||||
#t)
|
||||
(let* ((deploy-cmd (build-deploy-command machine-name skip-checks auto-rollback magic-rollback))
|
||||
(start-time (current-time)))
|
||||
(log-info "Using SSH + rsync deployment method")
|
||||
(deploy-machine-ssh machine-name mode options))))))
|
||||
|
||||
(log-info "Deploy command: ~a" deploy-cmd)
|
||||
(log-info "Executing deployment with automatic rollback protection...")
|
||||
|
||||
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" deploy-cmd))
|
||||
(output (get-string-all port))
|
||||
(status (close-pipe port))
|
||||
(elapsed (- (current-time) start-time)))
|
||||
|
||||
(if (zero? status)
|
||||
(begin
|
||||
(log-success "Deploy-rs deployment completed successfully in ~as" elapsed)
|
||||
(log-info "Deployment output:")
|
||||
(log-info "~a" output)
|
||||
#t)
|
||||
(begin
|
||||
(log-error "Deploy-rs deployment failed (exit: ~a)" status)
|
||||
(log-error "Error output:")
|
||||
(log-error "~a" output)
|
||||
(log-info "Deploy-rs automatic rollback should have been triggered")
|
||||
#f)))))))
|
||||
|
||||
;; Build deploy-rs command with options
|
||||
(define (build-deploy-command machine-name skip-checks auto-rollback magic-rollback)
|
||||
"Build the deploy-rs command with appropriate flags"
|
||||
(let ((base-cmd (format #f "cd ~a && deploy '.#~a'" (get-homelab-root) machine-name))
|
||||
(flags '()))
|
||||
|
||||
;; Add flags based on options
|
||||
(when skip-checks
|
||||
(set! flags (cons "--skip-checks" flags)))
|
||||
|
||||
(when auto-rollback
|
||||
(set! flags (cons "--auto-rollback=true" flags)))
|
||||
|
||||
(when magic-rollback
|
||||
(set! flags (cons "--magic-rollback=true" flags)))
|
||||
|
||||
;; Combine command with flags
|
||||
(if (null? flags)
|
||||
base-cmd
|
||||
(format #f "~a ~a" base-cmd (string-join (reverse flags) " ")))))
|
||||
|
||||
;; Deploy to all machines
|
||||
;; Deploy to all machines - delegate to appropriate module
|
||||
(define (deploy-all-machines . args)
|
||||
"Deploy to all machines using deploy-rs"
|
||||
"Deploy to all machines using SSH + rsync (default) or deploy-rs (optional)"
|
||||
(let* ((options (if (null? args) '() (car args)))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(machines (get-all-machines)))
|
||||
(use-deploy-rs (option-ref options 'use-deploy-rs #f)))
|
||||
|
||||
(log-info "Starting deployment to all machines (~a total)" (length machines))
|
||||
(if use-deploy-rs
|
||||
(begin
|
||||
(log-info "Using deploy-rs for all machines")
|
||||
(deploy-all-machines-deploy-rs options))
|
||||
(begin
|
||||
(log-info "Using SSH + rsync for all machines")
|
||||
(deploy-all-machines-ssh options)))))
|
||||
|
||||
(let ((results
|
||||
(map (lambda (machine)
|
||||
(log-info "Deploying to ~a..." machine)
|
||||
(let ((result (deploy-machine machine "default" options)))
|
||||
(if result
|
||||
(log-success "✓ ~a deployed successfully" machine)
|
||||
(log-error "✗ ~a deployment failed" machine))
|
||||
(cons machine result)))
|
||||
machines)))
|
||||
|
||||
;; Summary
|
||||
(let ((successful (filter cdr results))
|
||||
(failed (filter (lambda (r) (not (cdr r))) results)))
|
||||
(log-info "Deployment summary:")
|
||||
(log-info " Successful: ~a/~a machines" (length successful) (length machines))
|
||||
(when (not (null? failed))
|
||||
(log-error " Failed: ~a" (string-join (map car failed) ", ")))
|
||||
|
||||
;; Return true if all succeeded
|
||||
(= (length successful) (length machines))))))
|
||||
|
||||
;; Deploy with explicit rollback testing
|
||||
;; Deploy with rollback testing - only available with deploy-rs
|
||||
(define (deploy-with-rollback machine-name . args)
|
||||
"Deploy with explicit rollback capability testing"
|
||||
"Deploy with explicit rollback capability testing (deploy-rs only)"
|
||||
(let* ((options (if (null? args) '() (car args)))
|
||||
(test-rollback (option-ref options 'test-rollback #f)))
|
||||
(modified-options (cons '(use-deploy-rs . #t) options)))
|
||||
|
||||
(log-info "Deploying ~a with rollback testing..." machine-name)
|
||||
(log-info "Rollback testing requires deploy-rs - switching to deploy-rs mode")
|
||||
(deploy-with-rollback machine-name modified-options)))
|
||||
|
||||
(if test-rollback
|
||||
(begin
|
||||
(log-info "Testing rollback mechanism (deploy will be reverted)")
|
||||
;; Deploy with magic rollback disabled to test manual rollback
|
||||
(let ((modified-options (cons '(magic-rollback . #f) options)))
|
||||
(execute-deploy-rs machine-name "default" modified-options)))
|
||||
(execute-deploy-rs machine-name "default" options))))
|
||||
|
||||
;; Update flake inputs (moved from old deployment module)
|
||||
(define (update-flake . args)
|
||||
"Update flake inputs (impure - has side effects)"
|
||||
(let* ((options (if (null? args) '() (car args)))
|
||||
(dry-run (option-ref options 'dry-run #f)))
|
||||
|
||||
(log-info "Updating flake inputs...")
|
||||
|
||||
(if dry-run
|
||||
(begin
|
||||
(log-info "DRY RUN: Would execute: nix flake update")
|
||||
#t)
|
||||
(let* ((homelab-root (get-homelab-root))
|
||||
(update-cmd (format #f "cd ~a && nix flake update" homelab-root))
|
||||
(port (open-pipe* OPEN_READ "/bin/sh" "-c" update-cmd))
|
||||
(output (get-string-all port))
|
||||
(status (close-pipe port)))
|
||||
|
||||
(if (zero? status)
|
||||
(begin
|
||||
(log-success "Flake inputs updated successfully")
|
||||
#t)
|
||||
(begin
|
||||
(log-error "Flake update failed (exit: ~a)" status)
|
||||
(log-error "Error output: ~a" output)
|
||||
#f))))))
|
||||
;; Update flake inputs - delegate to ssh-deploy module
|
||||
(define update-flake
|
||||
(@ (lab ssh-deploy) update-flake))
|
||||
|
|
|
|||
198
packages/lab-tool/lab/ssh-deploy.scm
Normal file
198
packages/lab-tool/lab/ssh-deploy.scm
Normal file
|
|
@ -0,0 +1,198 @@
|
|||
;; lab/ssh-deploy.scm - SSH + rsync + nixos-rebuild deployment operations
|
||||
|
||||
(define-module (lab ssh-deploy)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (utils logging)
|
||||
#:use-module (utils config)
|
||||
#:use-module (utils ssh)
|
||||
#:export (deploy-machine-ssh
|
||||
deploy-all-machines-ssh
|
||||
update-flake
|
||||
sync-config-to-machine
|
||||
option-ref))
|
||||
|
||||
;; Helper function for option handling
|
||||
(define (option-ref options key default)
|
||||
"Get option value with default fallback"
|
||||
(let ((value (assoc-ref options key)))
|
||||
(if value value default)))
|
||||
|
||||
;; Main SSH deployment function
|
||||
(define (deploy-machine-ssh machine-name . args)
|
||||
"Deploy configuration to machine using SSH + rsync + nixos-rebuild"
|
||||
(let* ((mode (if (null? args) "default" (car args)))
|
||||
(options (if (< (length args) 2) '() (cadr args)))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(boot-mode (option-ref options 'boot #f)))
|
||||
|
||||
(if (not (validate-machine-name machine-name))
|
||||
#f
|
||||
(begin
|
||||
(log-info "Starting SSH deployment: ~a" machine-name)
|
||||
(execute-ssh-deploy machine-name mode options)))))
|
||||
|
||||
;; Execute SSH-based deployment
|
||||
(define (execute-ssh-deploy machine-name mode options)
|
||||
"Execute deployment using SSH + rsync + nixos-rebuild"
|
||||
(let* ((homelab-root (get-homelab-root))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(boot-mode (option-ref options 'boot #f))
|
||||
(test-mode (option-ref options 'test #f))
|
||||
(remote-path "/tmp/home-lab-config"))
|
||||
|
||||
(log-info "Deploying ~a using SSH + rsync + nixos-rebuild..." machine-name)
|
||||
|
||||
(if dry-run
|
||||
(begin
|
||||
(log-info "DRY RUN: Would sync config and rebuild ~a" machine-name)
|
||||
(log-info "Would execute: rsync + nixos-rebuild --flake /tmp/home-lab-config#~a" machine-name)
|
||||
#t)
|
||||
(let ((start-time (current-time)))
|
||||
|
||||
;; Step 1: Sync configuration to remote machine
|
||||
(log-info "Step 1: Syncing configuration to ~a:~a" machine-name remote-path)
|
||||
(if (sync-config-to-machine machine-name remote-path)
|
||||
;; Step 2: Execute nixos-rebuild on remote machine
|
||||
(begin
|
||||
(log-info "Step 2: Executing nixos-rebuild on ~a" machine-name)
|
||||
(execute-remote-rebuild machine-name remote-path boot-mode test-mode start-time))
|
||||
(begin
|
||||
(log-error "Failed to sync configuration to ~a" machine-name)
|
||||
#f))))))
|
||||
|
||||
;; Sync configuration to remote machine
|
||||
(define (sync-config-to-machine machine-name remote-path)
|
||||
"Sync Home-lab configuration to remote machine using rsync"
|
||||
(let* ((homelab-root (get-homelab-root))
|
||||
(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 "sync" - just ensure path exists
|
||||
(begin
|
||||
(log-debug "Local machine ~a, copying to ~a" machine-name remote-path)
|
||||
(let* ((cp-cmd (format #f "sudo mkdir -p ~a && sudo cp -r ~a/* ~a/"
|
||||
remote-path homelab-root remote-path))
|
||||
(status (system cp-cmd)))
|
||||
(if (zero? status)
|
||||
(begin
|
||||
(log-debug "Local configuration copied successfully")
|
||||
#t)
|
||||
(begin
|
||||
(log-error "Local configuration copy failed (exit: ~a)" status)
|
||||
#f))))
|
||||
;; Remote sync using rsync
|
||||
(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 (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) ""))
|
||||
(rsync-cmd (format #f "rsync -avz --delete -e 'ssh ~a' ~a/ ~a:~a/"
|
||||
key-arg homelab-root target remote-path)))
|
||||
|
||||
(log-debug "Rsync command: ~a" rsync-cmd)
|
||||
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" rsync-cmd))
|
||||
(output (get-string-all port))
|
||||
(status (close-pipe port)))
|
||||
|
||||
(if (zero? status)
|
||||
(begin
|
||||
(log-debug "Configuration synced successfully")
|
||||
(log-debug "Rsync output: ~a" output)
|
||||
#t)
|
||||
(begin
|
||||
(log-error "Configuration sync failed (exit: ~a)" status)
|
||||
(log-error "Rsync error: ~a" output)
|
||||
#f))))))))
|
||||
|
||||
;; Execute nixos-rebuild on remote machine
|
||||
(define (execute-remote-rebuild machine-name remote-path boot-mode test-mode start-time)
|
||||
"Execute nixos-rebuild on the remote machine"
|
||||
(let* ((rebuild-mode (cond
|
||||
(test-mode "test")
|
||||
(boot-mode "boot")
|
||||
(else "switch")))
|
||||
(rebuild-cmd (format #f "sudo nixos-rebuild ~a --flake ~a#~a"
|
||||
rebuild-mode remote-path machine-name)))
|
||||
|
||||
(log-info "Executing: ~a" rebuild-cmd)
|
||||
|
||||
(call-with-values
|
||||
(lambda () (run-remote-command machine-name rebuild-cmd))
|
||||
(lambda (success output)
|
||||
(let ((elapsed (- (current-time) start-time)))
|
||||
(if success
|
||||
(begin
|
||||
(log-success "SSH deployment completed successfully in ~as" elapsed)
|
||||
(log-info "Rebuild output:")
|
||||
(log-info "~a" output)
|
||||
#t)
|
||||
(begin
|
||||
(log-error "SSH deployment failed (exit code indicates failure)")
|
||||
(log-error "Rebuild error output:")
|
||||
(log-error "~a" output)
|
||||
#f)))))))
|
||||
|
||||
;; Deploy to all machines using SSH
|
||||
(define (deploy-all-machines-ssh . args)
|
||||
"Deploy to all machines using SSH + rsync + nixos-rebuild"
|
||||
(let* ((options (if (null? args) '() (car args)))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(machines (get-all-machines)))
|
||||
|
||||
(log-info "Starting SSH deployment to all machines (~a total)" (length machines))
|
||||
|
||||
(let ((results
|
||||
(map (lambda (machine)
|
||||
(log-info "Deploying to ~a..." machine)
|
||||
(let ((result (deploy-machine-ssh machine "default" options)))
|
||||
(if result
|
||||
(log-success "✓ ~a deployed successfully" machine)
|
||||
(log-error "✗ ~a deployment failed" machine))
|
||||
(cons machine result)))
|
||||
machines)))
|
||||
|
||||
;; Summary
|
||||
(let ((successful (filter cdr results))
|
||||
(failed (filter (lambda (r) (not (cdr r))) results)))
|
||||
(log-info "SSH deployment summary:")
|
||||
(log-info " Successful: ~a/~a machines" (length successful) (length machines))
|
||||
(when (not (null? failed))
|
||||
(log-error " Failed: ~a" (string-join (map car failed) ", ")))
|
||||
|
||||
;; Return true if all succeeded
|
||||
(= (length successful) (length machines))))))
|
||||
|
||||
;; Update flake inputs
|
||||
(define (update-flake . args)
|
||||
"Update flake inputs (impure - has side effects)"
|
||||
(let* ((options (if (null? args) '() (car args)))
|
||||
(dry-run (option-ref options 'dry-run #f)))
|
||||
|
||||
(log-info "Updating flake inputs...")
|
||||
|
||||
(if dry-run
|
||||
(begin
|
||||
(log-info "DRY RUN: Would execute: nix flake update")
|
||||
#t)
|
||||
(let* ((homelab-root (get-homelab-root))
|
||||
(update-cmd (format #f "cd ~a && nix flake update" homelab-root))
|
||||
(port (open-pipe* OPEN_READ "/bin/sh" "-c" update-cmd))
|
||||
(output (get-string-all port))
|
||||
(status (close-pipe port)))
|
||||
|
||||
(if (zero? status)
|
||||
(begin
|
||||
(log-success "Flake inputs updated successfully")
|
||||
#t)
|
||||
(begin
|
||||
(log-error "Flake update failed (exit: ~a)" status)
|
||||
(log-error "Error output: ~a" output)
|
||||
#f))))))
|
||||
|
|
@ -1,326 +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 - Deploy-rs Edition
|
||||
|
||||
USAGE: lab <command> [args...]
|
||||
|
||||
COMMANDS:
|
||||
status Show infrastructure status
|
||||
machines List all machines
|
||||
deploy <machine> [options] Deploy configuration to machine using deploy-rs
|
||||
Options: --dry-run, --skip-checks
|
||||
deploy-all [options] Deploy to all machines using deploy-rs
|
||||
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
|
||||
help Show this help
|
||||
|
||||
EXAMPLES:
|
||||
lab status
|
||||
lab machines
|
||||
lab deploy congenital-optimist # Deploy with deploy-rs safety
|
||||
lab deploy sleeper-service --dry-run # Test deployment without applying
|
||||
lab deploy grey-area --skip-checks # Deploy without health checks
|
||||
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
|
||||
lab ssh sleeper-service # SSH to machine as sma user
|
||||
|
||||
Deploy-rs Features:
|
||||
- Automatic rollback on deployment failure
|
||||
- Health checks after deployment
|
||||
- Magic rollback for network connectivity issues
|
||||
- Atomic deployments with safety guarantees
|
||||
- Consistent sma user for all deployments
|
||||
|
||||
This implementation uses deploy-rs for all deployments:
|
||||
- Robust: Automatic rollback protection
|
||||
- Safe: Health checks and validation
|
||||
- Consistent: Same deployment method for all machines
|
||||
- Flexible: Dry-run and skip-checks options 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
1
packages/lab-tool/main/cli.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; main/cli.scm - Pure CLI parsing
|
||||
1
packages/lab-tool/main/dispatcher.scm
Normal file
1
packages/lab-tool/main/dispatcher.scm
Normal file
|
|
@ -0,0 +1 @@
|
|||
;; main/dispatcher.scm - Pure command dispatch
|
||||
96
packages/lab-tool/main/runner.scm
Normal file
96
packages/lab-tool/main/runner.scm
Normal 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)))))
|
||||
|
|
@ -1,148 +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)
|
||||
(ssh-user . ,ssh-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)
|
||||
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue