diff --git a/packages/lab-tool/REFACTOR_PLAN.md b/packages/lab-tool/REFACTOR_PLAN.md deleted file mode 100644 index 6efdb0a..0000000 --- a/packages/lab-tool/REFACTOR_PLAN.md +++ /dev/null @@ -1,95 +0,0 @@ -# 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! \ No newline at end of file diff --git a/packages/lab-tool/lab-old/config/config.scm b/packages/lab-tool/config/config.scm similarity index 100% rename from packages/lab-tool/lab-old/config/config.scm rename to packages/lab-tool/config/config.scm diff --git a/packages/lab-tool/lab-old/config/lab-auto-update.service b/packages/lab-tool/config/lab-auto-update.service similarity index 100% rename from packages/lab-tool/lab-old/config/lab-auto-update.service rename to packages/lab-tool/config/lab-auto-update.service diff --git a/packages/lab-tool/core/commands.scm b/packages/lab-tool/core/commands.scm deleted file mode 100644 index 4b15480..0000000 --- a/packages/lab-tool/core/commands.scm +++ /dev/null @@ -1,53 +0,0 @@ -;; 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)) diff --git a/packages/lab-tool/core/config.scm b/packages/lab-tool/core/config.scm deleted file mode 100644 index d553c7d..0000000 --- a/packages/lab-tool/core/config.scm +++ /dev/null @@ -1,81 +0,0 @@ -;; 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")) diff --git a/packages/lab-tool/default.nix b/packages/lab-tool/default.nix index c4e81b8..39be92d 100644 --- a/packages/lab-tool/default.nix +++ b/packages/lab-tool/default.nix @@ -12,8 +12,8 @@ nixos-rebuild, }: stdenv.mkDerivation { - pname = "lab"; - version = "0.1.0-dev"; + pname = "lab-tool"; + version = "0.2.0"; 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/ + cp -r . $out/share/guile/site/3.0/lab-tool/ # 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:${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" "$@" + 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" "\$@" 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:${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)" + 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)" EOF chmod +x $out/bin/lab-mcp-server diff --git a/packages/lab-tool/deploy/default.scm b/packages/lab-tool/deploy/default.scm deleted file mode 100644 index e69de29..0000000 diff --git a/packages/lab-tool/deploy/executor.scm b/packages/lab-tool/deploy/executor.scm deleted file mode 100644 index d937a19..0000000 --- a/packages/lab-tool/deploy/executor.scm +++ /dev/null @@ -1,70 +0,0 @@ -;; 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)) \ No newline at end of file diff --git a/packages/lab-tool/deploy/ssh-strategy.scm b/packages/lab-tool/deploy/ssh-strategy.scm deleted file mode 100644 index 2204067..0000000 --- a/packages/lab-tool/deploy/ssh-strategy.scm +++ /dev/null @@ -1,71 +0,0 @@ -;; 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))) diff --git a/packages/lab-tool/health/checks.scm b/packages/lab-tool/health/checks.scm deleted file mode 100644 index ab40e3e..0000000 --- a/packages/lab-tool/health/checks.scm +++ /dev/null @@ -1 +0,0 @@ -;; health/checks.scm - Pure health check logic diff --git a/packages/lab-tool/health/monitor.scm b/packages/lab-tool/health/monitor.scm deleted file mode 100644 index 69697e0..0000000 --- a/packages/lab-tool/health/monitor.scm +++ /dev/null @@ -1 +0,0 @@ -;; health/monitor.scm - Impure health monitoring diff --git a/packages/lab-tool/io/rsync.scm b/packages/lab-tool/io/rsync.scm deleted file mode 100644 index 55f857e..0000000 --- a/packages/lab-tool/io/rsync.scm +++ /dev/null @@ -1 +0,0 @@ -;; io/rsync.scm - Impure rsync execution helpers diff --git a/packages/lab-tool/io/shell.scm b/packages/lab-tool/io/shell.scm deleted file mode 100644 index dd2eb2b..0000000 --- a/packages/lab-tool/io/shell.scm +++ /dev/null @@ -1,36 +0,0 @@ -;; 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))) \ No newline at end of file diff --git a/packages/lab-tool/io/ssh.scm b/packages/lab-tool/io/ssh.scm deleted file mode 100644 index 88e27d9..0000000 --- a/packages/lab-tool/io/ssh.scm +++ /dev/null @@ -1,37 +0,0 @@ -;; 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)) \ No newline at end of file diff --git a/packages/lab-tool/lab-old/io/shell.scm b/packages/lab-tool/lab-old/io/shell.scm deleted file mode 100644 index b25e6f4..0000000 --- a/packages/lab-tool/lab-old/io/shell.scm +++ /dev/null @@ -1 +0,0 @@ -;; backup of old io/shell.scm diff --git a/packages/lab-tool/lab-old/io/ssh.scm b/packages/lab-tool/lab-old/io/ssh.scm deleted file mode 100644 index 5dd2a73..0000000 --- a/packages/lab-tool/lab-old/io/ssh.scm +++ /dev/null @@ -1 +0,0 @@ -;; backup of old io/ssh.scm diff --git a/packages/lab-tool/lab-old/lab/auto-update.scm b/packages/lab-tool/lab-old/lab/auto-update.scm deleted file mode 100644 index 0adf345..0000000 --- a/packages/lab-tool/lab-old/lab/auto-update.scm +++ /dev/null @@ -1 +0,0 @@ -;; backup of old lab/auto-update.scm diff --git a/packages/lab-tool/lab-old/lab/core.scm b/packages/lab-tool/lab-old/lab/core.scm deleted file mode 100644 index cb310fb..0000000 --- a/packages/lab-tool/lab-old/lab/core.scm +++ /dev/null @@ -1 +0,0 @@ -;; backup of old lab/core.scm diff --git a/packages/lab-tool/lab-old/lab/deploy-rs.scm b/packages/lab-tool/lab-old/lab/deploy-rs.scm deleted file mode 100644 index a6d4bb6..0000000 --- a/packages/lab-tool/lab-old/lab/deploy-rs.scm +++ /dev/null @@ -1 +0,0 @@ -;; backup of old lab/deploy-rs.scm diff --git a/packages/lab-tool/lab-old/lab/deployment.scm b/packages/lab-tool/lab-old/lab/deployment.scm deleted file mode 100644 index 921924d..0000000 --- a/packages/lab-tool/lab-old/lab/deployment.scm +++ /dev/null @@ -1 +0,0 @@ -;; backup of old lab/deployment.scm diff --git a/packages/lab-tool/lab-old/lab/machines.scm b/packages/lab-tool/lab-old/lab/machines.scm deleted file mode 100644 index 13608d2..0000000 --- a/packages/lab-tool/lab-old/lab/machines.scm +++ /dev/null @@ -1 +0,0 @@ -;; backup of old lab/machines.scm diff --git a/packages/lab-tool/lab-old/lab/monitoring.scm b/packages/lab-tool/lab-old/lab/monitoring.scm deleted file mode 100644 index a3221bb..0000000 --- a/packages/lab-tool/lab-old/lab/monitoring.scm +++ /dev/null @@ -1 +0,0 @@ -;; backup of old lab/monitoring.scm diff --git a/packages/lab-tool/lab-old/lab/ssh-deploy.scm b/packages/lab-tool/lab-old/lab/ssh-deploy.scm deleted file mode 100644 index a3724ef..0000000 --- a/packages/lab-tool/lab-old/lab/ssh-deploy.scm +++ /dev/null @@ -1 +0,0 @@ -;; backup of old lab/ssh-deploy.scm diff --git a/packages/lab-tool/lab-old/main.scm b/packages/lab-tool/lab-old/main.scm deleted file mode 100644 index 6f2e378..0000000 --- a/packages/lab-tool/lab-old/main.scm +++ /dev/null @@ -1,78 +0,0 @@ -;; 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 [args...] - -COMMANDS: - status Show infrastructure status - machines List all machines - deploy [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 SSH to machine (using sma user) - test-rollback 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... diff --git a/packages/lab-tool/lab-old/utils/config.scm b/packages/lab-tool/lab-old/utils/config.scm deleted file mode 100644 index f9bb666..0000000 --- a/packages/lab-tool/lab-old/utils/config.scm +++ /dev/null @@ -1,69 +0,0 @@ -;; 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))) diff --git a/packages/lab-tool/lab-old/utils/ssh.scm b/packages/lab-tool/lab-old/utils/ssh.scm deleted file mode 100644 index 2ba6049..0000000 --- a/packages/lab-tool/lab-old/utils/ssh.scm +++ /dev/null @@ -1,188 +0,0 @@ -;; 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))) \ No newline at end of file diff --git a/packages/lab-tool/lab/deploy-rs.scm b/packages/lab-tool/lab/deploy-rs.scm deleted file mode 100644 index 1b558ce..0000000 --- a/packages/lab-tool/lab/deploy-rs.scm +++ /dev/null @@ -1,140 +0,0 @@ -;; 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)))) \ No newline at end of file diff --git a/packages/lab-tool/lab/deployment.scm b/packages/lab-tool/lab/deployment.scm index 47275c9..fedb748 100644 --- a/packages/lab-tool/lab/deployment.scm +++ b/packages/lab-tool/lab/deployment.scm @@ -1,4 +1,4 @@ -;; lab/deployment.scm - Unified deployment operations (SSH + rsync by default) +;; lab/deployment.scm - Deploy-rs based deployment operations (define-module (lab deployment) #:use-module (ice-9 format) @@ -7,60 +7,162 @@ #: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 (re-exported from ssh-deploy) +;; 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 - SSH by default, deploy-rs optional +;; Main deployment function using deploy-rs (define (deploy-machine machine-name . args) - "Deploy configuration to machine using SSH + rsync (default) or deploy-rs (optional)" + "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))) - (use-deploy-rs (option-ref options 'use-deploy-rs #f))) + (dry-run (option-ref options 'dry-run #f)) + (skip-checks (option-ref options 'skip-checks #f))) (if (not (validate-machine-name machine-name)) #f - (if use-deploy-rs - (begin - (log-info "Using deploy-rs deployment method") - (deploy-machine-deploy-rs machine-name mode options)) - (begin - (log-info "Using SSH + rsync deployment method") - (deploy-machine-ssh machine-name mode options)))))) + (begin + (log-info "Starting deploy-rs deployment: ~a" machine-name) + (execute-deploy-rs machine-name mode options))))) -;; Deploy to all machines - delegate to appropriate module +;; 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 . args) - "Deploy to all machines using SSH + rsync (default) or deploy-rs (optional)" + "Deploy to all machines using deploy-rs" (let* ((options (if (null? args) '() (car args))) - (use-deploy-rs (option-ref options 'use-deploy-rs #f))) + (dry-run (option-ref options 'dry-run #f)) + (machines (get-all-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))))) + (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 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 rollback testing - only available with deploy-rs +;; Deploy with explicit rollback testing (define (deploy-with-rollback machine-name . args) - "Deploy with explicit rollback capability testing (deploy-rs only)" + "Deploy with explicit rollback capability testing" (let* ((options (if (null? args) '() (car args))) - (modified-options (cons '(use-deploy-rs . #t) options))) + (test-rollback (option-ref options 'test-rollback #f))) - (log-info "Rollback testing requires deploy-rs - switching to deploy-rs mode") - (deploy-with-rollback machine-name modified-options))) + (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)))) -;; Update flake inputs - delegate to ssh-deploy module -(define update-flake - (@ (lab ssh-deploy) update-flake)) +;; 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)))))) diff --git a/packages/lab-tool/lab/ssh-deploy.scm b/packages/lab-tool/lab/ssh-deploy.scm deleted file mode 100644 index ae82a92..0000000 --- a/packages/lab-tool/lab/ssh-deploy.scm +++ /dev/null @@ -1,198 +0,0 @@ -;; 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)))))) \ No newline at end of file diff --git a/packages/lab-tool/main.scm b/packages/lab-tool/main.scm index 3f3f2cc..15803b6 100755 --- a/packages/lab-tool/main.scm +++ b/packages/lab-tool/main.scm @@ -1,8 +1,326 @@ #!/usr/bin/env guile !# -;; Home Lab Tool - Entrypoint +;; Home Lab Tool - Main Entry Point +;; K.I.S.S Refactored Implementation -(use-modules (main runner)) +;; Load path is set by the wrapper script in default.nix +;; No need to add current directory when running from Nix -(main) +(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 [args...] + +COMMANDS: + status Show infrastructure status + machines List all machines + deploy [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 SSH to machine (using sma user) + test-rollback 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 [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 \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 \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 \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))) \ No newline at end of file diff --git a/packages/lab-tool/main/cli.scm b/packages/lab-tool/main/cli.scm deleted file mode 100644 index 612362d..0000000 --- a/packages/lab-tool/main/cli.scm +++ /dev/null @@ -1 +0,0 @@ -;; main/cli.scm - Pure CLI parsing diff --git a/packages/lab-tool/main/dispatcher.scm b/packages/lab-tool/main/dispatcher.scm deleted file mode 100644 index e4ac779..0000000 --- a/packages/lab-tool/main/dispatcher.scm +++ /dev/null @@ -1 +0,0 @@ -;; main/dispatcher.scm - Pure command dispatch diff --git a/packages/lab-tool/main/runner.scm b/packages/lab-tool/main/runner.scm deleted file mode 100644 index dbc45b5..0000000 --- a/packages/lab-tool/main/runner.scm +++ /dev/null @@ -1,96 +0,0 @@ -;; 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 [options]\n") - (display "\nCommands:\n") - (display " update Update flake inputs\n") - (display " deploy 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 [options]\n") - (show-help)) - (else (show-help))))) diff --git a/packages/lab-tool/utils/config.scm b/packages/lab-tool/utils/config.scm new file mode 100644 index 0000000..51abd04 --- /dev/null +++ b/packages/lab-tool/utils/config.scm @@ -0,0 +1,148 @@ +;; 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) diff --git a/packages/lab-tool/lab-old/utils/json.scm b/packages/lab-tool/utils/json.scm similarity index 100% rename from packages/lab-tool/lab-old/utils/json.scm rename to packages/lab-tool/utils/json.scm diff --git a/packages/lab-tool/lab-old/utils/logging.scm b/packages/lab-tool/utils/logging.scm similarity index 100% rename from packages/lab-tool/lab-old/utils/logging.scm rename to packages/lab-tool/utils/logging.scm diff --git a/packages/lab-tool/utils/ssh.scm b/packages/lab-tool/utils/ssh.scm new file mode 100644 index 0000000..f6be303 --- /dev/null +++ b/packages/lab-tool/utils/ssh.scm @@ -0,0 +1,149 @@ +;; 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