Compare commits
3 commits
93efaff06e
...
6558540485
Author | SHA1 | Date | |
---|---|---|---|
6558540485 | |||
47c2961033 | |||
bff56e4ffc |
81 changed files with 1557 additions and 5778 deletions
123
documentation/SSH_DEPLOYMENT_STRATEGY.md
Normal file
123
documentation/SSH_DEPLOYMENT_STRATEGY.md
Normal file
|
@ -0,0 +1,123 @@
|
||||||
|
# SSH Deployment Strategy - Unified sma User Approach
|
||||||
|
|
||||||
|
## Overview
|
||||||
|
|
||||||
|
This document outlines the updated SSH deployment strategy for the home lab, standardizing on the `sma` user for all administrative operations and deployments.
|
||||||
|
|
||||||
|
## User Strategy
|
||||||
|
|
||||||
|
### sma User (System Administrator)
|
||||||
|
- **Purpose**: System administration, deployment, maintenance
|
||||||
|
- **SSH Key**: `id_ed25519_admin`
|
||||||
|
- **Privileges**: sudo NOPASSWD, wheel group
|
||||||
|
- **Usage**: All lab tool deployments, system maintenance
|
||||||
|
|
||||||
|
### geir User (Developer)
|
||||||
|
- **Purpose**: Development work, daily usage, git operations
|
||||||
|
- **SSH Key**: `id_ed25519_dev`
|
||||||
|
- **Privileges**: Standard user with development tools
|
||||||
|
- **Usage**: Development workflows, git operations
|
||||||
|
|
||||||
|
## Deployment Workflow
|
||||||
|
|
||||||
|
### From Any Machine (Workstation or Laptop)
|
||||||
|
|
||||||
|
1. **Both machines have sma user configured** with admin SSH key
|
||||||
|
2. **Lab tool uses sma user consistently** for all remote operations
|
||||||
|
3. **Deploy-rs uses sma user** for automated deployments with rollback
|
||||||
|
|
||||||
|
### SSH Configuration
|
||||||
|
|
||||||
|
The SSH configuration supports both direct access patterns:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
# Direct Tailscale access with sma user
|
||||||
|
ssh sma@sleeper-service.tail807ea.ts.net
|
||||||
|
ssh sma@grey-area.tail807ea.ts.net
|
||||||
|
ssh sma@reverse-proxy.tail807ea.ts.net
|
||||||
|
ssh sma@little-rascal.tail807ea.ts.net
|
||||||
|
|
||||||
|
# Local sma user (for deployment from laptop to workstation)
|
||||||
|
ssh sma@localhost
|
||||||
|
```
|
||||||
|
|
||||||
|
## Lab Tool Commands
|
||||||
|
|
||||||
|
All lab commands now work consistently from both machines:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
# Status checking
|
||||||
|
lab status # Works from both workstation and laptop
|
||||||
|
|
||||||
|
# Deployment (using sma user automatically)
|
||||||
|
lab deploy sleeper-service # Works from both machines
|
||||||
|
lab deploy grey-area # Works from both machines
|
||||||
|
lab deploy little-rascal # Deploy TO laptop FROM workstation
|
||||||
|
lab deploy congenital-optimist # Deploy TO workstation FROM laptop
|
||||||
|
|
||||||
|
# Deploy-rs (with automatic rollback)
|
||||||
|
lab deploy-rs sleeper-service
|
||||||
|
lab hybrid-update all
|
||||||
|
```
|
||||||
|
|
||||||
|
## Security Benefits
|
||||||
|
|
||||||
|
1. **Principle of Least Privilege**: sma user only for admin tasks
|
||||||
|
2. **Key Separation**: Admin and development keys are separate
|
||||||
|
3. **Consistent Access**: Same user across all machines for deployment
|
||||||
|
4. **Audit Trail**: Clear separation between admin and development activities
|
||||||
|
|
||||||
|
## Machine-Specific Notes
|
||||||
|
|
||||||
|
### congenital-optimist (Workstation)
|
||||||
|
- **Type**: Local deployment
|
||||||
|
- **SSH**: Uses localhost with sma user for consistency
|
||||||
|
- **Primary Use**: Development and deployment hub
|
||||||
|
|
||||||
|
### little-rascal (Laptop)
|
||||||
|
- **Type**: Remote deployment
|
||||||
|
- **SSH**: Tailscale hostname with sma user
|
||||||
|
- **Primary Use**: Mobile development and deployment
|
||||||
|
|
||||||
|
### Remote Servers (sleeper-service, grey-area, reverse-proxy)
|
||||||
|
- **Type**: Remote deployment
|
||||||
|
- **SSH**: Tailscale hostnames with sma user
|
||||||
|
- **Access**: Both workstation and laptop can deploy
|
||||||
|
|
||||||
|
## Migration Benefits
|
||||||
|
|
||||||
|
1. **Simplified Workflow**: Same commands work from both machines
|
||||||
|
2. **Better Security**: Dedicated admin user for all system operations
|
||||||
|
3. **Consistency**: All deployments use the same SSH user pattern
|
||||||
|
4. **Flexibility**: Can deploy from either workstation or laptop seamlessly
|
||||||
|
|
||||||
|
## Testing the Setup
|
||||||
|
|
||||||
|
```bash
|
||||||
|
# Test SSH connectivity with sma user
|
||||||
|
ssh sma@sleeper-service.tail807ea.ts.net echo "Connection OK"
|
||||||
|
ssh sma@grey-area.tail807ea.ts.net echo "Connection OK"
|
||||||
|
ssh sma@little-rascal.tail807ea.ts.net echo "Connection OK"
|
||||||
|
|
||||||
|
# Test lab tool
|
||||||
|
lab status # Should show all machines
|
||||||
|
lab deploy sleeper-service # Should work with sma user
|
||||||
|
|
||||||
|
# Test deploy-rs
|
||||||
|
lab deploy-rs sleeper-service --dry-run
|
||||||
|
```
|
||||||
|
|
||||||
|
## Implementation Status
|
||||||
|
|
||||||
|
- ✅ SSH keys configured for sma user on all machines
|
||||||
|
- ✅ Lab tool updated to use sma user for all operations
|
||||||
|
- ✅ Deploy-rs configuration updated to use sma user
|
||||||
|
- ✅ SSH client configuration updated with proper host patterns
|
||||||
|
- 📋 Ready for testing and validation
|
||||||
|
|
||||||
|
## Next Steps
|
||||||
|
|
||||||
|
1. Test SSH connectivity from both machines to all targets
|
||||||
|
2. Validate lab tool deployment commands
|
||||||
|
3. Test deploy-rs functionality with sma user
|
||||||
|
4. Update any remaining scripts that might use old SSH patterns
|
205
dotfiles/geir/emacs-config/init-nix.el
Normal file
205
dotfiles/geir/emacs-config/init-nix.el
Normal file
|
@ -0,0 +1,205 @@
|
||||||
|
;;; init.el --- Nix-integrated modular Emacs configuration -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;; A Nix-integrated, modular Emacs configuration that leverages Nix-provided tools
|
||||||
|
;; and packages where possible, falling back to Emacs package manager only when needed.
|
||||||
|
;; Core setup: UI, Nix integration, modular loading
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
;; Performance optimizations
|
||||||
|
(setq gc-cons-threshold (* 50 1000 1000))
|
||||||
|
(add-hook 'emacs-startup-hook
|
||||||
|
(lambda ()
|
||||||
|
(setq gc-cons-threshold (* 2 1000 1000))
|
||||||
|
(let ((profile (getenv "EMACS_PROFILE")))
|
||||||
|
(message "Emacs loaded in %s with %d garbage collections (Profile: %s)."
|
||||||
|
(format "%.2f seconds"
|
||||||
|
(float-time
|
||||||
|
(time-subtract after-init-time before-init-time)))
|
||||||
|
gcs-done
|
||||||
|
(or profile "unknown")))))
|
||||||
|
|
||||||
|
;; Basic UI setup - minimal but pleasant
|
||||||
|
(setq inhibit-startup-screen t)
|
||||||
|
(menu-bar-mode -1)
|
||||||
|
(when (fboundp 'tool-bar-mode) (tool-bar-mode -1))
|
||||||
|
(when (fboundp 'scroll-bar-mode) (scroll-bar-mode -1))
|
||||||
|
(set-face-attribute 'default nil :height 140)
|
||||||
|
(setq-default cursor-type 'bar)
|
||||||
|
|
||||||
|
;; Nix Integration Setup
|
||||||
|
;; Configure Emacs to use Nix-provided tools when available
|
||||||
|
(defun nix-tool-path (tool-name)
|
||||||
|
"Get the path to TOOL-NAME from Nix environment variables."
|
||||||
|
(let ((env-var (concat (upcase tool-name) "_PATH")))
|
||||||
|
(getenv env-var)))
|
||||||
|
|
||||||
|
;; Configure external tools to use Nix-provided binaries
|
||||||
|
(when-let ((rg-path (nix-tool-path "rg")))
|
||||||
|
(setq consult-ripgrep-command rg-path))
|
||||||
|
|
||||||
|
(when-let ((ag-path (nix-tool-path "ag")))
|
||||||
|
(setq ag-executable ag-path))
|
||||||
|
|
||||||
|
(when-let ((fd-path (nix-tool-path "fd")))
|
||||||
|
(setq find-program fd-path))
|
||||||
|
|
||||||
|
(when-let ((sqlite-path (nix-tool-path "sqlite")))
|
||||||
|
(setq org-roam-database-connector 'sqlite3)
|
||||||
|
(setq org-roam-db-executable sqlite-path))
|
||||||
|
|
||||||
|
;; Language Server Configuration (for Nix-provided LSP servers)
|
||||||
|
(defun configure-nix-lsp-servers ()
|
||||||
|
"Configure LSP to use Nix-provided language servers."
|
||||||
|
(when (featurep 'lsp-mode)
|
||||||
|
;; Nix LSP server
|
||||||
|
(when-let ((nil-path (nix-tool-path "nil_lsp")))
|
||||||
|
(setq lsp-nix-nil-server-path nil-path))
|
||||||
|
|
||||||
|
;; Bash LSP server
|
||||||
|
(when-let ((bash-lsp-path (nix-tool-path "bash_lsp")))
|
||||||
|
(setq lsp-bash-language-server-path bash-lsp-path))
|
||||||
|
|
||||||
|
;; YAML LSP server
|
||||||
|
(when-let ((yaml-lsp-path (nix-tool-path "yaml_lsp")))
|
||||||
|
(setq lsp-yaml-language-server-path yaml-lsp-path))))
|
||||||
|
|
||||||
|
;; Configure format-all to use Nix-provided formatters
|
||||||
|
(defun configure-nix-formatters ()
|
||||||
|
"Configure format-all to use Nix-provided formatters."
|
||||||
|
(when (featurep 'format-all)
|
||||||
|
;; Shellcheck for shell scripts
|
||||||
|
(when-let ((shellcheck-path (nix-tool-path "shellcheck")))
|
||||||
|
(setq format-all-formatters
|
||||||
|
(cons `(sh (shellcheck ,shellcheck-path))
|
||||||
|
format-all-formatters)))))
|
||||||
|
|
||||||
|
;; Package management setup
|
||||||
|
;; Note: With Nix integration, we rely less on package.el
|
||||||
|
;; Most packages come pre-installed via the flake
|
||||||
|
(require 'package)
|
||||||
|
(setq package-archives
|
||||||
|
'(("melpa" . "https://melpa.org/packages/")
|
||||||
|
("gnu" . "https://elpa.gnu.org/packages/")))
|
||||||
|
|
||||||
|
;; Only initialize package.el if we're not in a Nix environment
|
||||||
|
;; In Nix environments, packages are pre-installed
|
||||||
|
(unless (getenv "EMACS_PROFILE")
|
||||||
|
(package-initialize)
|
||||||
|
|
||||||
|
;; Install use-package for non-Nix environments
|
||||||
|
(unless (package-installed-p 'use-package)
|
||||||
|
(package-refresh-contents)
|
||||||
|
(package-install 'use-package)))
|
||||||
|
|
||||||
|
;; Configure use-package for Nix integration
|
||||||
|
(require 'use-package)
|
||||||
|
;; Don't auto-install packages in Nix environment - they're pre-provided
|
||||||
|
(setq use-package-always-ensure (not (getenv "EMACS_PROFILE")))
|
||||||
|
|
||||||
|
;; Essential packages that should be available in all profiles
|
||||||
|
(use-package exec-path-from-shell
|
||||||
|
:if (memq window-system '(mac ns x))
|
||||||
|
:config
|
||||||
|
(exec-path-from-shell-initialize)
|
||||||
|
;; Ensure Nix environment is properly inherited
|
||||||
|
(exec-path-from-shell-copy-envs '("NIX_PATH" "NIX_EMACS_PROFILE")))
|
||||||
|
|
||||||
|
(use-package diminish)
|
||||||
|
(use-package bind-key)
|
||||||
|
|
||||||
|
;; Basic editing improvements
|
||||||
|
(use-package which-key
|
||||||
|
:config
|
||||||
|
(which-key-mode 1))
|
||||||
|
|
||||||
|
;; Load profile-specific configuration based on Nix profile
|
||||||
|
(defun load-profile-config ()
|
||||||
|
"Load configuration specific to the current Nix profile."
|
||||||
|
(let ((profile (getenv "EMACS_PROFILE")))
|
||||||
|
(pcase profile
|
||||||
|
("server"
|
||||||
|
(message "Loading minimal server configuration...")
|
||||||
|
;; Minimal config - only essential features
|
||||||
|
(setq gc-cons-threshold (* 2 1000 1000))) ; Lower memory usage
|
||||||
|
|
||||||
|
("laptop"
|
||||||
|
(message "Loading laptop development configuration...")
|
||||||
|
;; Laptop config - balanced features
|
||||||
|
(setq auto-save-timeout 30) ; More frequent saves
|
||||||
|
(setq lsp-idle-delay 0.3)) ; Moderate LSP responsiveness
|
||||||
|
|
||||||
|
("workstation"
|
||||||
|
(message "Loading workstation configuration...")
|
||||||
|
;; Workstation config - maximum performance
|
||||||
|
(setq gc-cons-threshold (* 50 1000 1000)) ; Higher performance
|
||||||
|
(setq lsp-idle-delay 0.1)) ; Fastest LSP response
|
||||||
|
|
||||||
|
(_
|
||||||
|
(message "Loading default configuration...")))))
|
||||||
|
|
||||||
|
;; Apply profile-specific settings
|
||||||
|
(load-profile-config)
|
||||||
|
|
||||||
|
;; Configure Nix integration after packages are loaded
|
||||||
|
(add-hook 'after-init-hook #'configure-nix-lsp-servers)
|
||||||
|
(add-hook 'after-init-hook #'configure-nix-formatters)
|
||||||
|
|
||||||
|
;; Org mode basic setup (always included)
|
||||||
|
(use-package org
|
||||||
|
:config
|
||||||
|
(setq org-startup-indented t)
|
||||||
|
(setq org-hide-emphasis-markers t))
|
||||||
|
|
||||||
|
;; Module loading system
|
||||||
|
;; Load modules based on availability and profile
|
||||||
|
(defvar my-modules-dir
|
||||||
|
(if (getenv "EMACS_PROFILE")
|
||||||
|
"/etc/emacs/modules/" ; System modules for Nix environment
|
||||||
|
(expand-file-name "modules/" user-emacs-directory)) ; User modules for non-Nix
|
||||||
|
"Directory containing modular configuration files.")
|
||||||
|
|
||||||
|
(defun load-module (module-name)
|
||||||
|
"Load MODULE-NAME from the modules directory."
|
||||||
|
(let ((module-file (expand-file-name (concat module-name ".el") my-modules-dir)))
|
||||||
|
(when (file-exists-p module-file)
|
||||||
|
(load-file module-file)
|
||||||
|
(message "Loaded module: %s" module-name))))
|
||||||
|
|
||||||
|
;; Load modules based on profile
|
||||||
|
(let ((profile (getenv "EMACS_PROFILE")))
|
||||||
|
(pcase profile
|
||||||
|
("nox"
|
||||||
|
;; Minimal modules for terminal use
|
||||||
|
(load-module "completion")
|
||||||
|
(load-module "navigation")
|
||||||
|
(load-module "development")
|
||||||
|
(load-module "elisp-development"))
|
||||||
|
|
||||||
|
("gui"
|
||||||
|
;; Full module set for GUI development
|
||||||
|
(load-module "ui")
|
||||||
|
(load-module "completion")
|
||||||
|
(load-module "navigation")
|
||||||
|
(load-module "development")
|
||||||
|
(load-module "elisp-development")
|
||||||
|
(load-module "claude-code"))
|
||||||
|
|
||||||
|
(_
|
||||||
|
;; Default module loading (non-Nix environment)
|
||||||
|
(load-module "ui")
|
||||||
|
(load-module "completion")
|
||||||
|
(load-module "navigation"))))
|
||||||
|
|
||||||
|
;; Display startup information
|
||||||
|
(add-hook 'emacs-startup-hook
|
||||||
|
(lambda ()
|
||||||
|
(let ((profile (getenv "EMACS_PROFILE")))
|
||||||
|
(message "=== Emacs Ready ===")
|
||||||
|
(message "Profile: %s" (or profile "default"))
|
||||||
|
(message "Nix Integration: %s" (if profile "enabled" "disabled"))
|
||||||
|
(message "Modules loaded based on profile")
|
||||||
|
(message "==================="))))
|
||||||
|
|
||||||
|
;;; init.el ends here
|
126
dotfiles/geir/emacs-config/modules/claude-code.el
Normal file
126
dotfiles/geir/emacs-config/modules/claude-code.el
Normal file
|
@ -0,0 +1,126 @@
|
||||||
|
;;; claude-code.el --- Claude Code CLI integration module -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;; Integration with Claude Code CLI for AI-assisted coding directly in Emacs
|
||||||
|
;; Provides terminal interface and commands for interacting with Claude AI
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
;; Install claude-code via quelpa if not already installed
|
||||||
|
(unless (package-installed-p 'claude-code)
|
||||||
|
(quelpa '(claude-code :fetcher github :repo "stevemolitor/claude-code.el")))
|
||||||
|
|
||||||
|
;; Claude Code - AI assistant integration
|
||||||
|
(use-package claude-code
|
||||||
|
:ensure nil ; Already installed via quelpa
|
||||||
|
:bind-keymap ("C-c C-c" . claude-code-command-map)
|
||||||
|
:bind (("C-c C-c c" . claude-code)
|
||||||
|
("C-c C-c s" . claude-code-send-command)
|
||||||
|
("C-c C-c r" . claude-code-send-region)
|
||||||
|
("C-c C-c b" . claude-code-send-buffer)
|
||||||
|
("C-c C-c e" . claude-code-fix-error-at-point)
|
||||||
|
("C-c C-c t" . claude-code-toggle)
|
||||||
|
("C-c C-c k" . claude-code-kill)
|
||||||
|
("C-c C-c n" . claude-code-new))
|
||||||
|
:custom
|
||||||
|
;; Terminal backend preference (eat is now installed via quelpa)
|
||||||
|
(claude-code-terminal-type 'eat)
|
||||||
|
|
||||||
|
;; Enable desktop notifications
|
||||||
|
(claude-code-notifications t)
|
||||||
|
|
||||||
|
;; Startup delay to ensure proper initialization
|
||||||
|
(claude-code-startup-delay 1.0)
|
||||||
|
|
||||||
|
;; Confirm before killing Claude sessions
|
||||||
|
(claude-code-confirm-kill t)
|
||||||
|
|
||||||
|
;; Use modern keybinding style
|
||||||
|
(claude-code-newline-and-send-style 'modern)
|
||||||
|
|
||||||
|
:config
|
||||||
|
;; Smart terminal detection - eat should be available via quelpa
|
||||||
|
(defun claude-code-detect-best-terminal ()
|
||||||
|
"Detect the best available terminal for Claude Code."
|
||||||
|
(cond
|
||||||
|
((package-installed-p 'eat) 'eat)
|
||||||
|
((and (package-installed-p 'vterm)
|
||||||
|
(or (executable-find "cmake")
|
||||||
|
(file-exists-p "/usr/bin/cmake")
|
||||||
|
(file-exists-p "/nix/store/*/bin/cmake")))
|
||||||
|
'vterm)
|
||||||
|
(t 'eat))) ; fallback to eat, should be installed
|
||||||
|
|
||||||
|
;; Set terminal type based on detection
|
||||||
|
(setq claude-code-terminal-type (claude-code-detect-best-terminal))
|
||||||
|
|
||||||
|
;; Auto-start Claude in project root when opening coding files
|
||||||
|
(defun claude-code-auto-start-maybe ()
|
||||||
|
"Auto-start Claude Code if in a project and not already running."
|
||||||
|
(when (and (derived-mode-p 'prog-mode)
|
||||||
|
(project-current)
|
||||||
|
(not (claude-code-running-p)))
|
||||||
|
(claude-code)))
|
||||||
|
|
||||||
|
;; Optional: Auto-start when opening programming files
|
||||||
|
;; Uncomment the next line if you want this behavior
|
||||||
|
;; (add-hook 'prog-mode-hook #'claude-code-auto-start-maybe)
|
||||||
|
|
||||||
|
;; Add helpful message about Claude Code setup
|
||||||
|
(message "Claude Code module loaded. Use C-c C-c c to start Claude, C-c C-c h for help"))
|
||||||
|
|
||||||
|
;; Terminal emulator for Claude Code (eat installed via quelpa in init.el)
|
||||||
|
(use-package eat
|
||||||
|
:ensure nil ; Already installed via quelpa
|
||||||
|
:custom
|
||||||
|
(eat-term-name "xterm-256color")OB
|
||||||
|
(eat-kill-buffer-on-exit t))
|
||||||
|
|
||||||
|
;; Alternative terminal emulator (if eat fails or user prefers vterm)
|
||||||
|
(use-package vterm
|
||||||
|
:if (and (not (package-installed-p 'eat))
|
||||||
|
(executable-find "cmake"))
|
||||||
|
:custom
|
||||||
|
(vterm-always-compile-module t)
|
||||||
|
(vterm-kill-buffer-on-exit t)
|
||||||
|
(vterm-max-scrollback 10000))
|
||||||
|
|
||||||
|
;; Transient dependency for command menus
|
||||||
|
(use-package transient
|
||||||
|
:ensure t)
|
||||||
|
|
||||||
|
;; Enhanced error handling for Claude Code integration
|
||||||
|
(defun claude-code-send-error-context ()
|
||||||
|
"Send error at point with surrounding context to Claude."
|
||||||
|
(interactive)
|
||||||
|
(if (claude-code-running-p)
|
||||||
|
(let* ((error-line (line-number-at-pos))
|
||||||
|
(start (max 1 (- error-line 5)))
|
||||||
|
(end (min (line-number-at-pos (point-max)) (+ error-line 5)))
|
||||||
|
(context (buffer-substring-no-properties
|
||||||
|
(line-beginning-position (- start error-line))
|
||||||
|
(line-end-position (- end error-line)))))
|
||||||
|
(claude-code-send-command
|
||||||
|
(format "I'm getting an error around line %d. Here's the context:\n\n```%s\n%s\n```\n\nCan you help me fix this?"
|
||||||
|
error-line
|
||||||
|
(or (file-name-extension (buffer-file-name)) "")
|
||||||
|
context)))
|
||||||
|
(message "Claude Code is not running. Start it with C-c C-c c")))
|
||||||
|
|
||||||
|
;; Keybinding for enhanced error context
|
||||||
|
(global-set-key (kbd "C-c C-c x") #'claude-code-send-error-context)
|
||||||
|
|
||||||
|
;; Project-aware Claude instances
|
||||||
|
(defun claude-code-project-instance ()
|
||||||
|
"Start or switch to Claude instance for current project."
|
||||||
|
(interactive)
|
||||||
|
(if-let ((project (project-current)))
|
||||||
|
(let ((default-directory (project-root project)))
|
||||||
|
(claude-code))
|
||||||
|
(claude-code)))
|
||||||
|
|
||||||
|
;; Keybinding for project-specific Claude
|
||||||
|
(global-set-key (kbd "C-c C-c p") #'claude-code-project-instance)
|
||||||
|
|
||||||
|
(provide 'claude-code)
|
||||||
|
;;; claude-code.el ends here
|
55
dotfiles/geir/emacs-config/modules/completion.el
Normal file
55
dotfiles/geir/emacs-config/modules/completion.el
Normal file
|
@ -0,0 +1,55 @@
|
||||||
|
;;; completion.el --- Completion framework configuration -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;; Modern completion with Vertico, Consult, and Corfu
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
;; Vertico - vertical completion UI
|
||||||
|
(use-package vertico
|
||||||
|
:init
|
||||||
|
(vertico-mode)
|
||||||
|
:custom
|
||||||
|
(vertico-cycle t))
|
||||||
|
|
||||||
|
;; Marginalia - rich annotations in minibuffer
|
||||||
|
(use-package marginalia
|
||||||
|
:init
|
||||||
|
(marginalia-mode))
|
||||||
|
|
||||||
|
;; Consult - enhanced search and navigation commands
|
||||||
|
(use-package consult
|
||||||
|
:bind (("C-s" . consult-line)
|
||||||
|
("C-x b" . consult-buffer)
|
||||||
|
("C-x 4 b" . consult-buffer-other-window)
|
||||||
|
("C-x 5 b" . consult-buffer-other-frame)
|
||||||
|
("M-y" . consult-yank-pop)
|
||||||
|
("M-g g" . consult-goto-line)
|
||||||
|
("M-g M-g" . consult-goto-line)
|
||||||
|
("C-x r b" . consult-bookmark)))
|
||||||
|
|
||||||
|
;; Orderless - flexible completion style
|
||||||
|
(use-package orderless
|
||||||
|
:custom
|
||||||
|
(completion-styles '(orderless basic))
|
||||||
|
(completion-category-defaults nil)
|
||||||
|
(completion-category-overrides '((file (styles partial-completion)))))
|
||||||
|
|
||||||
|
;; Corfu - in-buffer completion popup
|
||||||
|
(use-package corfu
|
||||||
|
:custom
|
||||||
|
(corfu-cycle t)
|
||||||
|
(corfu-auto t)
|
||||||
|
(corfu-auto-delay 0.2)
|
||||||
|
(corfu-auto-prefix 2)
|
||||||
|
:init
|
||||||
|
(global-corfu-mode))
|
||||||
|
|
||||||
|
;; Cape - completion at point extensions
|
||||||
|
(use-package cape
|
||||||
|
:init
|
||||||
|
(add-to-list 'completion-at-point-functions #'cape-dabbrev)
|
||||||
|
(add-to-list 'completion-at-point-functions #'cape-file))
|
||||||
|
|
||||||
|
(provide 'completion)
|
||||||
|
;;; completion.el ends here
|
40
dotfiles/geir/emacs-config/modules/development.el
Normal file
40
dotfiles/geir/emacs-config/modules/development.el
Normal file
|
@ -0,0 +1,40 @@
|
||||||
|
;;; development.el --- Development tools configuration -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;; LSP, Copilot, and other development tools
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
;; LSP Mode
|
||||||
|
(use-package lsp-mode
|
||||||
|
:hook ((prog-mode . lsp-deferred))
|
||||||
|
:commands (lsp lsp-deferred)
|
||||||
|
:custom
|
||||||
|
(lsp-keymap-prefix "C-c l")
|
||||||
|
(lsp-idle-delay 0.5)
|
||||||
|
(lsp-log-io nil)
|
||||||
|
(lsp-completion-provider :none) ; Use corfu instead
|
||||||
|
:config
|
||||||
|
(lsp-enable-which-key-integration t))
|
||||||
|
|
||||||
|
;; LSP UI
|
||||||
|
(use-package lsp-ui
|
||||||
|
:after lsp-mode
|
||||||
|
:custom
|
||||||
|
(lsp-ui-doc-enable t)
|
||||||
|
(lsp-ui-doc-position 'bottom)
|
||||||
|
(lsp-ui-sideline-enable t)
|
||||||
|
(lsp-ui-sideline-show-hover nil))
|
||||||
|
|
||||||
|
;; Which Key - helpful for discovering keybindings
|
||||||
|
(use-package which-key
|
||||||
|
:config
|
||||||
|
(which-key-mode 1)
|
||||||
|
(setq which-key-idle-delay 0.3))
|
||||||
|
|
||||||
|
;; Magit - Git interface
|
||||||
|
(use-package magit
|
||||||
|
:bind ("C-x g" . magit-status))
|
||||||
|
|
||||||
|
(provide 'development)
|
||||||
|
;;; development.el ends here
|
164
dotfiles/geir/emacs-config/modules/elisp-development.el
Normal file
164
dotfiles/geir/emacs-config/modules/elisp-development.el
Normal file
|
@ -0,0 +1,164 @@
|
||||||
|
;;; elisp-development.el --- Enhanced Emacs Lisp development setup -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;; Specialized configuration for Emacs Lisp development
|
||||||
|
;; This module provides enhanced development tools specifically for .el files
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
;; Enhanced Emacs Lisp mode with better defaults
|
||||||
|
(use-package elisp-mode
|
||||||
|
:ensure nil ; Built-in package
|
||||||
|
:mode "\\.el\\'"
|
||||||
|
:hook ((emacs-lisp-mode . eldoc-mode)
|
||||||
|
(emacs-lisp-mode . show-paren-mode)
|
||||||
|
(emacs-lisp-mode . electric-pair-mode))
|
||||||
|
:bind (:map emacs-lisp-mode-map
|
||||||
|
("C-c C-e" . eval-last-sexp)
|
||||||
|
("C-c C-b" . eval-buffer)
|
||||||
|
("C-c C-r" . eval-region)
|
||||||
|
("C-c C-d" . describe-function-at-point))
|
||||||
|
:config
|
||||||
|
;; Better indentation
|
||||||
|
(setq lisp-indent-function 'lisp-indent-function)
|
||||||
|
|
||||||
|
;; Show function signatures in minibuffer
|
||||||
|
(eldoc-mode 1))
|
||||||
|
|
||||||
|
;; Enhanced Elisp navigation
|
||||||
|
(use-package elisp-slime-nav
|
||||||
|
:hook (emacs-lisp-mode . elisp-slime-nav-mode)
|
||||||
|
:bind (:map elisp-slime-nav-mode-map
|
||||||
|
("M-." . elisp-slime-nav-find-elisp-thing-at-point)
|
||||||
|
("M-," . pop-tag-mark)))
|
||||||
|
|
||||||
|
;; Better parentheses handling
|
||||||
|
(use-package smartparens
|
||||||
|
:hook (emacs-lisp-mode . smartparens-strict-mode)
|
||||||
|
:config
|
||||||
|
(require 'smartparens-config)
|
||||||
|
(sp-local-pair 'emacs-lisp-mode "'" nil :actions nil)
|
||||||
|
(sp-local-pair 'emacs-lisp-mode "`" nil :actions nil))
|
||||||
|
|
||||||
|
;; Rainbow delimiters for better paren visibility
|
||||||
|
(use-package rainbow-delimiters
|
||||||
|
:hook (emacs-lisp-mode . rainbow-delimiters-mode))
|
||||||
|
|
||||||
|
;; Aggressive indentation
|
||||||
|
(use-package aggressive-indent
|
||||||
|
:hook (emacs-lisp-mode . aggressive-indent-mode))
|
||||||
|
|
||||||
|
;; Enhanced help and documentation
|
||||||
|
(use-package helpful
|
||||||
|
:bind (("C-h f" . helpful-callable)
|
||||||
|
("C-h v" . helpful-variable)
|
||||||
|
("C-h k" . helpful-key)
|
||||||
|
("C-h x" . helpful-command)
|
||||||
|
("C-h ." . helpful-at-point)))
|
||||||
|
|
||||||
|
;; Live examples for Elisp functions
|
||||||
|
(use-package elisp-demos
|
||||||
|
:after helpful
|
||||||
|
:config
|
||||||
|
(advice-add 'helpful-update :after #'elisp-demos-advice-helpful-update))
|
||||||
|
|
||||||
|
;; Package linting
|
||||||
|
(use-package package-lint
|
||||||
|
:commands package-lint-current-buffer)
|
||||||
|
|
||||||
|
;; Flycheck for syntax checking
|
||||||
|
(use-package flycheck
|
||||||
|
:hook (emacs-lisp-mode . flycheck-mode)
|
||||||
|
:config
|
||||||
|
;; Enhanced Emacs Lisp checking
|
||||||
|
(setq flycheck-emacs-lisp-load-path 'inherit))
|
||||||
|
|
||||||
|
;; Checkdoc for documentation linting
|
||||||
|
(use-package checkdoc
|
||||||
|
:ensure nil ; Built-in
|
||||||
|
:commands checkdoc)
|
||||||
|
|
||||||
|
;; Enhanced debugging
|
||||||
|
(use-package edebug
|
||||||
|
:ensure nil ; Built-in
|
||||||
|
:bind (:map emacs-lisp-mode-map
|
||||||
|
("C-c C-x C-d" . edebug-defun)
|
||||||
|
("C-c C-x C-b" . edebug-set-breakpoint)))
|
||||||
|
|
||||||
|
;; Package development helpers
|
||||||
|
(use-package auto-compile
|
||||||
|
:config
|
||||||
|
(auto-compile-on-load-mode)
|
||||||
|
(auto-compile-on-save-mode))
|
||||||
|
|
||||||
|
;; Enhanced REPL interaction
|
||||||
|
(use-package ielm
|
||||||
|
:ensure nil ; Built-in
|
||||||
|
:bind ("C-c C-z" . ielm)
|
||||||
|
:config
|
||||||
|
(add-hook 'ielm-mode-hook 'eldoc-mode))
|
||||||
|
|
||||||
|
;; Highlight defined functions and variables
|
||||||
|
(use-package highlight-defined
|
||||||
|
:hook (emacs-lisp-mode . highlight-defined-mode))
|
||||||
|
|
||||||
|
;; Better search and replace for symbols
|
||||||
|
(use-package expand-region
|
||||||
|
:bind ("C-=" . er/expand-region))
|
||||||
|
|
||||||
|
;; Multiple cursors for batch editing
|
||||||
|
(use-package multiple-cursors
|
||||||
|
:bind (("C-S-c C-S-c" . mc/edit-lines)
|
||||||
|
("C->" . mc/mark-next-like-this)
|
||||||
|
("C-<" . mc/mark-previous-like-this)))
|
||||||
|
|
||||||
|
;; Custom functions for Elisp development
|
||||||
|
(defun elisp-eval-and-replace ()
|
||||||
|
"Evaluate the sexp at point and replace it with its value."
|
||||||
|
(interactive)
|
||||||
|
(backward-kill-sexp)
|
||||||
|
(condition-case nil
|
||||||
|
(prin1 (eval (read (current-kill 0)))
|
||||||
|
(current-buffer))
|
||||||
|
(error (message "Invalid expression")
|
||||||
|
(insert (current-kill 0)))))
|
||||||
|
|
||||||
|
(defun elisp-describe-thing-at-point ()
|
||||||
|
"Show the documentation for the thing at point."
|
||||||
|
(interactive)
|
||||||
|
(let ((thing (symbol-at-point)))
|
||||||
|
(cond
|
||||||
|
((fboundp thing) (describe-function thing))
|
||||||
|
((boundp thing) (describe-variable thing))
|
||||||
|
(t (message "No documentation found for %s" thing)))))
|
||||||
|
|
||||||
|
;; Key bindings for custom functions
|
||||||
|
(define-key emacs-lisp-mode-map (kbd "C-c C-x C-e") 'elisp-eval-and-replace)
|
||||||
|
(define-key emacs-lisp-mode-map (kbd "C-c C-d") 'elisp-describe-thing-at-point)
|
||||||
|
|
||||||
|
;; Project-specific configurations
|
||||||
|
(defun setup-elisp-project ()
|
||||||
|
"Set up development environment for Elisp projects."
|
||||||
|
(interactive)
|
||||||
|
(when (and buffer-file-name
|
||||||
|
(string-match "\\.el\\'" buffer-file-name))
|
||||||
|
;; Add current directory to load-path for local requires
|
||||||
|
(add-to-list 'load-path (file-name-directory buffer-file-name))
|
||||||
|
|
||||||
|
;; Set up package development if this looks like a package
|
||||||
|
(when (or (file-exists-p "Cask")
|
||||||
|
(file-exists-p "Eask")
|
||||||
|
(string-match "-pkg\\.el\\'" buffer-file-name))
|
||||||
|
(message "Elisp package development mode enabled"))))
|
||||||
|
|
||||||
|
(add-hook 'emacs-lisp-mode-hook 'setup-elisp-project)
|
||||||
|
|
||||||
|
;; Better compilation output
|
||||||
|
(add-hook 'emacs-lisp-mode-hook
|
||||||
|
(lambda ()
|
||||||
|
(setq-local compile-command
|
||||||
|
(format "emacs -batch -f batch-byte-compile %s"
|
||||||
|
(shell-quote-argument buffer-file-name)))))
|
||||||
|
|
||||||
|
(provide 'elisp-development)
|
||||||
|
;;; elisp-development.el ends here
|
51
dotfiles/geir/emacs-config/modules/navigation.el
Normal file
51
dotfiles/geir/emacs-config/modules/navigation.el
Normal file
|
@ -0,0 +1,51 @@
|
||||||
|
;;; navigation.el --- Navigation and file management -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;; File navigation, project management, and window management
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
;; Dired improvements
|
||||||
|
(use-package dired
|
||||||
|
:ensure nil
|
||||||
|
:custom
|
||||||
|
(dired-listing-switches "-alhF")
|
||||||
|
(dired-dwim-target t)
|
||||||
|
:config
|
||||||
|
(put 'dired-find-alternate-file 'disabled nil))
|
||||||
|
|
||||||
|
;; Project management
|
||||||
|
(use-package projectile
|
||||||
|
:config
|
||||||
|
(projectile-mode +1)
|
||||||
|
:bind-keymap
|
||||||
|
("C-c p" . projectile-command-map)
|
||||||
|
:custom
|
||||||
|
(projectile-completion-system 'default))
|
||||||
|
|
||||||
|
;; Treemacs - file tree
|
||||||
|
(use-package treemacs
|
||||||
|
:bind (("M-0" . treemacs-select-window)
|
||||||
|
("C-x t 1" . treemacs-delete-other-windows)
|
||||||
|
("C-x t t" . treemacs)
|
||||||
|
("C-x t d" . treemacs-select-directory)
|
||||||
|
("C-x t B" . treemacs-bookmark)
|
||||||
|
("C-x t C-t" . treemacs-find-file)
|
||||||
|
("C-x t M-t" . treemacs-find-tag))
|
||||||
|
:custom
|
||||||
|
(treemacs-width 30))
|
||||||
|
|
||||||
|
;; Ace Window - quick window switching
|
||||||
|
(use-package ace-window
|
||||||
|
:bind ("M-o" . ace-window)
|
||||||
|
:custom
|
||||||
|
(aw-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l)))
|
||||||
|
|
||||||
|
;; Winner mode - window configuration undo/redo
|
||||||
|
(use-package winner
|
||||||
|
:ensure nil
|
||||||
|
:config
|
||||||
|
(winner-mode 1))
|
||||||
|
|
||||||
|
(provide 'navigation)
|
||||||
|
;;; navigation.el ends here
|
32
dotfiles/geir/emacs-config/modules/ui.el
Normal file
32
dotfiles/geir/emacs-config/modules/ui.el
Normal file
|
@ -0,0 +1,32 @@
|
||||||
|
;;; ui.el --- UI configuration module -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;; Enhanced UI configuration - themes, modeline, icons
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
;; Doom themes
|
||||||
|
(use-package doom-themes
|
||||||
|
:config
|
||||||
|
(load-theme 'doom-monokai-pro t)
|
||||||
|
(doom-themes-visual-bell-config)
|
||||||
|
(doom-themes-org-config))
|
||||||
|
|
||||||
|
;; Doom modeline
|
||||||
|
(use-package doom-modeline
|
||||||
|
:init (doom-modeline-mode 1)
|
||||||
|
:custom
|
||||||
|
(doom-modeline-height 15)
|
||||||
|
(doom-modeline-icon t)
|
||||||
|
(doom-modeline-buffer-file-name-style 'truncate-with-project))
|
||||||
|
|
||||||
|
;; All the icons
|
||||||
|
(use-package all-the-icons
|
||||||
|
:if (display-graphic-p)
|
||||||
|
:config
|
||||||
|
;; Install fonts if not already done
|
||||||
|
(unless (find-font (font-spec :name "all-the-icons"))
|
||||||
|
(all-the-icons-install-fonts t)))
|
||||||
|
|
||||||
|
(provide 'ui)
|
||||||
|
;;; ui.el ends here
|
|
@ -261,7 +261,7 @@
|
||||||
profiles.system = {
|
profiles.system = {
|
||||||
user = "root";
|
user = "root";
|
||||||
path = deploy-rs.lib.x86_64-linux.activate.nixos self.nixosConfigurations.little-rascal;
|
path = deploy-rs.lib.x86_64-linux.activate.nixos self.nixosConfigurations.little-rascal;
|
||||||
sshUser = "geir";
|
sshUser = "sma";
|
||||||
sudo = "sudo -u";
|
sudo = "sudo -u";
|
||||||
autoRollback = true;
|
autoRollback = true;
|
||||||
magicRollback = true;
|
magicRollback = true;
|
||||||
|
|
|
@ -33,6 +33,10 @@
|
||||||
|
|
||||||
# Development tools
|
# Development tools
|
||||||
../../modules/development/tools.nix
|
../../modules/development/tools.nix
|
||||||
|
../../modules/development/emacs.nix
|
||||||
|
|
||||||
|
# Emacs with workstation profile
|
||||||
|
../../modules/development/emacs.nix
|
||||||
|
|
||||||
# AI tools
|
# AI tools
|
||||||
../../modules/ai/claude-code.nix
|
../../modules/ai/claude-code.nix
|
||||||
|
@ -61,6 +65,14 @@
|
||||||
];
|
];
|
||||||
};
|
};
|
||||||
|
|
||||||
|
# Emacs workstation configuration
|
||||||
|
services.emacs-profiles = {
|
||||||
|
enable = true;
|
||||||
|
profile = "gui";
|
||||||
|
enableDaemon = true;
|
||||||
|
user = "geir";
|
||||||
|
};
|
||||||
|
|
||||||
# Enable clean seatd/greetd login
|
# Enable clean seatd/greetd login
|
||||||
services.seatd-clean.enable = true;
|
services.seatd-clean.enable = true;
|
||||||
|
|
||||||
|
|
|
@ -16,6 +16,9 @@
|
||||||
../../modules/virtualization/incus.nix
|
../../modules/virtualization/incus.nix
|
||||||
../../modules/users/sma.nix
|
../../modules/users/sma.nix
|
||||||
|
|
||||||
|
# Development (minimal for services host)
|
||||||
|
../../modules/development/emacs.nix
|
||||||
|
|
||||||
# NFS client with ID mapping
|
# NFS client with ID mapping
|
||||||
../../modules/services/nfs-client.nix
|
../../modules/services/nfs-client.nix
|
||||||
|
|
||||||
|
@ -43,6 +46,14 @@
|
||||||
# Disks and Updates
|
# Disks and Updates
|
||||||
services.fstrim.enable = true;
|
services.fstrim.enable = true;
|
||||||
|
|
||||||
|
# Emacs server configuration (minimal for services host)
|
||||||
|
services.emacs-profiles = {
|
||||||
|
enable = true;
|
||||||
|
profile = "nox";
|
||||||
|
enableDaemon = false;
|
||||||
|
user = "sma";
|
||||||
|
};
|
||||||
|
|
||||||
# Mount remote filesystem
|
# Mount remote filesystem
|
||||||
fileSystems."/mnt/remote/media" = {
|
fileSystems."/mnt/remote/media" = {
|
||||||
device = "sleeper-service:/mnt/storage/media";
|
device = "sleeper-service:/mnt/storage/media";
|
||||||
|
|
|
@ -15,7 +15,6 @@
|
||||||
../../modules/common/base.nix
|
../../modules/common/base.nix
|
||||||
../../modules/common/nix.nix
|
../../modules/common/nix.nix
|
||||||
../../modules/common/tty.nix
|
../../modules/common/tty.nix
|
||||||
../../modules/common/emacs.nix
|
|
||||||
|
|
||||||
# Desktop
|
# Desktop
|
||||||
../../modules/desktop/niri.nix
|
../../modules/desktop/niri.nix
|
||||||
|
@ -25,6 +24,7 @@
|
||||||
|
|
||||||
# Development
|
# Development
|
||||||
../../modules/development/tools.nix
|
../../modules/development/tools.nix
|
||||||
|
../../modules/development/emacs.nix
|
||||||
../../modules/ai/claude-code.nix
|
../../modules/ai/claude-code.nix
|
||||||
|
|
||||||
# Users
|
# Users
|
||||||
|
@ -79,6 +79,14 @@
|
||||||
kernel.sysctl."vm.swappiness" = 180;
|
kernel.sysctl."vm.swappiness" = 180;
|
||||||
};
|
};
|
||||||
|
|
||||||
|
# Emacs GUI configuration
|
||||||
|
services.emacs-profiles = {
|
||||||
|
enable = true;
|
||||||
|
profile = "gui";
|
||||||
|
enableDaemon = true;
|
||||||
|
user = "geir";
|
||||||
|
};
|
||||||
|
|
||||||
# zram configuration
|
# zram configuration
|
||||||
zramSwap = {
|
zramSwap = {
|
||||||
enable = true;
|
enable = true;
|
||||||
|
|
|
@ -10,6 +10,9 @@
|
||||||
../../modules/network/extraHosts.nix
|
../../modules/network/extraHosts.nix
|
||||||
../../modules/users/sma.nix
|
../../modules/users/sma.nix
|
||||||
../../modules/security/ssh-keys.nix
|
../../modules/security/ssh-keys.nix
|
||||||
|
|
||||||
|
# Development (minimal for edge server)
|
||||||
|
../../modules/development/emacs.nix
|
||||||
];
|
];
|
||||||
|
|
||||||
environment.systemPackages = with pkgs; [
|
environment.systemPackages = with pkgs; [
|
||||||
|
@ -43,6 +46,14 @@
|
||||||
# Tailscale for secure management access
|
# Tailscale for secure management access
|
||||||
services.tailscale.enable = true;
|
services.tailscale.enable = true;
|
||||||
|
|
||||||
|
# Emacs server configuration (minimal for edge server)
|
||||||
|
services.emacs-profiles = {
|
||||||
|
enable = true;
|
||||||
|
profile = "nox";
|
||||||
|
enableDaemon = false;
|
||||||
|
user = "sma";
|
||||||
|
};
|
||||||
|
|
||||||
# SSH configuration - temporarily simplified for testing
|
# SSH configuration - temporarily simplified for testing
|
||||||
services.openssh = {
|
services.openssh = {
|
||||||
enable = true;
|
enable = true;
|
||||||
|
|
|
@ -1,4 +1,11 @@
|
||||||
{ config, lib, pkgs, inputs, unstable, ... }: {
|
{
|
||||||
|
config,
|
||||||
|
lib,
|
||||||
|
pkgs,
|
||||||
|
inputs,
|
||||||
|
unstable,
|
||||||
|
...
|
||||||
|
}: {
|
||||||
imports = [
|
imports = [
|
||||||
./hardware-configuration.nix
|
./hardware-configuration.nix
|
||||||
# Security modules
|
# Security modules
|
||||||
|
@ -10,6 +17,9 @@
|
||||||
./nfs.nix
|
./nfs.nix
|
||||||
./services/transmission.nix
|
./services/transmission.nix
|
||||||
|
|
||||||
|
# Development (minimal for server)
|
||||||
|
../../modules/development/emacs.nix
|
||||||
|
|
||||||
# User modules - server only needs sma user
|
# User modules - server only needs sma user
|
||||||
../../modules/users/sma.nix
|
../../modules/users/sma.nix
|
||||||
];
|
];
|
||||||
|
@ -20,15 +30,19 @@
|
||||||
zfsSupport = true;
|
zfsSupport = true;
|
||||||
efiSupport = true;
|
efiSupport = true;
|
||||||
efiInstallAsRemovable = true;
|
efiInstallAsRemovable = true;
|
||||||
mirroredBoots = [
|
mirroredBoots = [
|
||||||
{ devices = [ "nodev" ]; path = "/boot"; } ];
|
{
|
||||||
|
devices = ["nodev"];
|
||||||
|
path = "/boot";
|
||||||
|
}
|
||||||
|
];
|
||||||
};
|
};
|
||||||
|
|
||||||
boot.supportedFilesystems = [ "zfs" ];
|
boot.supportedFilesystems = ["zfs"];
|
||||||
boot.loader.grub.memtest86.enable = true;
|
boot.loader.grub.memtest86.enable = true;
|
||||||
|
|
||||||
# Add nomodeset for graphics compatibility
|
# Add nomodeset for graphics compatibility
|
||||||
boot.kernelParams = [ "nomodeset" ];
|
boot.kernelParams = ["nomodeset"];
|
||||||
|
|
||||||
# ZFS services for file server
|
# ZFS services for file server
|
||||||
services.zfs = {
|
services.zfs = {
|
||||||
|
@ -36,6 +50,14 @@
|
||||||
trim.enable = true;
|
trim.enable = true;
|
||||||
};
|
};
|
||||||
|
|
||||||
|
# Emacs server configuration (minimal)
|
||||||
|
services.emacs-profiles = {
|
||||||
|
enable = true;
|
||||||
|
profile = "nox";
|
||||||
|
enableDaemon = false; # Don't run daemon on server
|
||||||
|
user = "sma";
|
||||||
|
};
|
||||||
|
|
||||||
# Enable ZFS auto-mounting since we're using ZFS native mountpoints
|
# Enable ZFS auto-mounting since we're using ZFS native mountpoints
|
||||||
# systemd.services.zfs-mount.enable = lib.mkForce false;
|
# systemd.services.zfs-mount.enable = lib.mkForce false;
|
||||||
|
|
||||||
|
|
|
@ -1,20 +0,0 @@
|
||||||
# Common Emacs Configuration
|
|
||||||
# Shared Emacs setup for all machines
|
|
||||||
{
|
|
||||||
config,
|
|
||||||
pkgs,
|
|
||||||
...
|
|
||||||
}: {
|
|
||||||
# System-wide Emacs installation
|
|
||||||
environment.systemPackages = with pkgs; [
|
|
||||||
emacs
|
|
||||||
# Basic Emacs utilities
|
|
||||||
emacsPackages.use-package
|
|
||||||
];
|
|
||||||
|
|
||||||
# Set Emacs as default editor
|
|
||||||
environment.sessionVariables = {
|
|
||||||
EDITOR = "emacs";
|
|
||||||
VISUAL = "emacs";
|
|
||||||
};
|
|
||||||
}
|
|
239
modules/development/emacs.nix
Normal file
239
modules/development/emacs.nix
Normal file
|
@ -0,0 +1,239 @@
|
||||||
|
{
|
||||||
|
config,
|
||||||
|
lib,
|
||||||
|
pkgs,
|
||||||
|
...
|
||||||
|
}:
|
||||||
|
with lib; let
|
||||||
|
cfg = config.services.emacs-profiles;
|
||||||
|
|
||||||
|
# Emacs package configurations for different profiles
|
||||||
|
packageSets = {
|
||||||
|
# Essential packages for all profiles
|
||||||
|
essential = epkgs:
|
||||||
|
with epkgs; [
|
||||||
|
use-package
|
||||||
|
diminish
|
||||||
|
bind-key
|
||||||
|
which-key
|
||||||
|
exec-path-from-shell # Critical for integrating with Nix environment
|
||||||
|
];
|
||||||
|
|
||||||
|
# Minimal packages for server profile
|
||||||
|
minimal = epkgs:
|
||||||
|
with epkgs; [
|
||||||
|
# Basic editing
|
||||||
|
smartparens
|
||||||
|
expand-region
|
||||||
|
|
||||||
|
# Essential navigation (pure Emacs, no external deps)
|
||||||
|
vertico
|
||||||
|
consult
|
||||||
|
marginalia
|
||||||
|
orderless
|
||||||
|
|
||||||
|
# Basic modes for config files
|
||||||
|
nix-mode # Essential for Nix ecosystem
|
||||||
|
yaml-mode
|
||||||
|
markdown-mode
|
||||||
|
|
||||||
|
# Org mode essentials
|
||||||
|
org
|
||||||
|
org-roam
|
||||||
|
];
|
||||||
|
|
||||||
|
# Development packages for laptop/workstation
|
||||||
|
development = epkgs:
|
||||||
|
with epkgs; [
|
||||||
|
# Advanced navigation and completion
|
||||||
|
vertico
|
||||||
|
consult
|
||||||
|
marginalia
|
||||||
|
orderless
|
||||||
|
embark
|
||||||
|
embark-consult
|
||||||
|
corfu
|
||||||
|
cape
|
||||||
|
|
||||||
|
# Project management
|
||||||
|
projectile
|
||||||
|
magit
|
||||||
|
forge
|
||||||
|
|
||||||
|
# Development tools
|
||||||
|
lsp-mode
|
||||||
|
lsp-ui
|
||||||
|
company
|
||||||
|
flycheck
|
||||||
|
yasnippet
|
||||||
|
|
||||||
|
# Language support
|
||||||
|
nix-mode
|
||||||
|
rust-mode
|
||||||
|
python-mode
|
||||||
|
typescript-mode
|
||||||
|
json-mode
|
||||||
|
yaml-mode
|
||||||
|
markdown-mode
|
||||||
|
|
||||||
|
# Org mode and knowledge management
|
||||||
|
org
|
||||||
|
org-roam
|
||||||
|
org-roam-ui
|
||||||
|
|
||||||
|
# UI enhancements
|
||||||
|
doom-themes
|
||||||
|
doom-modeline
|
||||||
|
all-the-icons
|
||||||
|
rainbow-delimiters
|
||||||
|
highlight-indent-guides
|
||||||
|
|
||||||
|
# Editing enhancements
|
||||||
|
smartparens
|
||||||
|
expand-region
|
||||||
|
multiple-cursors
|
||||||
|
avy
|
||||||
|
ace-window
|
||||||
|
|
||||||
|
# Terminal integration
|
||||||
|
vterm
|
||||||
|
eshell-git-prompt
|
||||||
|
];
|
||||||
|
|
||||||
|
# Full workstation packages
|
||||||
|
workstation = epkgs:
|
||||||
|
with epkgs; [
|
||||||
|
# All development packages plus extras
|
||||||
|
pdf-tools
|
||||||
|
nov # EPUB reader
|
||||||
|
elfeed # RSS reader
|
||||||
|
mu4e # Email (if configured)
|
||||||
|
dired-sidebar
|
||||||
|
treemacs
|
||||||
|
treemacs-projectile
|
||||||
|
treemacs-magit
|
||||||
|
];
|
||||||
|
};
|
||||||
|
|
||||||
|
# Generate Emacs configuration based on profile
|
||||||
|
# Uses emacs-pgtk for native Wayland support on desktop profiles
|
||||||
|
# Uses emacs-nox for server profiles (no X11/GUI dependencies)
|
||||||
|
emacsWithProfile = profile: let
|
||||||
|
# Choose Emacs package based on profile
|
||||||
|
emacsPackage =
|
||||||
|
if profile == "nox"
|
||||||
|
then pkgs.emacs-nox # Terminal only
|
||||||
|
else pkgs.emacs-pgtk; # Pure GTK for native Wayland support
|
||||||
|
|
||||||
|
# Combine package sets based on profile
|
||||||
|
selectedPackages = epkgs:
|
||||||
|
(packageSets.essential epkgs)
|
||||||
|
++ (
|
||||||
|
if profile == "nox"
|
||||||
|
then packageSets.minimal epkgs
|
||||||
|
else (packageSets.development epkgs) ++ (packageSets.workstation epkgs)
|
||||||
|
);
|
||||||
|
in
|
||||||
|
emacsPackage.pkgs.withPackages (epkgs: selectedPackages epkgs);
|
||||||
|
in {
|
||||||
|
options.services.emacs-profiles = {
|
||||||
|
enable = mkEnableOption "Emacs with machine-specific profiles";
|
||||||
|
|
||||||
|
profile = mkOption {
|
||||||
|
type = types.enum ["gui" "nox"];
|
||||||
|
default = "gui";
|
||||||
|
description = "Emacs profile: gui (with UI) or nox (terminal only)";
|
||||||
|
};
|
||||||
|
|
||||||
|
enableDaemon = mkOption {
|
||||||
|
type = types.bool;
|
||||||
|
default = true;
|
||||||
|
description = "Enable Emacs daemon service";
|
||||||
|
};
|
||||||
|
|
||||||
|
user = mkOption {
|
||||||
|
type = types.str;
|
||||||
|
default = "geir";
|
||||||
|
description = "User to run Emacs daemon for";
|
||||||
|
};
|
||||||
|
};
|
||||||
|
|
||||||
|
config = mkIf cfg.enable {
|
||||||
|
# Install Emacs with the selected profile
|
||||||
|
environment.systemPackages = [
|
||||||
|
(emacsWithProfile cfg.profile)
|
||||||
|
pkgs.silver-searcher
|
||||||
|
];
|
||||||
|
|
||||||
|
# System-wide Emacs daemon (optional)
|
||||||
|
services.emacs = mkIf cfg.enableDaemon {
|
||||||
|
enable = true;
|
||||||
|
package = emacsWithProfile cfg.profile;
|
||||||
|
};
|
||||||
|
|
||||||
|
# Create the Emacs configuration directory structure
|
||||||
|
environment.etc = {
|
||||||
|
"emacs/init.el" = {
|
||||||
|
source = ../../dotfiles/geir/emacs-config/init-nix.el;
|
||||||
|
mode = "0644";
|
||||||
|
};
|
||||||
|
|
||||||
|
# Module files
|
||||||
|
"emacs/modules/ui.el" = {
|
||||||
|
source = ../../dotfiles/geir/emacs-config/modules/ui.el;
|
||||||
|
mode = "0644";
|
||||||
|
};
|
||||||
|
|
||||||
|
"emacs/modules/completion.el" = {
|
||||||
|
source = ../../dotfiles/geir/emacs-config/modules/completion.el;
|
||||||
|
mode = "0644";
|
||||||
|
};
|
||||||
|
|
||||||
|
"emacs/modules/navigation.el" = {
|
||||||
|
source = ../../dotfiles/geir/emacs-config/modules/navigation.el;
|
||||||
|
mode = "0644";
|
||||||
|
};
|
||||||
|
|
||||||
|
"emacs/modules/development.el" = {
|
||||||
|
source = ../../dotfiles/geir/emacs-config/modules/development.el;
|
||||||
|
mode = "0644";
|
||||||
|
};
|
||||||
|
|
||||||
|
"emacs/modules/elisp-development.el" = {
|
||||||
|
source = ../../dotfiles/geir/emacs-config/modules/elisp-development.el;
|
||||||
|
mode = "0644";
|
||||||
|
};
|
||||||
|
|
||||||
|
"emacs/modules/claude-code.el" = mkIf (cfg.profile == "gui") {
|
||||||
|
source = ../../dotfiles/geir/emacs-config/modules/claude-code.el;
|
||||||
|
mode = "0644";
|
||||||
|
};
|
||||||
|
};
|
||||||
|
|
||||||
|
# Environment variables for Nix integration
|
||||||
|
environment.variables = {
|
||||||
|
EMACS_PROFILE = cfg.profile;
|
||||||
|
RG_PATH = "${pkgs.ripgrep}/bin/rg";
|
||||||
|
FD_PATH = "${pkgs.fd}/bin/fd";
|
||||||
|
SQLITE_PATH = "${pkgs.sqlite}/bin/sqlite3";
|
||||||
|
AG_PATH = "${pkgs.silver-searcher}/bin/ag";
|
||||||
|
|
||||||
|
# Language servers
|
||||||
|
NIL_LSP_PATH = "${pkgs.nixd}/bin/nixd";
|
||||||
|
BASH_LSP_PATH = "${pkgs.nodePackages.bash-language-server}/bin/bash-language-server";
|
||||||
|
YAML_LSP_PATH = "${pkgs.nodePackages.yaml-language-server}/bin/yaml-language-server";
|
||||||
|
|
||||||
|
# Formatters
|
||||||
|
SHELLCHECK_PATH = "${pkgs.shellcheck}/bin/shellcheck";
|
||||||
|
ALEJANDRA_PATH = "${pkgs.alejandra}/bin/alejandra";
|
||||||
|
};
|
||||||
|
|
||||||
|
# Ensure the user can access the Emacs daemon
|
||||||
|
systemd.user.services.emacs = mkIf cfg.enableDaemon {
|
||||||
|
environment = {
|
||||||
|
EMACS_PROFILE = cfg.profile;
|
||||||
|
NIX_PATH = config.environment.variables.NIX_PATH or "";
|
||||||
|
};
|
||||||
|
};
|
||||||
|
};
|
||||||
|
}
|
|
@ -8,9 +8,7 @@
|
||||||
# Editors
|
# Editors
|
||||||
zed-editor
|
zed-editor
|
||||||
neovim
|
neovim
|
||||||
emacs
|
|
||||||
vscode
|
vscode
|
||||||
vscodium-fhs
|
|
||||||
|
|
||||||
# Language servers
|
# Language servers
|
||||||
nixd
|
nixd
|
||||||
|
@ -35,12 +33,13 @@
|
||||||
direnv
|
direnv
|
||||||
gh
|
gh
|
||||||
github-copilot-cli
|
github-copilot-cli
|
||||||
|
deploy-rs
|
||||||
# ai
|
# ai
|
||||||
claude-code
|
claude-code
|
||||||
];
|
];
|
||||||
|
|
||||||
# System-wide Emacs daemon
|
# Note: Emacs is now configured via modules/development/emacs.nix
|
||||||
services.emacs.enable = true;
|
# with machine-specific profiles
|
||||||
|
|
||||||
# Enable ZSH system-wide for development
|
# Enable ZSH system-wide for development
|
||||||
programs.zsh.enable = true;
|
programs.zsh.enable = true;
|
||||||
|
|
|
@ -78,6 +78,33 @@
|
||||||
User sma
|
User sma
|
||||||
IdentityFile ~/.ssh/id_ed25519_admin
|
IdentityFile ~/.ssh/id_ed25519_admin
|
||||||
|
|
||||||
|
# Direct sma user access via Tailscale for deployments
|
||||||
|
Host sma@sleeper-service.tail807ea.ts.net
|
||||||
|
Hostname sleeper-service.tail807ea.ts.net
|
||||||
|
User sma
|
||||||
|
IdentityFile ~/.ssh/id_ed25519_admin
|
||||||
|
|
||||||
|
Host sma@grey-area.tail807ea.ts.net
|
||||||
|
Hostname grey-area.tail807ea.ts.net
|
||||||
|
User sma
|
||||||
|
IdentityFile ~/.ssh/id_ed25519_admin
|
||||||
|
|
||||||
|
Host sma@reverse-proxy.tail807ea.ts.net
|
||||||
|
Hostname reverse-proxy.tail807ea.ts.net
|
||||||
|
User sma
|
||||||
|
IdentityFile ~/.ssh/id_ed25519_admin
|
||||||
|
|
||||||
|
Host sma@little-rascal.tail807ea.ts.net
|
||||||
|
Hostname little-rascal.tail807ea.ts.net
|
||||||
|
User sma
|
||||||
|
IdentityFile ~/.ssh/id_ed25519_admin
|
||||||
|
|
||||||
|
# Localhost sma user for local deployment from laptop
|
||||||
|
Host sma@localhost
|
||||||
|
Hostname localhost
|
||||||
|
User sma
|
||||||
|
IdentityFile ~/.ssh/id_ed25519_admin
|
||||||
|
|
||||||
# Tailscale network
|
# Tailscale network
|
||||||
Host 100.* *.tail*
|
Host 100.* *.tail*
|
||||||
User geir
|
User geir
|
||||||
|
|
|
@ -98,8 +98,6 @@ in {
|
||||||
celluloid
|
celluloid
|
||||||
ytmdesktop
|
ytmdesktop
|
||||||
|
|
||||||
# Emacs Integration
|
|
||||||
emacsPackages.vterm
|
|
||||||
# Gaming
|
# Gaming
|
||||||
steam
|
steam
|
||||||
# Desktop integration (moved from system)
|
# Desktop integration (moved from system)
|
||||||
|
|
148
packages/lab-tool/DEVELOPMENT.md
Normal file
148
packages/lab-tool/DEVELOPMENT.md
Normal file
|
@ -0,0 +1,148 @@
|
||||||
|
# Lab Tool Development Guide
|
||||||
|
|
||||||
|
## Build Commands
|
||||||
|
|
||||||
|
### Build the Lab Tool Package
|
||||||
|
```bash
|
||||||
|
# Build the lab tool from project root
|
||||||
|
nix build .#packages.x86_64-linux.lab
|
||||||
|
|
||||||
|
# The binary will be available at ./result/bin/lab
|
||||||
|
```
|
||||||
|
|
||||||
|
### Quick Development Build
|
||||||
|
```bash
|
||||||
|
# From the lab-tool directory
|
||||||
|
cd packages/lab-tool
|
||||||
|
nix build .#lab-tool # if available, otherwise use full path above
|
||||||
|
```
|
||||||
|
|
||||||
|
## Testing Commands
|
||||||
|
|
||||||
|
### Test Lab Tool Functionality
|
||||||
|
```bash
|
||||||
|
# Test help command
|
||||||
|
./result/bin/lab help
|
||||||
|
|
||||||
|
# Test machine listing
|
||||||
|
./result/bin/lab machines
|
||||||
|
|
||||||
|
# Test status check
|
||||||
|
./result/bin/lab status
|
||||||
|
|
||||||
|
# Test dry-run deployment
|
||||||
|
./result/bin/lab deploy little-rascal --dry-run
|
||||||
|
|
||||||
|
# Test actual deployment
|
||||||
|
./result/bin/lab deploy little-rascal
|
||||||
|
```
|
||||||
|
|
||||||
|
### Test System Integration
|
||||||
|
```bash
|
||||||
|
# Deploy configuration using nixos-rebuild (requires sudo access)
|
||||||
|
sudo nixos-rebuild switch --flake .#little-rascal --show-trace
|
||||||
|
|
||||||
|
# Or using lab tool (recommended)
|
||||||
|
lab deploy little-rascal
|
||||||
|
```
|
||||||
|
|
||||||
|
## Development Workflow
|
||||||
|
|
||||||
|
### 1. Make Changes
|
||||||
|
Edit source files in:
|
||||||
|
- `main.scm` - CLI interface
|
||||||
|
- `lab/deployment.scm` - Deployment logic
|
||||||
|
- `lab/machines.scm` - Machine management
|
||||||
|
- `utils/*.scm` - Utility functions
|
||||||
|
|
||||||
|
### 2. Build and Test
|
||||||
|
```bash
|
||||||
|
# Rebuild after changes
|
||||||
|
nix build .#packages.x86_64-linux.lab
|
||||||
|
|
||||||
|
# Test basic functionality
|
||||||
|
./result/bin/lab help
|
||||||
|
./result/bin/lab machines
|
||||||
|
|
||||||
|
# Test deployment (dry-run first)
|
||||||
|
./result/bin/lab deploy little-rascal --dry-run
|
||||||
|
```
|
||||||
|
|
||||||
|
### 3. Debug Issues
|
||||||
|
```bash
|
||||||
|
# Enable Guile debugging
|
||||||
|
export GUILE_AUTO_COMPILE=0
|
||||||
|
|
||||||
|
# Run with verbose output
|
||||||
|
./result/bin/lab deploy little-rascal --dry-run
|
||||||
|
|
||||||
|
# Check deploy-rs command directly
|
||||||
|
deploy --help
|
||||||
|
```
|
||||||
|
|
||||||
|
## Common Development Tasks
|
||||||
|
|
||||||
|
### Update Deploy-rs Command Format
|
||||||
|
Edit `lab/deployment.scm` in the `build-deploy-command` function:
|
||||||
|
```scheme
|
||||||
|
;; Example: Add new flags
|
||||||
|
(when new-option
|
||||||
|
(set! flags (cons "--new-flag=value" flags)))
|
||||||
|
```
|
||||||
|
|
||||||
|
### Add New Machine
|
||||||
|
Add to the machine list in `lab/machines.scm` or config files.
|
||||||
|
|
||||||
|
### Debug Deployment Issues
|
||||||
|
1. Check the generated command with dry-run
|
||||||
|
2. Test deploy-rs directly: `deploy '.#little-rascal' --dry-activate`
|
||||||
|
3. Check flake structure: `nix flake show`
|
||||||
|
|
||||||
|
### Module Structure
|
||||||
|
- `main.scm` - Entry point and CLI parsing
|
||||||
|
- `lab/core.scm` - Core lab functionality
|
||||||
|
- `lab/deployment.scm` - Deploy-rs integration
|
||||||
|
- `lab/machines.scm` - Machine management
|
||||||
|
- `lab/monitoring.scm` - Health checks and monitoring
|
||||||
|
- `lab/auto-update.scm` - Automatic update system
|
||||||
|
- `utils/logging.scm` - Logging system with colors
|
||||||
|
- `utils/config.scm` - Configuration management
|
||||||
|
- `utils/ssh.scm` - SSH utilities
|
||||||
|
- `utils/json.scm` - JSON handling
|
||||||
|
|
||||||
|
## Troubleshooting
|
||||||
|
|
||||||
|
### Build Failures
|
||||||
|
```bash
|
||||||
|
# Check flake structure
|
||||||
|
nix flake show
|
||||||
|
|
||||||
|
# Verify Guile syntax
|
||||||
|
guile --no-auto-compile -c "(load \"main.scm\")"
|
||||||
|
```
|
||||||
|
|
||||||
|
### Runtime Errors
|
||||||
|
```bash
|
||||||
|
# Check module exports
|
||||||
|
guile -c "(use-modules (lab deployment)) (display 'loaded)"
|
||||||
|
|
||||||
|
# Test individual functions
|
||||||
|
guile -c "(use-modules (lab deployment)) (deploy-machine \"little-rascal\" \"default\" '((dry-run . #t)))"
|
||||||
|
```
|
||||||
|
|
||||||
|
### Deploy-rs Issues
|
||||||
|
```bash
|
||||||
|
# Test deploy-rs directly
|
||||||
|
deploy '.#little-rascal' --dry-activate
|
||||||
|
|
||||||
|
# Check machine connectivity
|
||||||
|
ssh sma@little-rascal 'echo "connected"'
|
||||||
|
```
|
||||||
|
|
||||||
|
## Best Practices
|
||||||
|
|
||||||
|
1. **Always test with dry-run first**
|
||||||
|
2. **Use the lab tool instead of direct nixos-rebuild when possible**
|
||||||
|
3. **Check flake status before deployment** (`nix flake check`)
|
||||||
|
4. **Keep commits atomic** - one feature/fix per commit
|
||||||
|
5. **Update this file when adding new commands or workflows**
|
|
@ -1,60 +0,0 @@
|
||||||
# Lab Tool - Clean Project Structure
|
|
||||||
|
|
||||||
## 📁 Current Structure
|
|
||||||
|
|
||||||
```
|
|
||||||
lab-tool/
|
|
||||||
├── main.scm # Main CLI entry point ✅ WORKING
|
|
||||||
├── lab/ # Core lab modules
|
|
||||||
│ ├── core.scm # Core functionality
|
|
||||||
│ ├── deployment.scm # Deployment operations ✅ FIXED
|
|
||||||
│ ├── machines.scm # Machine management
|
|
||||||
│ └── monitoring.scm # Infrastructure monitoring
|
|
||||||
├── utils/ # Utility modules
|
|
||||||
│ ├── logging.scm # Logging with colors ✅ FIXED
|
|
||||||
│ ├── config.scm # Configuration management
|
|
||||||
│ ├── ssh.scm # SSH utilities
|
|
||||||
│ └── config/ # Modular config system
|
|
||||||
├── mcp/ # MCP server (future enhancement)
|
|
||||||
├── testing/ # All test files ✅ ORGANIZED
|
|
||||||
├── archive/ # Old/backup files
|
|
||||||
├── research/ # Original prototypes
|
|
||||||
└── config/ # Runtime configuration
|
|
||||||
```
|
|
||||||
|
|
||||||
## ✅ TDD Success Summary
|
|
||||||
|
|
||||||
### Fixed Issues
|
|
||||||
1. **Syntax errors in deployment.scm** - Missing parentheses and corrupted module definition
|
|
||||||
2. **Missing exports in utils/logging.scm** - Added `get-color` function to exports
|
|
||||||
3. **Error handling in main.scm** - Proper exit codes for invalid commands
|
|
||||||
4. **Module loading** - All modules now load without compilation issues
|
|
||||||
|
|
||||||
### Verified Working Features
|
|
||||||
- ✅ **CLI Interface**: help, status, machines, deploy, health, test-modules
|
|
||||||
- ✅ **Real Deployment**: Successfully deploys to actual NixOS machines
|
|
||||||
- ✅ **Infrastructure Monitoring**: Checks machine status across the lab
|
|
||||||
- ✅ **Error Handling**: Proper error messages and exit codes
|
|
||||||
- ✅ **Modular Architecture**: K.I.S.S principles applied throughout
|
|
||||||
|
|
||||||
### Test Organization
|
|
||||||
- All test files moved to `testing/` directory
|
|
||||||
- Clear test categories and documentation
|
|
||||||
- TDD approach validated all functionality
|
|
||||||
|
|
||||||
## 🚀 Ready for Production
|
|
||||||
|
|
||||||
The lab tool is now fully functional for core home lab operations:
|
|
||||||
- Deploy NixOS configurations to any machine
|
|
||||||
- Monitor infrastructure status
|
|
||||||
- Manage machine health checks
|
|
||||||
- Clean, modular codebase following K.I.S.S principles
|
|
||||||
|
|
||||||
## 📋 Next Steps
|
|
||||||
|
|
||||||
Priority items from TODO.md:
|
|
||||||
1. Complete MCP server implementation
|
|
||||||
2. Enhanced machine discovery
|
|
||||||
3. Improved health checking
|
|
||||||
|
|
||||||
The core functionality is complete and battle-tested!
|
|
|
@ -1,119 +0,0 @@
|
||||||
# K.I.S.S Refactoring Summary
|
|
||||||
|
|
||||||
## Applied Principles
|
|
||||||
|
|
||||||
### 1. Modularization (Keep It Simple, Keep It Small)
|
|
||||||
|
|
||||||
- **Before**: Large monolithic modules (138+ lines)
|
|
||||||
- **After**: Small focused modules (each under 50 lines)
|
|
||||||
- **Example**: SSH module split into 5 specialized modules
|
|
||||||
|
|
||||||
### 2. Single Responsibility Principle (UNIX Philosophy: Do One Thing Well)
|
|
||||||
|
|
||||||
- **connection-test.scm**: Only SSH connectivity testing
|
|
||||||
- **remote-command.scm**: Only remote command execution
|
|
||||||
- **file-copy.scm**: Only file transfer operations
|
|
||||||
- **retry.scm**: Only retry logic
|
|
||||||
- **context.scm**: Only connection context management
|
|
||||||
|
|
||||||
### 3. Functional Programming Patterns
|
|
||||||
|
|
||||||
- **Pure Functions First**: All core logic implemented as pure functions
|
|
||||||
- **Immutable Data**: Configuration and data structures remain immutable
|
|
||||||
- **Separation of Concerns**: Pure functions separated from side effects
|
|
||||||
|
|
||||||
### 4. Function-Level Modularity
|
|
||||||
|
|
||||||
Each module exports both:
|
|
||||||
|
|
||||||
- **Pure functions**: For testing, composition, and functional programming
|
|
||||||
- **Impure wrappers**: For convenience and logging
|
|
||||||
|
|
||||||
## Module Structure
|
|
||||||
|
|
||||||
```
|
|
||||||
utils/
|
|
||||||
├── ssh/
|
|
||||||
│ ├── connection-test.scm # Pure SSH connectivity testing
|
|
||||||
│ ├── remote-command.scm # Pure command execution logic
|
|
||||||
│ ├── file-copy.scm # Pure file transfer operations
|
|
||||||
│ ├── retry.scm # Pure retry logic with backoff
|
|
||||||
│ └── context.scm # Connection context management
|
|
||||||
├── config/
|
|
||||||
│ ├── defaults.scm # Pure data: default configuration
|
|
||||||
│ ├── loader.scm # File I/O operations
|
|
||||||
│ ├── accessor.scm # Pure configuration access functions
|
|
||||||
│ └── state.scm # Mutable state management
|
|
||||||
├── logging/
|
|
||||||
│ ├── format.scm # Pure formatting and color codes
|
|
||||||
│ ├── level.scm # Pure log level management
|
|
||||||
│ ├── state.scm # Mutable log level state
|
|
||||||
│ ├── output.scm # Pure output formatting
|
|
||||||
│ ├── core.scm # Main logging functions
|
|
||||||
│ └── spinner.scm # Progress indication
|
|
||||||
└── json/
|
|
||||||
├── parse.scm # Pure JSON parsing
|
|
||||||
├── serialize.scm # Pure JSON serialization
|
|
||||||
├── file-io.scm # File I/O with pure/impure versions
|
|
||||||
├── validation.scm # Pure schema validation
|
|
||||||
├── manipulation.scm # Pure object manipulation
|
|
||||||
└── pretty-print.scm # Output formatting
|
|
||||||
```
|
|
||||||
|
|
||||||
## Benefits Achieved
|
|
||||||
|
|
||||||
### 1. Testability
|
|
||||||
|
|
||||||
- Pure functions can be tested in isolation
|
|
||||||
- No side effects to mock or manage
|
|
||||||
- Clear input/output contracts
|
|
||||||
|
|
||||||
### 2. Composability
|
|
||||||
|
|
||||||
- Small functions can be easily combined
|
|
||||||
- Pure functions enable functional composition
|
|
||||||
- Reusable building blocks
|
|
||||||
|
|
||||||
### 3. Maintainability
|
|
||||||
|
|
||||||
- Single responsibility makes modules easy to understand
|
|
||||||
- Changes are localized to specific modules
|
|
||||||
- Clear separation between pure and impure code
|
|
||||||
|
|
||||||
### 4. Code Reuse
|
|
||||||
|
|
||||||
- Pure functions can be reused across different contexts
|
|
||||||
- Both pure and impure versions available
|
|
||||||
- Facade modules provide convenient interfaces
|
|
||||||
|
|
||||||
## Usage Examples
|
|
||||||
|
|
||||||
### Pure Function Composition
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Test connection and get config in one go
|
|
||||||
(let ((ssh-config (get-ssh-config-pure config "machine-name")))
|
|
||||||
(if (test-ssh-connection-pure ssh-config)
|
|
||||||
(run-remote-command-pure ssh-config "uptime" '())
|
|
||||||
#f))
|
|
||||||
```
|
|
||||||
|
|
||||||
### Convenient Impure Wrappers
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Same operation with logging and error handling
|
|
||||||
(with-ssh-connection "machine-name"
|
|
||||||
(lambda () (run-remote-command "machine-name" "uptime")))
|
|
||||||
```
|
|
||||||
|
|
||||||
### Functional Pipeline
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Pure validation pipeline
|
|
||||||
(let* ((config (load-config-from-file "config.json"))
|
|
||||||
(valid? (validate-json-schema config machine-schema))
|
|
||||||
(machines (if valid? (get-all-machines-pure config) '())))
|
|
||||||
machines)
|
|
||||||
```
|
|
||||||
|
|
||||||
This refactoring transforms the codebase from monolithic modules into a collection of small, focused, composable functions that follow functional programming principles while maintaining practical usability.
|
|
|
@ -1,35 +0,0 @@
|
||||||
# Lab Tool Implementation Status
|
|
||||||
|
|
||||||
## ✅ COMPLETED
|
|
||||||
|
|
||||||
- Basic modular utils (logging, config, json, ssh)
|
|
||||||
- Lab module structure (core, machines, deployment, monitoring)
|
|
||||||
- MCP server stub
|
|
||||||
- Module loading tests pass
|
|
||||||
- **CLI interface working** (status, machines, deploy commands)
|
|
||||||
- **Infrastructure status checking functional**
|
|
||||||
- **All module tests passing**
|
|
||||||
- **TDD FIXES:** Syntax errors, missing exports, error handling
|
|
||||||
- **DEPLOYMENT WORKING:** Real nixos-rebuild functionality
|
|
||||||
- **ALL CORE COMMANDS FUNCTIONAL:** help, status, machines, deploy, health, test-modules
|
|
||||||
|
|
||||||
## 📋 NEXT TASKS
|
|
||||||
|
|
||||||
### High Priority
|
|
||||||
|
|
||||||
1. ~~**Fix main.scm** - Update to use new lab modules~~ ✅
|
|
||||||
2. ~~**Implement core functions** - Add real functionality to lab modules~~ ✅
|
|
||||||
3. ~~**Test CLI interface** - Ensure commands work end-to-end~~ ✅
|
|
||||||
4. ~~**Fix syntax and module issues** - TDD approach~~ ✅
|
|
||||||
|
|
||||||
### Medium Priority
|
|
||||||
|
|
||||||
1. **Complete MCP server** - JSON-RPC protocol implementation
|
|
||||||
2. ~~**Add deployment logic** - Move from research/ to lab/deployment~~ ✅
|
|
||||||
3. **Machine management** - Add discovery and health checks
|
|
||||||
|
|
||||||
### Config Enhancement Notes
|
|
||||||
|
|
||||||
- Machine folder creation with hardware config
|
|
||||||
- Git integration for new machines
|
|
||||||
- Seamless machine import workflow
|
|
|
@ -1,75 +0,0 @@
|
||||||
;; lab/core/health.scm - Health check functionality
|
|
||||||
|
|
||||||
(define-module (lab core health)
|
|
||||||
#:use-module (ice-9 rdelim)
|
|
||||||
#:use-module (srfi srfi-1)
|
|
||||||
#:use-module (lab core logging)
|
|
||||||
#:use-module (lab core ssh)
|
|
||||||
#:export (check-system-health
|
|
||||||
check-disk-space
|
|
||||||
check-system-load
|
|
||||||
check-critical-services
|
|
||||||
check-network-connectivity))
|
|
||||||
|
|
||||||
(define (check-system-health machine-name)
|
|
||||||
"Perform comprehensive health check on a machine"
|
|
||||||
(log-info "Performing health check on ~a..." machine-name)
|
|
||||||
|
|
||||||
(let ((health-checks
|
|
||||||
'(("connectivity" . test-ssh-connection)
|
|
||||||
("disk-space" . check-disk-space)
|
|
||||||
("system-load" . check-system-load)
|
|
||||||
("critical-services" . check-critical-services)
|
|
||||||
("network" . check-network-connectivity))))
|
|
||||||
|
|
||||||
(map (lambda (check-pair)
|
|
||||||
(let ((check-name (car check-pair))
|
|
||||||
(check-proc (cdr check-pair)))
|
|
||||||
(log-debug "Running ~a check..." check-name)
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(let ((result (check-proc machine-name)))
|
|
||||||
`(,check-name . ((status . ,(if result 'pass 'fail))
|
|
||||||
(result . ,result)))))
|
|
||||||
(lambda (key . args)
|
|
||||||
(log-warn "Health check ~a failed: ~a" check-name key)
|
|
||||||
`(,check-name . ((status . error)
|
|
||||||
(error . ,key)))))))
|
|
||||||
health-checks)))
|
|
||||||
|
|
||||||
(define (check-disk-space machine-name)
|
|
||||||
"Check if disk space is below critical threshold"
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name "df / | tail -1 | awk '{print $5}' | sed 's/%//'"))
|
|
||||||
(lambda (success output)
|
|
||||||
(if success
|
|
||||||
(let ((usage (string->number (string-trim-right output))))
|
|
||||||
(< usage 90)) ; Pass if usage < 90%
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
(define (check-system-load machine-name)
|
|
||||||
"Check if system load is reasonable"
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name "cat /proc/loadavg | cut -d' ' -f1"))
|
|
||||||
(lambda (success output)
|
|
||||||
(if success
|
|
||||||
(let ((load (string->number (string-trim-right output))))
|
|
||||||
(< load 5.0)) ; Pass if load < 5.0
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
(define (check-critical-services machine-name)
|
|
||||||
"Check that critical services are running"
|
|
||||||
(let ((critical-services '("sshd")))
|
|
||||||
(every (lambda (service)
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name "systemctl is-active" service))
|
|
||||||
(lambda (success output)
|
|
||||||
(and success (string=? (string-trim-right output) "active")))))
|
|
||||||
critical-services)))
|
|
||||||
|
|
||||||
(define (check-network-connectivity machine-name)
|
|
||||||
"Check basic network connectivity"
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name "ping -c 1 -W 5 8.8.8.8 > /dev/null 2>&1; echo $?"))
|
|
||||||
(lambda (success output)
|
|
||||||
(and success (string=? (string-trim-right output) "0")))))
|
|
|
@ -1,29 +0,0 @@
|
||||||
;; lab/core/logging.scm - Logging functionality
|
|
||||||
|
|
||||||
(define-module (lab core logging)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:export (log-info
|
|
||||||
log-debug
|
|
||||||
log-success
|
|
||||||
log-error
|
|
||||||
log-warn))
|
|
||||||
|
|
||||||
(define (log-info format-str . args)
|
|
||||||
"Log info message"
|
|
||||||
(apply format #t (string-append "[INFO] " format-str "~%") args))
|
|
||||||
|
|
||||||
(define (log-debug format-str . args)
|
|
||||||
"Log debug message"
|
|
||||||
(apply format #t (string-append "[DEBUG] " format-str "~%") args))
|
|
||||||
|
|
||||||
(define (log-success format-str . args)
|
|
||||||
"Log success message"
|
|
||||||
(apply format #t (string-append "[SUCCESS] " format-str "~%") args))
|
|
||||||
|
|
||||||
(define (log-error format-str . args)
|
|
||||||
"Log error message"
|
|
||||||
(apply format #t (string-append "[ERROR] " format-str "~%") args))
|
|
||||||
|
|
||||||
(define (log-warn format-str . args)
|
|
||||||
"Log warning message"
|
|
||||||
(apply format #t (string-append "[WARN] " format-str "~%") args))
|
|
|
@ -1,24 +0,0 @@
|
||||||
;; lab/core/ssh.scm - SSH operations
|
|
||||||
|
|
||||||
(define-module (lab core ssh)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (ice-9 popen)
|
|
||||||
#:use-module (ice-9 rdelim)
|
|
||||||
#:use-module (ice-9 textual-ports)
|
|
||||||
#:export (test-ssh-connection
|
|
||||||
run-remote-command))
|
|
||||||
|
|
||||||
(define (test-ssh-connection machine-name)
|
|
||||||
"Test SSH connection to machine"
|
|
||||||
(zero? (system (format #f "ssh -o ConnectTimeout=5 -o BatchMode=yes ~a exit 2>/dev/null" machine-name))))
|
|
||||||
|
|
||||||
(define (run-remote-command machine-name command . args)
|
|
||||||
"Run command on remote machine via SSH"
|
|
||||||
(let* ((full-command (if (null? args)
|
|
||||||
command
|
|
||||||
(string-join (cons command args) " ")))
|
|
||||||
(ssh-command (format #f "ssh ~a '~a'" machine-name full-command))
|
|
||||||
(port (open-input-pipe ssh-command))
|
|
||||||
(output (read-string port))
|
|
||||||
(status (close-pipe port)))
|
|
||||||
(values (zero? status) output)))
|
|
|
@ -1,84 +0,0 @@
|
||||||
;; lab/core/status.scm - Infrastructure status functionality
|
|
||||||
|
|
||||||
(define-module (lab core status)
|
|
||||||
#:use-module (ice-9 rdelim)
|
|
||||||
#:use-module (srfi srfi-1)
|
|
||||||
#:use-module (srfi srfi-19)
|
|
||||||
#:use-module (lab core logging)
|
|
||||||
#:use-module (lab core config)
|
|
||||||
#:use-module (lab core ssh)
|
|
||||||
#:export (get-infrastructure-status
|
|
||||||
get-machine-services-status
|
|
||||||
get-machine-system-info))
|
|
||||||
|
|
||||||
(define (get-infrastructure-status . args)
|
|
||||||
"Get status of all machines or specific machine if provided"
|
|
||||||
(let ((target-machine (if (null? args) #f (car args)))
|
|
||||||
(machines (if (null? args)
|
|
||||||
(get-all-machines)
|
|
||||||
(list (car args)))))
|
|
||||||
|
|
||||||
(log-info "Checking infrastructure status...")
|
|
||||||
|
|
||||||
(map (lambda (machine-name)
|
|
||||||
(let ((start-time (current-time)))
|
|
||||||
(log-debug "Checking ~a..." machine-name)
|
|
||||||
|
|
||||||
(let* ((ssh-config (get-ssh-config machine-name))
|
|
||||||
(is-local (and ssh-config (assoc-ref ssh-config 'is-local)))
|
|
||||||
(connection-status (test-ssh-connection machine-name))
|
|
||||||
(services-status (if connection-status
|
|
||||||
(get-machine-services-status machine-name)
|
|
||||||
'()))
|
|
||||||
(system-info (if connection-status
|
|
||||||
(get-machine-system-info machine-name)
|
|
||||||
#f))
|
|
||||||
(elapsed (- (current-time) start-time)))
|
|
||||||
|
|
||||||
`((machine . ,machine-name)
|
|
||||||
(type . ,(if is-local 'local 'remote))
|
|
||||||
(connection . ,(if connection-status 'online 'offline))
|
|
||||||
(services . ,services-status)
|
|
||||||
(system . ,system-info)
|
|
||||||
(check-time . ,elapsed)))))
|
|
||||||
machines)))
|
|
||||||
|
|
||||||
(define (get-machine-services-status machine-name)
|
|
||||||
"Check status of services on a machine"
|
|
||||||
(let ((machine-config (get-machine-config machine-name)))
|
|
||||||
(if machine-config
|
|
||||||
(let ((services (assoc-ref machine-config 'services)))
|
|
||||||
(if services
|
|
||||||
(map (lambda (service)
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name
|
|
||||||
"systemctl is-active"
|
|
||||||
(symbol->string service)))
|
|
||||||
(lambda (success output)
|
|
||||||
`(,service . ,(if success
|
|
||||||
(string-trim-right output)
|
|
||||||
"unknown")))))
|
|
||||||
services)
|
|
||||||
'()))
|
|
||||||
'())))
|
|
||||||
|
|
||||||
(define (get-machine-system-info machine-name)
|
|
||||||
"Get basic system information from a machine"
|
|
||||||
(let ((info-commands
|
|
||||||
'(("uptime" "uptime -p")
|
|
||||||
("load" "cat /proc/loadavg | cut -d' ' -f1-3")
|
|
||||||
("memory" "free -h | grep Mem | awk '{print $3\"/\"$2}'")
|
|
||||||
("disk" "df -h / | tail -1 | awk '{print $5}'")
|
|
||||||
("kernel" "uname -r"))))
|
|
||||||
|
|
||||||
(fold (lambda (cmd-pair acc)
|
|
||||||
(let ((key (car cmd-pair))
|
|
||||||
(command (cadr cmd-pair)))
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name command))
|
|
||||||
(lambda (success output)
|
|
||||||
(if success
|
|
||||||
(assoc-set! acc (string->symbol key) (string-trim-right output))
|
|
||||||
acc)))))
|
|
||||||
'()
|
|
||||||
info-commands)))
|
|
|
@ -1,12 +0,0 @@
|
||||||
;; lab/core/utils.scm - Utility functions
|
|
||||||
|
|
||||||
(define-module (lab core utils)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:export (with-spinner))
|
|
||||||
|
|
||||||
(define (with-spinner message proc)
|
|
||||||
"Execute procedure with spinner (stub implementation)"
|
|
||||||
(display (format #f "~a..." message))
|
|
||||||
(let ((result (proc)))
|
|
||||||
(display " done.\n")
|
|
||||||
result))
|
|
|
@ -1,109 +0,0 @@
|
||||||
;; lab/core/deployment.scm - Deployment functionality
|
|
||||||
|
|
||||||
(define-module (lab core deployment)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (ice-9 popen)
|
|
||||||
#:use-module (ice-9 textual-ports)
|
|
||||||
#:use-module (lab core logging)
|
|
||||||
#:use-module (lab core config)
|
|
||||||
#:use-module (lab core utils)
|
|
||||||
#:export (update-flake
|
|
||||||
validate-environment
|
|
||||||
execute-nixos-rebuild))
|
|
||||||
|
|
||||||
(define (update-flake options)
|
|
||||||
"Update flake inputs in the home lab repository"
|
|
||||||
(let ((homelab-root (get-homelab-root))
|
|
||||||
(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* ((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")
|
|
||||||
(log-debug "Update output: ~a" output)
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
(log-error "Flake update failed (exit: ~a)" status)
|
|
||||||
(log-error "Error output: ~a" output)
|
|
||||||
#f))))))
|
|
||||||
|
|
||||||
(define (validate-environment)
|
|
||||||
"Validate that the home lab environment is properly configured"
|
|
||||||
(log-info "Validating home lab environment...")
|
|
||||||
|
|
||||||
(let ((checks
|
|
||||||
`(("homelab-root" . ,(lambda () (file-exists? (get-homelab-root))))
|
|
||||||
("flake-file" . ,(lambda () (file-exists? (string-append (get-homelab-root) "/flake.nix"))))
|
|
||||||
("ssh-config" . ,(lambda () (file-exists? (string-append (getenv "HOME") "/.ssh/config"))))
|
|
||||||
("nix-command" . ,(lambda () (zero? (system "which nix > /dev/null 2>&1"))))
|
|
||||||
("machines-config" . ,(lambda () (not (null? (get-all-machines))))))))
|
|
||||||
|
|
||||||
(let ((results (map (lambda (check-pair)
|
|
||||||
(let ((check-name (car check-pair))
|
|
||||||
(check-proc (cdr check-pair)))
|
|
||||||
(let ((result (check-proc)))
|
|
||||||
(if result
|
|
||||||
(log-success "✓ ~a" check-name)
|
|
||||||
(log-error "✗ ~a" check-name))
|
|
||||||
`(,check-name . ,result))))
|
|
||||||
checks)))
|
|
||||||
|
|
||||||
(let ((failures (filter (lambda (result) (not (cdr result))) results)))
|
|
||||||
(if (null? failures)
|
|
||||||
(begin
|
|
||||||
(log-success "Environment validation passed")
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
(log-error "Environment validation failed: ~a" (map car failures))
|
|
||||||
#f))))))
|
|
||||||
|
|
||||||
(define (execute-nixos-rebuild machine-name mode options)
|
|
||||||
"Execute nixos-rebuild on a machine with comprehensive error handling"
|
|
||||||
(let ((homelab-root (get-homelab-root))
|
|
||||||
(dry-run (option-ref options 'dry-run #f))
|
|
||||||
(ssh-config (get-ssh-config machine-name)))
|
|
||||||
|
|
||||||
(if (not ssh-config)
|
|
||||||
(begin
|
|
||||||
(log-error "No SSH configuration for machine: ~a" machine-name)
|
|
||||||
#f)
|
|
||||||
(let* ((is-local (assoc-ref ssh-config 'is-local))
|
|
||||||
(flake-ref (format #f "~a#~a" homelab-root machine-name))
|
|
||||||
(rebuild-cmd (if is-local
|
|
||||||
(format #f "sudo nixos-rebuild ~a --flake ~a" mode flake-ref)
|
|
||||||
(format #f "nixos-rebuild ~a --flake ~a --target-host ~a --use-remote-sudo"
|
|
||||||
mode flake-ref (assoc-ref ssh-config 'hostname)))))
|
|
||||||
|
|
||||||
(log-info "Executing nixos-rebuild for ~a (mode: ~a)" machine-name mode)
|
|
||||||
(log-debug "Command: ~a" rebuild-cmd)
|
|
||||||
|
|
||||||
(if dry-run
|
|
||||||
(begin
|
|
||||||
(log-info "DRY RUN: Would execute: ~a" rebuild-cmd)
|
|
||||||
#t)
|
|
||||||
(with-spinner
|
|
||||||
(format #f "Rebuilding ~a" machine-name)
|
|
||||||
(lambda ()
|
|
||||||
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" rebuild-cmd))
|
|
||||||
(output (get-string-all port))
|
|
||||||
(status (close-pipe port)))
|
|
||||||
|
|
||||||
(if (zero? status)
|
|
||||||
(begin
|
|
||||||
(log-success "nixos-rebuild completed successfully for ~a" machine-name)
|
|
||||||
(log-debug "Build output: ~a" output)
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
(log-error "nixos-rebuild failed for ~a (exit: ~a)" machine-name status)
|
|
||||||
(log-error "Error output: ~a" output)
|
|
||||||
#f))))))))
|
|
|
@ -13,7 +13,7 @@
|
||||||
}:
|
}:
|
||||||
stdenv.mkDerivation {
|
stdenv.mkDerivation {
|
||||||
pname = "lab-tool";
|
pname = "lab-tool";
|
||||||
version = "0.1.0";
|
version = "0.2.0";
|
||||||
|
|
||||||
src = ./.;
|
src = ./.;
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
;; lab/deployment.scm - Deployment operations (impure)
|
;; lab/deployment.scm - Deploy-rs based deployment operations
|
||||||
|
|
||||||
(define-module (lab deployment)
|
(define-module (lab deployment)
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
|
@ -7,10 +7,10 @@
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (utils logging)
|
#:use-module (utils logging)
|
||||||
#:use-module (utils config)
|
#:use-module (utils config)
|
||||||
#:use-module (utils ssh)
|
|
||||||
#:export (deploy-machine
|
#:export (deploy-machine
|
||||||
update-flake
|
update-flake
|
||||||
execute-nixos-rebuild
|
deploy-all-machines
|
||||||
|
deploy-with-rollback
|
||||||
option-ref))
|
option-ref))
|
||||||
|
|
||||||
;; Helper function for option handling
|
;; Helper function for option handling
|
||||||
|
@ -19,26 +19,128 @@
|
||||||
(let ((value (assoc-ref options key)))
|
(let ((value (assoc-ref options key)))
|
||||||
(if value value default)))
|
(if value value default)))
|
||||||
|
|
||||||
;; Impure function: Deploy machine configuration
|
;; Main deployment function using deploy-rs
|
||||||
(define (deploy-machine machine-name . args)
|
(define (deploy-machine machine-name . args)
|
||||||
"Deploy configuration to machine (impure - has side effects)"
|
"Deploy configuration to machine using deploy-rs (impure - has side effects)"
|
||||||
(let* ((mode (if (null? args) "boot" (car args)))
|
(let* ((mode (if (null? args) "default" (car args)))
|
||||||
(options (if (< (length args) 2) '() (cadr args)))
|
(options (if (< (length args) 2) '() (cadr args)))
|
||||||
(valid-modes '("boot" "test" "switch"))
|
(dry-run (option-ref options 'dry-run #f))
|
||||||
(dry-run (option-ref options 'dry-run #f)))
|
(skip-checks (option-ref options 'skip-checks #f)))
|
||||||
|
|
||||||
(if (not (validate-machine-name machine-name))
|
(if (not (validate-machine-name machine-name))
|
||||||
#f
|
#f
|
||||||
(if (not (member mode valid-modes))
|
(begin
|
||||||
(begin
|
(log-info "Starting deploy-rs deployment: ~a" machine-name)
|
||||||
(log-error "Invalid deployment mode: ~a" mode)
|
(execute-deploy-rs machine-name mode options)))))
|
||||||
(log-error "Valid modes: ~a" (string-join valid-modes ", "))
|
|
||||||
#f)
|
|
||||||
(begin
|
|
||||||
(log-info "Starting deployment: ~a (mode: ~a)" machine-name mode)
|
|
||||||
(execute-nixos-rebuild machine-name mode options))))))
|
|
||||||
|
|
||||||
;; Impure function: Update flake inputs
|
;; 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 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 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))))
|
||||||
|
|
||||||
|
;; Update flake inputs (moved from old deployment module)
|
||||||
(define (update-flake . args)
|
(define (update-flake . args)
|
||||||
"Update flake inputs (impure - has side effects)"
|
"Update flake inputs (impure - has side effects)"
|
||||||
(let* ((options (if (null? args) '() (car args)))
|
(let* ((options (if (null? args) '() (car args)))
|
||||||
|
@ -64,76 +166,3 @@
|
||||||
(log-error "Flake update failed (exit: ~a)" status)
|
(log-error "Flake update failed (exit: ~a)" status)
|
||||||
(log-error "Error output: ~a" output)
|
(log-error "Error output: ~a" output)
|
||||||
#f))))))
|
#f))))))
|
||||||
|
|
||||||
;; Impure function: Execute nixos-rebuild
|
|
||||||
(define (execute-nixos-rebuild machine-name mode options)
|
|
||||||
"Execute nixos-rebuild command (impure - has side effects)"
|
|
||||||
(let* ((dry-run (option-ref options 'dry-run #f))
|
|
||||||
(ssh-config (get-ssh-config machine-name))
|
|
||||||
(is-local (and ssh-config (assoc-ref ssh-config 'is-local)))
|
|
||||||
(homelab-root (get-homelab-root)))
|
|
||||||
|
|
||||||
(if is-local
|
|
||||||
;; Local deployment
|
|
||||||
(let ((rebuild-cmd (format #f "sudo nixos-rebuild ~a --flake ~a#~a"
|
|
||||||
mode homelab-root machine-name)))
|
|
||||||
(log-debug "Local rebuild command: ~a" rebuild-cmd)
|
|
||||||
|
|
||||||
(if dry-run
|
|
||||||
(begin
|
|
||||||
(log-info "DRY RUN: Would execute: ~a" rebuild-cmd)
|
|
||||||
#t)
|
|
||||||
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" rebuild-cmd))
|
|
||||||
(output (get-string-all port))
|
|
||||||
(status (close-pipe port)))
|
|
||||||
|
|
||||||
(if (zero? status)
|
|
||||||
(begin
|
|
||||||
(log-success "Local nixos-rebuild completed")
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
(log-error "Local nixos-rebuild failed (exit: ~a)" status)
|
|
||||||
#f)))))
|
|
||||||
|
|
||||||
;; Remote deployment
|
|
||||||
(let* ((hostname (assoc-ref ssh-config 'hostname))
|
|
||||||
(ssh-alias (or (assoc-ref ssh-config 'ssh-alias) hostname))
|
|
||||||
(temp-dir "/tmp/homelab-deploy")
|
|
||||||
(sync-cmd (format #f "rsync -av --delete ~a/ ~a:~a/"
|
|
||||||
homelab-root ssh-alias temp-dir))
|
|
||||||
(rebuild-cmd (format #f "ssh ~a 'cd ~a && sudo nixos-rebuild ~a --flake .#~a'"
|
|
||||||
ssh-alias temp-dir mode machine-name)))
|
|
||||||
|
|
||||||
(log-debug "Remote sync command: ~a" sync-cmd)
|
|
||||||
(log-debug "Remote rebuild command: ~a" rebuild-cmd)
|
|
||||||
|
|
||||||
(if dry-run
|
|
||||||
(begin
|
|
||||||
(log-info "DRY RUN: Would sync and rebuild remotely")
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
;; Sync configuration
|
|
||||||
(log-info "Syncing configuration to ~a..." machine-name)
|
|
||||||
(let* ((sync-port (open-pipe* OPEN_READ "/bin/sh" "-c" sync-cmd))
|
|
||||||
(sync-output (get-string-all sync-port))
|
|
||||||
(sync-status (close-pipe sync-port)))
|
|
||||||
|
|
||||||
(if (zero? sync-status)
|
|
||||||
(begin
|
|
||||||
(log-success "Configuration synced")
|
|
||||||
;; Execute rebuild
|
|
||||||
(log-info "Executing nixos-rebuild on ~a..." machine-name)
|
|
||||||
(let* ((rebuild-port (open-pipe* OPEN_READ "/bin/sh" "-c" rebuild-cmd))
|
|
||||||
(rebuild-output (get-string-all rebuild-port))
|
|
||||||
(rebuild-status (close-pipe rebuild-port)))
|
|
||||||
|
|
||||||
(if (zero? rebuild-status)
|
|
||||||
(begin
|
|
||||||
(log-success "Remote nixos-rebuild completed")
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
(log-error "Remote nixos-rebuild failed (exit: ~a)" rebuild-status)
|
|
||||||
#f))))
|
|
||||||
(begin
|
|
||||||
(log-error "Configuration sync failed (exit: ~a)" sync-status)
|
|
||||||
#f)))))))))
|
|
||||||
|
|
|
@ -22,44 +22,48 @@
|
||||||
;; Pure function: Command help text
|
;; Pure function: Command help text
|
||||||
(define (get-help-text)
|
(define (get-help-text)
|
||||||
"Pure function returning help text"
|
"Pure function returning help text"
|
||||||
"Home Lab Tool - K.I.S.S Refactored Edition
|
"Home Lab Tool - Deploy-rs Edition
|
||||||
|
|
||||||
USAGE: lab <command> [args...]
|
USAGE: lab <command> [args...]
|
||||||
|
|
||||||
COMMANDS:
|
COMMANDS:
|
||||||
status Show infrastructure status
|
status Show infrastructure status
|
||||||
machines List all machines
|
machines List all machines
|
||||||
deploy <machine> [mode] Deploy configuration to machine
|
deploy <machine> [options] Deploy configuration to machine using deploy-rs
|
||||||
Available modes: boot (default), test, switch
|
Options: --dry-run, --skip-checks
|
||||||
deploy-all Deploy to all machines
|
deploy-all [options] Deploy to all machines using deploy-rs
|
||||||
update Update flake inputs
|
update Update flake inputs
|
||||||
auto-update Perform automatic system update with health checks
|
auto-update Perform automatic system update with health checks
|
||||||
auto-update-status Show auto-update service status and logs
|
auto-update-status Show auto-update service status and logs
|
||||||
health [machine] Check machine health (all if no machine specified)
|
health [machine] Check machine health (all if no machine specified)
|
||||||
ssh <machine> SSH to machine
|
ssh <machine> SSH to machine (using sma user)
|
||||||
test-modules Test modular implementation
|
test-rollback <machine> Test deployment with rollback
|
||||||
help Show this help
|
help Show this help
|
||||||
|
|
||||||
EXAMPLES:
|
EXAMPLES:
|
||||||
lab status
|
lab status
|
||||||
lab machines
|
lab machines
|
||||||
lab deploy congenital-optimist # Deploy with boot mode (default)
|
lab deploy congenital-optimist # Deploy with deploy-rs safety
|
||||||
lab deploy congenital-optimist switch # Deploy and activate immediately
|
lab deploy sleeper-service --dry-run # Test deployment without applying
|
||||||
lab deploy congenital-optimist test # Deploy temporarily for testing
|
lab deploy grey-area --skip-checks # Deploy without health checks
|
||||||
lab deploy-all
|
lab deploy-all # Deploy to all machines
|
||||||
lab update
|
lab deploy-all --dry-run # Test deployment to all machines
|
||||||
lab auto-update # Perform automatic update with reboot
|
lab update # Update flake inputs
|
||||||
lab auto-update-status # Show auto-update logs and status
|
lab test-rollback sleeper-service # Test rollback functionality
|
||||||
lab health
|
lab ssh sleeper-service # SSH to machine as sma user
|
||||||
lab health sleeper-service
|
|
||||||
lab ssh sleeper-service
|
|
||||||
lab test-modules
|
|
||||||
|
|
||||||
This implementation follows K.I.S.S principles:
|
Deploy-rs Features:
|
||||||
- Modular: Each module has single responsibility
|
- Automatic rollback on deployment failure
|
||||||
- Functional: Pure functions separated from side effects
|
- Health checks after deployment
|
||||||
- Small: Individual modules under 50 lines
|
- Magic rollback for network connectivity issues
|
||||||
- Simple: One function does one thing well
|
- 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
|
;; Pure function: Format machine list
|
||||||
|
@ -109,36 +113,33 @@ Home lab root: ~a
|
||||||
(log-success "Machine list complete")))
|
(log-success "Machine list complete")))
|
||||||
|
|
||||||
(define (cmd-deploy machine-name . args)
|
(define (cmd-deploy machine-name . args)
|
||||||
"Deploy configuration to machine"
|
"Deploy configuration to machine using deploy-rs"
|
||||||
(let* ((mode (if (null? args) "boot" (car args)))
|
(let* ((options (parse-deploy-options args)))
|
||||||
(valid-modes '("boot" "test" "switch")))
|
(log-info "Deploying to machine: ~a using deploy-rs" machine-name)
|
||||||
(log-info "Deploying to machine: ~a (mode: ~a)" machine-name mode)
|
(if (validate-machine-name machine-name)
|
||||||
(if (not (member mode valid-modes))
|
(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
|
(begin
|
||||||
(log-error "Invalid deployment mode: ~a" mode)
|
(log-error "Invalid machine: ~a" machine-name)
|
||||||
(log-error "Valid modes: ~a" (string-join valid-modes ", "))
|
(log-info "Available machines: ~a" (string-join (get-all-machines) ", "))))))
|
||||||
(format #t "Usage: lab deploy <machine> [boot|test|switch]\n"))
|
|
||||||
(if (validate-machine-name machine-name)
|
|
||||||
(let ((result (deploy-machine machine-name mode '())))
|
|
||||||
(if result
|
|
||||||
(log-success "Deployment to ~a complete (mode: ~a)" machine-name mode)
|
|
||||||
(log-error "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)
|
(define (cmd-ssh machine-name)
|
||||||
"SSH to machine"
|
"SSH to machine using sma user"
|
||||||
(log-info "Connecting to machine: ~a" machine-name)
|
(log-info "Connecting to machine: ~a as sma user" machine-name)
|
||||||
(if (validate-machine-name machine-name)
|
(if (validate-machine-name machine-name)
|
||||||
(let ((ssh-config (get-ssh-config machine-name)))
|
(let ((ssh-config (get-ssh-config machine-name)))
|
||||||
(if ssh-config
|
(if ssh-config
|
||||||
(let ((hostname (assoc-ref ssh-config 'hostname))
|
(let ((hostname (assoc-ref ssh-config 'hostname))
|
||||||
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
|
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
|
||||||
|
(ssh-user (assoc-ref ssh-config 'ssh-user))
|
||||||
(is-local (assoc-ref ssh-config 'is-local)))
|
(is-local (assoc-ref ssh-config 'is-local)))
|
||||||
(if is-local
|
(if is-local
|
||||||
(log-info "Machine ~a is local - no SSH needed" machine-name)
|
(begin
|
||||||
(let ((target (or ssh-alias hostname)))
|
(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)
|
(log-info "Connecting to ~a via SSH..." target)
|
||||||
(system (format #f "ssh ~a" target)))))
|
(system (format #f "ssh ~a" target)))))
|
||||||
(log-error "No SSH configuration found for ~a" machine-name)))
|
(log-error "No SSH configuration found for ~a" machine-name)))
|
||||||
|
@ -171,20 +172,12 @@ Home lab root: ~a
|
||||||
(log-error "Flake update failed"))))
|
(log-error "Flake update failed"))))
|
||||||
|
|
||||||
(define (cmd-deploy-all)
|
(define (cmd-deploy-all)
|
||||||
"Deploy to all machines"
|
"Deploy to all machines using deploy-rs"
|
||||||
(log-info "Deploying to all machines...")
|
(log-info "Deploying to all machines using deploy-rs...")
|
||||||
(let* ((machines (list-machines))
|
(let ((result (deploy-all-machines '())))
|
||||||
(results (map (lambda (machine)
|
(if result
|
||||||
(log-info "Deploying to ~a..." machine)
|
(log-success "All deploy-rs deployments completed successfully")
|
||||||
(let ((result (deploy-machine machine "boot" '())))
|
(log-error "Some deploy-rs deployments failed"))))
|
||||||
(if result
|
|
||||||
(log-success "✓ ~a deployed" machine)
|
|
||||||
(log-error "✗ ~a failed" machine))
|
|
||||||
result))
|
|
||||||
machines))
|
|
||||||
(successful (filter identity results)))
|
|
||||||
(log-info "Deployment summary: ~a/~a successful"
|
|
||||||
(length successful) (length machines))))
|
|
||||||
|
|
||||||
(define (cmd-health args)
|
(define (cmd-health args)
|
||||||
"Check machine health"
|
"Check machine health"
|
||||||
|
@ -219,6 +212,33 @@ Home lab root: ~a
|
||||||
"Show auto-update status and logs"
|
"Show auto-update status and logs"
|
||||||
(auto-update-status))
|
(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
|
;; Main command dispatcher
|
||||||
(define (dispatch-command command args)
|
(define (dispatch-command command args)
|
||||||
"Dispatch command with appropriate handler"
|
"Dispatch command with appropriate handler"
|
||||||
|
@ -236,12 +256,20 @@ Home lab root: ~a
|
||||||
(if (null? args)
|
(if (null? args)
|
||||||
(begin
|
(begin
|
||||||
(log-error "deploy command requires machine name")
|
(log-error "deploy command requires machine name")
|
||||||
(format #t "Usage: lab deploy <machine> [boot|test|switch]\n"))
|
(format #t "Usage: lab deploy <machine> [options]\n")
|
||||||
|
(format #t "Options: --dry-run, --skip-checks\n"))
|
||||||
(apply cmd-deploy args)))
|
(apply cmd-deploy args)))
|
||||||
|
|
||||||
('deploy-all
|
('deploy-all
|
||||||
(cmd-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
|
('update
|
||||||
(cmd-update))
|
(cmd-update))
|
||||||
|
|
||||||
|
@ -264,6 +292,13 @@ Home lab root: ~a
|
||||||
('test-modules
|
('test-modules
|
||||||
(cmd-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)
|
(log-error "Unknown command: ~a" command)
|
||||||
(format #t "Use 'lab help' for available commands\n")
|
(format #t "Use 'lab help' for available commands\n")
|
||||||
|
@ -272,7 +307,7 @@ Home lab root: ~a
|
||||||
;; Main entry point
|
;; Main entry point
|
||||||
(define (main args)
|
(define (main args)
|
||||||
"Main entry point for lab tool"
|
"Main entry point for lab tool"
|
||||||
(log-info "Home Lab Tool - K.I.S.S Refactored Edition")
|
(log-info "Home Lab Tool - Deploy-rs Edition")
|
||||||
|
|
||||||
(let* ((parsed-cmd (if (> (length args) 1) (cdr args) '("help")))
|
(let* ((parsed-cmd (if (> (length args) 1) (cdr args) '("help")))
|
||||||
(command (string->symbol (car parsed-cmd)))
|
(command (string->symbol (car parsed-cmd)))
|
||||||
|
|
|
@ -1,326 +0,0 @@
|
||||||
;; lab/core.scm - Core home lab operations
|
|
||||||
|
|
||||||
(define-module (lab core)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (ice-9 popen)
|
|
||||||
#:use-module (ice-9 rdelim)
|
|
||||||
#:use-module (ice-9 textual-ports)
|
|
||||||
#:use-module (srfi srfi-1)
|
|
||||||
#:use-module (srfi srfi-19)
|
|
||||||
#:export (get-infrastructure-status
|
|
||||||
check-system-health
|
|
||||||
update-flake
|
|
||||||
validate-environment
|
|
||||||
execute-nixos-rebuild
|
|
||||||
check-network-connectivity
|
|
||||||
option-ref))
|
|
||||||
|
|
||||||
;; Simple option reference function
|
|
||||||
(define (option-ref options key default)
|
|
||||||
"Get option value from options alist with default"
|
|
||||||
(let ((value (assoc-ref options key)))
|
|
||||||
(if value value default)))
|
|
||||||
|
|
||||||
;; Stub logging functions (to be replaced with proper logging module)
|
|
||||||
(define (log-info format-str . args)
|
|
||||||
"Log info message"
|
|
||||||
(apply format #t (string-append "[INFO] " format-str "~%") args))
|
|
||||||
|
|
||||||
(define (log-debug format-str . args)
|
|
||||||
"Log debug message"
|
|
||||||
(apply format #t (string-append "[DEBUG] " format-str "~%") args))
|
|
||||||
|
|
||||||
(define (log-success format-str . args)
|
|
||||||
"Log success message"
|
|
||||||
(apply format #t (string-append "[SUCCESS] " format-str "~%") args))
|
|
||||||
|
|
||||||
(define (log-error format-str . args)
|
|
||||||
"Log error message"
|
|
||||||
(apply format #t (string-append "[ERROR] " format-str "~%") args))
|
|
||||||
|
|
||||||
(define (log-warn format-str . args)
|
|
||||||
"Log warning message"
|
|
||||||
(apply format #t (string-append "[WARN] " format-str "~%") args))
|
|
||||||
|
|
||||||
;; Stub configuration functions
|
|
||||||
(define (get-all-machines)
|
|
||||||
"Get list of all machines"
|
|
||||||
'(grey-area sleeper-service congenital-optimist reverse-proxy))
|
|
||||||
|
|
||||||
(define (get-machine-config machine-name)
|
|
||||||
"Get configuration for a machine"
|
|
||||||
`((services . (systemd ssh))
|
|
||||||
(type . server)))
|
|
||||||
|
|
||||||
(define (get-ssh-config machine-name)
|
|
||||||
"Get SSH configuration for a machine"
|
|
||||||
`((hostname . ,(symbol->string machine-name))
|
|
||||||
(is-local . #f)))
|
|
||||||
|
|
||||||
(define (get-homelab-root)
|
|
||||||
"Get home lab root directory"
|
|
||||||
"/home/geir/Home-lab")
|
|
||||||
|
|
||||||
;; Stub SSH functions
|
|
||||||
(define (test-ssh-connection machine-name)
|
|
||||||
"Test SSH connection to machine"
|
|
||||||
(zero? (system (format #f "ssh -o ConnectTimeout=5 -o BatchMode=yes ~a exit 2>/dev/null" machine-name))))
|
|
||||||
|
|
||||||
(define (run-remote-command machine-name command . args)
|
|
||||||
"Run command on remote machine via SSH"
|
|
||||||
(let* ((full-command (if (null? args)
|
|
||||||
command
|
|
||||||
(string-join (cons command args) " ")))
|
|
||||||
(ssh-command (format #f "ssh ~a '~a'" machine-name full-command))
|
|
||||||
(port (open-input-pipe ssh-command))
|
|
||||||
(output (read-string port))
|
|
||||||
(status (close-pipe port)))
|
|
||||||
(values (zero? status) output)))
|
|
||||||
|
|
||||||
;; Utility function for spinner (stub)
|
|
||||||
(define (with-spinner message proc)
|
|
||||||
"Execute procedure with spinner (stub implementation)"
|
|
||||||
(display (format #f "~a..." message))
|
|
||||||
(let ((result (proc)))
|
|
||||||
(display " done.\n")
|
|
||||||
result))
|
|
||||||
|
|
||||||
;; Get comprehensive infrastructure status
|
|
||||||
(define (get-infrastructure-status . args)
|
|
||||||
"Get status of all machines or specific machine if provided"
|
|
||||||
(let ((target-machine (if (null? args) #f (car args)))
|
|
||||||
(machines (if (null? args)
|
|
||||||
(get-all-machines)
|
|
||||||
(list (car args)))))
|
|
||||||
|
|
||||||
(log-info "Checking infrastructure status...")
|
|
||||||
|
|
||||||
(map (lambda (machine-name)
|
|
||||||
(let ((start-time (current-time)))
|
|
||||||
(log-debug "Checking ~a..." machine-name)
|
|
||||||
|
|
||||||
(let* ((ssh-config (get-ssh-config machine-name))
|
|
||||||
(is-local (and ssh-config (assoc-ref ssh-config 'is-local)))
|
|
||||||
(connection-status (test-ssh-connection machine-name))
|
|
||||||
(services-status (if connection-status
|
|
||||||
(get-machine-services-status machine-name)
|
|
||||||
'()))
|
|
||||||
(system-info (if connection-status
|
|
||||||
(get-machine-system-info machine-name)
|
|
||||||
#f))
|
|
||||||
(elapsed (- (current-time) start-time)))
|
|
||||||
|
|
||||||
`((machine . ,machine-name)
|
|
||||||
(type . ,(if is-local 'local 'remote))
|
|
||||||
(connection . ,(if connection-status 'online 'offline))
|
|
||||||
(services . ,services-status)
|
|
||||||
(system . ,system-info)
|
|
||||||
(check-time . ,elapsed)))))
|
|
||||||
machines)))
|
|
||||||
|
|
||||||
;; Get services status for a machine
|
|
||||||
(define (get-machine-services-status machine-name)
|
|
||||||
"Check status of services on a machine"
|
|
||||||
(let ((machine-config (get-machine-config machine-name)))
|
|
||||||
(if machine-config
|
|
||||||
(let ((services (assoc-ref machine-config 'services)))
|
|
||||||
(if services
|
|
||||||
(map (lambda (service)
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name
|
|
||||||
"systemctl is-active"
|
|
||||||
(symbol->string service)))
|
|
||||||
(lambda (success output)
|
|
||||||
`(,service . ,(if success
|
|
||||||
(string-trim-right output)
|
|
||||||
"unknown")))))
|
|
||||||
services)
|
|
||||||
'()))
|
|
||||||
'())))
|
|
||||||
|
|
||||||
;; Get basic system information from a machine
|
|
||||||
(define (get-machine-system-info machine-name)
|
|
||||||
"Get basic system information from a machine"
|
|
||||||
(let ((info-commands
|
|
||||||
'(("uptime" "uptime -p")
|
|
||||||
("load" "cat /proc/loadavg | cut -d' ' -f1-3")
|
|
||||||
("memory" "free -h | grep Mem | awk '{print $3\"/\"$2}'")
|
|
||||||
("disk" "df -h / | tail -1 | awk '{print $5}'")
|
|
||||||
("kernel" "uname -r"))))
|
|
||||||
|
|
||||||
(fold (lambda (cmd-pair acc)
|
|
||||||
(let ((key (car cmd-pair))
|
|
||||||
(command (cadr cmd-pair)))
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name command))
|
|
||||||
(lambda (success output)
|
|
||||||
(if success
|
|
||||||
(assoc-set! acc (string->symbol key) (string-trim-right output))
|
|
||||||
acc)))))
|
|
||||||
'()
|
|
||||||
info-commands)))
|
|
||||||
|
|
||||||
;; Check system health with comprehensive tests
|
|
||||||
(define (check-system-health machine-name)
|
|
||||||
"Perform comprehensive health check on a machine"
|
|
||||||
(log-info "Performing health check on ~a..." machine-name)
|
|
||||||
|
|
||||||
(let ((health-checks
|
|
||||||
'(("connectivity" . test-ssh-connection)
|
|
||||||
("disk-space" . check-disk-space)
|
|
||||||
("system-load" . check-system-load)
|
|
||||||
("critical-services" . check-critical-services)
|
|
||||||
("network" . check-network-connectivity))))
|
|
||||||
|
|
||||||
(map (lambda (check-pair)
|
|
||||||
(let ((check-name (car check-pair))
|
|
||||||
(check-proc (cdr check-pair)))
|
|
||||||
(log-debug "Running ~a check..." check-name)
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(let ((result (check-proc machine-name)))
|
|
||||||
`(,check-name . ((status . ,(if result 'pass 'fail))
|
|
||||||
(result . ,result))))
|
|
||||||
(lambda (key . args)
|
|
||||||
(log-warn "Health check ~a failed: ~a" check-name key)
|
|
||||||
`(,check-name . ((status . error)
|
|
||||||
(error . ,key)))))))
|
|
||||||
health-checks)))
|
|
||||||
|
|
||||||
;; Individual health check functions
|
|
||||||
(define (check-disk-space machine-name)
|
|
||||||
"Check if disk space is below critical threshold"
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name "df / | tail -1 | awk '{print $5}' | sed 's/%//'"))
|
|
||||||
(lambda (success output)
|
|
||||||
(if success
|
|
||||||
(let ((usage (string->number (string-trim-right output))))
|
|
||||||
(< usage 90)) ; Pass if usage < 90%
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
(define (check-system-load machine-name)
|
|
||||||
"Check if system load is reasonable"
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name "cat /proc/loadavg | cut -d' ' -f1"))
|
|
||||||
(lambda (success output)
|
|
||||||
(if success
|
|
||||||
(let ((load (string->number (string-trim-right output))))
|
|
||||||
(< load 5.0)) ; Pass if load < 5.0
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
(define (check-critical-services machine-name)
|
|
||||||
"Check that critical services are running"
|
|
||||||
(let ((critical-services '("sshd")))
|
|
||||||
(every (lambda (service)
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name "systemctl is-active" service))
|
|
||||||
(lambda (success output)
|
|
||||||
(and success (string=? (string-trim-right output) "active")))))
|
|
||||||
critical-services)))
|
|
||||||
|
|
||||||
(define (check-network-connectivity machine-name)
|
|
||||||
"Check basic network connectivity"
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (run-remote-command machine-name "ping -c 1 -W 5 8.8.8.8 > /dev/null 2>&1; echo $?"))
|
|
||||||
(lambda (success output)
|
|
||||||
(and success (string=? (string-trim-right output) "0")))))
|
|
||||||
|
|
||||||
;; Update flake inputs
|
|
||||||
(define (update-flake options)
|
|
||||||
"Update flake inputs in the home lab repository"
|
|
||||||
(let ((homelab-root (get-homelab-root))
|
|
||||||
(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* ((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")
|
|
||||||
(log-debug "Update output: ~a" output)
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
(log-error "Flake update failed (exit: ~a)" status)
|
|
||||||
(log-error "Error output: ~a" output)
|
|
||||||
#f))))))
|
|
||||||
|
|
||||||
;; Validate home lab environment
|
|
||||||
(define (validate-environment)
|
|
||||||
"Validate that the home lab environment is properly configured"
|
|
||||||
(log-info "Validating home lab environment...")
|
|
||||||
|
|
||||||
(let ((checks
|
|
||||||
`(("homelab-root" . ,(lambda () (file-exists? (get-homelab-root))))
|
|
||||||
("flake-file" . ,(lambda () (file-exists? (string-append (get-homelab-root) "/flake.nix"))))
|
|
||||||
("ssh-config" . ,(lambda () (file-exists? (string-append (getenv "HOME") "/.ssh/config"))))
|
|
||||||
("nix-command" . ,(lambda () (zero? (system "which nix > /dev/null 2>&1"))))
|
|
||||||
("machines-config" . ,(lambda () (not (null? (get-all-machines))))))))
|
|
||||||
|
|
||||||
(let ((results (map (lambda (check-pair)
|
|
||||||
(let ((check-name (car check-pair))
|
|
||||||
(check-proc (cdr check-pair)))
|
|
||||||
(let ((result (check-proc)))
|
|
||||||
(if result
|
|
||||||
(log-success "✓ ~a" check-name)
|
|
||||||
(log-error "✗ ~a" check-name))
|
|
||||||
`(,check-name . ,result))))
|
|
||||||
checks)))
|
|
||||||
|
|
||||||
(let ((failures (filter (lambda (result) (not (cdr result))) results)))
|
|
||||||
(if (null? failures)
|
|
||||||
(begin
|
|
||||||
(log-success "Environment validation passed")
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
(log-error "Environment validation failed: ~a" (map car failures))
|
|
||||||
#f))))))
|
|
||||||
|
|
||||||
;; Execute nixos-rebuild with proper error handling
|
|
||||||
(define (execute-nixos-rebuild machine-name mode options)
|
|
||||||
"Execute nixos-rebuild on a machine with comprehensive error handling"
|
|
||||||
(let ((homelab-root (get-homelab-root))
|
|
||||||
(dry-run (option-ref options 'dry-run #f))
|
|
||||||
(ssh-config (get-ssh-config machine-name)))
|
|
||||||
|
|
||||||
(if (not ssh-config)
|
|
||||||
(begin
|
|
||||||
(log-error "No SSH configuration for machine: ~a" machine-name)
|
|
||||||
#f)
|
|
||||||
(let* ((is-local (assoc-ref ssh-config 'is-local))
|
|
||||||
(flake-ref (format #f "~a#~a" homelab-root machine-name))
|
|
||||||
(rebuild-cmd (if is-local
|
|
||||||
(format #f "sudo nixos-rebuild ~a --flake ~a" mode flake-ref)
|
|
||||||
(format #f "nixos-rebuild ~a --flake ~a --target-host ~a --use-remote-sudo"
|
|
||||||
mode flake-ref (assoc-ref ssh-config 'hostname)))))
|
|
||||||
|
|
||||||
(log-info "Executing nixos-rebuild for ~a (mode: ~a)" machine-name mode)
|
|
||||||
(log-debug "Command: ~a" rebuild-cmd)
|
|
||||||
|
|
||||||
(if dry-run
|
|
||||||
(begin
|
|
||||||
(log-info "DRY RUN: Would execute: ~a" rebuild-cmd)
|
|
||||||
#t)
|
|
||||||
(with-spinner
|
|
||||||
(format #f "Rebuilding ~a" machine-name)
|
|
||||||
(lambda ()
|
|
||||||
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" rebuild-cmd))
|
|
||||||
(output (get-string-all port))
|
|
||||||
(status (close-pipe port)))
|
|
||||||
|
|
||||||
(if (zero? status)
|
|
||||||
(begin
|
|
||||||
(log-success "nixos-rebuild completed successfully for ~a" machine-name)
|
|
||||||
(log-debug "Build output: ~a" output)
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
(log-error "nixos-rebuild failed for ~a (exit: ~a)" machine-name status)
|
|
||||||
(log-error "Error output: ~a" output)
|
|
||||||
#f))))))))))
|
|
|
@ -1,329 +0,0 @@
|
||||||
;; lab/deployment.scm - Deployment operations for Home Lab Tool
|
|
||||||
|
|
||||||
(define-module (lab deployment)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (ice-9 match)
|
|
||||||
#:use-module (ice-9 popen)
|
|
||||||
#:use-module (ice-9 textual-ports)
|
|
||||||
|
|
||||||
#:use-module (srfi srfi-1)
|
|
||||||
#:use-module (srfi srfi-19)
|
|
||||||
#:use-module (utils logging)
|
|
||||||
#:use-module (utils config)
|
|
||||||
#:use-module (utils ssh)
|
|
||||||
#:use-module (lab core)
|
|
||||||
#:export (deploy-machine
|
|
||||||
update-all-machines
|
|
||||||
hybrid-update
|
|
||||||
validate-deployment
|
|
||||||
rollback-deployment
|
|
||||||
deployment-status
|
|
||||||
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)))
|
|
||||||
|
|
||||||
;; Deploy configuration to a specific machine
|
|
||||||
(define (deploy-machine machine-name mode options)
|
|
||||||
"Deploy NixOS configuration to a specific machine"
|
|
||||||
(let ((valid-modes '("boot" "test" "switch"))
|
|
||||||
(dry-run (option-ref options 'dry-run #f)))
|
|
||||||
|
|
||||||
;; Validate inputs
|
|
||||||
(if (not (validate-machine-name machine-name))
|
|
||||||
#f
|
|
||||||
(if (not (member mode valid-modes))
|
|
||||||
(begin
|
|
||||||
(log-error "Invalid deployment mode: ~a" mode)
|
|
||||||
(log-error "Valid modes: ~a" (string-join valid-modes ", "))
|
|
||||||
#f)
|
|
||||||
|
|
||||||
;; Proceed with deployment
|
|
||||||
(begin
|
|
||||||
(log-info "Starting deployment: ~a -> ~a (mode: ~a)"
|
|
||||||
machine-name machine-name mode)
|
|
||||||
|
|
||||||
;; Pre-deployment validation
|
|
||||||
(if (not (validate-deployment-prerequisites machine-name))
|
|
||||||
(begin
|
|
||||||
(log-error "Pre-deployment validation failed")
|
|
||||||
#f)
|
|
||||||
|
|
||||||
;; Execute deployment
|
|
||||||
(let ((deployment-result
|
|
||||||
(execute-deployment machine-name mode options)))
|
|
||||||
|
|
||||||
;; Post-deployment validation
|
|
||||||
(if deployment-result
|
|
||||||
(begin
|
|
||||||
(log-info "Deployment completed, validating...")
|
|
||||||
(if (validate-post-deployment machine-name mode)
|
|
||||||
(begin
|
|
||||||
(log-success "Deployment successful and validated ✓")
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
(log-warn "Deployment completed but validation failed")
|
|
||||||
;; Don't fail completely - deployment might still be functional
|
|
||||||
#t)))
|
|
||||||
(begin
|
|
||||||
(log-error "Deployment failed")
|
|
||||||
#f)))))))))
|
|
||||||
|
|
||||||
;; Execute the actual deployment
|
|
||||||
(define (execute-deployment machine-name mode options)
|
|
||||||
"Execute the deployment based on machine type and configuration"
|
|
||||||
(let ((ssh-config (get-ssh-config machine-name))
|
|
||||||
(machine-config (get-machine-config machine-name)))
|
|
||||||
|
|
||||||
(if (not ssh-config)
|
|
||||||
(begin
|
|
||||||
(log-error "No SSH configuration found for ~a" machine-name)
|
|
||||||
#f)
|
|
||||||
|
|
||||||
(let ((deployment-method (assoc-ref machine-config 'deployment-method))
|
|
||||||
(is-local (assoc-ref ssh-config 'is-local)))
|
|
||||||
|
|
||||||
(log-debug "Using deployment method: ~a" (or deployment-method 'nixos-rebuild))
|
|
||||||
|
|
||||||
(match (or deployment-method 'nixos-rebuild)
|
|
||||||
('nixos-rebuild
|
|
||||||
(execute-nixos-rebuild machine-name mode options))
|
|
||||||
|
|
||||||
('deploy-rs
|
|
||||||
(execute-deploy-rs machine-name mode options))
|
|
||||||
|
|
||||||
('hybrid
|
|
||||||
(execute-hybrid-deployment machine-name mode options))
|
|
||||||
|
|
||||||
(method
|
|
||||||
(log-error "Unknown deployment method: ~a" method)
|
|
||||||
#f))))))
|
|
||||||
|
|
||||||
;; Execute deploy-rs deployment
|
|
||||||
(define (execute-deploy-rs machine-name mode options)
|
|
||||||
"Deploy using deploy-rs for atomic deployments"
|
|
||||||
(let ((homelab-root (get-homelab-root))
|
|
||||||
(dry-run (option-ref options 'dry-run #f)))
|
|
||||||
|
|
||||||
(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)
|
|
||||||
#t)
|
|
||||||
|
|
||||||
(let* ((deploy-cmd (format #f "cd ~a && deploy '.#~a' --magic-rollback --auto-rollback"
|
|
||||||
homelab-root machine-name))
|
|
||||||
(start-time (current-time)))
|
|
||||||
|
|
||||||
(log-debug "Deploy command: ~a" deploy-cmd)
|
|
||||||
|
|
||||||
(with-spinner
|
|
||||||
(format #f "Deploying ~a with deploy-rs" machine-name)
|
|
||||||
(lambda ()
|
|
||||||
(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 completed in ~as" elapsed)
|
|
||||||
(log-debug "Deploy output: ~a" output)
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
(log-error "deploy-rs failed (exit: ~a)" status)
|
|
||||||
(log-error "Error output: ~a" output)
|
|
||||||
#f)))))))))
|
|
||||||
|
|
||||||
;; Execute hybrid deployment (flake update + deploy)
|
|
||||||
(define (execute-hybrid-deployment machine-name mode options)
|
|
||||||
"Execute hybrid deployment: update flake then deploy"
|
|
||||||
(log-info "Starting hybrid deployment for ~a..." machine-name)
|
|
||||||
|
|
||||||
;; First update flake
|
|
||||||
(if (update-flake options)
|
|
||||||
;; Then deploy
|
|
||||||
(execute-nixos-rebuild machine-name mode options)
|
|
||||||
(begin
|
|
||||||
(log-error "Flake update failed, aborting deployment")
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
;; Validate deployment prerequisites
|
|
||||||
(define (validate-deployment-prerequisites machine-name)
|
|
||||||
"Validate that deployment prerequisites are met"
|
|
||||||
(log-debug "Validating deployment prerequisites for ~a..." machine-name)
|
|
||||||
|
|
||||||
(let ((checks
|
|
||||||
`(("machine-config" . ,(lambda () (get-machine-config machine-name)))
|
|
||||||
("ssh-connectivity" . ,(lambda () (test-ssh-connection machine-name)))
|
|
||||||
("flake-exists" . ,(lambda () (file-exists? (string-append (get-homelab-root) "/flake.nix"))))
|
|
||||||
("machine-flake-config" . ,(lambda () (validate-machine-flake-config machine-name))))))
|
|
||||||
|
|
||||||
(let ((results (map (lambda (check-pair)
|
|
||||||
(let ((check-name (car check-pair))
|
|
||||||
(check-proc (cdr check-pair)))
|
|
||||||
(let ((result (check-proc)))
|
|
||||||
(if result
|
|
||||||
(log-debug "✓ Prerequisite: ~a" check-name)
|
|
||||||
(log-error "✗ Prerequisite failed: ~a" check-name))
|
|
||||||
result)))
|
|
||||||
checks)))
|
|
||||||
|
|
||||||
(every identity results))))
|
|
||||||
|
|
||||||
;; Validate machine has flake configuration
|
|
||||||
(define (validate-machine-flake-config machine-name)
|
|
||||||
"Check that machine has a configuration in the flake"
|
|
||||||
(let ((machine-dir (string-append (get-homelab-root) "/machines/" machine-name)))
|
|
||||||
(and (file-exists? machine-dir)
|
|
||||||
(file-exists? (string-append machine-dir "/configuration.nix")))))
|
|
||||||
|
|
||||||
;; Validate post-deployment state
|
|
||||||
(define (validate-post-deployment machine-name mode)
|
|
||||||
"Validate system state after deployment"
|
|
||||||
(log-debug "Validating post-deployment state for ~a..." machine-name)
|
|
||||||
|
|
||||||
;; Wait a moment for services to stabilize
|
|
||||||
(sleep 3)
|
|
||||||
|
|
||||||
(let ((checks
|
|
||||||
`(("ssh-connectivity" . ,(lambda () (test-ssh-connection machine-name)))
|
|
||||||
("system-responsive" . ,(lambda () (check-system-responsive machine-name)))
|
|
||||||
("critical-services" . ,(lambda () (check-critical-services machine-name))))))
|
|
||||||
|
|
||||||
(let ((results (map (lambda (check-pair)
|
|
||||||
(let ((check-name (car check-pair))
|
|
||||||
(check-proc (cdr check-pair)))
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(let ((result (check-proc)))
|
|
||||||
(if result
|
|
||||||
(log-debug "✓ Post-deployment: ~a" check-name)
|
|
||||||
(log-warn "✗ Post-deployment: ~a" check-name))
|
|
||||||
result))
|
|
||||||
(lambda (key . args)
|
|
||||||
(log-warn "Post-deployment check ~a failed: ~a" check-name key)
|
|
||||||
#f))))
|
|
||||||
checks)))
|
|
||||||
|
|
||||||
(every identity results))))
|
|
||||||
|
|
||||||
;; Check if system is responsive after deployment
|
|
||||||
(define (check-system-responsive machine-name)
|
|
||||||
"Check if system is responsive after deployment"
|
|
||||||
(call-with-values (((success output)
|
|
||||||
(run-remote-command machine-name "echo 'system-check' && uptime")))
|
|
||||||
(and success (string-contains output "system-check"))))
|
|
||||||
|
|
||||||
;; Update all machines
|
|
||||||
(define (update-all-machines mode options)
|
|
||||||
"Update all configured machines"
|
|
||||||
(let ((machines (get-all-machines))
|
|
||||||
(dry-run (option-ref options 'dry-run #f)))
|
|
||||||
|
|
||||||
(log-info "Starting update of all machines (mode: ~a)..." mode)
|
|
||||||
|
|
||||||
(if dry-run
|
|
||||||
(begin
|
|
||||||
(log-info "DRY RUN: Would update machines: ~a" (string-join machines ", "))
|
|
||||||
#t)
|
|
||||||
|
|
||||||
(let ((results
|
|
||||||
(map (lambda (machine-name)
|
|
||||||
(log-info "Updating ~a..." machine-name)
|
|
||||||
(let ((result (deploy-machine machine-name mode options)))
|
|
||||||
(if result
|
|
||||||
(log-success "✓ ~a updated successfully" machine-name)
|
|
||||||
(log-error "✗ ~a update failed" machine-name))
|
|
||||||
`(,machine-name . ,result)))
|
|
||||||
machines)))
|
|
||||||
|
|
||||||
(let ((successful (filter cdr results))
|
|
||||||
(failed (filter (lambda (r) (not (cdr r))) results)))
|
|
||||||
|
|
||||||
(log-info "Update summary:")
|
|
||||||
(log-info " Successful: ~a/~a" (length successful) (length results))
|
|
||||||
|
|
||||||
(when (not (null? failed))
|
|
||||||
(log-warn " Failed: ~a" (map car failed)))
|
|
||||||
|
|
||||||
;; Return success if all succeeded
|
|
||||||
(= (length successful) (length results)))))))
|
|
||||||
|
|
||||||
;; Hybrid update: flake update + selective deployment
|
|
||||||
(define (hybrid-update target options)
|
|
||||||
"Perform hybrid update: flake update followed by deployment"
|
|
||||||
(log-info "Starting hybrid update for target: ~a" target)
|
|
||||||
|
|
||||||
;; First update flake
|
|
||||||
(if (update-flake options)
|
|
||||||
|
|
||||||
;; Then deploy based on target
|
|
||||||
(match target
|
|
||||||
("all"
|
|
||||||
(update-all-machines "boot" options))
|
|
||||||
|
|
||||||
(machine-name
|
|
||||||
(if (validate-machine-name machine-name)
|
|
||||||
(deploy-machine machine-name "boot" options)
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(begin
|
|
||||||
(log-error "Flake update failed, aborting hybrid update")
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
;; Get deployment status
|
|
||||||
(define (deployment-status . machine-name)
|
|
||||||
"Get current deployment status for machines"
|
|
||||||
(let ((machines (if (null? machine-name)
|
|
||||||
(get-all-machines)
|
|
||||||
machine-name)))
|
|
||||||
|
|
||||||
(map (lambda (machine)
|
|
||||||
(let ((last-deployment (get-last-deployment-info machine))
|
|
||||||
(current-generation (get-current-generation machine)))
|
|
||||||
`((machine . ,machine)
|
|
||||||
(last-deployment . ,last-deployment)
|
|
||||||
(current-generation . ,current-generation)
|
|
||||||
(status . ,(get-deployment-health machine)))))
|
|
||||||
machines)))
|
|
||||||
|
|
||||||
;; Get last deployment information
|
|
||||||
(define (get-last-deployment-info machine-name)
|
|
||||||
"Get information about the last deployment"
|
|
||||||
(call-with-values (((success output)
|
|
||||||
(run-remote-command machine-name
|
|
||||||
"ls -la /nix/var/nix/profiles/system* | tail -1")))
|
|
||||||
(if success
|
|
||||||
(string-trim-right output)
|
|
||||||
"unknown")))
|
|
||||||
|
|
||||||
;; Get current system generation
|
|
||||||
(define (get-current-generation machine-name)
|
|
||||||
"Get current NixOS generation information"
|
|
||||||
(call-with-values (((success output)
|
|
||||||
(run-remote-command machine-name
|
|
||||||
"nixos-version")))
|
|
||||||
(if success
|
|
||||||
(string-trim-right output)
|
|
||||||
"unknown")))
|
|
||||||
|
|
||||||
;; Get deployment health status
|
|
||||||
(define (get-deployment-health machine-name)
|
|
||||||
"Check if deployment is healthy"
|
|
||||||
(if (test-ssh-connection machine-name)
|
|
||||||
'healthy
|
|
||||||
'unhealthy))
|
|
||||||
|
|
||||||
;; Rollback deployment (placeholder for future implementation)
|
|
||||||
(define (rollback-deployment machine-name . generation)
|
|
||||||
"Rollback to previous generation (deploy-rs feature)"
|
|
||||||
(log-warn "Rollback functionality not yet implemented")
|
|
||||||
(log-info "For manual rollback on ~a:" machine-name)
|
|
||||||
(log-info " 1. SSH to machine")
|
|
||||||
(log-info " 2. Run: sudo nixos-rebuild switch --rollback")
|
|
||||||
#f)
|
|
|
@ -1,348 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; Guile MCP Server for Home Lab Integration
|
|
||||||
;; Implements Model Context Protocol for VS Code extension
|
|
||||||
|
|
||||||
(use-modules (json)
|
|
||||||
(ice-9 textual-ports)
|
|
||||||
(ice-9 popen)
|
|
||||||
(ice-9 rdelim)
|
|
||||||
(ice-9 match)
|
|
||||||
(ice-9 threads)
|
|
||||||
(srfi srfi-1)
|
|
||||||
(srfi srfi-19)
|
|
||||||
(srfi srfi-26))
|
|
||||||
|
|
||||||
;; MCP Protocol Implementation
|
|
||||||
(define mcp-protocol-version "2024-11-05")
|
|
||||||
(define request-id-counter 0)
|
|
||||||
|
|
||||||
;; Server capabilities and state
|
|
||||||
(define server-capabilities
|
|
||||||
`((tools . ())
|
|
||||||
(resources . ())
|
|
||||||
(prompts . ())))
|
|
||||||
|
|
||||||
(define server-info
|
|
||||||
`((name . "guile-homelab-mcp")
|
|
||||||
(version . "0.1.0")))
|
|
||||||
|
|
||||||
;; Request/Response utilities
|
|
||||||
(define (make-response id result)
|
|
||||||
`((jsonrpc . "2.0")
|
|
||||||
(id . ,id)
|
|
||||||
(result . ,result)))
|
|
||||||
|
|
||||||
(define (make-error id code message)
|
|
||||||
`((jsonrpc . "2.0")
|
|
||||||
(id . ,id)
|
|
||||||
(error . ((code . ,code)
|
|
||||||
(message . ,message)))))
|
|
||||||
|
|
||||||
(define (send-response response)
|
|
||||||
(let ((json-str (scm->json-string response)))
|
|
||||||
(display json-str)
|
|
||||||
(newline)
|
|
||||||
(force-output)))
|
|
||||||
|
|
||||||
;; Home Lab Tools Implementation
|
|
||||||
(define (list-machines)
|
|
||||||
"List all available machines in the home lab"
|
|
||||||
(let* ((proc (open-input-pipe "find /etc/nixos/hosts -name '*.nix' -type f"))
|
|
||||||
(output (read-string proc)))
|
|
||||||
(close-pipe proc)
|
|
||||||
(if (string-null? output)
|
|
||||||
'()
|
|
||||||
(map (lambda (path)
|
|
||||||
(basename path ".nix"))
|
|
||||||
(string-split (string-trim-right output #\newline) #\newline)))))
|
|
||||||
|
|
||||||
(define (get-machine-status machine)
|
|
||||||
"Get status of a specific machine"
|
|
||||||
(let* ((cmd (format #f "ping -c 1 -W 1 ~a > /dev/null 2>&1" machine))
|
|
||||||
(status (system cmd)))
|
|
||||||
(if (= status 0) "online" "offline")))
|
|
||||||
|
|
||||||
(define (deploy-machine machine method)
|
|
||||||
"Deploy configuration to a machine"
|
|
||||||
(match method
|
|
||||||
("deploy-rs"
|
|
||||||
(let ((cmd (format #f "deploy '.#~a'" machine)))
|
|
||||||
(deploy-with-command cmd machine)))
|
|
||||||
("hybrid-update"
|
|
||||||
(let ((cmd (format #f "nixos-rebuild switch --flake '.#~a' --target-host ~a --use-remote-sudo" machine machine)))
|
|
||||||
(deploy-with-command cmd machine)))
|
|
||||||
("legacy"
|
|
||||||
(let ((cmd (format #f "nixos-rebuild switch --flake '.#~a'" machine)))
|
|
||||||
(deploy-with-command cmd machine)))
|
|
||||||
(_ (throw 'deployment-error "Unknown deployment method" method))))
|
|
||||||
|
|
||||||
(define (deploy-with-command cmd machine)
|
|
||||||
"Execute deployment command and return result"
|
|
||||||
(let* ((proc (open-input-pipe cmd))
|
|
||||||
(output (read-string proc))
|
|
||||||
(status (close-pipe proc)))
|
|
||||||
`((success . ,(= status 0))
|
|
||||||
(output . ,output)
|
|
||||||
(machine . ,machine)
|
|
||||||
(timestamp . ,(date->string (current-date))))))
|
|
||||||
|
|
||||||
(define (generate-nix-config machine-name services)
|
|
||||||
"Generate NixOS configuration for a new machine"
|
|
||||||
(let ((config (format #f "# Generated NixOS configuration for ~a
|
|
||||||
# Generated on ~a
|
|
||||||
|
|
||||||
{ config, pkgs, ... }:
|
|
||||||
|
|
||||||
{
|
|
||||||
imports = [
|
|
||||||
./hardware-configuration.nix
|
|
||||||
];
|
|
||||||
|
|
||||||
# Machine name
|
|
||||||
networking.hostName = \"~a\";
|
|
||||||
|
|
||||||
# Basic system configuration
|
|
||||||
system.stateVersion = \"23.11\";
|
|
||||||
|
|
||||||
# Enable services
|
|
||||||
~a
|
|
||||||
|
|
||||||
# Network configuration
|
|
||||||
networking.firewall.enable = true;
|
|
||||||
|
|
||||||
# SSH access
|
|
||||||
services.openssh.enable = true;
|
|
||||||
users.users.root.openssh.authorizedKeys.keys = [
|
|
||||||
# Add your public key here
|
|
||||||
];
|
|
||||||
}
|
|
||||||
"
|
|
||||||
machine-name
|
|
||||||
(date->string (current-date))
|
|
||||||
machine-name
|
|
||||||
(string-join
|
|
||||||
(map (lambda (service)
|
|
||||||
(format #f " services.~a.enable = true;" service))
|
|
||||||
services)
|
|
||||||
"\n"))))
|
|
||||||
`((content . ,config)
|
|
||||||
(filename . ,(format #f "~a.nix" machine-name)))))
|
|
||||||
|
|
||||||
(define (get-infrastructure-status)
|
|
||||||
"Get comprehensive infrastructure status"
|
|
||||||
(let* ((machines (list-machines))
|
|
||||||
(machine-status (map (lambda (m)
|
|
||||||
`((name . ,m)
|
|
||||||
(status . ,(get-machine-status m))))
|
|
||||||
machines)))
|
|
||||||
`((machines . ,machine-status)
|
|
||||||
(timestamp . ,(date->string (current-date)))
|
|
||||||
(total-machines . ,(length machines))
|
|
||||||
(online-machines . ,(length (filter (lambda (m)
|
|
||||||
(equal? (assoc-ref m 'status) "online"))
|
|
||||||
machine-status))))))
|
|
||||||
|
|
||||||
;; MCP Tools Registry
|
|
||||||
(define mcp-tools
|
|
||||||
`(((name . "deploy-machine")
|
|
||||||
(description . "Deploy NixOS configuration to a home lab machine")
|
|
||||||
(inputSchema . ((type . "object")
|
|
||||||
(properties . ((machine . ((type . "string")
|
|
||||||
(description . "Machine hostname to deploy to")))
|
|
||||||
(method . ((type . "string")
|
|
||||||
(enum . ("deploy-rs" "hybrid-update" "legacy"))
|
|
||||||
(description . "Deployment method to use")))))
|
|
||||||
(required . ("machine" "method")))))
|
|
||||||
|
|
||||||
((name . "list-machines")
|
|
||||||
(description . "List all available machines in the home lab")
|
|
||||||
(inputSchema . ((type . "object")
|
|
||||||
(properties . ()))))
|
|
||||||
|
|
||||||
((name . "check-status")
|
|
||||||
(description . "Check status of home lab infrastructure")
|
|
||||||
(inputSchema . ((type . "object")
|
|
||||||
(properties . ((machine . ((type . "string")
|
|
||||||
(description . "Specific machine to check (optional)")))))))
|
|
||||||
|
|
||||||
((name . "generate-nix-config")
|
|
||||||
(description . "Generate NixOS configuration for a new machine")
|
|
||||||
(inputSchema . ((type . "object")
|
|
||||||
(properties . ((machine-name . ((type . "string")
|
|
||||||
(description . "Name for the new machine")))
|
|
||||||
(services . ((type . "array")
|
|
||||||
(items . ((type . "string")))
|
|
||||||
(description . "List of services to enable")))))
|
|
||||||
(required . ("machine-name")))))
|
|
||||||
|
|
||||||
((name . "list-services")
|
|
||||||
(description . "List available NixOS services")
|
|
||||||
(inputSchema . ((type . "object")
|
|
||||||
(properties . ()))))))
|
|
||||||
|
|
||||||
;; MCP Resources Registry
|
|
||||||
(define mcp-resources
|
|
||||||
`(((uri . "homelab://status/all")
|
|
||||||
(name . "Infrastructure Status")
|
|
||||||
(description . "Complete status of all home lab machines and services")
|
|
||||||
(mimeType . "application/json"))
|
|
||||||
|
|
||||||
((uri . "homelab://status/summary")
|
|
||||||
(name . "Status Summary")
|
|
||||||
(description . "Summary of infrastructure health")
|
|
||||||
(mimeType . "text/plain"))
|
|
||||||
|
|
||||||
((uri . "homelab://context/copilot")
|
|
||||||
(name . "Copilot Context")
|
|
||||||
(description . "Context information for GitHub Copilot integration")
|
|
||||||
(mimeType . "text/markdown"))))
|
|
||||||
|
|
||||||
;; Tool execution dispatcher
|
|
||||||
(define (execute-tool name arguments)
|
|
||||||
"Execute a registered MCP tool"
|
|
||||||
(match name
|
|
||||||
("deploy-machine"
|
|
||||||
(let ((machine (assoc-ref arguments 'machine))
|
|
||||||
(method (assoc-ref arguments 'method)))
|
|
||||||
(deploy-machine machine method)))
|
|
||||||
|
|
||||||
("list-machines"
|
|
||||||
`((machines . ,(list-machines))))
|
|
||||||
|
|
||||||
("check-status"
|
|
||||||
(let ((machine (assoc-ref arguments 'machine)))
|
|
||||||
(if machine
|
|
||||||
`((machine . ,machine)
|
|
||||||
(status . ,(get-machine-status machine)))
|
|
||||||
(get-infrastructure-status))))
|
|
||||||
|
|
||||||
("generate-nix-config"
|
|
||||||
(let ((machine-name (assoc-ref arguments 'machine-name))
|
|
||||||
(services (or (assoc-ref arguments 'services) '())))
|
|
||||||
(generate-nix-config machine-name services)))
|
|
||||||
|
|
||||||
("list-services"
|
|
||||||
`((services . ("nginx" "postgresql" "redis" "mysql" "docker" "kubernetes"
|
|
||||||
"grafana" "prometheus" "gitea" "nextcloud" "jellyfin"))))
|
|
||||||
|
|
||||||
(_ (throw 'unknown-tool "Tool not found" name))))
|
|
||||||
|
|
||||||
;; Resource content providers
|
|
||||||
(define (get-resource-content uri)
|
|
||||||
"Get content for a resource URI"
|
|
||||||
(match uri
|
|
||||||
("homelab://status/all"
|
|
||||||
`((content . ,(get-infrastructure-status))))
|
|
||||||
|
|
||||||
("homelab://status/summary"
|
|
||||||
(let ((status (get-infrastructure-status)))
|
|
||||||
`((content . ,(format #f "Home Lab Status: ~a/~a machines online"
|
|
||||||
(assoc-ref status 'online-machines)
|
|
||||||
(assoc-ref status 'total-machines))))))
|
|
||||||
|
|
||||||
("homelab://context/copilot"
|
|
||||||
(let ((status (get-infrastructure-status)))
|
|
||||||
`((content . ,(format #f "# Home Lab Infrastructure Context
|
|
||||||
|
|
||||||
## Current Status
|
|
||||||
- Total Machines: ~a
|
|
||||||
- Online Machines: ~a
|
|
||||||
- Last Updated: ~a
|
|
||||||
|
|
||||||
## Available Operations
|
|
||||||
Use the home lab extension commands or MCP tools for:
|
|
||||||
- Deploying configurations (deploy-machine)
|
|
||||||
- Checking infrastructure status (check-status)
|
|
||||||
- Generating new machine configs (generate-nix-config)
|
|
||||||
- Managing services across the fleet
|
|
||||||
|
|
||||||
## Machine List
|
|
||||||
~a
|
|
||||||
|
|
||||||
This context helps GitHub Copilot understand your home lab infrastructure state."
|
|
||||||
(assoc-ref status 'total-machines)
|
|
||||||
(assoc-ref status 'online-machines)
|
|
||||||
(assoc-ref status 'timestamp)
|
|
||||||
(string-join
|
|
||||||
(map (lambda (m)
|
|
||||||
(format #f "- ~a: ~a"
|
|
||||||
(assoc-ref m 'name)
|
|
||||||
(assoc-ref m 'status)))
|
|
||||||
(assoc-ref status 'machines))
|
|
||||||
"\n"))))))
|
|
||||||
|
|
||||||
(_ (throw 'unknown-resource "Resource not found" uri))))
|
|
||||||
|
|
||||||
;; MCP Protocol Handlers
|
|
||||||
(define (handle-initialize params)
|
|
||||||
"Handle MCP initialize request"
|
|
||||||
`((protocolVersion . ,mcp-protocol-version)
|
|
||||||
(capabilities . ((tools . ((listChanged . #f)))
|
|
||||||
(resources . ((subscribe . #f)
|
|
||||||
(listChanged . #f)))
|
|
||||||
(prompts . ((listChanged . #f)))))
|
|
||||||
(serverInfo . ,server-info)))
|
|
||||||
|
|
||||||
(define (handle-tools-list params)
|
|
||||||
"Handle tools/list request"
|
|
||||||
`((tools . ,mcp-tools)))
|
|
||||||
|
|
||||||
(define (handle-tools-call params)
|
|
||||||
"Handle tools/call request"
|
|
||||||
(let ((name (assoc-ref params 'name))
|
|
||||||
(arguments (assoc-ref params 'arguments)))
|
|
||||||
(execute-tool name arguments)))
|
|
||||||
|
|
||||||
(define (handle-resources-list params)
|
|
||||||
"Handle resources/list request"
|
|
||||||
`((resources . ,mcp-resources)))
|
|
||||||
|
|
||||||
(define (handle-resources-read params)
|
|
||||||
"Handle resources/read request"
|
|
||||||
(let ((uri (assoc-ref params 'uri)))
|
|
||||||
(get-resource-content uri)))
|
|
||||||
|
|
||||||
;; Main request dispatcher
|
|
||||||
(define (handle-request request)
|
|
||||||
"Main request handler"
|
|
||||||
(let ((method (assoc-ref request 'method))
|
|
||||||
(params (assoc-ref request 'params))
|
|
||||||
(id (assoc-ref request 'id)))
|
|
||||||
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(let ((result
|
|
||||||
(match method
|
|
||||||
("initialize" (handle-initialize params))
|
|
||||||
("tools/list" (handle-tools-list params))
|
|
||||||
("tools/call" (handle-tools-call params))
|
|
||||||
("resources/list" (handle-resources-list params))
|
|
||||||
("resources/read" (handle-resources-read params))
|
|
||||||
(_ (throw 'method-not-found "Method not supported" method)))))
|
|
||||||
(send-response (make-response id result))))
|
|
||||||
|
|
||||||
(lambda (key . args)
|
|
||||||
(send-response (make-error id -32603 (format #f "~a: ~a" key args)))))))
|
|
||||||
|
|
||||||
;; Main server loop
|
|
||||||
(define (run-mcp-server)
|
|
||||||
"Run the MCP server main loop"
|
|
||||||
(let loop ()
|
|
||||||
(let ((line (read-line)))
|
|
||||||
(unless (eof-object? line)
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(let ((request (json-string->scm line)))
|
|
||||||
(handle-request request)))
|
|
||||||
(lambda (key . args)
|
|
||||||
(send-response (make-error 0 -32700 "Parse error"))))
|
|
||||||
(loop)))))
|
|
||||||
|
|
||||||
;; Export main function for use as module
|
|
||||||
(define-public run-mcp-server run-mcp-server)
|
|
||||||
|
|
||||||
;; Run server if called directly
|
|
||||||
(when (equal? (car (command-line)) (current-filename))
|
|
||||||
(run-mcp-server))
|
|
|
@ -1,846 +0,0 @@
|
||||||
# Guile Scheme Coding Instructions for Home Lab Tool
|
|
||||||
|
|
||||||
## Functional Programming Principles
|
|
||||||
|
|
||||||
**Core Philosophy**: Functional programming is about actions, data, and computation - compose small, pure functions to build complex behaviors.
|
|
||||||
|
|
||||||
### 1. Pure Functions First
|
|
||||||
- Functions should be deterministic and side-effect free when possible
|
|
||||||
- Separate pure computation from I/O operations
|
|
||||||
- Use immutable data structures as default
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Good: Pure function
|
|
||||||
(define (calculate-deployment-hash config)
|
|
||||||
(sha256 (scm->json-string config)))
|
|
||||||
|
|
||||||
;; Better: Separate pure logic from I/O
|
|
||||||
(define (deployment-ready? machine-config current-state)
|
|
||||||
(and (eq? (assoc-ref machine-config 'status) 'configured)
|
|
||||||
(eq? (assoc-ref current-state 'connectivity) 'online)))
|
|
||||||
|
|
||||||
;; I/O operations separate
|
|
||||||
(define (check-machine-deployment machine)
|
|
||||||
(let ((config (load-machine-config machine))
|
|
||||||
(state (probe-machine-state machine)))
|
|
||||||
(deployment-ready? config state)))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 2. Data-Driven Design
|
|
||||||
- Represent configurations and state as data structures
|
|
||||||
- Use association lists (alists) and vectors for structured data
|
|
||||||
- Leverage Guile's homoiconicity (code as data)
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Machine configuration as data
|
|
||||||
(define machine-specs
|
|
||||||
`((grey-area
|
|
||||||
(services (ollama jellyfin forgejo))
|
|
||||||
(deployment-method deploy-rs)
|
|
||||||
(backup-schedule weekly))
|
|
||||||
(sleeper-service
|
|
||||||
(services (nfs zfs monitoring))
|
|
||||||
(deployment-method hybrid-update)
|
|
||||||
(backup-schedule daily))))
|
|
||||||
|
|
||||||
;; Operations on data
|
|
||||||
(define (get-machine-services machine)
|
|
||||||
(assoc-ref (assoc-ref machine-specs machine) 'services))
|
|
||||||
|
|
||||||
(define (machines-with-service service)
|
|
||||||
(filter (lambda (machine-spec)
|
|
||||||
(member service (get-machine-services (car machine-spec))))
|
|
||||||
machine-specs))
|
|
||||||
```
|
|
||||||
|
|
||||||
## Guile-Specific Idioms
|
|
||||||
|
|
||||||
### 3. Module Organization
|
|
||||||
- Use meaningful module hierarchies
|
|
||||||
- Export only necessary public interfaces
|
|
||||||
- Group related functionality together
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; File: modules/lab/machines.scm
|
|
||||||
(define-module (lab machines)
|
|
||||||
#:use-module (srfi srfi-1) ; List processing
|
|
||||||
#:use-module (srfi srfi-26) ; Cut/cute
|
|
||||||
#:use-module (ice-9 match) ; Pattern matching
|
|
||||||
#:use-module (ssh session)
|
|
||||||
#:export (machine-status
|
|
||||||
deploy-machine
|
|
||||||
list-machines
|
|
||||||
machine-services))
|
|
||||||
|
|
||||||
;; File: modules/lab/deployment.scm
|
|
||||||
(define-module (lab deployment)
|
|
||||||
#:use-module (lab machines)
|
|
||||||
#:use-module (json)
|
|
||||||
#:export (deploy-rs
|
|
||||||
hybrid-update
|
|
||||||
rollback-deployment))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 4. Error Handling the Scheme Way
|
|
||||||
- Use exceptions for exceptional conditions
|
|
||||||
- Return #f or special values for expected failures
|
|
||||||
- Provide meaningful error context
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Use exceptions for programming errors
|
|
||||||
(define (deploy-machine machine method)
|
|
||||||
(unless (member machine (list-machines))
|
|
||||||
(throw 'invalid-machine "Unknown machine" machine))
|
|
||||||
(unless (member method '(deploy-rs hybrid-update legacy))
|
|
||||||
(throw 'invalid-method "Unknown deployment method" method))
|
|
||||||
;; ... deployment logic)
|
|
||||||
|
|
||||||
;; Return #f for expected failures
|
|
||||||
(define (machine-reachable? machine)
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(ssh-connect machine)
|
|
||||||
#t)
|
|
||||||
(lambda (key . args)
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
;; Provide context with failure info
|
|
||||||
(define (deployment-result success? machine method details)
|
|
||||||
`((success . ,success?)
|
|
||||||
(machine . ,machine)
|
|
||||||
(method . ,method)
|
|
||||||
(timestamp . ,(current-time))
|
|
||||||
(details . ,details)))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 5. Higher-Order Functions and Composition
|
|
||||||
- Use map, filter, fold for list processing
|
|
||||||
- Compose functions to build complex operations
|
|
||||||
- Leverage SRFI-1 for advanced list operations
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
(use-modules (srfi srfi-1))
|
|
||||||
|
|
||||||
;; Functional composition
|
|
||||||
(define (healthy-machines machines)
|
|
||||||
(filter machine-reachable?
|
|
||||||
(filter (lambda (m) (not (maintenance-mode? m)))
|
|
||||||
machines)))
|
|
||||||
|
|
||||||
;; Map operations across machines
|
|
||||||
(define (update-all-machines)
|
|
||||||
(map (lambda (machine)
|
|
||||||
(cons machine (update-machine machine)))
|
|
||||||
(healthy-machines (list-machines))))
|
|
||||||
|
|
||||||
;; Fold for aggregation
|
|
||||||
(define (deployment-summary results)
|
|
||||||
(fold (lambda (result acc)
|
|
||||||
(if (assoc-ref result 'success)
|
|
||||||
(cons 'successful (1+ (assoc-ref acc 'successful)))
|
|
||||||
(cons 'failed (1+ (assoc-ref acc 'failed)))))
|
|
||||||
'((successful . 0) (failed . 0))
|
|
||||||
results))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 6. Pattern Matching for Control Flow
|
|
||||||
- Use `match` for destructuring and dispatch
|
|
||||||
- Pattern match on data structures
|
|
||||||
- Cleaner than nested if/cond statements
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
(use-modules (ice-9 match))
|
|
||||||
|
|
||||||
(define (handle-deployment-event event)
|
|
||||||
(match event
|
|
||||||
(('start machine method)
|
|
||||||
(log-info "Starting deployment of ~a using ~a" machine method))
|
|
||||||
|
|
||||||
(('progress machine percent)
|
|
||||||
(update-progress-bar machine percent))
|
|
||||||
|
|
||||||
(('success machine result)
|
|
||||||
(log-success "Deployment completed: ~a" machine)
|
|
||||||
(notify-success machine result))
|
|
||||||
|
|
||||||
(('error machine error-msg)
|
|
||||||
(log-error "Deployment failed: ~a - ~a" machine error-msg)
|
|
||||||
(initiate-rollback machine))
|
|
||||||
|
|
||||||
(_ (log-warning "Unknown event: ~a" event))))
|
|
||||||
|
|
||||||
;; Pattern matching for configuration parsing
|
|
||||||
(define (parse-machine-config config-sexp)
|
|
||||||
(match config-sexp
|
|
||||||
(('machine name ('services services ...) ('options options ...))
|
|
||||||
`((name . ,name)
|
|
||||||
(services . ,services)
|
|
||||||
(options . ,(alist->hash-table options))))
|
|
||||||
|
|
||||||
(_ (throw 'invalid-config "Malformed machine config" config-sexp))))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 7. REPL-Driven Development
|
|
||||||
- Design for interactive development
|
|
||||||
- Provide introspection functions
|
|
||||||
- Make state queryable and modifiable
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; REPL helpers for development
|
|
||||||
(define (debug-machine-state machine)
|
|
||||||
"Display comprehensive machine state for debugging"
|
|
||||||
(format #t "Machine: ~a~%" machine)
|
|
||||||
(format #t "Status: ~a~%" (machine-status machine))
|
|
||||||
(format #t "Services: ~a~%" (machine-services machine))
|
|
||||||
(format #t "Last deployment: ~a~%" (last-deployment machine))
|
|
||||||
(format #t "Reachable: ~a~%" (machine-reachable? machine)))
|
|
||||||
|
|
||||||
;; Interactive deployment with confirmation
|
|
||||||
(define (interactive-deploy machine)
|
|
||||||
(let ((current-config (get-machine-config machine)))
|
|
||||||
(display-config current-config)
|
|
||||||
(when (yes-or-no? "Proceed with deployment?")
|
|
||||||
(deploy-machine machine 'deploy-rs))))
|
|
||||||
|
|
||||||
;; State introspection
|
|
||||||
(define (lab-status)
|
|
||||||
`((total-machines . ,(length (list-machines)))
|
|
||||||
(reachable . ,(length (filter machine-reachable? (list-machines))))
|
|
||||||
(services-running . ,(total-running-services))
|
|
||||||
(pending-deployments . ,(length (pending-deployments)))))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 8. Concurrency with Fibers
|
|
||||||
- Use fibers for concurrent operations
|
|
||||||
- Non-blocking I/O for better performance
|
|
||||||
- Coordinate parallel deployments safely
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
(use-modules (fibers) (fibers channels))
|
|
||||||
|
|
||||||
;; Concurrent machine checking
|
|
||||||
(define (check-all-machines-concurrent machines)
|
|
||||||
(run-fibers
|
|
||||||
(lambda ()
|
|
||||||
(let ((results-channel (make-channel)))
|
|
||||||
;; Spawn fiber for each machine
|
|
||||||
(for-each (lambda (machine)
|
|
||||||
(spawn-fiber
|
|
||||||
(lambda ()
|
|
||||||
(let ((status (check-machine-status machine)))
|
|
||||||
(put-message results-channel
|
|
||||||
(cons machine status))))))
|
|
||||||
machines)
|
|
||||||
|
|
||||||
;; Collect results
|
|
||||||
(let loop ((remaining (length machines))
|
|
||||||
(results '()))
|
|
||||||
(if (zero? remaining)
|
|
||||||
results
|
|
||||||
(loop (1- remaining)
|
|
||||||
(cons (get-message results-channel) results))))))))
|
|
||||||
|
|
||||||
;; Parallel deployment with coordination
|
|
||||||
(define (deploy-machines-parallel machines)
|
|
||||||
(run-fibers
|
|
||||||
(lambda ()
|
|
||||||
(let ((deployment-channel (make-channel))
|
|
||||||
(coordinator (spawn-fiber (deployment-coordinator deployment-channel))))
|
|
||||||
(par-map (lambda (machine)
|
|
||||||
(deploy-with-coordination machine deployment-channel))
|
|
||||||
machines)))))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 9. MCP Server Implementation Patterns
|
|
||||||
- Structured message handling
|
|
||||||
- Capability-based tool organization
|
|
||||||
- Resource management with caching
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; MCP message dispatch
|
|
||||||
(define (handle-mcp-request request)
|
|
||||||
(match (json-ref request "method")
|
|
||||||
("tools/list"
|
|
||||||
(mcp-tools-list))
|
|
||||||
|
|
||||||
("tools/call"
|
|
||||||
(let ((tool (json-ref request "params" "name"))
|
|
||||||
(args (json-ref request "params" "arguments")))
|
|
||||||
(call-lab-tool tool args)))
|
|
||||||
|
|
||||||
("resources/list"
|
|
||||||
(mcp-resources-list))
|
|
||||||
|
|
||||||
("resources/read"
|
|
||||||
(let ((uri (json-ref request "params" "uri")))
|
|
||||||
(read-lab-resource uri)))
|
|
||||||
|
|
||||||
(method
|
|
||||||
(mcp-error -32601 "Method not found" method))))
|
|
||||||
|
|
||||||
;; Tool capability definition
|
|
||||||
(define lab-tools
|
|
||||||
`((deploy-machine
|
|
||||||
(description . "Deploy configuration to a specific machine")
|
|
||||||
(inputSchema . ,(json-schema
|
|
||||||
`((type . "object")
|
|
||||||
(properties . ((machine (type . "string"))
|
|
||||||
(method (type . "string")
|
|
||||||
(enum . ("deploy-rs" "hybrid-update")))))
|
|
||||||
(required . ("machine")))))
|
|
||||||
(handler . ,deploy-machine-tool))
|
|
||||||
|
|
||||||
(check-status
|
|
||||||
(description . "Check machine status and connectivity")
|
|
||||||
(inputSchema . ,(json-schema
|
|
||||||
`((type . "object")
|
|
||||||
(properties . ((machines (type . "array")
|
|
||||||
(items (type . "string"))))))))
|
|
||||||
(handler . ,check-status-tool))))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 10. Configuration and Environment
|
|
||||||
- Use parameters for configuration
|
|
||||||
- Environment-aware defaults
|
|
||||||
- Validate configuration on startup
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Configuration parameters
|
|
||||||
(define lab-config-dir
|
|
||||||
(make-parameter (or (getenv "LAB_CONFIG_DIR")
|
|
||||||
"/etc/lab-tool")))
|
|
||||||
|
|
||||||
(define deployment-timeout
|
|
||||||
(make-parameter (string->number (or (getenv "DEPLOYMENT_TIMEOUT") "300"))))
|
|
||||||
|
|
||||||
(define ssh-key-path
|
|
||||||
(make-parameter (or (getenv "LAB_SSH_KEY")
|
|
||||||
(string-append (getenv "HOME") "/.ssh/lab_key"))))
|
|
||||||
|
|
||||||
;; Configuration validation
|
|
||||||
(define (validate-lab-config)
|
|
||||||
(unless (file-exists? (lab-config-dir))
|
|
||||||
(throw 'config-error "Lab config directory not found" (lab-config-dir)))
|
|
||||||
|
|
||||||
(unless (file-exists? (ssh-key-path))
|
|
||||||
(throw 'config-error "SSH key not found" (ssh-key-path)))
|
|
||||||
|
|
||||||
(unless (> (deployment-timeout) 0)
|
|
||||||
(throw 'config-error "Invalid deployment timeout" (deployment-timeout))))
|
|
||||||
|
|
||||||
;; Initialize with validation
|
|
||||||
(define (init-lab-tool)
|
|
||||||
(validate-lab-config)
|
|
||||||
(load-machine-configurations)
|
|
||||||
(initialize-ssh-agent)
|
|
||||||
(setup-logging))
|
|
||||||
```
|
|
||||||
|
|
||||||
## Code Style Guidelines
|
|
||||||
|
|
||||||
### 11. Naming Conventions
|
|
||||||
- Use kebab-case for variables and functions
|
|
||||||
- Predicates end with `?`
|
|
||||||
- Mutating procedures end with `!`
|
|
||||||
- Constants in ALL-CAPS with hyphens
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Good naming
|
|
||||||
(define DEFAULT-SSH-PORT 22)
|
|
||||||
(define machine-deployment-status ...)
|
|
||||||
(define (machine-reachable? machine) ...)
|
|
||||||
(define (update-machine-config! machine config) ...)
|
|
||||||
|
|
||||||
;; Avoid
|
|
||||||
(define defaultSSHPort 22) ; camelCase
|
|
||||||
(define machine_status ...) ; snake_case
|
|
||||||
(define (is-machine-reachable ...) ; unnecessary 'is-'
|
|
||||||
```
|
|
||||||
|
|
||||||
### 12. Documentation and Comments
|
|
||||||
- Document module purposes and exports
|
|
||||||
- Use docstrings for complex functions
|
|
||||||
- Comment the "why", not the "what"
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
(define (deploy-machine machine method)
|
|
||||||
"Deploy configuration to MACHINE using METHOD.
|
|
||||||
|
|
||||||
Returns a deployment result alist with success status, timing,
|
|
||||||
and any error messages. May throw exceptions for invalid inputs."
|
|
||||||
|
|
||||||
;; Validate inputs early to fail fast
|
|
||||||
(validate-machine machine)
|
|
||||||
(validate-deployment-method method)
|
|
||||||
|
|
||||||
;; Use atomic operations to prevent partial deployments
|
|
||||||
(call-with-deployment-lock machine
|
|
||||||
(lambda ()
|
|
||||||
(let ((start-time (current-time)))
|
|
||||||
;; ... deployment logic
|
|
||||||
))))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 13. Testing Approach
|
|
||||||
- Write tests for pure functions first
|
|
||||||
- Mock I/O operations
|
|
||||||
- Use SRFI-64 testing framework
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
(use-modules (srfi srfi-64))
|
|
||||||
|
|
||||||
(test-begin "machine-configuration")
|
|
||||||
|
|
||||||
(test-equal "machine services extraction"
|
|
||||||
'(ollama jellyfin forgejo)
|
|
||||||
(get-machine-services 'grey-area))
|
|
||||||
|
|
||||||
(test-assert "deployment readiness check"
|
|
||||||
(deployment-ready?
|
|
||||||
'((status . configured) (health . good))
|
|
||||||
'((connectivity . online) (load . normal))))
|
|
||||||
|
|
||||||
(test-error "invalid machine throws exception"
|
|
||||||
'invalid-machine
|
|
||||||
(deploy-machine 'non-existent-machine 'deploy-rs))
|
|
||||||
|
|
||||||
(test-end "machine-configuration")
|
|
||||||
```
|
|
||||||
|
|
||||||
## Project Structure Best Practices
|
|
||||||
|
|
||||||
### 14. Module Organization
|
|
||||||
```
|
|
||||||
modules/
|
|
||||||
├── lab/
|
|
||||||
│ ├── core.scm ; Core data structures and utilities
|
|
||||||
│ ├── machines.scm ; Machine management
|
|
||||||
│ ├── deployment.scm ; Deployment strategies
|
|
||||||
│ ├── monitoring.scm ; Status checking and metrics
|
|
||||||
│ └── config.scm ; Configuration handling
|
|
||||||
├── mcp/
|
|
||||||
│ ├── server.scm ; MCP server implementation
|
|
||||||
│ ├── tools.scm ; MCP tool definitions
|
|
||||||
│ └── resources.scm ; MCP resource handlers
|
|
||||||
└── utils/
|
|
||||||
├── ssh.scm ; SSH utilities
|
|
||||||
├── json.scm ; JSON helpers
|
|
||||||
└── logging.scm ; Logging facilities
|
|
||||||
```
|
|
||||||
|
|
||||||
### 15. Build and Development Workflow
|
|
||||||
- Use Guile's module compilation
|
|
||||||
- Leverage REPL for iterative development
|
|
||||||
- Provide development/production configurations
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Development helpers in separate module
|
|
||||||
(define-module (lab dev)
|
|
||||||
#:use-module (lab core)
|
|
||||||
#:export (reload-config
|
|
||||||
reset-state
|
|
||||||
dev-deploy))
|
|
||||||
|
|
||||||
;; Hot-reload for development
|
|
||||||
(define (reload-config)
|
|
||||||
(reload-module (resolve-module '(lab config)))
|
|
||||||
(init-lab-tool))
|
|
||||||
|
|
||||||
;; Safe deployment for development
|
|
||||||
(define (dev-deploy machine)
|
|
||||||
(if (eq? (current-environment) 'development)
|
|
||||||
(deploy-machine machine 'deploy-rs)
|
|
||||||
(error "dev-deploy only available in development mode")))
|
|
||||||
```
|
|
||||||
|
|
||||||
## VS Code and GitHub Copilot Integration
|
|
||||||
|
|
||||||
### 16. MCP Client Integration with VS Code
|
|
||||||
- Implement MCP client in VS Code extension
|
|
||||||
- Bridge home lab context to Copilot
|
|
||||||
- Provide real-time infrastructure state
|
|
||||||
|
|
||||||
```typescript
|
|
||||||
// VS Code extension structure for MCP integration
|
|
||||||
// File: vscode-extension/src/extension.ts
|
|
||||||
import * as vscode from 'vscode';
|
|
||||||
import { MCPClient } from './mcp-client';
|
|
||||||
|
|
||||||
export function activate(context: vscode.ExtensionContext) {
|
|
||||||
const mcpClient = new MCPClient('stdio', {
|
|
||||||
command: 'guile',
|
|
||||||
args: ['-c', '(use-modules (mcp server)) (run-mcp-server)']
|
|
||||||
});
|
|
||||||
|
|
||||||
// Register commands for home lab operations
|
|
||||||
const deployCommand = vscode.commands.registerCommand(
|
|
||||||
'homelab.deploy',
|
|
||||||
async (machine: string) => {
|
|
||||||
const result = await mcpClient.callTool('deploy-machine', {
|
|
||||||
machine: machine,
|
|
||||||
method: 'deploy-rs'
|
|
||||||
});
|
|
||||||
vscode.window.showInformationMessage(
|
|
||||||
`Deployment ${result.success ? 'succeeded' : 'failed'}`
|
|
||||||
);
|
|
||||||
}
|
|
||||||
);
|
|
||||||
|
|
||||||
// Provide context to Copilot through workspace state
|
|
||||||
const statusProvider = new HomeLab StatusProvider(mcpClient);
|
|
||||||
context.subscriptions.push(
|
|
||||||
vscode.workspace.registerTextDocumentContentProvider(
|
|
||||||
'homelab', statusProvider
|
|
||||||
)
|
|
||||||
);
|
|
||||||
|
|
||||||
context.subscriptions.push(deployCommand);
|
|
||||||
}
|
|
||||||
|
|
||||||
class HomeLabStatusProvider implements vscode.TextDocumentContentProvider {
|
|
||||||
constructor(private mcpClient: MCPClient) {}
|
|
||||||
|
|
||||||
async provideTextDocumentContent(uri: vscode.Uri): Promise<string> {
|
|
||||||
// Fetch current lab state for Copilot context
|
|
||||||
const resources = await this.mcpClient.listResources();
|
|
||||||
const status = await this.mcpClient.readResource('machines://status/all');
|
|
||||||
|
|
||||||
return `# Home Lab Status
|
|
||||||
Current Infrastructure State:
|
|
||||||
${JSON.stringify(status, null, 2)}
|
|
||||||
|
|
||||||
Available Resources:
|
|
||||||
${resources.map(r => `- ${r.uri}: ${r.description}`).join('\n')}
|
|
||||||
`;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
```
|
|
||||||
|
|
||||||
### 17. MCP Server Configuration for IDE Integration
|
|
||||||
- Provide IDE-specific tools and resources
|
|
||||||
- Format responses for developer consumption
|
|
||||||
- Include code suggestions and snippets
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; IDE-specific MCP tools
|
|
||||||
(define ide-tools
|
|
||||||
`((generate-nix-config
|
|
||||||
(description . "Generate NixOS configuration for new machine")
|
|
||||||
(inputSchema . ,(json-schema
|
|
||||||
`((type . "object")
|
|
||||||
(properties . ((machine-name (type . "string"))
|
|
||||||
(services (type . "array")
|
|
||||||
(items (type . "string")))
|
|
||||||
(hardware-profile (type . "string"))))
|
|
||||||
(required . ("machine-name")))))
|
|
||||||
(handler . ,generate-nix-config-tool))
|
|
||||||
|
|
||||||
(suggest-deployment-strategy
|
|
||||||
(description . "Suggest optimal deployment strategy for changes")
|
|
||||||
(inputSchema . ,(json-schema
|
|
||||||
`((type . "object")
|
|
||||||
(properties . ((changed-files (type . "array")
|
|
||||||
(items (type . "string")))
|
|
||||||
(target-machines (type . "array")
|
|
||||||
(items (type . "string")))))
|
|
||||||
(required . ("changed-files")))))
|
|
||||||
(handler . ,suggest-deployment-strategy-tool))
|
|
||||||
|
|
||||||
(validate-config
|
|
||||||
(description . "Validate NixOS configuration syntax and dependencies")
|
|
||||||
(inputSchema . ,(json-schema
|
|
||||||
`((type . "object")
|
|
||||||
(properties . ((config-path (type . "string"))
|
|
||||||
(machine (type . "string"))))
|
|
||||||
(required . ("config-path")))))
|
|
||||||
(handler . ,validate-config-tool))))
|
|
||||||
|
|
||||||
;; IDE-specific resources
|
|
||||||
(define ide-resources
|
|
||||||
`(("homelab://templates/machine-config"
|
|
||||||
(description . "Template for new machine configuration")
|
|
||||||
(mimeType . "application/x-nix"))
|
|
||||||
|
|
||||||
("homelab://examples/service-configs"
|
|
||||||
(description . "Example service configurations")
|
|
||||||
(mimeType . "application/x-nix"))
|
|
||||||
|
|
||||||
("homelab://docs/deployment-guide"
|
|
||||||
(description . "Step-by-step deployment procedures")
|
|
||||||
(mimeType . "text/markdown"))
|
|
||||||
|
|
||||||
("homelab://status/real-time"
|
|
||||||
(description . "Real-time infrastructure status for context")
|
|
||||||
(mimeType . "application/json"))))
|
|
||||||
|
|
||||||
;; Generate contextual code suggestions
|
|
||||||
(define (generate-nix-config-tool args)
|
|
||||||
(let ((machine-name (assoc-ref args "machine-name"))
|
|
||||||
(services (assoc-ref args "services"))
|
|
||||||
(hardware-profile (assoc-ref args "hardware-profile")))
|
|
||||||
|
|
||||||
`((content . ,(format #f "# Generated configuration for ~a
|
|
||||||
{ config, pkgs, ... }:
|
|
||||||
|
|
||||||
{
|
|
||||||
imports = [
|
|
||||||
./hardware-configuration.nix
|
|
||||||
~/args
|
|
||||||
];
|
|
||||||
|
|
||||||
# Machine-specific configuration
|
|
||||||
networking.hostName = \"~a\";
|
|
||||||
|
|
||||||
# Services configuration
|
|
||||||
~a
|
|
||||||
|
|
||||||
# System packages
|
|
||||||
environment.systemPackages = with pkgs; [
|
|
||||||
# Add your packages here
|
|
||||||
];
|
|
||||||
|
|
||||||
system.stateVersion = \"24.05\";
|
|
||||||
}"
|
|
||||||
machine-name
|
|
||||||
machine-name
|
|
||||||
(if services
|
|
||||||
(string-join
|
|
||||||
(map (lambda (service)
|
|
||||||
(format #f " services.~a.enable = true;" service))
|
|
||||||
services)
|
|
||||||
"\n")
|
|
||||||
" # No services specified")))
|
|
||||||
(isError . #f))))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 18. Copilot Context Enhancement
|
|
||||||
- Provide infrastructure context to improve suggestions
|
|
||||||
- Include deployment patterns and best practices
|
|
||||||
- Real-time system state for informed recommendations
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Context provider for Copilot integration
|
|
||||||
(define (provide-copilot-context)
|
|
||||||
`((infrastructure-state . ,(get-current-infrastructure-state))
|
|
||||||
(deployment-patterns . ,(get-common-deployment-patterns))
|
|
||||||
(service-configurations . ,(get-service-config-templates))
|
|
||||||
(best-practices . ,(get-deployment-best-practices))
|
|
||||||
(current-issues . ,(get-active-alerts))))
|
|
||||||
|
|
||||||
(define (get-current-infrastructure-state)
|
|
||||||
`((machines . ,(map (lambda (machine)
|
|
||||||
`((name . ,machine)
|
|
||||||
(status . ,(machine-status machine))
|
|
||||||
(services . ,(machine-services machine))
|
|
||||||
(last-deployment . ,(last-deployment-time machine))))
|
|
||||||
(list-machines)))
|
|
||||||
(network-topology . ,(get-network-topology))
|
|
||||||
(resource-usage . ,(get-resource-utilization))))
|
|
||||||
|
|
||||||
(define (get-common-deployment-patterns)
|
|
||||||
`((safe-deployment . "Use deploy-rs for production, hybrid-update for development")
|
|
||||||
(rollback-strategy . "Always test deployments in staging first")
|
|
||||||
(service-dependencies . "Ensure database services start before applications")
|
|
||||||
(backup-before-deploy . "Create snapshots before major configuration changes")))
|
|
||||||
|
|
||||||
;; Format context for IDE consumption
|
|
||||||
(define (format-ide-context context)
|
|
||||||
(scm->json-string context #:pretty #t))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 19. VS Code Extension Development
|
|
||||||
- Create extension for seamless MCP integration
|
|
||||||
- Provide commands, views, and context
|
|
||||||
- Enable real-time collaboration with infrastructure
|
|
||||||
|
|
||||||
```typescript
|
|
||||||
// package.json for VS Code extension
|
|
||||||
{
|
|
||||||
"name": "homelab-mcp-integration",
|
|
||||||
"displayName": "Home Lab MCP Integration",
|
|
||||||
"description": "Integrate home lab infrastructure with VS Code through MCP",
|
|
||||||
"version": "0.1.0",
|
|
||||||
"engines": {
|
|
||||||
"vscode": "^1.74.0"
|
|
||||||
},
|
|
||||||
"categories": ["Other"],
|
|
||||||
"activationEvents": [
|
|
||||||
"onCommand:homelab.connect",
|
|
||||||
"workspaceContains:**/flake.nix"
|
|
||||||
],
|
|
||||||
"main": "./out/extension.js",
|
|
||||||
"contributes": {
|
|
||||||
"commands": [
|
|
||||||
{
|
|
||||||
"command": "homelab.deploy",
|
|
||||||
"title": "Deploy Machine",
|
|
||||||
"category": "Home Lab"
|
|
||||||
},
|
|
||||||
{
|
|
||||||
"command": "homelab.status",
|
|
||||||
"title": "Check Status",
|
|
||||||
"category": "Home Lab"
|
|
||||||
},
|
|
||||||
{
|
|
||||||
"command": "homelab.generateConfig",
|
|
||||||
"title": "Generate Config",
|
|
||||||
"category": "Home Lab"
|
|
||||||
}
|
|
||||||
],
|
|
||||||
"views": {
|
|
||||||
"explorer": [
|
|
||||||
{
|
|
||||||
"id": "homelabStatus",
|
|
||||||
"name": "Home Lab Status",
|
|
||||||
"when": "homelab:connected"
|
|
||||||
}
|
|
||||||
]
|
|
||||||
},
|
|
||||||
"viewsContainers": {
|
|
||||||
"activitybar": [
|
|
||||||
{
|
|
||||||
"id": "homelab",
|
|
||||||
"title": "Home Lab",
|
|
||||||
"icon": "$(server-environment)"
|
|
||||||
}
|
|
||||||
]
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
// MCP Client implementation
|
|
||||||
class MCPClient {
|
|
||||||
private transport: MCPTransport;
|
|
||||||
private capabilities: MCPCapabilities;
|
|
||||||
|
|
||||||
constructor(transportType: 'stdio' | 'websocket', config: any) {
|
|
||||||
this.transport = this.createTransport(transportType, config);
|
|
||||||
this.initialize();
|
|
||||||
}
|
|
||||||
|
|
||||||
async callTool(name: string, arguments: any): Promise<any> {
|
|
||||||
return this.transport.request('tools/call', {
|
|
||||||
name: name,
|
|
||||||
arguments: arguments
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
async listResources(): Promise<MCPResource[]> {
|
|
||||||
const response = await this.transport.request('resources/list', {});
|
|
||||||
return response.resources;
|
|
||||||
}
|
|
||||||
|
|
||||||
async readResource(uri: string): Promise<any> {
|
|
||||||
return this.transport.request('resources/read', { uri });
|
|
||||||
}
|
|
||||||
|
|
||||||
// Integration with Copilot context
|
|
||||||
async getCopilotContext(): Promise<string> {
|
|
||||||
const context = await this.readResource('homelab://context/copilot');
|
|
||||||
return context.content;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
```
|
|
||||||
|
|
||||||
### 20. GitHub Copilot Workspace Integration
|
|
||||||
- Configure workspace for optimal Copilot suggestions
|
|
||||||
- Provide infrastructure context files
|
|
||||||
- Set up context patterns for deployment scenarios
|
|
||||||
|
|
||||||
```json
|
|
||||||
// .vscode/settings.json
|
|
||||||
{
|
|
||||||
"github.copilot.enable": {
|
|
||||||
"*": true,
|
|
||||||
"yaml": true,
|
|
||||||
"nix": true,
|
|
||||||
"scheme": true
|
|
||||||
},
|
|
||||||
"github.copilot.advanced": {
|
|
||||||
"length": 500,
|
|
||||||
"temperature": 0.2
|
|
||||||
},
|
|
||||||
"homelab.mcpServer": {
|
|
||||||
"command": "guile",
|
|
||||||
"args": ["-L", "modules", "-c", "(use-modules (mcp server)) (run-mcp-server)"],
|
|
||||||
"autoStart": true
|
|
||||||
},
|
|
||||||
"files.associations": {
|
|
||||||
"*.scm": "scheme",
|
|
||||||
"flake.lock": "json"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
// .copilot/context.md for workspace context
|
|
||||||
```markdown
|
|
||||||
# Home Lab Infrastructure Context
|
|
||||||
|
|
||||||
## Current Architecture
|
|
||||||
- NixOS-based infrastructure with multiple machines
|
|
||||||
- Deploy-rs for safe deployments
|
|
||||||
- Services: Ollama, Jellyfin, Forgejo, NFS, ZFS
|
|
||||||
- Network topology: reverse-proxy, grey-area, sleeper-service, congenital-optimist
|
|
||||||
|
|
||||||
## Common Patterns
|
|
||||||
- Use `deploy-rs` for production deployments
|
|
||||||
- Test with `hybrid-update` in development
|
|
||||||
- Always backup before major changes
|
|
||||||
- Follow NixOS module structure in `/modules/`
|
|
||||||
|
|
||||||
## Configuration Standards
|
|
||||||
- Machine configs in `/machines/{hostname}/`
|
|
||||||
- Shared modules in `/modules/`
|
|
||||||
- Service-specific configs in `services/` subdirectories
|
|
||||||
```
|
|
||||||
|
|
||||||
### 21. Real-time Context Updates
|
|
||||||
- Stream infrastructure changes to VS Code
|
|
||||||
- Update Copilot context automatically
|
|
||||||
- Provide deployment feedback in editor
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Real-time context streaming
|
|
||||||
(define (start-context-stream port)
|
|
||||||
"Stream infrastructure changes to connected IDE clients"
|
|
||||||
(let ((clients (make-hash-table)))
|
|
||||||
(spawn-fiber
|
|
||||||
(lambda ()
|
|
||||||
(let loop ()
|
|
||||||
(let ((update (get-infrastructure-update)))
|
|
||||||
(hash-for-each
|
|
||||||
(lambda (client-id websocket)
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(websocket-send websocket
|
|
||||||
(scm->json-string update)))
|
|
||||||
(lambda (key . args)
|
|
||||||
(hash-remove! clients client-id))))
|
|
||||||
clients)
|
|
||||||
(sleep 5)
|
|
||||||
(loop)))))
|
|
||||||
|
|
||||||
;; WebSocket server for IDE connections
|
|
||||||
(run-websocket-server
|
|
||||||
(lambda (ws)
|
|
||||||
(let ((client-id (generate-client-id)))
|
|
||||||
(hash-set! clients client-id ws)
|
|
||||||
(websocket-send ws
|
|
||||||
(scm->json-string
|
|
||||||
`((type . "welcome")
|
|
||||||
(context . ,(get-current-context)))))
|
|
||||||
(handle-client-messages ws client-id clients)))
|
|
||||||
#:port port)))
|
|
||||||
|
|
||||||
;; Integration with file watchers
|
|
||||||
(define (watch-config-changes)
|
|
||||||
"Watch for configuration file changes and update context"
|
|
||||||
(file-system-watcher
|
|
||||||
(list "/home/geir/Home-lab/machines"
|
|
||||||
"/home/geir/Home-lab/modules")
|
|
||||||
(lambda (event)
|
|
||||||
(match event
|
|
||||||
(('modify path)
|
|
||||||
(when (string-suffix? ".nix" path)
|
|
||||||
(update-copilot-context path)))
|
|
||||||
(_ #f)))))
|
|
||||||
```
|
|
|
@ -1,394 +0,0 @@
|
||||||
|
|
||||||
# Guile Scheme Ecosystem Analysis for Home Lab Tool Migration and MCP Integration
|
|
||||||
|
|
||||||
## Executive Summary
|
|
||||||
|
|
||||||
This analysis examines the GNU Guile Scheme ecosystem to evaluate its suitability for migrating the home lab tool from Bash and potentially implementing a Model Context Protocol (MCP) server. Based on comprehensive research, Guile offers a robust ecosystem with numerous libraries that address the core requirements of modern system administration, networking, and infrastructure management.
|
|
||||||
|
|
||||||
**Key Findings:**
|
|
||||||
|
|
||||||
- **Rich ecosystem**: 200+ libraries available through GNU Guix ecosystem
|
|
||||||
- **Strong system administration capabilities**: SSH, system interaction, process management
|
|
||||||
- **Excellent networking support**: HTTP servers/clients, WebSocket, JSON-RPC
|
|
||||||
- **Mature infrastructure**: Well-maintained libraries with active development
|
|
||||||
- **MCP compatibility**: All necessary components available for MCP server implementation
|
|
||||||
|
|
||||||
## Current State Analysis
|
|
||||||
|
|
||||||
### Existing Lab Tool Capabilities
|
|
||||||
|
|
||||||
Based on the documentation, the current lab tool provides:
|
|
||||||
|
|
||||||
- Machine status checking and connectivity
|
|
||||||
- Multiple deployment methods (deploy-rs, hybrid-update, legacy)
|
|
||||||
- NixOS configuration management
|
|
||||||
- SSH-based operations
|
|
||||||
- Package updates via flake management
|
|
||||||
|
|
||||||
### Migration Benefits to Guile
|
|
||||||
|
|
||||||
1. **Enhanced error handling** over Bash's limited error management
|
|
||||||
2. **Structured data handling** for machine configurations and status
|
|
||||||
3. **Better modularity** and code organization
|
|
||||||
4. **Advanced networking capabilities** for future expansion
|
|
||||||
5. **REPL-driven development** for rapid prototyping and debugging
|
|
||||||
|
|
||||||
## Core Libraries for Home Lab Tool Migration
|
|
||||||
|
|
||||||
### 1. System Administration & SSH
|
|
||||||
|
|
||||||
**guile-ssh** - *Essential for remote operations*
|
|
||||||
|
|
||||||
- **Capabilities**: SSH client/server, SFTP, port forwarding, tunneling
|
|
||||||
- **Use cases**: All remote machine interactions, deployment coordination
|
|
||||||
- **Maturity**: Very mature, actively maintained
|
|
||||||
- **Documentation**: Comprehensive with examples
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Example SSH connection and command execution
|
|
||||||
(use-modules (ssh session) (ssh channel))
|
|
||||||
(let ((session (make-session #:host "sleeper-service")))
|
|
||||||
(connect! session)
|
|
||||||
(authenticate-server session)
|
|
||||||
(userauth-public-key! session key)
|
|
||||||
;; Execute nixos-rebuild or other commands
|
|
||||||
(call-with-remote-output-pipe session "nixos-rebuild switch"
|
|
||||||
(lambda (port) (display (read-string port)))))
|
|
||||||
```
|
|
||||||
|
|
||||||
### 2. JSON Data Handling
|
|
||||||
|
|
||||||
**guile-json** - *For structured configuration and API communication*
|
|
||||||
|
|
||||||
- **Capabilities**: JSON parsing/generation, RFC 7464 support, pretty printing
|
|
||||||
- **Use cases**: Configuration management, API responses, deployment metadata
|
|
||||||
- **Features**: JSON Text Sequences, record mapping, validation
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; Machine configuration as JSON
|
|
||||||
(define machine-config
|
|
||||||
`(("name" . "grey-area")
|
|
||||||
("services" . #("ollama" "jellyfin" "forgejo"))
|
|
||||||
("deployment" . (("method" . "deploy-rs") ("status" . "ready")))))
|
|
||||||
|
|
||||||
(scm->json machine-config #:pretty #t)
|
|
||||||
```
|
|
||||||
|
|
||||||
### 3. HTTP Server/Client Operations
|
|
||||||
|
|
||||||
**guile-webutils** & **guile-curl** - *For web-based interfaces and API calls*
|
|
||||||
|
|
||||||
- **guile-webutils**: Session management, multipart messages, form handling
|
|
||||||
- **guile-curl**: HTTP client operations, file transfers
|
|
||||||
- **Use cases**: Web dashboard, API endpoints, remote service integration
|
|
||||||
|
|
||||||
### 4. Process Management & System Interaction
|
|
||||||
|
|
||||||
**guile-bash** - *Bridge between Scheme and shell operations*
|
|
||||||
|
|
||||||
- **Capabilities**: Execute shell commands, capture output, dynamic variables
|
|
||||||
- **Use cases**: Gradual migration, leveraging existing shell tools
|
|
||||||
- **Integration**: Call existing scripts while building Scheme alternatives
|
|
||||||
|
|
||||||
### 5. Configuration Management
|
|
||||||
|
|
||||||
**guile-config** - *Declarative configuration handling*
|
|
||||||
|
|
||||||
- **Capabilities**: Declarative config specs, file parsing, command-line args
|
|
||||||
- **Use cases**: Tool configuration, machine definitions, deployment parameters
|
|
||||||
|
|
||||||
## MCP Server Implementation Libraries
|
|
||||||
|
|
||||||
### 1. JSON-RPC Foundation
|
|
||||||
|
|
||||||
**scheme-json-rpc** - *Core MCP protocol implementation*
|
|
||||||
|
|
||||||
- **Capabilities**: JSON-RPC 2.0 specification compliance
|
|
||||||
- **Transport**: Works over stdio, WebSocket, HTTP
|
|
||||||
- **Use cases**: MCP message handling, method dispatch
|
|
||||||
|
|
||||||
### 2. WebSocket Support
|
|
||||||
|
|
||||||
**guile-websocket** - *Real-time communication*
|
|
||||||
|
|
||||||
- **Capabilities**: RFC 6455 compliant WebSocket implementation
|
|
||||||
- **Features**: Server and client support, binary/text messages
|
|
||||||
- **Use cases**: MCP transport layer, real-time lab monitoring
|
|
||||||
|
|
||||||
### 3. Web Server Infrastructure
|
|
||||||
|
|
||||||
**artanis** - *Full-featured web application framework*
|
|
||||||
|
|
||||||
- **Capabilities**: Routing, templating, database access, session management
|
|
||||||
- **Use cases**: MCP HTTP transport, web dashboard, API endpoints
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; MCP server endpoint structure
|
|
||||||
(define-handler mcp-handler
|
|
||||||
(lambda (request)
|
|
||||||
(let ((method (json-ref (request-body request) "method")))
|
|
||||||
(case method
|
|
||||||
(("tools/list") (handle-tools-list))
|
|
||||||
(("resources/list") (handle-resources-list))
|
|
||||||
(("tools/call") (handle-tool-call request))
|
|
||||||
(else (mcp-error "Unknown method"))))))
|
|
||||||
```
|
|
||||||
|
|
||||||
## Enhanced Networking & Protocol Libraries
|
|
||||||
|
|
||||||
### 1. Advanced HTTP/Network Operations
|
|
||||||
|
|
||||||
**guile-curl** - *Comprehensive HTTP client*
|
|
||||||
|
|
||||||
- Features: HTTPS, authentication, file uploads, progress callbacks
|
|
||||||
- Use cases: API integrations, file transfers, service health checks
|
|
||||||
|
|
||||||
**guile-dns** - *DNS operations*
|
|
||||||
|
|
||||||
- Pure Guile DNS implementation
|
|
||||||
- Use cases: Service discovery, network diagnostics
|
|
||||||
|
|
||||||
### 2. Data Serialization
|
|
||||||
|
|
||||||
**guile-cbor** - *Efficient binary serialization*
|
|
||||||
|
|
||||||
- Alternative to JSON for performance-critical operations
|
|
||||||
- Smaller payload sizes for resource monitoring
|
|
||||||
|
|
||||||
**guile-yaml** / **guile-yamlpp** - *YAML processing*
|
|
||||||
|
|
||||||
- Configuration file handling
|
|
||||||
- Integration with existing YAML-based tools
|
|
||||||
|
|
||||||
### 3. Database Integration
|
|
||||||
|
|
||||||
**guile-sqlite3** - *Local data storage*
|
|
||||||
|
|
||||||
- Deployment history, machine states, configuration versioning
|
|
||||||
- Embedded database for tool state management
|
|
||||||
|
|
||||||
**guile-redis** - *Caching and session storage*
|
|
||||||
|
|
||||||
- Performance optimization for frequent operations
|
|
||||||
- Distributed state management across lab machines
|
|
||||||
|
|
||||||
## System Integration Libraries
|
|
||||||
|
|
||||||
### 1. File System Operations
|
|
||||||
|
|
||||||
**guile-filesystem** & **f.scm** - *Enhanced file handling*
|
|
||||||
|
|
||||||
- Beyond basic Guile file operations
|
|
||||||
- Path manipulation, directory traversal, file monitoring
|
|
||||||
|
|
||||||
### 2. Process and Service Management
|
|
||||||
|
|
||||||
**shepherd** - *Service management*
|
|
||||||
|
|
||||||
- GNU Shepherd integration for service lifecycle management
|
|
||||||
- Alternative to systemd interactions
|
|
||||||
|
|
||||||
### 3. Cryptography and Security
|
|
||||||
|
|
||||||
**guile-gcrypt** - *Cryptographic operations*
|
|
||||||
|
|
||||||
- Key management, encryption/decryption, hashing
|
|
||||||
- Secure configuration storage, deployment verification
|
|
||||||
|
|
||||||
## Specialized Infrastructure Libraries
|
|
||||||
|
|
||||||
### 1. Containerization Support
|
|
||||||
|
|
||||||
**guile-docker** / Container operations
|
|
||||||
|
|
||||||
- Docker/Podman integration for containerized services
|
|
||||||
- Image management, container lifecycle
|
|
||||||
|
|
||||||
### 2. Version Control Integration
|
|
||||||
|
|
||||||
**guile-git** - *Git operations*
|
|
||||||
|
|
||||||
- Flake updates, configuration versioning
|
|
||||||
- Automated commit/push for deployment tracking
|
|
||||||
|
|
||||||
### 3. Monitoring and Metrics
|
|
||||||
|
|
||||||
**prometheus** (Guile implementation) - *Metrics collection*
|
|
||||||
|
|
||||||
- Performance monitoring, deployment success rates
|
|
||||||
- Integration with existing monitoring infrastructure
|
|
||||||
|
|
||||||
## MCP Server Implementation Strategy
|
|
||||||
|
|
||||||
### Core MCP Capabilities to Implement
|
|
||||||
|
|
||||||
1. **Tools**: Home lab management operations
|
|
||||||
- `deploy-machine`: Deploy specific machine configurations
|
|
||||||
- `check-status`: Machine connectivity and health checks
|
|
||||||
- `update-flake`: Update package definitions
|
|
||||||
- `rollback-deployment`: Emergency rollback procedures
|
|
||||||
|
|
||||||
2. **Resources**: Lab state and configuration access
|
|
||||||
- Machine configurations (read-only access to NixOS configs)
|
|
||||||
- Deployment history and logs
|
|
||||||
- Service status across all machines
|
|
||||||
- Network topology and connectivity maps
|
|
||||||
|
|
||||||
3. **Prompts**: Common operational templates
|
|
||||||
- Deployment workflows
|
|
||||||
- Troubleshooting procedures
|
|
||||||
- Security audit checklists
|
|
||||||
|
|
||||||
### Implementation Architecture
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
(use-modules (json) (web socket) (ssh session) (scheme json-rpc))
|
|
||||||
|
|
||||||
(define-mcp-server home-lab-mcp
|
|
||||||
#:tools `(("deploy-machine"
|
|
||||||
#:description "Deploy configuration to specified machine"
|
|
||||||
#:parameters ,(make-schema-object
|
|
||||||
`(("machine" #:type "string" #:required #t)
|
|
||||||
("method" #:type "string" #:enum ("deploy-rs" "hybrid-update")))))
|
|
||||||
|
|
||||||
("check-status"
|
|
||||||
#:description "Check machine connectivity and services"
|
|
||||||
#:parameters ,(make-schema-object
|
|
||||||
`(("machines" #:type "array" #:items "string")))))
|
|
||||||
|
|
||||||
#:resources `(("machines://config/{machine}"
|
|
||||||
#:description "NixOS configuration for machine")
|
|
||||||
("machines://status/{machine}"
|
|
||||||
#:description "Current status and health metrics"))
|
|
||||||
|
|
||||||
#:prompts `(("deployment-workflow"
|
|
||||||
#:description "Standard deployment procedure")
|
|
||||||
("troubleshoot-machine"
|
|
||||||
#:description "Machine diagnostics checklist")))
|
|
||||||
```
|
|
||||||
|
|
||||||
## Migration Strategy
|
|
||||||
|
|
||||||
### Phase 1: Core Infrastructure (Weeks 1-2)
|
|
||||||
|
|
||||||
1. Set up Guile development environment in NixOS
|
|
||||||
2. Implement basic SSH operations using guile-ssh
|
|
||||||
3. Port status checking functionality
|
|
||||||
4. Create JSON-based machine configuration format
|
|
||||||
|
|
||||||
### Phase 2: Enhanced Features (Weeks 3-4)
|
|
||||||
|
|
||||||
1. Implement deployment methods (deploy-rs integration)
|
|
||||||
2. Add error handling and logging
|
|
||||||
3. Create web interface for monitoring
|
|
||||||
4. Develop basic MCP server capabilities
|
|
||||||
|
|
||||||
### Phase 3: Advanced Integration (Weeks 5-6)
|
|
||||||
|
|
||||||
1. Full MCP server implementation
|
|
||||||
2. Web dashboard with real-time updates
|
|
||||||
3. Integration with existing monitoring tools
|
|
||||||
4. Documentation and testing
|
|
||||||
|
|
||||||
### Phase 4: Production Deployment (Week 7)
|
|
||||||
|
|
||||||
1. Gradual rollout with fallback to Bash tool
|
|
||||||
2. Performance optimization
|
|
||||||
3. User training and documentation
|
|
||||||
4. Monitoring and feedback collection
|
|
||||||
|
|
||||||
## Guile vs. Alternative Languages
|
|
||||||
|
|
||||||
### Advantages of Guile
|
|
||||||
|
|
||||||
- **Homoiconicity**: Code as data enables powerful metaprogramming
|
|
||||||
- **REPL Development**: Interactive development and debugging
|
|
||||||
- **GNU Integration**: Seamless integration with GNU tools and philosophy
|
|
||||||
- **Extensibility**: Easy C library bindings for performance-critical code
|
|
||||||
- **Stability**: Mature language with stable API
|
|
||||||
|
|
||||||
### Considerations
|
|
||||||
|
|
||||||
- **Learning Curve**: Lisp syntax may be unfamiliar
|
|
||||||
- **Performance**: Generally slower than compiled languages for CPU-intensive tasks
|
|
||||||
- **Ecosystem Size**: Smaller than Python/JavaScript ecosystems
|
|
||||||
- **Tooling**: Fewer IDE integrations compared to mainstream languages
|
|
||||||
|
|
||||||
## Recommended Libraries by Priority
|
|
||||||
|
|
||||||
### Tier 1 (Essential)
|
|
||||||
|
|
||||||
1. **guile-ssh** - Remote operations foundation
|
|
||||||
2. **guile-json** - Data interchange format
|
|
||||||
3. **scheme-json-rpc** - MCP protocol implementation
|
|
||||||
4. **guile-webutils** - Web application utilities
|
|
||||||
|
|
||||||
### Tier 2 (Important)
|
|
||||||
|
|
||||||
1. **guile-websocket** - Real-time communication
|
|
||||||
2. **artanis** - Web framework
|
|
||||||
3. **guile-curl** - HTTP client operations
|
|
||||||
4. **guile-config** - Configuration management
|
|
||||||
|
|
||||||
### Tier 3 (Enhancement)
|
|
||||||
|
|
||||||
1. **guile-git** - Version control integration
|
|
||||||
2. **guile-sqlite3** - Local data storage
|
|
||||||
3. **prometheus** - Metrics and monitoring
|
|
||||||
4. **guile-gcrypt** - Security operations
|
|
||||||
|
|
||||||
## Security Considerations
|
|
||||||
|
|
||||||
### Authentication and Authorization
|
|
||||||
|
|
||||||
- **guile-ssh**: Public key authentication, agent support
|
|
||||||
- **guile-gcrypt**: Secure credential storage
|
|
||||||
- **MCP Security**: Implement capability-based access control
|
|
||||||
|
|
||||||
### Network Security
|
|
||||||
|
|
||||||
- **TLS Support**: Via guile-gnutls for encrypted communications
|
|
||||||
- **SSH Tunneling**: Secure communication channels
|
|
||||||
- **Input Validation**: JSON schema validation for all inputs
|
|
||||||
|
|
||||||
### Deployment Security
|
|
||||||
|
|
||||||
- **Signed Deployments**: Cryptographic verification of configurations
|
|
||||||
- **Audit Logging**: Comprehensive operation logging
|
|
||||||
- **Rollback Capability**: Quick recovery from failed deployments
|
|
||||||
|
|
||||||
## Performance Considerations
|
|
||||||
|
|
||||||
### Optimization Strategies
|
|
||||||
|
|
||||||
1. **Compiled Modules**: Use `.go` files for performance-critical code
|
|
||||||
2. **Async Operations**: Leverage fibers for concurrent operations
|
|
||||||
3. **Caching**: Redis integration for frequently accessed data
|
|
||||||
4. **Native Extensions**: C bindings for system-level operations
|
|
||||||
|
|
||||||
### Expected Performance
|
|
||||||
|
|
||||||
- **SSH Operations**: Comparable to native SSH client
|
|
||||||
- **JSON Processing**: Adequate for configuration sizes (< 1MB)
|
|
||||||
- **Web Serving**: Suitable for low-traffic administrative interfaces
|
|
||||||
- **Startup Time**: Fast REPL startup, moderate for compiled applications
|
|
||||||
|
|
||||||
## Conclusion
|
|
||||||
|
|
||||||
The Guile ecosystem provides comprehensive support for implementing both a sophisticated home lab management tool and a Model Context Protocol server. The availability of mature libraries for SSH operations, JSON handling, web services, and system integration makes Guile an excellent choice for this migration.
|
|
||||||
|
|
||||||
**Key Strengths:**
|
|
||||||
|
|
||||||
- Rich library ecosystem specifically suited to system administration
|
|
||||||
- Excellent JSON-RPC and WebSocket support for MCP implementation
|
|
||||||
- Strong SSH and networking capabilities
|
|
||||||
- Active development community with good documentation
|
|
||||||
|
|
||||||
**Recommended Approach:**
|
|
||||||
|
|
||||||
1. Start with core SSH and JSON functionality
|
|
||||||
2. Gradually migrate features from Bash to Guile
|
|
||||||
3. Implement MCP server capabilities incrementally
|
|
||||||
4. Maintain backwards compatibility during transition
|
|
||||||
|
|
||||||
The migration to Guile will provide significant benefits in code maintainability, error handling, and extensibility while enabling advanced features like MCP integration that would be difficult to implement in Bash.
|
|
|
@ -1,334 +0,0 @@
|
||||||
# Replacing Bash with Guile Scheme for Home Lab Tools
|
|
||||||
|
|
||||||
This document outlines a proposal to migrate the `home-lab-tools` script from Bash to GNU Guile Scheme. This change aims to address the increasing complexity of the script and leverage the benefits of a more powerful programming language.
|
|
||||||
|
|
||||||
## 1. Introduction: Why Guile Scheme?
|
|
||||||
|
|
||||||
GNU Guile is the official extension language for the GNU Project. It is an implementation of the Scheme programming language, a dialect of Lisp. Using Guile for scripting offers several advantages over Bash, especially as scripts grow in size and complexity.
|
|
||||||
|
|
||||||
Key reasons for considering Guile:
|
|
||||||
|
|
||||||
* **Expressiveness and Power:** Scheme is a full-fledged programming language with features like first-class functions, macros, and a rich standard library. This allows for more elegant and maintainable solutions to complex problems.
|
|
||||||
* **Better Error Handling:** Guile provides robust error handling mechanisms (conditions and handlers) that are more sophisticated than Bash's `set -e` and trap.
|
|
||||||
* **Modularity:** Guile supports modules, making it easier to organize code into reusable components.
|
|
||||||
* **Data Manipulation:** Scheme excels at handling structured data, which can be beneficial for managing configurations or parsing output from commands.
|
|
||||||
* **Readability (for Lisp programmers):** While Lisp syntax can be initially unfamiliar, it can lead to very clear and concise code once learned.
|
|
||||||
* **Interoperability:** Guile can easily call external programs and libraries, and can be extended with C code if needed.
|
|
||||||
|
|
||||||
## 2. Advantages over Bash for `home-lab-tools`
|
|
||||||
|
|
||||||
Migrating `home-lab-tools` from Bash to Guile offers specific benefits:
|
|
||||||
|
|
||||||
* **Improved Logic Handling:** Complex conditional logic, loops, and function definitions are more naturally expressed in Guile. The current Bash script uses case statements and string comparisons extensively, which can become unwieldy.
|
|
||||||
* **Structured Data Management:** Machine definitions, deployment modes, and status information could be represented as Scheme data structures (lists, association lists, records), making them easier to manage and query.
|
|
||||||
* **Enhanced Error Reporting:** More descriptive error messages and better control over script termination in case of failures.
|
|
||||||
* **Code Reusability:** Functions for common tasks (e.g., SSHing to a machine, running `nixos-rebuild`) can be more cleanly defined and reused.
|
|
||||||
* **Easier Testing:** Guile's nature as a programming language makes it more amenable to unit testing individual functions or modules.
|
|
||||||
* **Future Extensibility:** Adding new commands, machines, or features will be simpler and less error-prone in a more structured language.
|
|
||||||
|
|
||||||
## 3. Setting up Guile
|
|
||||||
|
|
||||||
Guile is often available through system package managers. On NixOS, it can be added to your environment or system configuration.
|
|
||||||
|
|
||||||
```nix
|
|
||||||
# Example: Adding Guile to a Nix shell
|
|
||||||
nix-shell -p guile
|
|
||||||
```
|
|
||||||
|
|
||||||
A Guile script typically starts with a shebang line:
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
```
|
|
||||||
|
|
||||||
The `!#` at the end is a Guile-specific convention that allows the script to be both executable and loadable into a Guile REPL.
|
|
||||||
|
|
||||||
## 4. Basic Guile Scripting Concepts
|
|
||||||
|
|
||||||
* **S-expressions:** Code is written using S-expressions (Symbolic Expressions), which are lists enclosed in parentheses, e.g., `(function arg1 arg2)`.
|
|
||||||
* **Definitions:** `(define variable value)` and `(define (function-name arg1 arg2) ...body...)`.
|
|
||||||
* **Procedures (Functions):** Core of Guile programming.
|
|
||||||
* **Control Flow:** `(if condition then-expr else-expr)`, `(cond (test1 expr1) (test2 expr2) ... (else else-expr))`, `(case ...)`
|
|
||||||
* **Modules:** `(use-modules (ice-9 popen))` for using libraries.
|
|
||||||
|
|
||||||
## 5. Interacting with the System
|
|
||||||
|
|
||||||
Guile provides modules for system interaction:
|
|
||||||
|
|
||||||
* **(ice-9 popen):** For running external commands and capturing their output (similar to backticks or `$(...)` in Bash).
|
|
||||||
* `open-pipe* command mode`: Opens a pipe to a command.
|
|
||||||
* `get-string-all port`: Reads all output from a port.
|
|
||||||
* **(ice-9 rdelim):** For reading lines from ports.
|
|
||||||
* **(ice-9 filesys):** For file system operations (checking existence, deleting, etc.).
|
|
||||||
* `file-exists? path`
|
|
||||||
* `delete-file path`
|
|
||||||
* **(srfi srfi-1):** List processing utilities.
|
|
||||||
* **(srfi srfi-26):** `cut` for partial application, useful for creating specialized functions.
|
|
||||||
* **Environment Variables:** `(getenv "VAR_NAME")`, `(setenv "VAR_NAME" "value")`.
|
|
||||||
|
|
||||||
## Example: Running a command**
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
(use-modules (ice-9 popen))
|
|
||||||
|
|
||||||
(define (run-command . args)
|
|
||||||
(let* ((cmd (string-join args " "))
|
|
||||||
(port (open-pipe* cmd OPEN_READ)))
|
|
||||||
(let ((output (get-string-all port)))
|
|
||||||
(close-pipe port)
|
|
||||||
output)))
|
|
||||||
|
|
||||||
(display (run-command "echo" "Hello from Guile"))
|
|
||||||
(newline)
|
|
||||||
```
|
|
||||||
|
|
||||||
## 6. Error Handling
|
|
||||||
|
|
||||||
Guile uses a condition system for error handling.
|
|
||||||
|
|
||||||
* `catch`: Allows you to catch specific types of errors.
|
|
||||||
* `throw`: Raises an error.
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
(use-modules (ice-9 exceptions))
|
|
||||||
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(display "Trying something that might fail...
|
|
||||||
")
|
|
||||||
;; Example: Force an error
|
|
||||||
(if #t (error "Something went wrong!"))
|
|
||||||
(display "This won't be printed if an error occurs above.
|
|
||||||
"))
|
|
||||||
(lambda (key . args)
|
|
||||||
(format (current-error-port) "Caught an error: ~a - Args: ~a
|
|
||||||
" key args)
|
|
||||||
#f)) ; Return value indicating an error was caught
|
|
||||||
```
|
|
||||||
|
|
||||||
For `home-lab-tools`, this means we can provide more specific feedback when a deployment fails or a machine is unreachable.
|
|
||||||
|
|
||||||
## 7. Modularity and Code Organization
|
|
||||||
|
|
||||||
Guile's module system allows splitting the code into logical units. For `home-lab-tools`, we could have modules for:
|
|
||||||
|
|
||||||
* `lab-config`: Machine definitions, paths.
|
|
||||||
* `lab-deploy`: Functions related to deploying configurations.
|
|
||||||
* `lab-ssh`: SSH interaction utilities.
|
|
||||||
* `lab-status`: Functions for checking machine status.
|
|
||||||
* `lab-utils`: General helper functions, logging.
|
|
||||||
|
|
||||||
**Example module structure:**
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; file: lab-utils.scm
|
|
||||||
(define-module (lab utils)
|
|
||||||
#:export (log success warn error))
|
|
||||||
|
|
||||||
(define blue "[0;34m")
|
|
||||||
(define nc "[0m")
|
|
||||||
|
|
||||||
(define (log msg)
|
|
||||||
(format #t "~a[lab]~a ~a
|
|
||||||
" blue nc msg))
|
|
||||||
;; ... other logging functions
|
|
||||||
```
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; file: main-lab-script.scm
|
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
(use-modules (lab utils) (ice-9 popen))
|
|
||||||
|
|
||||||
(log "Starting lab script...")
|
|
||||||
;; ... rest of the script
|
|
||||||
```
|
|
||||||
|
|
||||||
## 8. Example: Rewriting a Small Part of `home-lab-tools.nix` (Conceptual)
|
|
||||||
|
|
||||||
Let's consider the `log` function and a simplified `deploy_machine` for local deployment.
|
|
||||||
|
|
||||||
**Current Bash:**
|
|
||||||
|
|
||||||
```bash
|
|
||||||
BLUE='[0;34m'
|
|
||||||
NC='[0m' # No Color
|
|
||||||
|
|
||||||
log() {
|
|
||||||
echo -e "''${BLUE}[lab]''${NC} $1"
|
|
||||||
}
|
|
||||||
|
|
||||||
deploy_machine() {
|
|
||||||
local machine="$1"
|
|
||||||
# ...
|
|
||||||
if [[ "$machine" == "congenital-optimist" ]]; then
|
|
||||||
log "Deploying $machine (mode: $mode) locally"
|
|
||||||
sudo nixos-rebuild $mode --flake "$HOMELAB_ROOT#$machine"
|
|
||||||
fi
|
|
||||||
# ...
|
|
||||||
}
|
|
||||||
```
|
|
||||||
|
|
||||||
**Conceptual Guile Scheme:**
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
;; main-lab-script.scm
|
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
(use-modules (ice-9 popen)
|
|
||||||
(ice-9 rdelim)
|
|
||||||
(ice-9 pretty-print)
|
|
||||||
(ice-9 exceptions)
|
|
||||||
(srfi srfi-1)) ;; For list utilities like `string-join`
|
|
||||||
|
|
||||||
;; Configuration (could be in a separate module)
|
|
||||||
(define homelab-root "/home/geir/Home-lab")
|
|
||||||
|
|
||||||
;; Color Definitions
|
|
||||||
(define RED "[0;31m")
|
|
||||||
(define GREEN "[0;32m")
|
|
||||||
(define YELLOW "[1;33m")
|
|
||||||
(define BLUE "[0;34m")
|
|
||||||
(define NC "[0m")
|
|
||||||
|
|
||||||
;; Logging functions
|
|
||||||
(define (log level-color level-name message)
|
|
||||||
(format #t "~a[~a]~a ~a
|
|
||||||
" level-color level-name NC message))
|
|
||||||
|
|
||||||
(define (info . messages)
|
|
||||||
(log BLUE "lab" (apply string-append (map (lambda (m) (if (string? m) m (format #f "~s" m))) messages))))
|
|
||||||
|
|
||||||
(define (success . messages)
|
|
||||||
(log GREEN "lab" (apply string-append (map (lambda (m) (if (string? m) m (format #f "~s" m))) messages))))
|
|
||||||
|
|
||||||
(define (warn . messages)
|
|
||||||
(log YELLOW "lab" (apply string-append (map (lambda (m) (if (string? m) m (format #f "~s" m))) messages))))
|
|
||||||
|
|
||||||
(define (err . messages)
|
|
||||||
(log RED "lab" (apply string-append (map (lambda (m) (if (string? m) m (format #f "~s" m))) messages)))
|
|
||||||
(exit 1)) ;; Exit on error
|
|
||||||
|
|
||||||
;; Function to run shell commands and handle output/errors
|
|
||||||
(define (run-shell-command . command-parts)
|
|
||||||
(let ((command-string (string-join command-parts " ")))
|
|
||||||
(info "Executing: " command-string)
|
|
||||||
(let ((pipe (open-pipe* command-string OPEN_READ)))
|
|
||||||
(let loop ((lines '()))
|
|
||||||
(let ((line (read-line pipe)))
|
|
||||||
(if (eof-object? line)
|
|
||||||
(begin
|
|
||||||
(close-pipe pipe)
|
|
||||||
(reverse lines)) ;; Return lines in order
|
|
||||||
(begin
|
|
||||||
(display line) (newline) ;; Display live output
|
|
||||||
(loop (cons line lines)))))))
|
|
||||||
;; TODO: Add proper error checking based on exit status of the command
|
|
||||||
;; For now, we assume success if open-pipe* doesn't fail.
|
|
||||||
;; A more robust solution would check `close-pipe` status or use `system*`.
|
|
||||||
))
|
|
||||||
|
|
||||||
;; Simplified deploy_machine
|
|
||||||
(define (deploy-machine machine mode)
|
|
||||||
(info "Deploying " machine " (mode: " mode ")")
|
|
||||||
(cond
|
|
||||||
((string=? machine "congenital-optimist")
|
|
||||||
(info "Deploying " machine " locally")
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(run-shell-command "sudo" "nixos-rebuild" mode "--flake" (string-append homelab-root "#" machine))
|
|
||||||
(success "Successfully deployed " machine))
|
|
||||||
(lambda (key . args)
|
|
||||||
(err "Failed to deploy " machine ". Error: " key " Args: " args))))
|
|
||||||
;; Add other machines here
|
|
||||||
(else
|
|
||||||
(err "Unknown machine: " machine))))
|
|
||||||
|
|
||||||
;; Main script logic (parsing arguments, calling functions)
|
|
||||||
(define (main args)
|
|
||||||
(if (< (length args) 3)
|
|
||||||
(begin
|
|
||||||
(err "Usage: <script> deploy <machine> [mode]")
|
|
||||||
(exit 1))
|
|
||||||
(let ((command (cadr args))
|
|
||||||
(machine (caddr args))
|
|
||||||
(mode (if (> (length args) 3) (cadddr args) "boot")))
|
|
||||||
(cond
|
|
||||||
((string=? command "deploy")
|
|
||||||
(deploy-machine machine mode))
|
|
||||||
;; Add other commands like "status", "update"
|
|
||||||
(else
|
|
||||||
(err "Unknown command: " command))))))
|
|
||||||
|
|
||||||
;; Run the main function with command-line arguments
|
|
||||||
;; (cdr args) to skip the script name itself
|
|
||||||
(main (program-arguments))
|
|
||||||
```
|
|
||||||
|
|
||||||
## 9. Creating Terminal User Interfaces (TUIs) with Guile-Ncurses
|
|
||||||
|
|
||||||
For more interactive command-line tools, Guile Scheme can be used to create Text User Interfaces (TUIs). The primary library for this is `guile-ncurses`.
|
|
||||||
|
|
||||||
**Guile-Ncurses** is a GNU project that provides Scheme bindings for the ncurses library, including its components for forms, panels, and menus. This allows you to build sophisticated text-based interfaces directly in Guile.
|
|
||||||
|
|
||||||
**Key Features:**
|
|
||||||
|
|
||||||
* **Windowing:** Create and manage multiple windows on the terminal.
|
|
||||||
* **Input Handling:** Process keyboard input, including special keys.
|
|
||||||
* **Text Attributes:** Control colors, bolding, underlining, and other text styles.
|
|
||||||
* **Forms, Panels, Menus:** Higher-level components for building complex interfaces.
|
|
||||||
|
|
||||||
**Getting Started with Guile-Ncurses:**
|
|
||||||
|
|
||||||
1. **Installation:** `guile-ncurses` would typically be installed via your system's package manager or built from source. If you are using NixOS, you would look for a Nix package for `guile-ncurses`.
|
|
||||||
|
|
||||||
```nix
|
|
||||||
# Example: Adding guile-ncurses to a Nix shell (package name might vary)
|
|
||||||
nix-shell -p guile guile-ncurses
|
|
||||||
```
|
|
||||||
|
|
||||||
2. **Using in Code:**
|
|
||||||
You would use the `(ncurses curses)` module (and others like `(ncurses form)`, `(ncurses menu)`, `(ncurses panel)`) in your Guile script.
|
|
||||||
|
|
||||||
```scheme
|
|
||||||
(use-modules (ncurses curses))
|
|
||||||
|
|
||||||
(define (tui-main stdscr)
|
|
||||||
;; Initialize ncurses
|
|
||||||
(cbreak!) ;; Line buffering disabled, Pass on ever char
|
|
||||||
(noecho!) ;; Don't echo() while we do getch
|
|
||||||
(keypad stdscr #t) ;; Enable Fx keys, arrow keys etc.
|
|
||||||
|
|
||||||
(addstr "Hello, Guile Ncurses TUI!")
|
|
||||||
(refresh)
|
|
||||||
(getch) ;; Wait for a key press
|
|
||||||
(endwin)) ;; End curses mode
|
|
||||||
|
|
||||||
;; Initialize and run the TUI
|
|
||||||
(initscr)
|
|
||||||
(tui-main stdscr)
|
|
||||||
```
|
|
||||||
|
|
||||||
**Resources:**
|
|
||||||
|
|
||||||
* **Guile-Ncurses Project Page:** [https://www.nongnu.org/guile-ncurses/](https://www.nongnu.org/guile-ncurses/)
|
|
||||||
* **Guile-Ncurses Manual:** [https://www.gnu.org/software/guile-ncurses/manual/](https://www.gnu.org/software/guile-ncurses/manual/)
|
|
||||||
|
|
||||||
Integrating `guile-ncurses` can significantly enhance the user experience of your `home-lab-tools` script, allowing for interactive menus, status dashboards, and more complex user interactions beyond simple command-line arguments and output.
|
|
||||||
|
|
||||||
## 10. Conclusion and Next Steps
|
|
||||||
|
|
||||||
Migrating `home-lab-tools` to Guile Scheme offers a path to a more maintainable, robust, and extensible solution. While there is a learning curve for Scheme, the long-term benefits for managing a complex set of administration tasks are significant.
|
|
||||||
|
|
||||||
**Next Steps:**
|
|
||||||
|
|
||||||
1. **Install Guile:** Ensure Guile is available in the development environment.
|
|
||||||
2. **Start Small:** Begin by porting one command or a set of utility functions (e.g., logging, SSH wrappers).
|
|
||||||
3. **Learn Guile Basics:** Familiarize with Scheme syntax, common procedures, and modules. The Guile Reference Manual is an excellent resource.
|
|
||||||
4. **Develop Incrementally:** Port functionality piece by piece, testing along the way.
|
|
||||||
5. **Explore Guile Libraries:** Investigate Guile libraries for argument parsing (e.g., `(gnu cmdline)`), file system operations, and other needs.
|
|
||||||
6. **Refactor and Organize:** Use Guile's module system to keep the codebase clean and organized.
|
|
||||||
|
|
||||||
This transition will require an initial investment in learning and development but promises a more powerful and sustainable tool for managing the home lab infrastructure.
|
|
|
@ -1,74 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; Home Lab Tool - Guile Scheme Implementation (Minimal Version)
|
|
||||||
;; Main entry point for the lab command-line tool
|
|
||||||
|
|
||||||
(use-modules (ice-9 match)
|
|
||||||
(ice-9 format))
|
|
||||||
|
|
||||||
;; Simple logging
|
|
||||||
(define (log-info msg . args)
|
|
||||||
(apply format #t (string-append "[lab] " msg "~%") args))
|
|
||||||
|
|
||||||
(define (log-error msg . args)
|
|
||||||
(apply format (current-error-port) (string-append "[ERROR] " msg "~%") args))
|
|
||||||
|
|
||||||
;; Configuration
|
|
||||||
(define machines '("congenital-optimist" "sleeper-service" "grey-area" "reverse-proxy"))
|
|
||||||
|
|
||||||
;; Main command dispatcher
|
|
||||||
(define (dispatch-command command args)
|
|
||||||
(match command
|
|
||||||
("status"
|
|
||||||
(log-info "Infrastructure status:")
|
|
||||||
(for-each (lambda (machine)
|
|
||||||
(format #t " ~a: Online~%" machine))
|
|
||||||
machines))
|
|
||||||
|
|
||||||
("deploy"
|
|
||||||
(if (null? args)
|
|
||||||
(log-error "deploy command requires machine name")
|
|
||||||
(let ((machine (car args)))
|
|
||||||
(if (member machine machines)
|
|
||||||
(log-info "Deploying to ~a..." machine)
|
|
||||||
(log-error "Unknown machine: ~a" machine)))))
|
|
||||||
|
|
||||||
("mcp"
|
|
||||||
(if (null? args)
|
|
||||||
(log-error "mcp command requires: start, stop, or status")
|
|
||||||
(match (car args)
|
|
||||||
("status" (log-info "MCP server: Development mode"))
|
|
||||||
(_ (log-error "MCP command not implemented: ~a" (car args))))))
|
|
||||||
|
|
||||||
(_ (log-error "Unknown command: ~a" command))))
|
|
||||||
|
|
||||||
;; Show help
|
|
||||||
(define (show-help)
|
|
||||||
(format #t "Home Lab Tool (Guile) v0.1.0
|
|
||||||
|
|
||||||
Usage: lab [COMMAND] [ARGS...]
|
|
||||||
|
|
||||||
Commands:
|
|
||||||
status Show infrastructure status
|
|
||||||
deploy MACHINE Deploy to machine
|
|
||||||
mcp status Show MCP server status
|
|
||||||
help Show this help
|
|
||||||
|
|
||||||
Machines: ~a
|
|
||||||
" (string-join machines ", ")))
|
|
||||||
|
|
||||||
;; Main entry point
|
|
||||||
(define (main args)
|
|
||||||
(if (< (length args) 2)
|
|
||||||
(show-help)
|
|
||||||
(let ((command (cadr args))
|
|
||||||
(command-args (cddr args)))
|
|
||||||
(if (string=? command "help")
|
|
||||||
(show-help)
|
|
||||||
(dispatch-command command command-args)))))
|
|
||||||
|
|
||||||
;; Execute main if this script is run directly
|
|
||||||
(when (and (> (length (command-line)) 0)
|
|
||||||
(string=? (car (command-line)) "./home-lab-tool.scm"))
|
|
||||||
(main (command-line)))
|
|
|
@ -1,258 +0,0 @@
|
||||||
;; lab/machines.scm - Machine-specific operations
|
|
||||||
|
|
||||||
(define-module (lab machines)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (ice-9 match)
|
|
||||||
|
|
||||||
#:use-module (srfi srfi-1)
|
|
||||||
#:use-module (srfi srfi-19)
|
|
||||||
#:use-module (utils logging)
|
|
||||||
#:use-module (utils config)
|
|
||||||
#:use-module (utils ssh)
|
|
||||||
#:use-module (lab core)
|
|
||||||
#:export (show-infrastructure-status
|
|
||||||
get-machine-details
|
|
||||||
discover-machines
|
|
||||||
validate-machine-health
|
|
||||||
get-machine-metrics
|
|
||||||
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)))
|
|
||||||
|
|
||||||
;; Display infrastructure status in a human-readable format
|
|
||||||
(define (show-infrastructure-status machine-name options)
|
|
||||||
"Display comprehensive infrastructure status"
|
|
||||||
(let ((verbose (option-ref options 'verbose #f))
|
|
||||||
(status-data (get-infrastructure-status machine-name)))
|
|
||||||
|
|
||||||
(log-info "Home-lab infrastructure status:")
|
|
||||||
(newline)
|
|
||||||
|
|
||||||
(for-each
|
|
||||||
(lambda (machine-status)
|
|
||||||
(display-machine-status machine-status verbose))
|
|
||||||
status-data)
|
|
||||||
|
|
||||||
;; Summary statistics
|
|
||||||
(let ((total-machines (length status-data))
|
|
||||||
(online-machines (length (filter
|
|
||||||
(lambda (status)
|
|
||||||
(eq? (assoc-ref status 'connection) 'online))
|
|
||||||
status-data))))
|
|
||||||
(newline)
|
|
||||||
(if (= online-machines total-machines)
|
|
||||||
(log-success "All ~a machines online ✓" total-machines)
|
|
||||||
(log-warn "~a/~a machines online" online-machines total-machines)))))
|
|
||||||
|
|
||||||
;; Display status for a single machine
|
|
||||||
(define (display-machine-status machine-status verbose)
|
|
||||||
"Display formatted status for a single machine"
|
|
||||||
(let* ((machine-name (assoc-ref machine-status 'machine))
|
|
||||||
(machine-type (assoc-ref machine-status 'type))
|
|
||||||
(connection (assoc-ref machine-status 'connection))
|
|
||||||
(services (assoc-ref machine-status 'services))
|
|
||||||
(system-info (assoc-ref machine-status 'system))
|
|
||||||
(check-time (assoc-ref machine-status 'check-time)))
|
|
||||||
|
|
||||||
;; Machine header with connection status
|
|
||||||
(let ((status-symbol (if (eq? connection 'online) "✅" "❌"))
|
|
||||||
(type-label (if (eq? machine-type 'local) "(local)" "(remote)")))
|
|
||||||
(format #t "━━━ ~a ~a ~a ━━━~%" machine-name type-label status-symbol))
|
|
||||||
|
|
||||||
;; Connection details
|
|
||||||
(if (eq? connection 'online)
|
|
||||||
(begin
|
|
||||||
(when system-info
|
|
||||||
(let ((uptime (assoc-ref system-info 'uptime))
|
|
||||||
(load (assoc-ref system-info 'load))
|
|
||||||
(memory (assoc-ref system-info 'memory))
|
|
||||||
(disk (assoc-ref system-info 'disk)))
|
|
||||||
(when uptime (format #t "⏱️ Uptime: ~a~%" uptime))
|
|
||||||
(when load (format #t "📊 Load: ~a~%" load))
|
|
||||||
(when memory (format #t "🧠 Memory: ~a~%" memory))
|
|
||||||
(when disk (format #t "💾 Disk: ~a~%" disk))))
|
|
||||||
|
|
||||||
;; Services status
|
|
||||||
(when (not (null? services))
|
|
||||||
(format #t "🔧 Services: ")
|
|
||||||
(for-each (lambda (service-status)
|
|
||||||
(let ((service-name (symbol->string (car service-status)))
|
|
||||||
(service-state (cdr service-status)))
|
|
||||||
(let ((status-icon (cond
|
|
||||||
((string=? service-state "active") "✅")
|
|
||||||
((string=? service-state "inactive") "❌")
|
|
||||||
((string=? service-state "failed") "💥")
|
|
||||||
(else "❓"))))
|
|
||||||
(format #t "~a ~a " service-name status-icon))))
|
|
||||||
services)
|
|
||||||
(newline))
|
|
||||||
|
|
||||||
(format #t "⚡ Response: ~ams~%" (inexact->exact (round (* check-time 1000)))))
|
|
||||||
(format #t "⚠️ Status: Offline~%"))
|
|
||||||
|
|
||||||
;; Verbose information
|
|
||||||
(when verbose
|
|
||||||
(let ((ssh-config (get-ssh-config machine-name)))
|
|
||||||
(when ssh-config
|
|
||||||
(format #t "🔗 SSH: ~a~%" (assoc-ref ssh-config 'hostname))
|
|
||||||
(let ((ssh-alias (assoc-ref ssh-config 'ssh-alias)))
|
|
||||||
(when ssh-alias
|
|
||||||
(format #t "🏷️ Alias: ~a~%" ssh-alias))))))
|
|
||||||
|
|
||||||
(newline)))
|
|
||||||
|
|
||||||
;; Get detailed information about a specific machine
|
|
||||||
(define (get-machine-details machine-name)
|
|
||||||
"Get comprehensive details about a specific machine"
|
|
||||||
(let ((machine-config (get-machine-config machine-name)))
|
|
||||||
(if (not machine-config)
|
|
||||||
(begin
|
|
||||||
(log-error "Machine ~a not found in configuration" machine-name)
|
|
||||||
#f)
|
|
||||||
(let* ((ssh-config (get-ssh-config machine-name))
|
|
||||||
(health-status (check-system-health machine-name))
|
|
||||||
(current-status (car (get-infrastructure-status machine-name))))
|
|
||||||
|
|
||||||
`((name . ,machine-name)
|
|
||||||
(config . ,machine-config)
|
|
||||||
(ssh . ,ssh-config)
|
|
||||||
(status . ,current-status)
|
|
||||||
(health . ,health-status)
|
|
||||||
(last-updated . ,(current-date)))))))
|
|
||||||
|
|
||||||
;; Discover machines on the network
|
|
||||||
(define (discover-machines)
|
|
||||||
"Discover available machines on the network"
|
|
||||||
(log-info "Discovering machines on the network...")
|
|
||||||
|
|
||||||
(let ((configured-machines (get-all-machines)))
|
|
||||||
(log-debug "Configured machines: ~a" configured-machines)
|
|
||||||
|
|
||||||
;; Test connectivity to each configured machine
|
|
||||||
(let ((discovery-results
|
|
||||||
(map (lambda (machine-name)
|
|
||||||
(log-debug "Testing connectivity to ~a..." machine-name)
|
|
||||||
(let ((reachable (test-ssh-connection machine-name))
|
|
||||||
(ssh-config (get-ssh-config machine-name)))
|
|
||||||
`((machine . ,machine-name)
|
|
||||||
(configured . #t)
|
|
||||||
(reachable . ,reachable)
|
|
||||||
(type . ,(if (and ssh-config (assoc-ref ssh-config 'is-local))
|
|
||||||
'local 'remote))
|
|
||||||
(hostname . ,(if ssh-config
|
|
||||||
(assoc-ref ssh-config 'hostname)
|
|
||||||
"unknown")))))
|
|
||||||
configured-machines)))
|
|
||||||
|
|
||||||
;; TODO: Add network scanning for unconfigured machines
|
|
||||||
;; This could use nmap or similar tools to discover machines
|
|
||||||
|
|
||||||
(log-info "Discovery completed")
|
|
||||||
discovery-results)))
|
|
||||||
|
|
||||||
;; Validate health of a machine with detailed checks
|
|
||||||
(define (validate-machine-health machine-name . detailed)
|
|
||||||
"Perform comprehensive health validation on a machine"
|
|
||||||
(let ((run-detailed (if (null? detailed) #f (car detailed))))
|
|
||||||
(log-info "Validating health of ~a..." machine-name)
|
|
||||||
|
|
||||||
(let ((basic-health (check-system-health machine-name)))
|
|
||||||
(if run-detailed
|
|
||||||
;; Extended health checks for detailed mode
|
|
||||||
(let ((extended-checks
|
|
||||||
'(("filesystem" . check-filesystem-health)
|
|
||||||
("network-services" . check-network-services)
|
|
||||||
("system-logs" . check-system-logs)
|
|
||||||
("performance" . check-performance-metrics))))
|
|
||||||
|
|
||||||
(let ((extended-results
|
|
||||||
(map (lambda (check-pair)
|
|
||||||
(let ((check-name (car check-pair))
|
|
||||||
(check-proc (cdr check-pair)))
|
|
||||||
(log-debug "Running extended check: ~a" check-name)
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
`(,check-name . ,(check-proc machine-name)))
|
|
||||||
(lambda (key . args)
|
|
||||||
(log-warn "Extended check ~a failed: ~a" check-name key)
|
|
||||||
`(,check-name . (error . ,key))))))
|
|
||||||
extended-checks)))
|
|
||||||
|
|
||||||
`((basic . ,basic-health)
|
|
||||||
(extended . ,extended-results)
|
|
||||||
(timestamp . ,(current-date)))))
|
|
||||||
|
|
||||||
;; Just basic health checks
|
|
||||||
`((basic . ,basic-health)
|
|
||||||
(timestamp . ,(current-date)))))))
|
|
||||||
|
|
||||||
;; Extended health check functions
|
|
||||||
(define (check-filesystem-health machine-name)
|
|
||||||
"Check filesystem health and disk usage"
|
|
||||||
(call-with-values (((success output)
|
|
||||||
(run-remote-command machine-name "df -h && echo '---' && mount | grep -E '^/' | head -5")))
|
|
||||||
(if success
|
|
||||||
`((status . pass)
|
|
||||||
(details . ,(string-trim-right output)))
|
|
||||||
`((status . fail)
|
|
||||||
(error . "Could not retrieve filesystem information")))))
|
|
||||||
|
|
||||||
(define (check-network-services machine-name)
|
|
||||||
"Check network service connectivity"
|
|
||||||
(let ((services-to-test '(("ssh" "22") ("http" "80") ("https" "443"))))
|
|
||||||
(map (lambda (service-pair)
|
|
||||||
(let ((service-name (car service-pair))
|
|
||||||
(port (cadr service-pair)))
|
|
||||||
(call-with-values (((success output)
|
|
||||||
(run-remote-command machine-name
|
|
||||||
(format #f "netstat -ln | grep ':~a ' > /dev/null 2>&1; echo $?" port))))
|
|
||||||
`(,service-name . ,(if (and success (string=? (string-trim-right output) "0"))
|
|
||||||
'listening 'not-listening)))))
|
|
||||||
services-to-test)))
|
|
||||||
|
|
||||||
(define (check-system-logs machine-name)
|
|
||||||
"Check system logs for recent errors"
|
|
||||||
(call-with-values (((success output)
|
|
||||||
(run-remote-command machine-name
|
|
||||||
"journalctl --since='1 hour ago' --priority=err --no-pager | wc -l")))
|
|
||||||
(if success
|
|
||||||
(let ((error-count (string->number (string-trim-right output))))
|
|
||||||
`((status . ,(if (< error-count 10) 'good 'concerning))
|
|
||||||
(error-count . ,error-count)))
|
|
||||||
`((status . unknown)
|
|
||||||
(error . "Could not check system logs")))))
|
|
||||||
|
|
||||||
(define (check-performance-metrics machine-name)
|
|
||||||
"Get basic performance metrics"
|
|
||||||
(let ((metrics-commands
|
|
||||||
'(("cpu-usage" "top -bn1 | grep 'Cpu(s)' | awk '{print $2}' | sed 's/%us,//'")
|
|
||||||
("memory-usage" "free | grep Mem | awk '{printf \"%.1f\", ($3/$2) * 100.0}'")
|
|
||||||
("io-wait" "iostat 1 2 | tail -1 | awk '{print $4}'"))))
|
|
||||||
|
|
||||||
(map (lambda (metric-pair)
|
|
||||||
(let ((metric-name (car metric-pair))
|
|
||||||
(command (cadr metric-pair)))
|
|
||||||
(call-with-values (((success output) (run-remote-command machine-name command)))
|
|
||||||
`(,(string->symbol metric-name) .
|
|
||||||
,(if success (string-trim-right output) "unknown")))))
|
|
||||||
metrics-commands)))
|
|
||||||
|
|
||||||
;; Get machine metrics for monitoring
|
|
||||||
(define (get-machine-metrics machine-name . time-range)
|
|
||||||
"Get machine metrics for monitoring and analysis"
|
|
||||||
(let ((range (if (null? time-range) "1h" (car time-range))))
|
|
||||||
(log-debug "Collecting metrics for ~a (range: ~a)" machine-name range)
|
|
||||||
|
|
||||||
(let ((current-time (current-date))
|
|
||||||
(performance (check-performance-metrics machine-name))
|
|
||||||
(health (validate-machine-health machine-name)))
|
|
||||||
|
|
||||||
`((machine . ,machine-name)
|
|
||||||
(timestamp . ,current-time)
|
|
||||||
(performance . ,performance)
|
|
||||||
(health . ,health)
|
|
||||||
(range . ,range)))))
|
|
|
@ -1,337 +0,0 @@
|
||||||
;; lab/monitoring.scm - Infrastructure monitoring and health checks
|
|
||||||
|
|
||||||
(define-module (lab monitoring)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (ice-9 match)
|
|
||||||
#:use-module (ice-9 popen)
|
|
||||||
#:use-module (ice-9 textual-ports)
|
|
||||||
|
|
||||||
#:use-module (srfi srfi-1)
|
|
||||||
#:use-module (srfi srfi-19)
|
|
||||||
#:use-module (utils logging)
|
|
||||||
#:use-module (utils config)
|
|
||||||
#:use-module (utils ssh)
|
|
||||||
#:use-module (lab core)
|
|
||||||
#:use-module (lab machines)
|
|
||||||
#:export (monitor-infrastructure
|
|
||||||
start-monitoring
|
|
||||||
stop-monitoring
|
|
||||||
get-monitoring-status
|
|
||||||
collect-metrics
|
|
||||||
generate-monitoring-report))
|
|
||||||
|
|
||||||
;; Monitor infrastructure with optional service filtering
|
|
||||||
(define (monitor-infrastructure service options)
|
|
||||||
"Monitor infrastructure, optionally filtering by service"
|
|
||||||
(let ((verbose (option-ref options 'verbose #f))
|
|
||||||
(machines (get-all-machines)))
|
|
||||||
|
|
||||||
(log-info "Starting infrastructure monitoring...")
|
|
||||||
|
|
||||||
(if service
|
|
||||||
(monitor-specific-service service machines verbose)
|
|
||||||
(monitor-all-services machines verbose))))
|
|
||||||
|
|
||||||
;; Monitor a specific service across all machines
|
|
||||||
(define (monitor-specific-service service machines verbose)
|
|
||||||
"Monitor a specific service across all configured machines"
|
|
||||||
(log-info "Monitoring service: ~a" service)
|
|
||||||
|
|
||||||
(let ((service-symbol (string->symbol service)))
|
|
||||||
(for-each
|
|
||||||
(lambda (machine-name)
|
|
||||||
(let ((machine-config (get-machine-config machine-name)))
|
|
||||||
(when machine-config
|
|
||||||
(let ((machine-services (assoc-ref machine-config 'services)))
|
|
||||||
(when (and machine-services (member service-symbol machine-services))
|
|
||||||
(monitor-service-on-machine machine-name service verbose))))))
|
|
||||||
machines)))
|
|
||||||
|
|
||||||
;; Monitor all services across all machines
|
|
||||||
(define (monitor-all-services machines verbose)
|
|
||||||
"Monitor all services across all machines"
|
|
||||||
(log-info "Monitoring all services across ~a machines" (length machines))
|
|
||||||
|
|
||||||
(let ((monitoring-results
|
|
||||||
(map (lambda (machine-name)
|
|
||||||
(log-debug "Monitoring ~a..." machine-name)
|
|
||||||
(monitor-machine-services machine-name verbose))
|
|
||||||
machines)))
|
|
||||||
|
|
||||||
(display-monitoring-summary monitoring-results)))
|
|
||||||
|
|
||||||
;; Monitor services on a specific machine
|
|
||||||
(define (monitor-machine-services machine-name verbose)
|
|
||||||
"Monitor all services on a specific machine"
|
|
||||||
(let ((machine-config (get-machine-config machine-name))
|
|
||||||
(connection-status (test-ssh-connection machine-name)))
|
|
||||||
|
|
||||||
(if (not connection-status)
|
|
||||||
(begin
|
|
||||||
(log-warn "Cannot connect to ~a, skipping monitoring" machine-name)
|
|
||||||
`((machine . ,machine-name)
|
|
||||||
(status . offline)
|
|
||||||
(services . ())))
|
|
||||||
|
|
||||||
(let ((services (if machine-config
|
|
||||||
(assoc-ref machine-config 'services)
|
|
||||||
'())))
|
|
||||||
(if (null? services)
|
|
||||||
(begin
|
|
||||||
(log-debug "No services configured for ~a" machine-name)
|
|
||||||
`((machine . ,machine-name)
|
|
||||||
(status . online)
|
|
||||||
(services . ())))
|
|
||||||
|
|
||||||
(let ((service-statuses
|
|
||||||
(map (lambda (service)
|
|
||||||
(monitor-service-on-machine machine-name
|
|
||||||
(symbol->string service)
|
|
||||||
verbose))
|
|
||||||
services)))
|
|
||||||
`((machine . ,machine-name)
|
|
||||||
(status . online)
|
|
||||||
(services . ,service-statuses))))))))
|
|
||||||
|
|
||||||
;; Monitor a specific service on a specific machine
|
|
||||||
(define (monitor-service-on-machine machine-name service verbose)
|
|
||||||
"Monitor a specific service on a specific machine"
|
|
||||||
(log-debug "Checking ~a service on ~a..." service machine-name)
|
|
||||||
|
|
||||||
(let ((service-checks
|
|
||||||
`(("status" . ,(lambda () (check-service-status machine-name service)))
|
|
||||||
("health" . ,(lambda () (check-service-health machine-name service)))
|
|
||||||
("logs" . ,(lambda () (check-service-logs machine-name service))))))
|
|
||||||
|
|
||||||
(let ((results
|
|
||||||
(map (lambda (check-pair)
|
|
||||||
(let ((check-name (car check-pair))
|
|
||||||
(check-proc (cdr check-pair)))
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
`(,check-name . ,(check-proc)))
|
|
||||||
(lambda (key . args)
|
|
||||||
(log-warn "Service check ~a failed for ~a: ~a"
|
|
||||||
check-name service key)
|
|
||||||
`(,check-name . (error . ,key))))))
|
|
||||||
service-checks)))
|
|
||||||
|
|
||||||
(when verbose
|
|
||||||
(display-service-details machine-name service results))
|
|
||||||
|
|
||||||
`((service . ,service)
|
|
||||||
(machine . ,machine-name)
|
|
||||||
(checks . ,results)
|
|
||||||
(timestamp . ,(current-date))))))
|
|
||||||
|
|
||||||
;; Check service status using systemctl
|
|
||||||
(define (check-service-status machine-name service)
|
|
||||||
"Check if a service is active using systemctl"
|
|
||||||
(call-with-values (((success output)
|
|
||||||
(run-remote-command machine-name "systemctl is-active" service)))
|
|
||||||
(if success
|
|
||||||
(let ((status (string-trim-right output)))
|
|
||||||
`((active . ,(string=? status "active"))
|
|
||||||
(status . ,status)))
|
|
||||||
`((active . #f)
|
|
||||||
(status . "unknown")
|
|
||||||
(error . "command-failed")))))
|
|
||||||
|
|
||||||
;; Check service health with additional metrics
|
|
||||||
(define (check-service-health machine-name service)
|
|
||||||
"Perform health checks for a service"
|
|
||||||
(let ((health-commands
|
|
||||||
(get-service-health-commands service)))
|
|
||||||
|
|
||||||
(if (null? health-commands)
|
|
||||||
`((healthy . unknown)
|
|
||||||
(reason . "no-health-checks-defined"))
|
|
||||||
|
|
||||||
(let ((health-results
|
|
||||||
(map (lambda (cmd-pair)
|
|
||||||
(let ((check-name (car cmd-pair))
|
|
||||||
(command (cdr cmd-pair)))
|
|
||||||
(call-with-values (((success output)
|
|
||||||
(run-remote-command machine-name command)))
|
|
||||||
`(,check-name . ((success . ,success)
|
|
||||||
(output . ,(if success
|
|
||||||
(string-trim-right output)
|
|
||||||
output)))))))
|
|
||||||
health-commands)))
|
|
||||||
|
|
||||||
(let ((all-healthy (every (lambda (result)
|
|
||||||
(assoc-ref (cdr result) 'success))
|
|
||||||
health-results)))
|
|
||||||
`((healthy . ,all-healthy)
|
|
||||||
(checks . ,health-results)))))))
|
|
||||||
|
|
||||||
;; Get service-specific health check commands
|
|
||||||
(define (get-service-health-commands service)
|
|
||||||
"Get health check commands for specific services"
|
|
||||||
(match service
|
|
||||||
("ollama"
|
|
||||||
'(("api-check" . "curl -f http://localhost:11434/api/tags > /dev/null 2>&1; echo $?")
|
|
||||||
("process-check" . "pgrep ollama > /dev/null; echo $?")))
|
|
||||||
|
|
||||||
("forgejo"
|
|
||||||
'(("web-check" . "curl -f http://localhost:3000 > /dev/null 2>&1; echo $?")
|
|
||||||
("process-check" . "pgrep forgejo > /dev/null; echo $?")))
|
|
||||||
|
|
||||||
("jellyfin"
|
|
||||||
'(("web-check" . "curl -f http://localhost:8096/health > /dev/null 2>&1; echo $?")
|
|
||||||
("process-check" . "pgrep jellyfin > /dev/null; echo $?")))
|
|
||||||
|
|
||||||
("nfs-server"
|
|
||||||
'(("service-check" . "showmount -e localhost > /dev/null 2>&1; echo $?")
|
|
||||||
("exports-check" . "test -f /etc/exports; echo $?")))
|
|
||||||
|
|
||||||
("nginx"
|
|
||||||
'(("config-check" . "nginx -t 2>/dev/null; echo $?")
|
|
||||||
("web-check" . "curl -f http://localhost > /dev/null 2>&1; echo $?")))
|
|
||||||
|
|
||||||
("sshd"
|
|
||||||
'(("port-check" . "ss -tuln | grep ':22 ' > /dev/null; echo $?")))
|
|
||||||
|
|
||||||
(_ '())))
|
|
||||||
|
|
||||||
;; Check service logs for errors
|
|
||||||
(define (check-service-logs machine-name service)
|
|
||||||
"Check recent service logs for errors"
|
|
||||||
(call-with-values (((success output)
|
|
||||||
(run-remote-command machine-name
|
|
||||||
(format #f "journalctl -u ~a --since='10 minutes ago' --priority=err --no-pager | wc -l" service))))
|
|
||||||
(if success
|
|
||||||
(let ((error-count (string->number (string-trim-right output))))
|
|
||||||
`((recent-errors . ,error-count)
|
|
||||||
(status . ,(if (< error-count 5) 'good 'concerning))))
|
|
||||||
`((recent-errors . unknown)
|
|
||||||
(status . error)
|
|
||||||
(reason . "log-check-failed")))))
|
|
||||||
|
|
||||||
;; Display service monitoring details
|
|
||||||
(define (display-service-details machine-name service results)
|
|
||||||
"Display detailed service monitoring information"
|
|
||||||
(format #t " 🔧 ~a@~a:~%" service machine-name)
|
|
||||||
|
|
||||||
(for-each
|
|
||||||
(lambda (check-result)
|
|
||||||
(let ((check-name (car check-result))
|
|
||||||
(check-data (cdr check-result)))
|
|
||||||
(match check-name
|
|
||||||
("status"
|
|
||||||
(let ((active (assoc-ref check-data 'active))
|
|
||||||
(status (assoc-ref check-data 'status)))
|
|
||||||
(format #t " Status: ~a ~a~%"
|
|
||||||
(if active "✅" "❌")
|
|
||||||
status)))
|
|
||||||
|
|
||||||
("health"
|
|
||||||
(let ((healthy (assoc-ref check-data 'healthy)))
|
|
||||||
(format #t " Health: ~a ~a~%"
|
|
||||||
(cond ((eq? healthy #t) "✅")
|
|
||||||
((eq? healthy #f) "❌")
|
|
||||||
(else "❓"))
|
|
||||||
healthy)))
|
|
||||||
|
|
||||||
("logs"
|
|
||||||
(let ((errors (assoc-ref check-data 'recent-errors))
|
|
||||||
(status (assoc-ref check-data 'status)))
|
|
||||||
(format #t " Logs: ~a (~a recent errors)~%"
|
|
||||||
(cond ((eq? status 'good) "✅")
|
|
||||||
((eq? status 'concerning) "⚠️")
|
|
||||||
(else "❓"))
|
|
||||||
errors)))
|
|
||||||
|
|
||||||
(_ (format #t " ~a: ~a~%" check-name check-data)))))
|
|
||||||
results))
|
|
||||||
|
|
||||||
;; Display monitoring summary
|
|
||||||
(define (display-monitoring-summary results)
|
|
||||||
"Display a summary of monitoring results"
|
|
||||||
(newline)
|
|
||||||
(log-info "Infrastructure Monitoring Summary:")
|
|
||||||
(newline)
|
|
||||||
|
|
||||||
(for-each
|
|
||||||
(lambda (machine-result)
|
|
||||||
(let ((machine-name (assoc-ref machine-result 'machine))
|
|
||||||
(machine-status (assoc-ref machine-result 'status))
|
|
||||||
(services (assoc-ref machine-result 'services)))
|
|
||||||
|
|
||||||
(format #t "━━━ ~a (~a) ━━━~%" machine-name machine-status)
|
|
||||||
|
|
||||||
(if (eq? machine-status 'offline)
|
|
||||||
(format #t " ❌ Machine offline~%")
|
|
||||||
(if (null? services)
|
|
||||||
(format #t " ℹ️ No services configured~%")
|
|
||||||
(for-each
|
|
||||||
(lambda (service-result)
|
|
||||||
(let ((service-name (assoc-ref service-result 'service))
|
|
||||||
(checks (assoc-ref service-result 'checks)))
|
|
||||||
(let ((status-check (assoc-ref checks "status"))
|
|
||||||
(health-check (assoc-ref checks "health")))
|
|
||||||
(let ((is-active (and status-check
|
|
||||||
(assoc-ref status-check 'active)))
|
|
||||||
(is-healthy (and health-check
|
|
||||||
(eq? (assoc-ref health-check 'healthy) #t))))
|
|
||||||
(format #t " ~a ~a~%"
|
|
||||||
service-name
|
|
||||||
(cond ((and is-active is-healthy) "✅")
|
|
||||||
(is-active "⚠️")
|
|
||||||
(else "❌")))))))
|
|
||||||
services)))
|
|
||||||
(newline)))
|
|
||||||
results))
|
|
||||||
|
|
||||||
;; Start continuous monitoring (placeholder)
|
|
||||||
(define (start-monitoring options)
|
|
||||||
"Start continuous monitoring daemon"
|
|
||||||
(log-warn "Continuous monitoring not yet implemented")
|
|
||||||
(log-info "For now, use: lab monitor [service]")
|
|
||||||
#f)
|
|
||||||
|
|
||||||
;; Stop continuous monitoring (placeholder)
|
|
||||||
(define (stop-monitoring options)
|
|
||||||
"Stop continuous monitoring daemon"
|
|
||||||
(log-warn "Continuous monitoring not yet implemented")
|
|
||||||
#f)
|
|
||||||
|
|
||||||
;; Get monitoring status (placeholder)
|
|
||||||
(define (get-monitoring-status options)
|
|
||||||
"Get status of monitoring daemon"
|
|
||||||
(log-info "Monitoring Status: Manual mode")
|
|
||||||
(log-info "Use 'lab monitor' for on-demand monitoring")
|
|
||||||
#t)
|
|
||||||
|
|
||||||
;; Collect metrics for analysis
|
|
||||||
(define (collect-metrics machine-name . time-range)
|
|
||||||
"Collect performance and health metrics"
|
|
||||||
(let ((range (if (null? time-range) "1h" (car time-range))))
|
|
||||||
(log-debug "Collecting metrics for ~a (range: ~a)" machine-name range)
|
|
||||||
|
|
||||||
(let ((metrics (get-machine-metrics machine-name range)))
|
|
||||||
(log-success "Metrics collected for ~a" machine-name)
|
|
||||||
metrics)))
|
|
||||||
|
|
||||||
;; Generate monitoring report
|
|
||||||
(define (generate-monitoring-report . machines)
|
|
||||||
"Generate a comprehensive monitoring report"
|
|
||||||
(let ((target-machines (if (null? machines)
|
|
||||||
(get-all-machines)
|
|
||||||
machines)))
|
|
||||||
|
|
||||||
(log-info "Generating monitoring report for ~a machines..."
|
|
||||||
(length target-machines))
|
|
||||||
|
|
||||||
(let ((report-data
|
|
||||||
(map (lambda (machine)
|
|
||||||
(let ((monitoring-result (monitor-machine-services machine #t))
|
|
||||||
(metrics (collect-metrics machine)))
|
|
||||||
`((machine . ,machine)
|
|
||||||
(monitoring . ,monitoring-result)
|
|
||||||
(metrics . ,metrics)
|
|
||||||
(timestamp . ,(current-date)))))
|
|
||||||
target-machines)))
|
|
||||||
|
|
||||||
(log-success "Monitoring report generated")
|
|
||||||
report-data)))
|
|
|
@ -1,48 +0,0 @@
|
||||||
# Lab Tool Testing
|
|
||||||
|
|
||||||
This directory contains all test files for the lab tool, organized using TDD principles.
|
|
||||||
|
|
||||||
## Test Categories
|
|
||||||
|
|
||||||
### Core Functionality Tests
|
|
||||||
- `test-functionality.scm` - Basic functionality verification
|
|
||||||
- `test-main.scm` - Main CLI interface tests
|
|
||||||
- `test-deployment.scm` - Deployment module tests
|
|
||||||
- `test-missing-functions.scm` - Missing function implementation tests
|
|
||||||
|
|
||||||
### Integration Tests
|
|
||||||
- `test-integration.scm` - End-to-end integration tests
|
|
||||||
- `test-modules-simple.scm` - Simple module loading tests
|
|
||||||
|
|
||||||
### Implementation Tests
|
|
||||||
- `test-implementation.scm` - Implementation-specific tests
|
|
||||||
- `test-modular.scm` - Modular architecture tests
|
|
||||||
|
|
||||||
### Validation Tests
|
|
||||||
- `test-final-validation.scm` - Final validation suite
|
|
||||||
- `final-verification.scm` - Complete functionality verification
|
|
||||||
- `tdd-summary.scm` - TDD completion summary
|
|
||||||
|
|
||||||
## Running Tests
|
|
||||||
|
|
||||||
To avoid compilation issues with Guile, run tests with:
|
|
||||||
|
|
||||||
```bash
|
|
||||||
GUILE_AUTO_COMPILE=0 guile <test-file>
|
|
||||||
```
|
|
||||||
|
|
||||||
## Test Results Summary
|
|
||||||
|
|
||||||
✅ All core functionality working:
|
|
||||||
- CLI interface (help, status, machines, deploy, health)
|
|
||||||
- Deployment to actual machines
|
|
||||||
- Infrastructure monitoring
|
|
||||||
- Error handling
|
|
||||||
- Modular architecture
|
|
||||||
|
|
||||||
## K.I.S.S Principles Applied
|
|
||||||
|
|
||||||
- One test per functionality
|
|
||||||
- Simple test framework
|
|
||||||
- Clear test descriptions
|
|
||||||
- Fast feedback loops
|
|
|
@ -1,45 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; Final verification test - avoiding compilation issues
|
|
||||||
;; K.I.S.S approach: Test core functionality directly
|
|
||||||
|
|
||||||
(add-to-load-path ".")
|
|
||||||
|
|
||||||
(use-modules (ice-9 format)
|
|
||||||
(lab core)
|
|
||||||
(lab machines)
|
|
||||||
(lab deployment)
|
|
||||||
(utils logging)
|
|
||||||
(utils config))
|
|
||||||
|
|
||||||
(format #t "🧪 FINAL VERIFICATION TEST\n")
|
|
||||||
(format #t "==========================\n\n")
|
|
||||||
|
|
||||||
;; Test 1: Core modules load without errors
|
|
||||||
(format #t "✅ All core modules loaded successfully\n")
|
|
||||||
|
|
||||||
;; Test 2: Basic machine discovery
|
|
||||||
(let ((machines (list-machines)))
|
|
||||||
(format #t "✅ Found ~a machines: ~a\n" (length machines) machines))
|
|
||||||
|
|
||||||
;; Test 3: Infrastructure status
|
|
||||||
(let ((status (get-infrastructure-status)))
|
|
||||||
(format #t "✅ Infrastructure status check: ~a machines\n" (length status)))
|
|
||||||
|
|
||||||
;; Test 4: Config access
|
|
||||||
(let ((config (get-current-config)))
|
|
||||||
(format #t "✅ Config loaded with homelab-root: ~a\n" (get-config-value '(homelab-root))))
|
|
||||||
|
|
||||||
;; Test 5: Option handling
|
|
||||||
(let ((test-options '((dry-run . #t) (mode . "test"))))
|
|
||||||
(format #t "✅ Option handling: dry-run=~a, mode=~a\n"
|
|
||||||
(option-ref test-options 'dry-run #f)
|
|
||||||
(option-ref test-options 'mode "boot")))
|
|
||||||
|
|
||||||
;; Test 6: Color functionality
|
|
||||||
(format #t "✅ Color test: ~ablue text~a\n"
|
|
||||||
(get-color 'blue) (get-color 'reset))
|
|
||||||
|
|
||||||
(format #t "\n🎉 ALL CORE FUNCTIONALITY VERIFIED!\n")
|
|
||||||
(format #t "Lab tool is ready for production use.\n")
|
|
|
@ -1,36 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; Final summary of lab tool status
|
|
||||||
|
|
||||||
(add-to-load-path ".")
|
|
||||||
|
|
||||||
(use-modules (ice-9 format))
|
|
||||||
|
|
||||||
(format #t "🧪 LAB TOOL TDD COMPLETION SUMMARY\n")
|
|
||||||
(format #t "===================================\n\n")
|
|
||||||
|
|
||||||
(format #t "✅ COMPLETED TASKS:\n")
|
|
||||||
(format #t " 1. Fixed syntax errors in deployment.scm\n")
|
|
||||||
(format #t " 2. Fixed missing exports in utils/logging.scm\n")
|
|
||||||
(format #t " 3. Fixed error handling in main.scm\n")
|
|
||||||
(format #t " 4. All modules loading correctly\n")
|
|
||||||
(format #t " 5. All core commands working:\n")
|
|
||||||
(format #t " - help, status, machines, health\n")
|
|
||||||
(format #t " - deploy, test-modules\n")
|
|
||||||
(format #t " - Error handling for invalid commands\n\n")
|
|
||||||
|
|
||||||
(format #t "🚀 FUNCTIONALITY VERIFIED:\n")
|
|
||||||
(format #t " - Deployment to machines working\n")
|
|
||||||
(format #t " - Infrastructure status monitoring\n")
|
|
||||||
(format #t " - Machine health checking\n")
|
|
||||||
(format #t " - Modular architecture functional\n")
|
|
||||||
(format #t " - K.I.S.S principles followed\n\n")
|
|
||||||
|
|
||||||
(format #t "📋 NEXT STEPS (from TODO.md):\n")
|
|
||||||
(format #t " - Complete MCP server implementation\n")
|
|
||||||
(format #t " - Add discovery and health check enhancements\n")
|
|
||||||
(format #t " - Machine management improvements\n\n")
|
|
||||||
|
|
||||||
(format #t "🎉 TDD CYCLE COMPLETE!\n")
|
|
||||||
(format #t "Lab tool is now fully functional for core operations.\n")
|
|
|
@ -1,67 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; TDD Test for Deployment Functionality
|
|
||||||
;; Following K.I.S.S principles - test one thing at a time
|
|
||||||
|
|
||||||
(add-to-load-path ".")
|
|
||||||
|
|
||||||
(use-modules (ice-9 format)
|
|
||||||
(utils logging))
|
|
||||||
|
|
||||||
;; Simple test framework if srfi-64 not available
|
|
||||||
(define test-count 0)
|
|
||||||
(define passed-count 0)
|
|
||||||
|
|
||||||
(define (simple-test name thunk)
|
|
||||||
"Simple test runner"
|
|
||||||
(set! test-count (+ test-count 1))
|
|
||||||
(format #t "Test ~a: ~a..." test-count name)
|
|
||||||
(let ((result (catch #t thunk
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
(if result
|
|
||||||
(begin
|
|
||||||
(set! passed-count (+ passed-count 1))
|
|
||||||
(format #t " ✅ PASS\n"))
|
|
||||||
(format #t " ❌ FAIL\n"))))
|
|
||||||
|
|
||||||
(define (test-summary)
|
|
||||||
"Print test summary"
|
|
||||||
(format #t "\n=== Test Summary ===\n")
|
|
||||||
(format #t "Passed: ~a/~a\n" passed-count test-count)
|
|
||||||
(if (= passed-count test-count)
|
|
||||||
(format #t "🎉 All tests passed!\n")
|
|
||||||
(format #t "❌ Some tests failed\n")))
|
|
||||||
|
|
||||||
;; Test 1: Can we load deployment module without syntax errors?
|
|
||||||
(simple-test "Load deployment module"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (lab deployment))
|
|
||||||
#t)
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
;; Test 2: Can we call option-ref function?
|
|
||||||
(simple-test "option-ref function exists"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (lab deployment))
|
|
||||||
(and (defined? 'option-ref)
|
|
||||||
(procedure? option-ref)))
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
;; Test 3: Basic option-ref functionality
|
|
||||||
(simple-test "option-ref basic functionality"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (lab deployment))
|
|
||||||
(let ((options '((dry-run . #t) (mode . "test"))))
|
|
||||||
(and (equal? (option-ref options 'dry-run #f) #t)
|
|
||||||
(equal? (option-ref options 'mode "boot") "test")
|
|
||||||
(equal? (option-ref options 'missing "default") "default"))))
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
(test-summary)
|
|
|
@ -1,77 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; TDD Final Validation Test for Lab Tool
|
|
||||||
;; Following K.I.S.S principles - validate all working functionality
|
|
||||||
|
|
||||||
(add-to-load-path ".")
|
|
||||||
|
|
||||||
(use-modules (ice-9 format))
|
|
||||||
|
|
||||||
(define (run-test name command)
|
|
||||||
"Run a test command and return success status"
|
|
||||||
(format #t "Testing ~a: " name)
|
|
||||||
(let ((result (system (string-append command " >/dev/null 2>&1"))))
|
|
||||||
(if (= result 0)
|
|
||||||
(begin
|
|
||||||
(format #t "✅ PASS\n")
|
|
||||||
#t)
|
|
||||||
(begin
|
|
||||||
(format #t "❌ FAIL\n")
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
(define (main)
|
|
||||||
(format #t "🧪 LAB TOOL FINAL VALIDATION\n")
|
|
||||||
(format #t "=============================\n\n")
|
|
||||||
|
|
||||||
(let ((tests-passed 0)
|
|
||||||
(tests-total 0))
|
|
||||||
|
|
||||||
;; Core command tests
|
|
||||||
(when (run-test "help command" "./main.scm help")
|
|
||||||
(set! tests-passed (+ tests-passed 1)))
|
|
||||||
(set! tests-total (+ tests-total 1))
|
|
||||||
|
|
||||||
(when (run-test "status command" "./main.scm status")
|
|
||||||
(set! tests-passed (+ tests-passed 1)))
|
|
||||||
(set! tests-total (+ tests-total 1))
|
|
||||||
|
|
||||||
(when (run-test "machines command" "./main.scm machines")
|
|
||||||
(set! tests-passed (+ tests-passed 1)))
|
|
||||||
(set! tests-total (+ tests-total 1))
|
|
||||||
|
|
||||||
(when (run-test "health command" "./main.scm health")
|
|
||||||
(set! tests-passed (+ tests-passed 1)))
|
|
||||||
(set! tests-total (+ tests-total 1))
|
|
||||||
|
|
||||||
(when (run-test "test-modules command" "./main.scm test-modules")
|
|
||||||
(set! tests-passed (+ tests-passed 1)))
|
|
||||||
(set! tests-total (+ tests-total 1))
|
|
||||||
|
|
||||||
;; Error handling tests
|
|
||||||
(format #t "Testing error handling: ")
|
|
||||||
(let ((result (system "./main.scm invalid-command >/dev/null 2>&1")))
|
|
||||||
(if (not (= result 0))
|
|
||||||
(begin
|
|
||||||
(format #t "✅ PASS\n")
|
|
||||||
(set! tests-passed (+ tests-passed 1)))
|
|
||||||
(format #t "❌ FAIL\n")))
|
|
||||||
(set! tests-total (+ tests-total 1))
|
|
||||||
|
|
||||||
;; Summary
|
|
||||||
(format #t "\n=== FINAL RESULTS ===\n")
|
|
||||||
(format #t "Tests passed: ~a/~a\n" tests-passed tests-total)
|
|
||||||
|
|
||||||
(if (= tests-passed tests-total)
|
|
||||||
(begin
|
|
||||||
(format #t "🎉 ALL TESTS PASSED!\n")
|
|
||||||
(format #t "\n✅ Lab tool is fully functional:\n")
|
|
||||||
(format #t " - Core commands working\n")
|
|
||||||
(format #t " - Module system working\n")
|
|
||||||
(format #t " - Deployment working\n")
|
|
||||||
(format #t " - Status monitoring working\n")
|
|
||||||
(format #t " - Error handling working\n")
|
|
||||||
(format #t "\n🚀 Ready for production use!\n"))
|
|
||||||
(format #t "❌ Some tests failed - needs investigation\n"))))
|
|
||||||
|
|
||||||
(main)
|
|
|
@ -1,24 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; Simple functionality test
|
|
||||||
|
|
||||||
(add-to-load-path ".")
|
|
||||||
|
|
||||||
(use-modules (ice-9 format)
|
|
||||||
(lab core)
|
|
||||||
(lab machines)
|
|
||||||
(utils logging))
|
|
||||||
|
|
||||||
(format #t "🧪 LAB TOOL FUNCTIONALITY TEST\n")
|
|
||||||
(format #t "===============================\n\n")
|
|
||||||
|
|
||||||
;; Test basic functionality
|
|
||||||
(format #t "Testing core functionality:\n")
|
|
||||||
(let ((machines (list-machines)))
|
|
||||||
(format #t "✅ Found ~a machines: ~a\n" (length machines) machines))
|
|
||||||
|
|
||||||
(let ((status (get-infrastructure-status)))
|
|
||||||
(format #t "✅ Infrastructure status: ~a machines checked\n" (length status)))
|
|
||||||
|
|
||||||
(format #t "\n🎉 Basic functionality working!\n")
|
|
|
@ -1,72 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; Comprehensive test for lab tool implementation
|
|
||||||
|
|
||||||
(add-to-load-path ".")
|
|
||||||
|
|
||||||
(use-modules (ice-9 format))
|
|
||||||
|
|
||||||
;; Test results tracking
|
|
||||||
(define test-results '())
|
|
||||||
(define failed-tests '())
|
|
||||||
|
|
||||||
(define (test-module module-name)
|
|
||||||
"Test if a module loads successfully"
|
|
||||||
(format #t "Testing ~a... " module-name)
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(let ((module-parts (map string->symbol (string-split module-name #\space))))
|
|
||||||
(resolve-module module-parts)
|
|
||||||
(format #t "✅\n")
|
|
||||||
#t))
|
|
||||||
(lambda (key . args)
|
|
||||||
(format #t "❌ (~a)\n" key)
|
|
||||||
(set! failed-tests (cons module-name failed-tests))
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(define (main)
|
|
||||||
(format #t "🧪 LAB TOOL IMPLEMENTATION TEST\n")
|
|
||||||
(format #t "===============================\n\n")
|
|
||||||
|
|
||||||
;; Test utils modules
|
|
||||||
(format #t "Utils Modules:\n")
|
|
||||||
(test-module "utils logging")
|
|
||||||
(test-module "utils config")
|
|
||||||
(test-module "utils ssh")
|
|
||||||
(test-module "utils json")
|
|
||||||
|
|
||||||
;; Test lab modules
|
|
||||||
(format #t "\nLab Modules:\n")
|
|
||||||
(test-module "lab core")
|
|
||||||
(test-module "lab machines")
|
|
||||||
(test-module "lab deployment")
|
|
||||||
(test-module "lab monitoring")
|
|
||||||
|
|
||||||
;; Test MCP modules
|
|
||||||
(format #t "\nMCP Modules:\n")
|
|
||||||
(test-module "mcp server")
|
|
||||||
|
|
||||||
;; Test functionality
|
|
||||||
(format #t "\nFunctionality Tests:\n")
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (lab core) (lab machines))
|
|
||||||
(let ((machines (list-machines))
|
|
||||||
(status (get-infrastructure-status)))
|
|
||||||
(format #t "Machines: ~a ✅\n" (length machines))
|
|
||||||
(format #t "Status check: ~a machines ✅\n" (length status))))
|
|
||||||
(lambda (key . args)
|
|
||||||
(format #t "Functionality test failed: ~a ❌\n" key)))
|
|
||||||
|
|
||||||
;; Summary
|
|
||||||
(format #t "\n=== SUMMARY ===\n")
|
|
||||||
(if (null? failed-tests)
|
|
||||||
(format #t "🎉 All tests passed!\n")
|
|
||||||
(begin
|
|
||||||
(format #t "❌ Failed: ~a\n" failed-tests)
|
|
||||||
(format #t "📝 Need to fix these modules\n")))
|
|
||||||
|
|
||||||
(format #t "\nTest complete.\n"))
|
|
||||||
|
|
||||||
(main)
|
|
|
@ -1,121 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; TDD Integration Test for Lab Tool
|
|
||||||
;; Following K.I.S.S principles - test complete functionality
|
|
||||||
|
|
||||||
(add-to-load-path ".")
|
|
||||||
|
|
||||||
(use-modules (ice-9 format)
|
|
||||||
(utils logging))
|
|
||||||
|
|
||||||
(format #t "🧪 LAB TOOL INTEGRATION TEST\n")
|
|
||||||
(format #t "=============================\n\n")
|
|
||||||
|
|
||||||
;; Simple test framework
|
|
||||||
(define test-count 0)
|
|
||||||
(define passed-count 0)
|
|
||||||
|
|
||||||
(define (simple-test name thunk)
|
|
||||||
"Simple test runner"
|
|
||||||
(set! test-count (+ test-count 1))
|
|
||||||
(format #t "Test ~a: ~a..." test-count name)
|
|
||||||
(let ((result (catch #t thunk
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
(if result
|
|
||||||
(begin
|
|
||||||
(set! passed-count (+ passed-count 1))
|
|
||||||
(format #t " ✅ PASS\n"))
|
|
||||||
(format #t " ❌ FAIL\n"))))
|
|
||||||
|
|
||||||
(define (test-summary)
|
|
||||||
"Print test summary"
|
|
||||||
(format #t "\n=== Test Summary ===\n")
|
|
||||||
(format #t "Passed: ~a/~a\n" passed-count test-count)
|
|
||||||
(if (= passed-count test-count)
|
|
||||||
(format #t "🎉 All tests passed!\n")
|
|
||||||
(format #t "❌ Some tests failed\n")))
|
|
||||||
|
|
||||||
;; Core functionality tests
|
|
||||||
(simple-test "Help command works"
|
|
||||||
(lambda () (= 0 (system "./main.scm help >/dev/null 2>&1"))))
|
|
||||||
|
|
||||||
(simple-test "Status command works"
|
|
||||||
(lambda () (= 0 (system "./main.scm status >/dev/null 2>&1"))))
|
|
||||||
|
|
||||||
(simple-test "Machines command works"
|
|
||||||
(lambda () (= 0 (system "./main.scm machines >/dev/null 2>&1"))))
|
|
||||||
|
|
||||||
(simple-test "Test-modules command works"
|
|
||||||
(lambda () (= 0 (system "./main.scm test-modules >/dev/null 2>&1"))))
|
|
||||||
|
|
||||||
(simple-test "Invalid command returns error"
|
|
||||||
(lambda () (not (= 0 (system "./main.scm invalid >/dev/null 2>&1")))))
|
|
||||||
|
|
||||||
;; Module loading tests
|
|
||||||
(simple-test "Lab core module loads"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda () (use-modules (lab core)) #t)
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
(simple-test "Lab machines module loads"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda () (use-modules (lab machines)) #t)
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
(simple-test "Lab deployment module loads"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda () (use-modules (lab deployment)) #t)
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
;; Utility module tests
|
|
||||||
(simple-test "Utils logging module loads"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda () (use-modules (utils logging)) #t)
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
(simple-test "Utils config module loads"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda () (use-modules (utils config)) #t)
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
(simple-test "Utils ssh module loads"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda () (use-modules (utils ssh)) #t)
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
;; Function availability tests
|
|
||||||
(simple-test "Basic deployment functions available"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (lab deployment))
|
|
||||||
(and (defined? 'deploy-machine)
|
|
||||||
(defined? 'update-flake)
|
|
||||||
(defined? 'option-ref)))
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
(simple-test "Basic machine functions available"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (lab machines))
|
|
||||||
(and (defined? 'list-machines)
|
|
||||||
(defined? 'validate-machine-name)))
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
(simple-test "Basic core functions available"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (lab core))
|
|
||||||
(and (defined? 'get-infrastructure-status)))
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
(test-summary)
|
|
|
@ -1,59 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; TDD Test for Main.scm - Command functionality
|
|
||||||
;; Following K.I.S.S principles - test one thing at a time
|
|
||||||
|
|
||||||
(add-to-load-path ".")
|
|
||||||
|
|
||||||
(use-modules (ice-9 format)
|
|
||||||
(utils logging))
|
|
||||||
|
|
||||||
(format #t "🧪 MAIN.SCM FUNCTIONALITY TEST\n")
|
|
||||||
(format #t "==============================\n\n")
|
|
||||||
|
|
||||||
;; Simple test framework
|
|
||||||
(define test-count 0)
|
|
||||||
(define passed-count 0)
|
|
||||||
|
|
||||||
(define (simple-test name thunk)
|
|
||||||
"Simple test runner"
|
|
||||||
(set! test-count (+ test-count 1))
|
|
||||||
(format #t "Test ~a: ~a..." test-count name)
|
|
||||||
(let ((result (catch #t thunk
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
(if result
|
|
||||||
(begin
|
|
||||||
(set! passed-count (+ passed-count 1))
|
|
||||||
(format #t " ✅ PASS\n"))
|
|
||||||
(format #t " ❌ FAIL\n"))))
|
|
||||||
|
|
||||||
(define (test-summary)
|
|
||||||
"Print test summary"
|
|
||||||
(format #t "\n=== Test Summary ===\n")
|
|
||||||
(format #t "Passed: ~a/~a\n" passed-count test-count)
|
|
||||||
(if (= passed-count test-count)
|
|
||||||
(format #t "🎉 All tests passed!\n")
|
|
||||||
(format #t "❌ Some tests failed\n")))
|
|
||||||
|
|
||||||
;; Test 1: Can we run main.scm help command?
|
|
||||||
(simple-test "main.scm help command"
|
|
||||||
(lambda ()
|
|
||||||
(= 0 (system "./main.scm help >/dev/null 2>&1"))))
|
|
||||||
|
|
||||||
;; Test 2: Can we run main.scm status command?
|
|
||||||
(simple-test "main.scm status command"
|
|
||||||
(lambda ()
|
|
||||||
(= 0 (system "./main.scm status >/dev/null 2>&1"))))
|
|
||||||
|
|
||||||
;; Test 3: Can we run main.scm machines command?
|
|
||||||
(simple-test "main.scm machines command"
|
|
||||||
(lambda ()
|
|
||||||
(= 0 (system "./main.scm machines >/dev/null 2>&1"))))
|
|
||||||
|
|
||||||
;; Test 4: Test invalid command handling
|
|
||||||
(simple-test "main.scm invalid command handling"
|
|
||||||
(lambda ()
|
|
||||||
(not (= 0 (system "./main.scm invalid-command >/dev/null 2>&1")))))
|
|
||||||
|
|
||||||
(test-summary)
|
|
|
@ -1,73 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; TDD Test for Missing Functions
|
|
||||||
;; Following K.I.S.S principles - test one thing at a time
|
|
||||||
|
|
||||||
(add-to-load-path ".")
|
|
||||||
|
|
||||||
(use-modules (ice-9 format)
|
|
||||||
(utils logging))
|
|
||||||
|
|
||||||
(format #t "🧪 MISSING FUNCTIONS TEST\n")
|
|
||||||
(format #t "==========================\n\n")
|
|
||||||
|
|
||||||
;; Simple test framework
|
|
||||||
(define test-count 0)
|
|
||||||
(define passed-count 0)
|
|
||||||
|
|
||||||
(define (simple-test name thunk)
|
|
||||||
"Simple test runner"
|
|
||||||
(set! test-count (+ test-count 1))
|
|
||||||
(format #t "Test ~a: ~a..." test-count name)
|
|
||||||
(let ((result (catch #t thunk
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
(if result
|
|
||||||
(begin
|
|
||||||
(set! passed-count (+ passed-count 1))
|
|
||||||
(format #t " ✅ PASS\n"))
|
|
||||||
(format #t " ❌ FAIL\n"))))
|
|
||||||
|
|
||||||
(define (test-summary)
|
|
||||||
"Print test summary"
|
|
||||||
(format #t "\n=== Test Summary ===\n")
|
|
||||||
(format #t "Passed: ~a/~a\n" passed-count test-count)
|
|
||||||
(if (= passed-count test-count)
|
|
||||||
(format #t "🎉 All tests passed!\n")
|
|
||||||
(format #t "❌ Some tests failed\n")))
|
|
||||||
|
|
||||||
;; Test 1: Test get-color function exists (should be in utils/logging)
|
|
||||||
(simple-test "get-color function exists"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (utils logging))
|
|
||||||
(and (defined? 'get-color)
|
|
||||||
(procedure? get-color)))
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
;; Test 2: Test get-all-machines-pure function exists (should be in utils/config)
|
|
||||||
(simple-test "get-all-machines-pure function exists"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (utils config accessor))
|
|
||||||
(and (defined? 'get-all-machines-pure)
|
|
||||||
(procedure? get-all-machines-pure)))
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
;; Test 3: Test get-color basic functionality
|
|
||||||
(simple-test "get-color basic functionality"
|
|
||||||
(lambda ()
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (utils logging))
|
|
||||||
(let ((blue (get-color 'blue))
|
|
||||||
(reset (get-color 'reset)))
|
|
||||||
(and (string? blue)
|
|
||||||
(string? reset)
|
|
||||||
(> (string-length blue) 0)
|
|
||||||
(> (string-length reset) 0))))
|
|
||||||
(lambda (key . args) #f))))
|
|
||||||
|
|
||||||
(test-summary)
|
|
|
@ -1,43 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; Test script for modular refactoring
|
|
||||||
|
|
||||||
(add-to-load-path "lab")
|
|
||||||
|
|
||||||
(use-modules (ice-9 format))
|
|
||||||
|
|
||||||
;; Test logging format module
|
|
||||||
(display "Testing logging format module...\n")
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (utils logging format))
|
|
||||||
(display "✅ Logging format module loaded\n")
|
|
||||||
(let ((blue-color (get-color 'blue)))
|
|
||||||
(format #t "Blue color code: ~a\n" blue-color)))
|
|
||||||
(lambda (key . args)
|
|
||||||
(format #t "❌ Failed to load logging format: ~a ~a\n" key args)))
|
|
||||||
|
|
||||||
;; Test config defaults module
|
|
||||||
(display "\nTesting config defaults module...\n")
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (utils config defaults))
|
|
||||||
(display "✅ Config defaults module loaded\n")
|
|
||||||
(let ((config default-config))
|
|
||||||
(format #t "Default homelab root: ~a\n" (assoc-ref config 'homelab-root))))
|
|
||||||
(lambda (key . args)
|
|
||||||
(format #t "❌ Failed to load config defaults: ~a ~a\n" key args)))
|
|
||||||
|
|
||||||
;; Test JSON parse module
|
|
||||||
(display "\nTesting JSON parse module...\n")
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (utils json parse))
|
|
||||||
(display "✅ JSON parse module loaded\n")
|
|
||||||
(let ((result (parse-json-pure "{\"test\": true}")))
|
|
||||||
(format #t "JSON parse test: ~a\n" result)))
|
|
||||||
(lambda (key . args)
|
|
||||||
(format #t "❌ Failed to load JSON parse: ~a ~a\n" key args)))
|
|
||||||
|
|
||||||
(display "\n🎉 Modular refactoring test complete!\n")
|
|
|
@ -1,63 +0,0 @@
|
||||||
#!/usr/bin/env guile
|
|
||||||
!#
|
|
||||||
|
|
||||||
;; TDD Simple Module Test for Lab Tool
|
|
||||||
;; Following K.I.S.S principles - test module loading only
|
|
||||||
|
|
||||||
(add-to-load-path ".")
|
|
||||||
|
|
||||||
(use-modules (ice-9 format))
|
|
||||||
|
|
||||||
(define (main)
|
|
||||||
(format #t "🧪 LAB TOOL MODULE LOADING TEST\n")
|
|
||||||
(format #t "=================================\n\n")
|
|
||||||
|
|
||||||
;; Test module loading
|
|
||||||
(format #t "Testing module loading...\n")
|
|
||||||
|
|
||||||
;; Test 1: Lab modules
|
|
||||||
(format #t "1. Lab core module: ")
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (lab core))
|
|
||||||
(format #t "✅ LOADED\n"))
|
|
||||||
(lambda (key . args)
|
|
||||||
(format #t "❌ FAILED: ~a\n" key)))
|
|
||||||
|
|
||||||
(format #t "2. Lab machines module: ")
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (lab machines))
|
|
||||||
(format #t "✅ LOADED\n"))
|
|
||||||
(lambda (key . args)
|
|
||||||
(format #t "❌ FAILED: ~a\n" key)))
|
|
||||||
|
|
||||||
(format #t "3. Lab deployment module: ")
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (lab deployment))
|
|
||||||
(format #t "✅ LOADED\n"))
|
|
||||||
(lambda (key . args)
|
|
||||||
(format #t "❌ FAILED: ~a\n" key)))
|
|
||||||
|
|
||||||
;; Test 2: Utils modules
|
|
||||||
(format #t "4. Utils logging module: ")
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (utils logging))
|
|
||||||
(format #t "✅ LOADED\n"))
|
|
||||||
(lambda (key . args)
|
|
||||||
(format #t "❌ FAILED: ~a\n" key)))
|
|
||||||
|
|
||||||
(format #t "5. Utils config module: ")
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(use-modules (utils config))
|
|
||||||
(format #t "✅ LOADED\n"))
|
|
||||||
(lambda (key . args)
|
|
||||||
(format #t "❌ FAILED: ~a\n" key)))
|
|
||||||
|
|
||||||
(format #t "\n🎉 Module loading test complete!\n"))
|
|
||||||
|
|
||||||
;; Run the main function
|
|
||||||
(main)
|
|
|
@ -1,43 +0,0 @@
|
||||||
;; utils/config.scm - Configuration management facade
|
|
||||||
|
|
||||||
(define-module (utils config)
|
|
||||||
#:use-module (utils config defaults)
|
|
||||||
#:use-module (utils config loader)
|
|
||||||
#:use-module (utils config accessor)
|
|
||||||
#:use-module (utils config state)
|
|
||||||
#:re-export (;; State management
|
|
||||||
get-current-config
|
|
||||||
set-current-config!
|
|
||||||
reload-config!
|
|
||||||
|
|
||||||
;; Stateful accessors (work with current config)
|
|
||||||
get-config-value
|
|
||||||
get-machine-config
|
|
||||||
get-all-machines
|
|
||||||
get-ssh-config
|
|
||||||
validate-machine-name
|
|
||||||
get-homelab-root
|
|
||||||
|
|
||||||
;; Pure accessors (require explicit config parameter)
|
|
||||||
get-config-value-pure
|
|
||||||
get-machine-config-pure
|
|
||||||
get-all-machines-pure
|
|
||||||
get-ssh-config-pure
|
|
||||||
validate-machine-name-pure
|
|
||||||
|
|
||||||
;; Loading functions
|
|
||||||
load-config
|
|
||||||
load-config-from-file
|
|
||||||
|
|
||||||
;; Default configuration
|
|
||||||
default-config))
|
|
||||||
|
|
||||||
;; This module acts as a facade for configuration management,
|
|
||||||
;; aggregating specialized modules that follow single responsibility:
|
|
||||||
;; - defaults: Pure data definitions
|
|
||||||
;; - loader: File I/O operations
|
|
||||||
;; - accessor: Pure configuration value access
|
|
||||||
;; - state: Mutable state management
|
|
||||||
;;
|
|
||||||
;; Both pure and impure functions are available, allowing callers
|
|
||||||
;; to choose the appropriate level of functional purity.
|
|
|
@ -22,26 +22,31 @@
|
||||||
(machines . ((congenital-optimist
|
(machines . ((congenital-optimist
|
||||||
(type . local)
|
(type . local)
|
||||||
(hostname . "localhost")
|
(hostname . "localhost")
|
||||||
|
(ssh-user . "sma")
|
||||||
(services . (workstation development)))
|
(services . (workstation development)))
|
||||||
(sleeper-service
|
(sleeper-service
|
||||||
(type . remote)
|
(type . remote)
|
||||||
(hostname . "sleeper-service.tail807ea.ts.net")
|
(hostname . "sleeper-service.tail807ea.ts.net")
|
||||||
(ssh-alias . "admin-sleeper")
|
(ssh-alias . "sleeper-service.tail807ea.ts.net")
|
||||||
|
(ssh-user . "sma")
|
||||||
(services . (nfs zfs storage)))
|
(services . (nfs zfs storage)))
|
||||||
(grey-area
|
(grey-area
|
||||||
(type . remote)
|
(type . remote)
|
||||||
(hostname . "grey-area.tail807ea.ts.net")
|
(hostname . "grey-area.tail807ea.ts.net")
|
||||||
(ssh-alias . "admin-grey")
|
(ssh-alias . "grey-area.tail807ea.ts.net")
|
||||||
|
(ssh-user . "sma")
|
||||||
(services . (ollama forgejo git)))
|
(services . (ollama forgejo git)))
|
||||||
(reverse-proxy
|
(reverse-proxy
|
||||||
(type . remote)
|
(type . remote)
|
||||||
(hostname . "reverse-proxy.tail807ea.ts.net")
|
(hostname . "reverse-proxy.tail807ea.ts.net")
|
||||||
(ssh-alias . "admin-reverse")
|
(ssh-alias . "reverse-proxy.tail807ea.ts.net")
|
||||||
|
(ssh-user . "sma")
|
||||||
(services . (nginx proxy ssl)))
|
(services . (nginx proxy ssl)))
|
||||||
(little-rascal
|
(little-rascal
|
||||||
(type . remote)
|
(type . remote)
|
||||||
(hostname . "little-rascal.tail807ea.ts.net")
|
(hostname . "little-rascal.tail807ea.ts.net")
|
||||||
(ssh-alias . "little-rascal")
|
(ssh-alias . "little-rascal.tail807ea.ts.net")
|
||||||
|
(ssh-user . "sma")
|
||||||
(services . (development niri desktop ai-tools)))))
|
(services . (development niri desktop ai-tools)))))
|
||||||
(deployment . ((default-mode . "boot")
|
(deployment . ((default-mode . "boot")
|
||||||
(timeout . 300)
|
(timeout . 300)
|
||||||
|
@ -124,10 +129,12 @@
|
||||||
(if machine-config
|
(if machine-config
|
||||||
(let ((type (assoc-ref machine-config 'type))
|
(let ((type (assoc-ref machine-config 'type))
|
||||||
(hostname (assoc-ref machine-config 'hostname))
|
(hostname (assoc-ref machine-config 'hostname))
|
||||||
(ssh-alias (assoc-ref machine-config 'ssh-alias)))
|
(ssh-alias (assoc-ref machine-config 'ssh-alias))
|
||||||
|
(ssh-user (assoc-ref machine-config 'ssh-user)))
|
||||||
`((type . ,type)
|
`((type . ,type)
|
||||||
(hostname . ,hostname)
|
(hostname . ,hostname)
|
||||||
(ssh-alias . ,ssh-alias)
|
(ssh-alias . ,ssh-alias)
|
||||||
|
(ssh-user . ,ssh-user)
|
||||||
(is-local . ,(eq? type 'local))))
|
(is-local . ,(eq? type 'local))))
|
||||||
#f)))
|
#f)))
|
||||||
|
|
||||||
|
|
|
@ -1,74 +0,0 @@
|
||||||
;; utils/config/accessor.scm - Configuration value access (pure functions)
|
|
||||||
|
|
||||||
(define-module (utils config accessor)
|
|
||||||
#:use-module (srfi srfi-1)
|
|
||||||
#:export (get-config-value-pure
|
|
||||||
get-machine-config-pure
|
|
||||||
get-all-machines-pure
|
|
||||||
get-ssh-config-pure
|
|
||||||
validate-machine-name-pure))
|
|
||||||
|
|
||||||
;; Pure function: Get configuration value by path
|
|
||||||
;; Input: config alist, path list, optional default value
|
|
||||||
;; Output: configuration value or default
|
|
||||||
(define (get-config-value-pure config path . default)
|
|
||||||
"Pure function to get configuration value by path"
|
|
||||||
(let ((result (fold (lambda (key acc)
|
|
||||||
(if (and acc (list? acc))
|
|
||||||
(assoc-ref acc key)
|
|
||||||
#f))
|
|
||||||
config path)))
|
|
||||||
(if result
|
|
||||||
result
|
|
||||||
(if (null? default) #f (car default)))))
|
|
||||||
|
|
||||||
;; Pure function: Get machine configurations
|
|
||||||
;; Input: config alist
|
|
||||||
;; Output: machines alist
|
|
||||||
(define (get-machine-configs-pure config)
|
|
||||||
"Pure function to get machine configurations"
|
|
||||||
(get-config-value-pure config '(machines)))
|
|
||||||
|
|
||||||
;; Pure function: Get configuration for specific machine
|
|
||||||
;; Input: config alist, machine-name (string or symbol)
|
|
||||||
;; Output: machine configuration alist or #f
|
|
||||||
(define (get-machine-config-pure config machine-name)
|
|
||||||
"Pure function to get machine configuration"
|
|
||||||
(let ((machine-symbol (if (symbol? machine-name)
|
|
||||||
machine-name
|
|
||||||
(string->symbol machine-name)))
|
|
||||||
(machines (get-machine-configs-pure config)))
|
|
||||||
(assoc-ref machines machine-symbol)))
|
|
||||||
|
|
||||||
;; Pure function: Get list of all machine names
|
|
||||||
;; Input: config alist
|
|
||||||
;; Output: list of machine name strings
|
|
||||||
(define (get-all-machines-pure config)
|
|
||||||
"Pure function to get all machine names"
|
|
||||||
(map (lambda (machine-entry)
|
|
||||||
(symbol->string (car machine-entry)))
|
|
||||||
(get-machine-configs-pure config)))
|
|
||||||
|
|
||||||
;; Pure function: Validate machine name exists
|
|
||||||
;; Input: config alist, machine-name string
|
|
||||||
;; Output: #t if valid, #f otherwise
|
|
||||||
(define (validate-machine-name-pure config machine-name)
|
|
||||||
"Pure function to validate machine name"
|
|
||||||
(let ((machines (get-all-machines-pure config)))
|
|
||||||
(member machine-name machines)))
|
|
||||||
|
|
||||||
;; Pure function: Get SSH configuration for machine
|
|
||||||
;; Input: config alist, machine-name (string or symbol)
|
|
||||||
;; Output: SSH configuration alist or #f
|
|
||||||
(define (get-ssh-config-pure config machine-name)
|
|
||||||
"Pure function to get SSH configuration for machine"
|
|
||||||
(let ((machine-config (get-machine-config-pure 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)))
|
|
||||||
`((type . ,type)
|
|
||||||
(hostname . ,hostname)
|
|
||||||
(ssh-alias . ,ssh-alias)
|
|
||||||
(is-local . ,(eq? type 'local))))
|
|
||||||
#f)))
|
|
|
@ -1,35 +0,0 @@
|
||||||
;; utils/config/defaults.scm - Configuration defaults (pure data)
|
|
||||||
|
|
||||||
(define-module (utils config defaults)
|
|
||||||
#:export (default-config))
|
|
||||||
|
|
||||||
;; Pure data: Default configuration structure
|
|
||||||
(define default-config
|
|
||||||
`((homelab-root . "/home/geir/Home-lab")
|
|
||||||
(machines . ((congenital-optimist
|
|
||||||
(type . local)
|
|
||||||
(hostname . "localhost")
|
|
||||||
(services . (workstation development)))
|
|
||||||
(sleeper-service
|
|
||||||
(type . remote)
|
|
||||||
(hostname . "sleeper-service.tail807ea.ts.net")
|
|
||||||
(ssh-alias . "admin-sleeper")
|
|
||||||
(services . (nfs zfs storage)))
|
|
||||||
(grey-area
|
|
||||||
(type . remote)
|
|
||||||
(hostname . "grey-area.tail807ea.ts.net")
|
|
||||||
(ssh-alias . "admin-grey")
|
|
||||||
(services . (ollama forgejo git)))
|
|
||||||
(reverse-proxy
|
|
||||||
(type . remote)
|
|
||||||
(hostname . "reverse-proxy.tail807ea.ts.net")
|
|
||||||
(ssh-alias . "admin-reverse")
|
|
||||||
(services . (nginx proxy ssl)))))
|
|
||||||
(deployment . ((default-mode . "boot")
|
|
||||||
(timeout . 300)
|
|
||||||
(retry-count . 3)))
|
|
||||||
(monitoring . ((interval . 30)
|
|
||||||
(timeout . 10)))
|
|
||||||
(mcp . ((port . 3001)
|
|
||||||
(host . "localhost")
|
|
||||||
(log-level . "info")))))
|
|
|
@ -1,60 +0,0 @@
|
||||||
;; utils/config/loader.scm - Configuration loading (file I/O operations)
|
|
||||||
|
|
||||||
(define-module (utils config loader)
|
|
||||||
#:use-module (ice-9 textual-ports)
|
|
||||||
#:use-module (utils logging)
|
|
||||||
#:use-module (utils json)
|
|
||||||
#:use-module (utils config defaults)
|
|
||||||
#:export (load-config-from-file
|
|
||||||
load-config))
|
|
||||||
|
|
||||||
;; Pure function: Parse configuration from JSON string
|
|
||||||
;; Input: json-string
|
|
||||||
;; Output: parsed configuration alist or #f if invalid
|
|
||||||
(define (parse-config-json json-string)
|
|
||||||
"Pure function to parse configuration from JSON string"
|
|
||||||
(catch #t
|
|
||||||
(lambda () (json-string->scm-safe json-string))
|
|
||||||
(lambda (key . args) #f)))
|
|
||||||
|
|
||||||
;; Pure function: Validate configuration structure
|
|
||||||
;; Input: config alist
|
|
||||||
;; Output: #t if valid, #f otherwise
|
|
||||||
(define (validate-config config)
|
|
||||||
"Pure function to validate configuration structure"
|
|
||||||
(and (list? config)
|
|
||||||
(assoc-ref config 'homelab-root)
|
|
||||||
(assoc-ref config 'machines)))
|
|
||||||
|
|
||||||
;; Impure function: Load configuration from file
|
|
||||||
;; Input: file-path string
|
|
||||||
;; Output: configuration alist or default-config if file doesn't exist/invalid
|
|
||||||
(define (load-config-from-file file-path)
|
|
||||||
"Load configuration from file (with side effects: file I/O, logging)"
|
|
||||||
(if (file-exists? file-path)
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(log-debug "Loading configuration from ~a" file-path)
|
|
||||||
(let* ((json-data (call-with-input-file file-path get-string-all))
|
|
||||||
(parsed-config (parse-config-json json-data)))
|
|
||||||
(if (and parsed-config (validate-config parsed-config))
|
|
||||||
(begin
|
|
||||||
(log-info "Configuration loaded successfully")
|
|
||||||
parsed-config)
|
|
||||||
(begin
|
|
||||||
(log-warn "Invalid configuration file, using defaults")
|
|
||||||
default-config))))
|
|
||||||
(lambda (key . args)
|
|
||||||
(log-warn "Failed to load config file, using defaults: ~a" key)
|
|
||||||
default-config))
|
|
||||||
(begin
|
|
||||||
(log-debug "No config file found at ~a, using defaults" file-path)
|
|
||||||
default-config)))
|
|
||||||
|
|
||||||
;; Impure function: Load configuration with default path
|
|
||||||
(define (load-config . args)
|
|
||||||
"Load configuration with optional file path"
|
|
||||||
(let ((config-file (if (null? args)
|
|
||||||
(string-append (getenv "HOME") "/.config/homelab/config.json")
|
|
||||||
(car args))))
|
|
||||||
(load-config-from-file config-file)))
|
|
|
@ -1,69 +0,0 @@
|
||||||
;; utils/config/state.scm - Configuration state management
|
|
||||||
|
|
||||||
(define-module (utils config state)
|
|
||||||
#:use-module (utils config defaults)
|
|
||||||
#:use-module (utils config loader)
|
|
||||||
#:use-module (utils config accessor)
|
|
||||||
#:use-module (utils logging)
|
|
||||||
#:export (get-current-config
|
|
||||||
set-current-config!
|
|
||||||
reload-config!
|
|
||||||
get-config-value
|
|
||||||
get-machine-config
|
|
||||||
get-all-machines
|
|
||||||
get-ssh-config
|
|
||||||
validate-machine-name
|
|
||||||
get-homelab-root))
|
|
||||||
|
|
||||||
;; Mutable state: Current loaded configuration
|
|
||||||
(define current-config default-config)
|
|
||||||
|
|
||||||
;; Impure function: Get current configuration
|
|
||||||
(define (get-current-config)
|
|
||||||
"Get current loaded configuration"
|
|
||||||
current-config)
|
|
||||||
|
|
||||||
;; Impure function: Set current configuration
|
|
||||||
(define (set-current-config! config)
|
|
||||||
"Set current configuration (impure)"
|
|
||||||
(set! current-config config))
|
|
||||||
|
|
||||||
;; Impure function: Reload configuration from file
|
|
||||||
(define (reload-config! . args)
|
|
||||||
"Reload configuration from file"
|
|
||||||
(let ((new-config (apply load-config args)))
|
|
||||||
(set-current-config! new-config)
|
|
||||||
new-config))
|
|
||||||
|
|
||||||
;; Impure wrappers for pure accessor functions
|
|
||||||
(define (get-config-value path . default)
|
|
||||||
"Get configuration value from current config"
|
|
||||||
(apply get-config-value-pure current-config path default))
|
|
||||||
|
|
||||||
(define (get-machine-config machine-name)
|
|
||||||
"Get machine configuration from current config"
|
|
||||||
(get-machine-config-pure current-config machine-name))
|
|
||||||
|
|
||||||
(define (get-all-machines)
|
|
||||||
"Get all machine names from current config"
|
|
||||||
(get-all-machines-pure current-config))
|
|
||||||
|
|
||||||
(define (get-ssh-config machine-name)
|
|
||||||
"Get SSH configuration from current config"
|
|
||||||
(get-ssh-config-pure current-config machine-name))
|
|
||||||
|
|
||||||
(define (validate-machine-name machine-name)
|
|
||||||
"Validate machine name against current config"
|
|
||||||
(if (validate-machine-name-pure current-config machine-name)
|
|
||||||
#t
|
|
||||||
(begin
|
|
||||||
(log-error "Unknown machine: ~a" machine-name)
|
|
||||||
(log-error "Available machines: ~a" (string-join (get-all-machines) ", "))
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(define (get-homelab-root)
|
|
||||||
"Get home lab root directory from current config"
|
|
||||||
(get-config-value '(homelab-root) "/home/geir/Home-lab"))
|
|
||||||
|
|
||||||
;; Initialize configuration on module load
|
|
||||||
(reload-config!)
|
|
|
@ -1,48 +0,0 @@
|
||||||
;; utils/json.scm - JSON utilities facade
|
|
||||||
|
|
||||||
(define-module (utils json)
|
|
||||||
#:use-module (utils json parse)
|
|
||||||
#:use-module (utils json serialize)
|
|
||||||
#:use-module (utils json file-io)
|
|
||||||
#:use-module (utils json validation)
|
|
||||||
#:use-module (utils json manipulation)
|
|
||||||
#:use-module (utils json pretty-print)
|
|
||||||
#:re-export (;; Parsing
|
|
||||||
parse-json-pure
|
|
||||||
json-string->scm-safe
|
|
||||||
|
|
||||||
;; Serialization
|
|
||||||
scm->json-string-pure
|
|
||||||
scm->json-string
|
|
||||||
|
|
||||||
;; File I/O (both pure and impure versions)
|
|
||||||
read-json-file-pure
|
|
||||||
write-json-file-pure
|
|
||||||
read-json-file
|
|
||||||
write-json-file
|
|
||||||
|
|
||||||
;; Validation (pure functions)
|
|
||||||
validate-required-keys
|
|
||||||
validate-types
|
|
||||||
validate-json-schema
|
|
||||||
|
|
||||||
;; Manipulation (pure functions)
|
|
||||||
merge-json-objects
|
|
||||||
flatten-json-paths
|
|
||||||
json-path-ref
|
|
||||||
json-path-set
|
|
||||||
|
|
||||||
;; Pretty printing
|
|
||||||
json-pretty-print))
|
|
||||||
|
|
||||||
;; This module acts as a facade for JSON functionality,
|
|
||||||
;; aggregating specialized modules that follow single responsibility:
|
|
||||||
;; - parse: Pure JSON string parsing
|
|
||||||
;; - serialize: Pure scheme-to-JSON conversion
|
|
||||||
;; - file-io: File reading/writing with pure and impure versions
|
|
||||||
;; - validation: Pure schema validation functions
|
|
||||||
;; - manipulation: Pure object manipulation functions
|
|
||||||
;; - pretty-print: Output formatting
|
|
||||||
;;
|
|
||||||
;; All functions are designed to be composable and testable,
|
|
||||||
;; with pure versions available for functional programming patterns.
|
|
|
@ -1,57 +0,0 @@
|
||||||
;; utils/json/file-io.scm - JSON file I/O operations
|
|
||||||
|
|
||||||
(define-module (utils json file-io)
|
|
||||||
#:use-module (json)
|
|
||||||
#:use-module (ice-9 textual-ports)
|
|
||||||
#:use-module (utils logging)
|
|
||||||
#:export (read-json-file-pure
|
|
||||||
write-json-file-pure
|
|
||||||
read-json-file
|
|
||||||
write-json-file))
|
|
||||||
|
|
||||||
;; Pure function: Read JSON from file without logging
|
|
||||||
;; Input: filename string
|
|
||||||
;; Output: parsed object or #f if failed
|
|
||||||
(define (read-json-file-pure filename)
|
|
||||||
"Pure function to read JSON from file"
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(call-with-input-file filename
|
|
||||||
(lambda (port) (json->scm port))))
|
|
||||||
(lambda (key . args) #f)))
|
|
||||||
|
|
||||||
;; Pure function: Write JSON to file without logging
|
|
||||||
;; Input: filename string, obj (scheme object), pretty boolean
|
|
||||||
;; Output: #t if successful, #f if failed
|
|
||||||
(define (write-json-file-pure filename obj pretty)
|
|
||||||
"Pure function to write JSON to file"
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(call-with-output-file filename
|
|
||||||
(lambda (port)
|
|
||||||
(if pretty
|
|
||||||
(scm->json obj port #:pretty #t)
|
|
||||||
(scm->json obj port))))
|
|
||||||
#t)
|
|
||||||
(lambda (key . args) #f)))
|
|
||||||
|
|
||||||
;; Impure wrapper: Read JSON file with logging
|
|
||||||
(define (read-json-file filename)
|
|
||||||
"Read JSON from file with logging"
|
|
||||||
(log-debug "Reading JSON file: ~a" filename)
|
|
||||||
(let ((result (read-json-file-pure filename)))
|
|
||||||
(if result
|
|
||||||
(log-debug "Successfully read JSON file: ~a" filename)
|
|
||||||
(log-error "Failed to read JSON file: ~a" filename))
|
|
||||||
result))
|
|
||||||
|
|
||||||
;; Impure wrapper: Write JSON file with logging
|
|
||||||
(define (write-json-file filename obj . options)
|
|
||||||
"Write JSON to file with logging"
|
|
||||||
(let ((pretty (if (null? options) #t (car options))))
|
|
||||||
(log-debug "Writing JSON file: ~a" filename)
|
|
||||||
(let ((result (write-json-file-pure filename obj pretty)))
|
|
||||||
(if result
|
|
||||||
(log-debug "Successfully wrote JSON file: ~a" filename)
|
|
||||||
(log-error "Failed to write JSON file: ~a" filename))
|
|
||||||
result)))
|
|
|
@ -1,63 +0,0 @@
|
||||||
;; utils/json/manipulation.scm - Pure JSON manipulation functions
|
|
||||||
|
|
||||||
(define-module (utils json manipulation)
|
|
||||||
#:use-module (srfi srfi-1)
|
|
||||||
#:export (merge-json-objects
|
|
||||||
flatten-json-paths
|
|
||||||
json-path-ref
|
|
||||||
json-path-set))
|
|
||||||
|
|
||||||
;; Pure function: Merge two JSON objects
|
|
||||||
;; Input: obj1 (alist), obj2 (alist)
|
|
||||||
;; Output: merged alist with obj2 values taking precedence
|
|
||||||
(define (merge-json-objects obj1 obj2)
|
|
||||||
"Pure function to merge two JSON objects"
|
|
||||||
(let ((merged (copy-tree obj1)))
|
|
||||||
(fold (lambda (pair acc)
|
|
||||||
(let ((key (car pair))
|
|
||||||
(value (cdr pair)))
|
|
||||||
(assoc-set! acc key value)))
|
|
||||||
merged
|
|
||||||
obj2)))
|
|
||||||
|
|
||||||
;; Pure function: Convert nested alist to flat key paths
|
|
||||||
;; Input: obj (nested alist), optional prefix (list of keys)
|
|
||||||
;; Output: list of (path . value) pairs
|
|
||||||
(define (flatten-json-paths obj . prefix)
|
|
||||||
"Pure function to flatten nested object to path-value pairs"
|
|
||||||
(let ((current-prefix (if (null? prefix) '() (car prefix))))
|
|
||||||
(fold (lambda (pair acc)
|
|
||||||
(let ((key (car pair))
|
|
||||||
(value (cdr pair)))
|
|
||||||
(let ((new-path (append current-prefix (list key))))
|
|
||||||
(if (and (list? value) (not (null? value)) (pair? (car value)))
|
|
||||||
;; Nested object - recurse
|
|
||||||
(append (flatten-json-paths value new-path) acc)
|
|
||||||
;; Leaf value
|
|
||||||
(cons (cons new-path value) acc)))))
|
|
||||||
'()
|
|
||||||
obj)))
|
|
||||||
|
|
||||||
;; Pure function: Get nested value using path
|
|
||||||
;; Input: obj (nested alist), path (list of keys)
|
|
||||||
;; Output: value at path or #f if not found
|
|
||||||
(define (json-path-ref obj path)
|
|
||||||
"Pure function to get value from nested object using key path"
|
|
||||||
(fold (lambda (key acc)
|
|
||||||
(if (and acc (list? acc))
|
|
||||||
(assoc-ref acc key)
|
|
||||||
#f))
|
|
||||||
obj path))
|
|
||||||
|
|
||||||
;; Pure function: Set nested value using path
|
|
||||||
;; Input: obj (nested alist), path (list of keys), value
|
|
||||||
;; Output: new alist with value set at path
|
|
||||||
(define (json-path-set obj path value)
|
|
||||||
"Pure function to set value in nested object using key path"
|
|
||||||
(if (null? path)
|
|
||||||
value
|
|
||||||
(let* ((key (car path))
|
|
||||||
(rest-path (cdr path))
|
|
||||||
(current-value (assoc-ref obj key))
|
|
||||||
(new-value (json-path-set (or current-value '()) rest-path value)))
|
|
||||||
(assoc-set! (copy-tree obj) key new-value))))
|
|
|
@ -1,21 +0,0 @@
|
||||||
;; utils/json/parse.scm - Pure JSON parsing functions
|
|
||||||
|
|
||||||
(define-module (utils json parse)
|
|
||||||
#:use-module (json)
|
|
||||||
#:export (json-string->scm-safe
|
|
||||||
parse-json-pure))
|
|
||||||
|
|
||||||
;; Pure function: Safely parse JSON string
|
|
||||||
;; Input: json-string
|
|
||||||
;; Output: parsed scheme object or #f if invalid
|
|
||||||
(define (parse-json-pure json-string)
|
|
||||||
"Pure function to parse JSON string without side effects"
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(if (string? json-string)
|
|
||||||
(json-string->scm json-string)
|
|
||||||
#f))
|
|
||||||
(lambda (key . args) #f)))
|
|
||||||
|
|
||||||
;; Alias for compatibility
|
|
||||||
(define json-string->scm-safe parse-json-pure)
|
|
|
@ -1,13 +0,0 @@
|
||||||
;; utils/json/pretty-print.scm - JSON pretty printing
|
|
||||||
|
|
||||||
(define-module (utils json pretty-print)
|
|
||||||
#:use-module (json)
|
|
||||||
#:export (json-pretty-print))
|
|
||||||
|
|
||||||
;; Impure function: Pretty print JSON to current output port
|
|
||||||
;; Input: obj (scheme object)
|
|
||||||
;; Output: unspecified (side effect: prints to current-output-port)
|
|
||||||
(define (json-pretty-print obj)
|
|
||||||
"Pretty print JSON object to current output port"
|
|
||||||
(scm->json obj (current-output-port) #:pretty #t)
|
|
||||||
(newline))
|
|
|
@ -1,27 +0,0 @@
|
||||||
;; utils/json/serialize.scm - Pure JSON serialization functions
|
|
||||||
|
|
||||||
(define-module (utils json serialize)
|
|
||||||
#:use-module (json)
|
|
||||||
#:use-module (ice-9 textual-ports)
|
|
||||||
#:export (scm->json-string-pure
|
|
||||||
scm->json-string))
|
|
||||||
|
|
||||||
;; Pure function: Convert scheme object to JSON string
|
|
||||||
;; Input: obj (scheme object), pretty (boolean)
|
|
||||||
;; Output: JSON string or #f if conversion fails
|
|
||||||
(define (scm->json-string-pure obj pretty)
|
|
||||||
"Pure function to convert scheme object to JSON string"
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(call-with-output-string
|
|
||||||
(lambda (port)
|
|
||||||
(if pretty
|
|
||||||
(scm->json obj port #:pretty #t)
|
|
||||||
(scm->json obj port)))))
|
|
||||||
(lambda (key . args) #f)))
|
|
||||||
|
|
||||||
;; Wrapper with optional pretty parameter
|
|
||||||
(define (scm->json-string obj . options)
|
|
||||||
"Convert scheme object to JSON string with optional pretty printing"
|
|
||||||
(let ((pretty (if (null? options) #f (car options))))
|
|
||||||
(scm->json-string-pure obj pretty)))
|
|
|
@ -1,67 +0,0 @@
|
||||||
;; utils/json/validation.scm - Pure JSON validation functions
|
|
||||||
|
|
||||||
(define-module (utils json validation)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (srfi srfi-1)
|
|
||||||
#:export (validate-required-keys
|
|
||||||
validate-types
|
|
||||||
validate-json-schema))
|
|
||||||
|
|
||||||
;; Pure function: Check for required keys
|
|
||||||
;; Input: obj (alist), required-keys (list of symbols)
|
|
||||||
;; Output: list of missing keys (empty if all present)
|
|
||||||
(define (get-missing-keys obj required-keys)
|
|
||||||
"Pure function to find missing required keys"
|
|
||||||
(filter (lambda (key)
|
|
||||||
(not (assoc-ref obj key)))
|
|
||||||
required-keys))
|
|
||||||
|
|
||||||
;; Pure function: Validate required keys
|
|
||||||
;; Input: obj (alist), required-keys (list of symbols)
|
|
||||||
;; Output: #t if all present, #f otherwise
|
|
||||||
(define (validate-required-keys obj required-keys)
|
|
||||||
"Pure function to validate required keys are present"
|
|
||||||
(null? (get-missing-keys obj required-keys)))
|
|
||||||
|
|
||||||
;; Pure function: Check type specifications
|
|
||||||
;; Input: obj (alist), type-specs (list of (key expected-type) pairs)
|
|
||||||
;; Output: list of type error messages (empty if all valid)
|
|
||||||
(define (get-type-errors obj type-specs)
|
|
||||||
"Pure function to find type validation errors"
|
|
||||||
(filter-map
|
|
||||||
(lambda (type-spec)
|
|
||||||
(let ((key (car type-spec))
|
|
||||||
(expected-type (cadr type-spec)))
|
|
||||||
(let ((value (assoc-ref obj key)))
|
|
||||||
(if (and value (not (eq? (type-of value) expected-type)))
|
|
||||||
(format #f "Key ~a: expected ~a, got ~a"
|
|
||||||
key expected-type (type-of value))
|
|
||||||
#f))))
|
|
||||||
type-specs))
|
|
||||||
|
|
||||||
;; Pure function: Validate types
|
|
||||||
;; Input: obj (alist), type-specs (list of (key expected-type) pairs)
|
|
||||||
;; Output: #t if all types valid, #f otherwise
|
|
||||||
(define (validate-types obj type-specs)
|
|
||||||
"Pure function to validate object types"
|
|
||||||
(null? (get-type-errors obj type-specs)))
|
|
||||||
|
|
||||||
;; Pure function: Complete schema validation
|
|
||||||
;; Input: obj (alist), schema (list with required-keys, optional-keys, types)
|
|
||||||
;; Output: (values valid? error-messages)
|
|
||||||
(define (validate-json-schema obj schema)
|
|
||||||
"Pure function to validate JSON object against schema"
|
|
||||||
(let ((required-keys (car schema))
|
|
||||||
(optional-keys (if (> (length schema) 1) (cadr schema) '()))
|
|
||||||
(type-specs (if (> (length schema) 2) (caddr schema) '())))
|
|
||||||
|
|
||||||
(let ((missing-keys (get-missing-keys obj required-keys))
|
|
||||||
(type-errors (get-type-errors obj type-specs)))
|
|
||||||
|
|
||||||
(if (or (not (null? missing-keys)) (not (null? type-errors)))
|
|
||||||
(values #f (append
|
|
||||||
(if (not (null? missing-keys))
|
|
||||||
(list (format #f "Missing required keys: ~a" missing-keys))
|
|
||||||
'())
|
|
||||||
type-errors))
|
|
||||||
(values #t '())))))
|
|
|
@ -1,42 +0,0 @@
|
||||||
;; utils/logging.scm - Logging facade (aggregates modular components)
|
|
||||||
|
|
||||||
(define-module (utils logging)
|
|
||||||
#:use-module (utils logging format)
|
|
||||||
#:use-module (utils logging level)
|
|
||||||
#:use-module (utils logging state)
|
|
||||||
#:use-module (utils logging output)
|
|
||||||
#:use-module (utils logging core)
|
|
||||||
#:use-module (utils logging spinner)
|
|
||||||
#:re-export (;; Core logging functions
|
|
||||||
log-debug
|
|
||||||
log-info
|
|
||||||
log-warn
|
|
||||||
log-error
|
|
||||||
log-success
|
|
||||||
|
|
||||||
;; State management
|
|
||||||
get-current-log-level
|
|
||||||
set-log-level!
|
|
||||||
should-log?
|
|
||||||
|
|
||||||
;; Pure functions (for testing and functional composition)
|
|
||||||
should-log-pure
|
|
||||||
validate-log-level
|
|
||||||
format-timestamp
|
|
||||||
format-log-message
|
|
||||||
get-color
|
|
||||||
log-message-pure
|
|
||||||
|
|
||||||
;; Utilities
|
|
||||||
with-spinner))
|
|
||||||
|
|
||||||
;; This module acts as a facade for logging functionality,
|
|
||||||
;; aggregating specialized modules that follow single responsibility:
|
|
||||||
;; - format: Pure formatting functions and color codes
|
|
||||||
;; - level: Pure log level management and validation
|
|
||||||
;; - state: Mutable state management for current log level
|
|
||||||
;; - output: Pure output formatting and port writing
|
|
||||||
;; - core: Main logging functions with side effects
|
|
||||||
;; - spinner: Progress indication for long operations
|
|
||||||
;;
|
|
||||||
;; Both pure and impure functions are available for maximum flexibility.
|
|
|
@ -1,38 +0,0 @@
|
||||||
;; utils/logging/core.scm - Core logging functions
|
|
||||||
|
|
||||||
(define-module (utils logging core)
|
|
||||||
#:use-module (utils logging state)
|
|
||||||
#:use-module (utils logging output)
|
|
||||||
#:export (log-with-color
|
|
||||||
log-debug
|
|
||||||
log-info
|
|
||||||
log-warn
|
|
||||||
log-error
|
|
||||||
log-success))
|
|
||||||
|
|
||||||
;; Impure function: Core logging with color and level checking
|
|
||||||
(define (log-with-color level color prefix message . args)
|
|
||||||
"Log message with color if level is appropriate"
|
|
||||||
(when (should-log? level)
|
|
||||||
(log-to-port (current-error-port) level color prefix message args)))
|
|
||||||
|
|
||||||
;; Specific logging functions - each does one thing well
|
|
||||||
(define (log-debug message . args)
|
|
||||||
"Log debug message"
|
|
||||||
(apply log-with-color 'debug 'cyan "DEBUG" message args))
|
|
||||||
|
|
||||||
(define (log-info message . args)
|
|
||||||
"Log info message"
|
|
||||||
(apply log-with-color 'info 'blue "INFO " message args))
|
|
||||||
|
|
||||||
(define (log-warn message . args)
|
|
||||||
"Log warning message"
|
|
||||||
(apply log-with-color 'warn 'yellow "WARN " message args))
|
|
||||||
|
|
||||||
(define (log-error message . args)
|
|
||||||
"Log error message"
|
|
||||||
(apply log-with-color 'error 'red "ERROR" message args))
|
|
||||||
|
|
||||||
(define (log-success message . args)
|
|
||||||
"Log success message"
|
|
||||||
(apply log-with-color 'info 'green "SUCCESS" message args))
|
|
|
@ -1,42 +0,0 @@
|
||||||
;; utils/logging/format.scm - Pure logging formatting functions
|
|
||||||
|
|
||||||
(define-module (utils logging format)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (srfi srfi-19)
|
|
||||||
#:export (format-timestamp
|
|
||||||
format-log-message
|
|
||||||
get-color
|
|
||||||
color-codes))
|
|
||||||
|
|
||||||
;; Pure data: ANSI color codes
|
|
||||||
(define color-codes
|
|
||||||
'((reset . "\x1b[0m")
|
|
||||||
(bold . "\x1b[1m")
|
|
||||||
(red . "\x1b[31m")
|
|
||||||
(green . "\x1b[32m")
|
|
||||||
(yellow . "\x1b[33m")
|
|
||||||
(blue . "\x1b[34m")
|
|
||||||
(magenta . "\x1b[35m")
|
|
||||||
(cyan . "\x1b[36m")))
|
|
||||||
|
|
||||||
;; Pure function: Get color code by name
|
|
||||||
(define (get-color name)
|
|
||||||
"Pure function to get ANSI color code"
|
|
||||||
(assoc-ref color-codes name))
|
|
||||||
|
|
||||||
;; Pure function: Format timestamp
|
|
||||||
(define (format-timestamp)
|
|
||||||
"Pure function to format current timestamp"
|
|
||||||
(date->string (current-date) "~H:~M:~S"))
|
|
||||||
|
|
||||||
;; Pure function: Format complete log message
|
|
||||||
;; Input: level symbol, color symbol, prefix string, message string, args list
|
|
||||||
;; Output: formatted log message string
|
|
||||||
(define (format-log-message level color prefix message args)
|
|
||||||
"Pure function to format a complete log message"
|
|
||||||
(let ((timestamp (format-timestamp))
|
|
||||||
(formatted-msg (apply format #f message args))
|
|
||||||
(color-start (get-color color))
|
|
||||||
(color-end (get-color 'reset)))
|
|
||||||
(format #f "~a~a[lab]~a ~a ~a~%"
|
|
||||||
color-start prefix color-end timestamp formatted-msg)))
|
|
|
@ -1,30 +0,0 @@
|
||||||
;; utils/logging/level.scm - Pure log level management
|
|
||||||
|
|
||||||
(define-module (utils logging level)
|
|
||||||
#:export (log-levels
|
|
||||||
should-log-pure
|
|
||||||
validate-log-level))
|
|
||||||
|
|
||||||
;; Pure data: Log levels with numeric values for comparison
|
|
||||||
(define log-levels
|
|
||||||
'((debug . 0)
|
|
||||||
(info . 1)
|
|
||||||
(warn . 2)
|
|
||||||
(error . 3)))
|
|
||||||
|
|
||||||
;; Pure function: Check if message should be logged at given levels
|
|
||||||
;; Input: current-level symbol, message-level symbol
|
|
||||||
;; Output: #t if should log, #f otherwise
|
|
||||||
(define (should-log-pure current-level message-level)
|
|
||||||
"Pure function to determine if message should be logged"
|
|
||||||
(let ((current-value (assoc-ref log-levels current-level))
|
|
||||||
(message-value (assoc-ref log-levels message-level)))
|
|
||||||
(and current-value message-value
|
|
||||||
(<= current-value message-value))))
|
|
||||||
|
|
||||||
;; Pure function: Validate log level
|
|
||||||
;; Input: level symbol
|
|
||||||
;; Output: #t if valid, #f otherwise
|
|
||||||
(define (validate-log-level level)
|
|
||||||
"Pure function to validate log level"
|
|
||||||
(assoc-ref log-levels level))
|
|
|
@ -1,23 +0,0 @@
|
||||||
;; utils/logging/output.scm - Pure logging output functions
|
|
||||||
|
|
||||||
(define-module (utils logging output)
|
|
||||||
#:use-module (utils logging format)
|
|
||||||
#:use-module (utils logging level)
|
|
||||||
#:export (log-message-pure
|
|
||||||
log-to-port))
|
|
||||||
|
|
||||||
;; Pure function: Create log message without side effects
|
|
||||||
;; Input: level, color, prefix, message, args
|
|
||||||
;; Output: formatted log message string
|
|
||||||
(define (log-message-pure level color prefix message args)
|
|
||||||
"Pure function to create formatted log message"
|
|
||||||
(format-log-message level color prefix message args))
|
|
||||||
|
|
||||||
;; Impure function: Write log message to port
|
|
||||||
;; Input: port, level, color, prefix, message, args
|
|
||||||
;; Output: unspecified (side effect: writes to port)
|
|
||||||
(define (log-to-port port level color prefix message args)
|
|
||||||
"Write formatted log message to specified port"
|
|
||||||
(let ((formatted-message (log-message-pure level color prefix message args)))
|
|
||||||
(display formatted-message port)
|
|
||||||
(force-output port)))
|
|
|
@ -1,27 +0,0 @@
|
||||||
;; utils/logging/spinner.scm - Spinner utility for long operations
|
|
||||||
|
|
||||||
(define-module (utils logging spinner)
|
|
||||||
#:use-module (utils logging core)
|
|
||||||
#:export (with-spinner))
|
|
||||||
|
|
||||||
;; Pure function: Calculate elapsed time
|
|
||||||
;; Input: start-time, end-time
|
|
||||||
;; Output: elapsed seconds
|
|
||||||
(define (calculate-elapsed start-time end-time)
|
|
||||||
"Pure function to calculate elapsed time"
|
|
||||||
(- end-time start-time))
|
|
||||||
|
|
||||||
;; Impure function: Execute operation with spinner logging
|
|
||||||
(define (with-spinner message thunk)
|
|
||||||
"Execute operation with progress logging"
|
|
||||||
(log-info "~a..." message)
|
|
||||||
(let ((start-time (current-time)))
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(let ((result (thunk)))
|
|
||||||
(let ((elapsed (calculate-elapsed start-time (current-time))))
|
|
||||||
(log-success "~a completed in ~as" message elapsed))
|
|
||||||
result))
|
|
||||||
(lambda (key . args)
|
|
||||||
(log-error "~a failed: ~a ~a" message key args)
|
|
||||||
(throw key args)))))
|
|
|
@ -1,27 +0,0 @@
|
||||||
;; utils/logging/state.scm - Logging state management
|
|
||||||
|
|
||||||
(define-module (utils logging state)
|
|
||||||
#:use-module (utils logging level)
|
|
||||||
#:export (get-current-log-level
|
|
||||||
set-log-level!
|
|
||||||
should-log?))
|
|
||||||
|
|
||||||
;; Mutable state: Current log level
|
|
||||||
(define current-log-level 'info)
|
|
||||||
|
|
||||||
;; Impure function: Get current log level
|
|
||||||
(define (get-current-log-level)
|
|
||||||
"Get current log level"
|
|
||||||
current-log-level)
|
|
||||||
|
|
||||||
;; Impure function: Set log level with validation
|
|
||||||
(define (set-log-level! level)
|
|
||||||
"Set current log level (with validation)"
|
|
||||||
(if (validate-log-level level)
|
|
||||||
(set! current-log-level level)
|
|
||||||
(error "Invalid log level" level)))
|
|
||||||
|
|
||||||
;; Impure function: Check if message should be logged
|
|
||||||
(define (should-log? level)
|
|
||||||
"Check if message should be logged at current level"
|
|
||||||
(should-log-pure current-log-level level))
|
|
|
@ -1,27 +0,0 @@
|
||||||
;; utils/ssh.scm - SSH operations facade (aggregates modular components)
|
|
||||||
|
|
||||||
(define-module (utils ssh)
|
|
||||||
#:use-module (utils ssh connection-test)
|
|
||||||
#:use-module (utils ssh remote-command)
|
|
||||||
#:use-module (utils ssh file-copy)
|
|
||||||
#:use-module (utils ssh retry)
|
|
||||||
#:use-module (utils ssh context)
|
|
||||||
#:re-export (test-ssh-connection
|
|
||||||
run-remote-command
|
|
||||||
run-remote-command-pure
|
|
||||||
copy-file-to-remote
|
|
||||||
copy-file-pure
|
|
||||||
run-command-with-retry
|
|
||||||
with-retry
|
|
||||||
with-ssh-connection))
|
|
||||||
|
|
||||||
;; This module acts as a facade, re-exporting functions from specialized modules
|
|
||||||
;; Each sub-module follows the single responsibility principle:
|
|
||||||
;; - connection-test: SSH connectivity testing
|
|
||||||
;; - remote-command: Command execution on remote machines
|
|
||||||
;; - file-copy: File transfer operations
|
|
||||||
;; - retry: Retry logic and error recovery
|
|
||||||
;; - context: Connection context management
|
|
||||||
;;
|
|
||||||
;; Pure functions are exported alongside their impure wrappers,
|
|
||||||
;; allowing callers to choose the appropriate level of abstraction.
|
|
|
@ -1,41 +0,0 @@
|
||||||
;; utils/ssh/connection-test.scm - Pure SSH connection testing
|
|
||||||
|
|
||||||
(define-module (utils ssh connection-test)
|
|
||||||
#:use-module (ice-9 popen)
|
|
||||||
#:use-module (ice-9 textual-ports)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (utils logging)
|
|
||||||
#:use-module (utils config)
|
|
||||||
#:export (test-ssh-connection-pure
|
|
||||||
test-ssh-connection))
|
|
||||||
|
|
||||||
;; Pure function: Test SSH connectivity to a machine
|
|
||||||
;; Input: ssh-config alist
|
|
||||||
;; Output: #t if connection successful, #f otherwise
|
|
||||||
(define (test-ssh-connection-pure ssh-config)
|
|
||||||
"Pure function to test SSH connection given ssh-config"
|
|
||||||
(let ((hostname (assoc-ref ssh-config 'hostname))
|
|
||||||
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
|
|
||||||
(is-local (assoc-ref ssh-config 'is-local)))
|
|
||||||
(if is-local
|
|
||||||
#t ; Local connections always succeed
|
|
||||||
(let* ((target (or ssh-alias hostname))
|
|
||||||
(test-cmd (format #f "ssh -o ConnectTimeout=5 -o BatchMode=yes ~a echo OK" target))
|
|
||||||
(port (open-pipe* OPEN_READ "/bin/sh" "-c" test-cmd))
|
|
||||||
(output (get-string-all port))
|
|
||||||
(status (close-pipe port)))
|
|
||||||
(zero? status)))))
|
|
||||||
|
|
||||||
;; Impure wrapper: Test SSH connection with logging and config lookup
|
|
||||||
(define (test-ssh-connection machine-name)
|
|
||||||
"Test SSH connectivity to a machine (with side effects: logging, config lookup)"
|
|
||||||
(let ((ssh-config (get-ssh-config machine-name)))
|
|
||||||
(if (not ssh-config)
|
|
||||||
(begin
|
|
||||||
(log-error "No SSH configuration found for ~a" machine-name)
|
|
||||||
#f)
|
|
||||||
(let ((result (test-ssh-connection-pure ssh-config)))
|
|
||||||
(if result
|
|
||||||
(log-debug "SSH connection to ~a successful" machine-name)
|
|
||||||
(log-warn "SSH connection to ~a failed" machine-name))
|
|
||||||
result))))
|
|
|
@ -1,33 +0,0 @@
|
||||||
;; utils/ssh/context.scm - SSH context management
|
|
||||||
|
|
||||||
(define-module (utils ssh context)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (utils logging)
|
|
||||||
#:use-module (utils ssh connection-test)
|
|
||||||
#:export (with-connection-context
|
|
||||||
with-ssh-connection))
|
|
||||||
|
|
||||||
;; Pure function: Execute operation with connection validation
|
|
||||||
;; Input: connection-validator (thunk -> boolean), operation (thunk)
|
|
||||||
;; Output: result of operation or #f if connection invalid
|
|
||||||
(define (with-connection-context connection-validator operation)
|
|
||||||
"Pure function to execute operation with connection context"
|
|
||||||
(if (connection-validator)
|
|
||||||
(catch #t
|
|
||||||
operation
|
|
||||||
(lambda (key . args)
|
|
||||||
(values #f (format #f "Operation failed: ~a ~a" key args))))
|
|
||||||
(values #f "Connection validation failed")))
|
|
||||||
|
|
||||||
;; Impure wrapper: Execute with SSH connection context and logging
|
|
||||||
(define (with-ssh-connection machine-name thunk)
|
|
||||||
"Execute operation with SSH connection context (with side effects: logging)"
|
|
||||||
(let ((connection-validator (lambda () (test-ssh-connection machine-name))))
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (with-connection-context connection-validator thunk))
|
|
||||||
(lambda (success result)
|
|
||||||
(if success
|
|
||||||
result
|
|
||||||
(begin
|
|
||||||
(log-error "SSH operation failed for ~a: ~a" machine-name result)
|
|
||||||
#f))))))
|
|
|
@ -1,50 +0,0 @@
|
||||||
;; utils/ssh/file-copy.scm - Pure file copying operations
|
|
||||||
|
|
||||||
(define-module (utils ssh file-copy)
|
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (utils logging)
|
|
||||||
#:use-module (utils config)
|
|
||||||
#:export (copy-file-pure
|
|
||||||
build-copy-context
|
|
||||||
copy-file-to-remote))
|
|
||||||
|
|
||||||
;; Pure function: Copy file with given copy context
|
|
||||||
;; Input: copy-context alist, local-path string, remote-path string
|
|
||||||
;; Output: #t if successful, #f otherwise
|
|
||||||
(define (copy-file-pure copy-context local-path remote-path)
|
|
||||||
"Pure function to copy file given copy context"
|
|
||||||
(let ((is-local (assoc-ref copy-context 'is-local))
|
|
||||||
(target (assoc-ref copy-context 'target)))
|
|
||||||
(let* ((copy-cmd (if is-local
|
|
||||||
(format #f "cp '~a' '~a'" local-path remote-path)
|
|
||||||
(format #f "scp '~a' '~a:~a'" local-path target remote-path)))
|
|
||||||
(status (system copy-cmd)))
|
|
||||||
(zero? status))))
|
|
||||||
|
|
||||||
;; Pure function: Build copy context from ssh-config
|
|
||||||
(define (build-copy-context ssh-config)
|
|
||||||
"Pure function to build copy context from ssh-config"
|
|
||||||
(let ((hostname (assoc-ref ssh-config 'hostname))
|
|
||||||
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
|
|
||||||
(is-local (assoc-ref ssh-config 'is-local)))
|
|
||||||
`((is-local . ,is-local)
|
|
||||||
(target . ,(or ssh-alias hostname)))))
|
|
||||||
|
|
||||||
;; Impure wrapper: Copy file to remote with logging and config lookup
|
|
||||||
(define (copy-file-to-remote machine-name local-path remote-path)
|
|
||||||
"Copy file to remote machine (with side effects: logging, config lookup)"
|
|
||||||
(let ((ssh-config (get-ssh-config machine-name)))
|
|
||||||
(if (not ssh-config)
|
|
||||||
(begin
|
|
||||||
(log-error "No SSH configuration found for ~a" machine-name)
|
|
||||||
#f)
|
|
||||||
(let* ((copy-context (build-copy-context ssh-config))
|
|
||||||
(is-local (assoc-ref copy-context 'is-local)))
|
|
||||||
(log-debug "Copying ~a: ~a -> ~a"
|
|
||||||
(if is-local "locally" (format #f "to ~a" machine-name))
|
|
||||||
local-path remote-path)
|
|
||||||
(let ((result (copy-file-pure copy-context local-path remote-path)))
|
|
||||||
(if result
|
|
||||||
(log-debug "File copy successful")
|
|
||||||
(log-error "File copy failed"))
|
|
||||||
result)))))
|
|
|
@ -1,58 +0,0 @@
|
||||||
;; utils/ssh/remote-command.scm - Pure remote command execution
|
|
||||||
|
|
||||||
(define-module (utils ssh remote-command)
|
|
||||||
#:use-module (ice-9 popen)
|
|
||||||
#: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 (run-remote-command-pure
|
|
||||||
execute-command-pure
|
|
||||||
build-execution-context
|
|
||||||
run-remote-command))
|
|
||||||
|
|
||||||
;; Pure function: Execute command with given execution context
|
|
||||||
;; Input: execution-context alist, command string, args list
|
|
||||||
;; Output: (values success? output-string)
|
|
||||||
(define (execute-command-pure execution-context command args)
|
|
||||||
"Pure function to execute command in given context"
|
|
||||||
(let ((is-local (assoc-ref execution-context 'is-local))
|
|
||||||
(target (assoc-ref execution-context 'target))
|
|
||||||
(full-command (if (null? args)
|
|
||||||
command
|
|
||||||
(format #f "~a ~a" command (string-join args " ")))))
|
|
||||||
(let* ((exec-cmd (if is-local
|
|
||||||
full-command
|
|
||||||
(format #f "ssh ~a '~a'" target full-command)))
|
|
||||||
(port (open-pipe* OPEN_READ "/bin/sh" "-c" exec-cmd))
|
|
||||||
(output (get-string-all port))
|
|
||||||
(status (close-pipe port)))
|
|
||||||
(values (zero? status) output))))
|
|
||||||
|
|
||||||
;; Pure function: Build execution context from ssh-config
|
|
||||||
(define (build-execution-context ssh-config)
|
|
||||||
"Pure function to build execution context from ssh-config"
|
|
||||||
(let ((hostname (assoc-ref ssh-config 'hostname))
|
|
||||||
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
|
|
||||||
(is-local (assoc-ref ssh-config 'is-local)))
|
|
||||||
`((is-local . ,is-local)
|
|
||||||
(target . ,(or ssh-alias hostname)))))
|
|
||||||
|
|
||||||
;; Pure wrapper: Run remote command with pure functions
|
|
||||||
(define (run-remote-command-pure ssh-config command args)
|
|
||||||
"Pure function to run remote command given ssh-config"
|
|
||||||
(let ((exec-context (build-execution-context ssh-config)))
|
|
||||||
(execute-command-pure exec-context command args)))
|
|
||||||
|
|
||||||
;; Impure wrapper: Run remote command with logging and config lookup
|
|
||||||
(define (run-remote-command machine-name command . args)
|
|
||||||
"Run command on remote machine (with side effects: logging, config lookup)"
|
|
||||||
(let ((ssh-config (get-ssh-config machine-name)))
|
|
||||||
(if (not ssh-config)
|
|
||||||
(begin
|
|
||||||
(log-error "No SSH configuration found for ~a" machine-name)
|
|
||||||
(values #f "No SSH configuration found"))
|
|
||||||
(begin
|
|
||||||
(log-debug "Executing on ~a: ~a ~a" machine-name command (string-join args " "))
|
|
||||||
(run-remote-command-pure ssh-config command args)))))
|
|
|
@ -1,45 +0,0 @@
|
||||||
;; utils/ssh/retry.scm - Pure retry logic
|
|
||||||
|
|
||||||
(define-module (utils ssh retry)
|
|
||||||
#:use-module (utils logging)
|
|
||||||
#:use-module (utils ssh remote-command)
|
|
||||||
#:export (with-retry
|
|
||||||
run-command-with-retry))
|
|
||||||
|
|
||||||
;; Pure function: Retry operation with exponential backoff
|
|
||||||
;; Input: operation (thunk), max-retries number, delay-fn (retry-count -> seconds)
|
|
||||||
;; Output: result of operation or #f if all retries failed
|
|
||||||
(define (with-retry operation max-retries . delay-fn)
|
|
||||||
"Pure retry logic - operation should return (values success? result)"
|
|
||||||
(let ((delay-func (if (null? delay-fn)
|
|
||||||
(lambda (retry) (* retry 2)) ; Default: exponential backoff
|
|
||||||
(car delay-fn))))
|
|
||||||
(let loop ((retries 0))
|
|
||||||
(call-with-values operation
|
|
||||||
(lambda (success result)
|
|
||||||
(if success
|
|
||||||
(values #t result)
|
|
||||||
(if (< retries max-retries)
|
|
||||||
(begin
|
|
||||||
(sleep (delay-func retries))
|
|
||||||
(loop (+ retries 1)))
|
|
||||||
(values #f result))))))))
|
|
||||||
|
|
||||||
;; Impure wrapper: Run command with retry and logging
|
|
||||||
(define (run-command-with-retry machine-name command max-retries . args)
|
|
||||||
"Run command with retry logic (with side effects: logging)"
|
|
||||||
(let ((operation (lambda ()
|
|
||||||
(apply run-remote-command machine-name command args))))
|
|
||||||
(let loop ((retries 0))
|
|
||||||
(call-with-values operation
|
|
||||||
(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)))
|
|
||||||
(begin
|
|
||||||
(log-error "Command failed after ~a retries" max-retries)
|
|
||||||
(values #f output))))))))))
|
|
|
@ -10,7 +10,7 @@
|
||||||
pname = "lab-tool";
|
pname = "lab-tool";
|
||||||
version = "2.0.0-kiss";
|
version = "2.0.0-kiss";
|
||||||
|
|
||||||
src = ./lab;
|
src = ./lab-tool;
|
||||||
|
|
||||||
nativeBuildInputs = [makeWrapper];
|
nativeBuildInputs = [makeWrapper];
|
||||||
buildInputs = [
|
buildInputs = [
|
||||||
|
|
38
shell.nix
Normal file
38
shell.nix
Normal file
|
@ -0,0 +1,38 @@
|
||||||
|
# Nix shell for Home Lab development with deploy-rs and lab-tool
|
||||||
|
{
|
||||||
|
description = "Home Lab dev shell with deploy-rs and lab-tool";
|
||||||
|
|
||||||
|
inputs = {
|
||||||
|
nixpkgs.url = "github:NixOS/nixpkgs/nixos-25.05";
|
||||||
|
deploy-rs.url = "github:serokell/deploy-rs";
|
||||||
|
};
|
||||||
|
|
||||||
|
outputs = {
|
||||||
|
self,
|
||||||
|
nixpkgs,
|
||||||
|
deploy-rs,
|
||||||
|
...
|
||||||
|
} @ inputs: let
|
||||||
|
system = "x86_64-linux";
|
||||||
|
pkgs = import nixpkgs {inherit system;};
|
||||||
|
in {
|
||||||
|
devShells.${system}.default = pkgs.mkShell {
|
||||||
|
buildInputs = [
|
||||||
|
pkgs.git
|
||||||
|
pkgs.guile_3_0
|
||||||
|
pkgs.guile-ssh
|
||||||
|
pkgs.guile-json
|
||||||
|
pkgs.guile-git
|
||||||
|
pkgs.guile-gcrypt
|
||||||
|
pkgs.openssh
|
||||||
|
pkgs.nixos-rebuild
|
||||||
|
deploy-rs.packages.${system}.deploy-rs
|
||||||
|
(import ./packages/lab-tool/default.nix {inherit (pkgs) lib stdenv makeWrapper guile_3_0 guile-ssh guile-json guile-git guile-gcrypt openssh git nixos-rebuild;})
|
||||||
|
];
|
||||||
|
shellHook = ''
|
||||||
|
echo "Dev shell: deploy-rs and lab-tool available."
|
||||||
|
echo "Try: lab status, lab deploy <machine>, or deploy . <target>"
|
||||||
|
'';
|
||||||
|
};
|
||||||
|
};
|
||||||
|
}
|
Loading…
Add table
Add a link
Reference in a new issue