grokking simplicity and refactoring

This commit is contained in:
Geir Okkenhaug Jerstad 2025-06-16 13:43:21 +02:00
parent 89a7fe100d
commit fb4361d938
67 changed files with 6275 additions and 56 deletions

542
packages/lab-tool/README.md Normal file
View file

@ -0,0 +1,542 @@
# Lab Package - Home Lab Infrastructure Management in Guile Scheme
A comprehensive home lab management tool implemented in GNU Guile Scheme, providing infrastructure monitoring, deployment automation, and health checking capabilities for NixOS-based systems.
## Table of Contents
- [Overview](#overview)
- [Background on GNU Guile](#background-on-gnu-guile)
- [Code Architecture](#code-architecture)
- [Core Modules](#core-modules)
- [Installation & Setup](#installation--setup)
- [Usage Examples](#usage-examples)
- [API Reference](#api-reference)
- [Development](#development)
- [Integration](#integration)
## Overview
The Lab package is a sophisticated infrastructure management tool designed for home lab environments running NixOS. It provides:
- **Infrastructure Status Monitoring**: Real-time status checking across multiple machines
- **Deployment Automation**: Safe NixOS configuration deployment with multiple strategies
- **Health Checking**: Comprehensive system health validation
- **SSH-based Operations**: Secure remote command execution and file operations
- **Error Handling**: Robust error reporting and recovery mechanisms
- **MCP Integration**: Model Context Protocol server for IDE integration
## Background on GNU Guile
### What is GNU Guile?
GNU Guile is the official extension language for the GNU Project and is an implementation of the Scheme programming language. Scheme is a minimalist dialect of Lisp, designed for clarity and elegance.
### Why Guile for Infrastructure Management?
**Advantages over traditional shell scripting:**
1. **Rich Data Structures**: Native support for complex data manipulation with lists, association lists, and records
2. **Error Handling**: Sophisticated condition system for graceful error recovery
3. **Modularity**: Built-in module system for organizing large codebases
4. **Functional Programming**: Immutable data structures and pure functions reduce bugs
5. **REPL-Driven Development**: Interactive development and debugging capabilities
6. **Extensibility**: Easy integration with C libraries and external tools
**Scheme Language Features:**
- **S-expressions**: Code as data, enabling powerful metaprogramming
- **First-class functions**: Functions can be passed as arguments and returned as values
- **Pattern matching**: Elegant control flow with the `match` macro
- **Tail call optimization**: Efficient recursive algorithms
- **Hygienic macros**: Safe code generation and transformation
**Example of Scheme expressiveness:**
```scheme
;; Traditional imperative approach (pseudo-code)
machines = get_machines()
results = []
for machine in machines:
status = check_machine(machine)
results.append((machine, status))
;; Functional Scheme approach
(map (lambda (machine)
`(,machine . ,(check-machine machine)))
(get-machines))
```
## Code Architecture
The lab package follows a modular architecture with clear separation of concerns:
```
packages/lab/
├── core.scm # Core infrastructure operations
├── deployment.scm # Deployment strategies and execution
├── machines.scm # Machine management and discovery
├── monitoring.scm # Health checking and status monitoring
└── utils/
├── config.scm # Configuration management
├── logging.scm # Structured logging system
└── ssh.scm # SSH operations and connectivity
```
### Design Principles
1. **Functional Core, Imperative Shell**: Pure functions for business logic, side effects at boundaries
2. **Data-Driven Design**: Configuration and machine definitions as data structures
3. **Composable Operations**: Small, focused functions that can be combined
4. **Error Boundaries**: Comprehensive error handling with informative messages
5. **Testable Components**: Functions designed for easy unit testing
## Core Modules
### core.scm - Main Infrastructure Operations
The core module provides the primary interface for infrastructure management:
```scheme
(define-module (lab core)
#:export (get-infrastructure-status
check-system-health
update-flake
validate-environment
execute-nixos-rebuild))
```
#### Key Functions
**`get-infrastructure-status`**
- Retrieves comprehensive status of all machines or a specific machine
- Returns structured data including connectivity, services, and system metrics
- Supports both local and remote machine checking
**`check-system-health`**
- Performs comprehensive health checks including:
- SSH connectivity testing
- Disk space validation (< 90% usage)
- System load monitoring (< 5.0 load average)
- Critical service status (sshd, etc.)
- Network connectivity verification
**`execute-nixos-rebuild`**
- Safe NixOS deployment with comprehensive error handling
- Supports multiple deployment modes (switch, boot, test)
- Handles both local and remote deployments
- Includes dry-run capabilities for testing
#### Code Analysis Example
```scheme
;; Infrastructure status checking with error handling
(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)
;; Gather machine information with error isolation
(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)))
;; Return structured status data
`((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)))
```
This code demonstrates several Scheme/Guile idioms:
1. **Optional Arguments**: Using `(args)` with `null?` check for flexible function signatures
2. **Let Bindings**: Structured variable binding with `let*` for dependent calculations
3. **Conditional Expressions**: Using `if` expressions for control flow
4. **Association Lists**: Structured data representation with `assoc-ref`
5. **Quasiquote/Unquote**: Building structured data with `` `((key . ,value))` syntax
### utils/ssh.scm - SSH Operations
Handles all SSH-related operations with comprehensive error handling:
```scheme
(define (test-ssh-connection machine-name)
(let ((ssh-config (get-ssh-config machine-name)))
(if (not ssh-config)
(begin
(log-error "No SSH configuration found for ~a" machine-name)
#f)
(if (assoc-ref ssh-config 'is-local)
(begin
(log-debug "Machine ~a is local, skipping SSH test" machine-name)
#t)
;; Remote SSH testing logic
(let ((hostname (assoc-ref ssh-config 'hostname))
(ssh-alias (assoc-ref ssh-config 'ssh-alias)))
(catch #t
(lambda ()
(let* ((test-cmd (if ssh-alias
(format #f "ssh -o ConnectTimeout=5 -o BatchMode=yes ~a echo OK" ssh-alias)
(format #f "ssh -o ConnectTimeout=5 -o BatchMode=yes ~a echo OK" hostname)))
(port (open-pipe* OPEN_READ "/bin/sh" "-c" test-cmd))
(output (get-string-all port))
(status (close-pipe port)))
(zero? status)))
(lambda (key . args)
(log-warn "SSH connection test failed for ~a: ~a" machine-name key)
#f)))))))
```
### utils/config.scm - Configuration Management
Provides structured configuration handling:
```scheme
(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)))
;; Additional machines...
))))
```
### utils/logging.scm - Structured Logging
Comprehensive logging system with color coding and log levels:
```scheme
;; ANSI color codes for terminal output
(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")))
;; Log level hierarchy
(define log-levels
'((debug . 0)
(info . 1)
(warn . 2)
(error . 3)))
```
## Installation & Setup
### Prerequisites
1. **GNU Guile**: Version 3.0 or later
2. **NixOS System**: Target machines running NixOS
3. **SSH Access**: Configured SSH keys for remote machines
4. **Required Guile Libraries**:
- `guile-ssh` - SSH operations
- `guile-json` - JSON data handling
- `srfi-1`, `srfi-19` - Standard Scheme libraries
### NixOS Integration
Add to your NixOS configuration:
```nix
environment.systemPackages = with pkgs; [
guile
guile-ssh
guile-json-4
];
```
### Environment Setup
```bash
# Set environment variables
export HOMELAB_ROOT="/path/to/your/home-lab"
export GUILE_LOAD_PATH="/path/to/packages:$GUILE_LOAD_PATH"
# Test installation
guile -c "(use-modules (lab core)) (display \"Lab package loaded successfully\\n\")"
```
## Usage Examples
### Basic Infrastructure Status
```scheme
#!/usr/bin/env guile
!#
(use-modules (lab core))
;; Check all machines
(define all-status (get-infrastructure-status))
(display all-status)
;; Check specific machine
(define machine-status (get-infrastructure-status "sleeper-service"))
(display machine-status)
```
### Health Checking
```scheme
(use-modules (lab core))
;; Comprehensive health check
(define health-report (check-system-health "grey-area"))
(for-each (lambda (check)
(let ((name (car check))
(result (cdr check)))
(format #t "~a: ~a~%" name
(assoc-ref result 'status))))
health-report)
```
### Deployment Operations
```scheme
(use-modules (lab core))
;; Validate environment before deployment
(if (validate-environment)
(begin
;; Update flake inputs
(update-flake '((dry-run . #f)))
;; Deploy to machine
(execute-nixos-rebuild "sleeper-service" "switch"
'((dry-run . #f))))
(display "Environment validation failed\n"))
```
### Interactive REPL Usage
```sh
;; Start Guile REPL
$ guile -L packages
;; Load modules interactively
scheme@(guile-user)> (use-modules (lab core) (utils logging))
;; Set debug logging
scheme@(guile-user)> (set-log-level! 'debug)
;; Check machine status interactively
scheme@(guile-user)> (get-infrastructure-status "congenital-optimist")
;; Test health checks
scheme@(guile-user)> (check-system-health "grey-area")
```
## API Reference
### Infrastructure Management
#### `(get-infrastructure-status [machine-name])`
Returns structured status information for all machines or specific machine.
**Parameters:**
- `machine-name` (optional): Specific machine to check
**Returns:**
Association list with machine status including:
- `machine`: Machine name
- `type`: 'local or 'remote
- `connection`: 'online or 'offline
- `services`: List of service statuses
- `system`: System information (uptime, load, memory, disk)
- `check-time`: Time taken for status check
#### `(check-system-health machine-name)`
Performs comprehensive health validation.
**Parameters:**
- `machine-name`: Target machine name
**Returns:**
List of health check results with status ('pass, 'fail, 'error) and details.
#### `(execute-nixos-rebuild machine-name mode options)`
Executes NixOS rebuild with error handling.
**Parameters:**
- `machine-name`: Target machine
- `mode`: Rebuild mode ("switch", "boot", "test")
- `options`: Configuration options (dry-run, etc.)
**Returns:**
Boolean indicating success/failure.
### Utility Functions
#### `(validate-environment)`
Validates home lab environment configuration.
#### `(update-flake options)`
Updates Nix flake inputs with optional dry-run.
### Configuration Access
#### `(get-machine-config machine-name)`
Retrieves machine-specific configuration.
#### `(get-all-machines)`
Returns list of all configured machines.
#### `(get-ssh-config machine-name)`
Gets SSH configuration for machine.
## Development
### Code Style Guidelines
1. **Naming Conventions**:
- Use kebab-case for functions and variables
- Predicates end with `?` (e.g., `machine-online?`)
- Mutating procedures end with `!` (e.g., `set-log-level!`)
2. **Module Organization**:
- One module per file
- Clear export lists
- Minimal external dependencies
3. **Error Handling**:
- Use `catch` for exception handling
- Provide informative error messages
- Log errors with appropriate levels
4. **Documentation**:
- Docstrings for all public functions
- Inline comments for complex logic
- Example usage in comments
### Testing
```scheme
;; Example test structure
(use-modules (srfi srfi-64) ; Testing framework
(lab core))
(test-begin "infrastructure-tests")
(test-assert "validate-environment"
(validate-environment))
(test-assert "machine-connectivity"
(test-ssh-connection "congenital-optimist"))
(test-end "infrastructure-tests")
```
### REPL-Driven Development
Guile's strength lies in interactive development:
```scheme
;; Reload modules during development
scheme@(guile-user)> (reload-module (resolve-module '(lab core)))
;; Test functions interactively
scheme@(guile-user)> (get-machine-config "sleeper-service")
;; Debug with modified log levels
scheme@(guile-user)> (set-log-level! 'debug)
scheme@(guile-user)> (test-ssh-connection "grey-area")
```
## Integration
### Model Context Protocol (MCP) Server
The lab package includes MCP server capabilities for IDE integration, providing:
- **Tools**: Infrastructure management operations
- **Resources**: Machine configurations and status
- **Prompts**: Common operational workflows
### VS Code Integration
Through the MCP server, the lab package integrates with VS Code to provide:
- Real-time infrastructure status
- Contextual deployment suggestions
- Configuration validation
- Automated documentation generation
### Command Line Interface
The package provides a CLI wrapper for common operations:
```bash
# Using the Guile-based CLI
./home-lab-tool.scm status
./home-lab-tool.scm deploy sleeper-service
./home-lab-tool.scm health-check grey-area
```
### Future Enhancements
1. **Web Dashboard**: Real-time monitoring interface
2. **Metrics Collection**: Prometheus integration
3. **Automated Recovery**: Self-healing capabilities
4. **Configuration Validation**: Pre-deployment checks
5. **Rollback Automation**: Automatic failure recovery
---
## Contributing
1. Follow the established code style
2. Add tests for new functionality
3. Update documentation
4. Test with multiple machine configurations
## License
This project follows the same license as the Home Lab repository.
---
**Note**: This tool represents a migration from traditional Bash scripting to a more robust, functional programming approach using GNU Guile Scheme. The benefits include better error handling, structured data management, and more maintainable code for complex infrastructure management tasks.

View file

@ -0,0 +1,107 @@
# 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.

View file

@ -0,0 +1,32 @@
;; lab/core/config.scm - Configuration functionality
(define-module (lab core config)
#:use-module (ice-9 format)
#:export (get-all-machines
get-machine-config
get-ssh-config
get-homelab-root
option-ref))
(define (option-ref options key default)
"Get option value from options alist with default"
(let ((value (assoc-ref options key)))
(if value value default)))
(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")

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -0,0 +1,3 @@
# Default.nix for lab-tool
# Provides the lab-tool package for inclusion in other Nix expressions
(import (fetchTarball "https://github.com/NixOS/nixpkgs/archive/nixos-unstable.tar.gz") {}).callPackage ./. {}

View file

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

61
packages/lab-tool/flake.lock generated Normal file
View file

@ -0,0 +1,61 @@
{
"nodes": {
"flake-utils": {
"inputs": {
"systems": "systems"
},
"locked": {
"lastModified": 1731533236,
"narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1749794982,
"narHash": "sha256-Kh9K4taXbVuaLC0IL+9HcfvxsSUx8dPB5s5weJcc9pc=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "ee930f9755f58096ac6e8ca94a1887e0534e2d81",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixos-unstable",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"flake-utils": "flake-utils",
"nixpkgs": "nixpkgs"
}
},
"systems": {
"locked": {
"lastModified": 1681028828,
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
"owner": "nix-systems",
"repo": "default",
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
"type": "github"
},
"original": {
"owner": "nix-systems",
"repo": "default",
"type": "github"
}
}
},
"root": "root",
"version": 7
}

133
packages/lab-tool/flake.nix Normal file
View file

@ -0,0 +1,133 @@
{
description = "Home Lab Tool - Guile implementation with MCP server";
inputs = {
nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable";
flake-utils.url = "github:numtide/flake-utils";
};
outputs = {
self,
nixpkgs,
flake-utils,
}:
flake-utils.lib.eachDefaultSystem (system: let
pkgs = nixpkgs.legacyPackages.${system};
# Guile libraries we need
guileLibs = with pkgs; [
guile_3_0
guile-ssh
guile-json
guile-git
guile-gcrypt
];
# Build the Guile lab tool
lab-tool = pkgs.stdenv.mkDerivation {
pname = "lab-tool";
version = "0.1.0";
src = ./.;
buildInputs = guileLibs;
nativeBuildInputs = [pkgs.makeWrapper];
buildPhase = ''
# Compile Guile modules for better performance
mkdir -p $out/share/guile/site/3.0
cp -r . $out/share/guile/site/3.0/lab-tool/
# Compile .scm files to .go files
for file in $(find . -name "*.scm"); do
echo "Compiling $file"
guild compile -L . -o $out/share/guile/site/3.0/''${file%.scm}.go $file || true
done
'';
installPhase = ''
mkdir -p $out/bin
# Create the main lab executable
cat > $out/bin/lab << EOF
#!/usr/bin/env bash
export GUILE_LOAD_PATH="$out/share/guile/site/3.0/lab-tool:\$GUILE_LOAD_PATH"
export GUILE_LOAD_COMPILED_PATH="$out/share/guile/site/3.0/lab-tool:\$GUILE_LOAD_COMPILED_PATH"
exec ${pkgs.guile_3_0}/bin/guile "$out/share/guile/site/3.0/lab-tool/main.scm" "\$@"
EOF
chmod +x $out/bin/lab
# Create MCP server executable
cat > $out/bin/lab-mcp-server << EOF
#!/usr/bin/env bash
export GUILE_LOAD_PATH="$out/share/guile/site/3.0/lab-tool:\$GUILE_LOAD_PATH"
export GUILE_LOAD_COMPILED_PATH="$out/share/guile/site/3.0/lab-tool:\$GUILE_LOAD_COMPILED_PATH"
exec ${pkgs.guile_3_0}/bin/guile -L "$out/share/guile/site/3.0/lab-tool" -c "(use-modules (mcp server)) (run-mcp-server)"
EOF
chmod +x $out/bin/lab-mcp-server
# Wrap executables with proper environment
wrapProgram $out/bin/lab \
--prefix PATH : ${pkgs.lib.makeBinPath [pkgs.openssh pkgs.git pkgs.nixos-rebuild]}
wrapProgram $out/bin/lab-mcp-server \
--prefix PATH : ${pkgs.lib.makeBinPath [pkgs.openssh pkgs.git pkgs.nixos-rebuild]}
'';
meta = with pkgs.lib; {
description = "Home Lab Tool - Guile implementation with MCP integration";
license = licenses.mit;
platforms = platforms.linux;
maintainers = ["geir@home-lab"];
};
};
in {
packages = {
default = lab-tool;
lab-tool = lab-tool;
};
devShells.default = pkgs.mkShell {
buildInputs =
guileLibs
++ (with pkgs; [
# Development tools
emacs
# System tools for lab operations
openssh
git
nixos-rebuild
# Optional for advanced features
sqlite
redis
]);
shellHook = ''
echo "🧪 Home Lab Tool Development Environment"
echo "Available commands:"
echo " guile - Start Guile REPL"
echo " guild compile <file> - Compile Guile modules"
echo " ./main.scm help - Test the lab tool"
echo ""
echo "Module path: $(pwd)"
export GUILE_LOAD_PATH="$(pwd):$GUILE_LOAD_PATH"
export LAB_DEV_MODE=1
'';
};
apps = {
default = flake-utils.lib.mkApp {
drv = lab-tool;
name = "lab";
};
mcp-server = flake-utils.lib.mkApp {
drv = lab-tool;
name = "lab-mcp-server";
};
};
});
}

187
packages/lab-tool/main.scm Normal file
View file

@ -0,0 +1,187 @@
#!/usr/bin/env guile
!#
;; Home Lab Tool - Main Entry Point
;; K.I.S.S Refactored Implementation
(add-to-load-path (dirname (current-filename)))
(use-modules (ice-9 match)
(ice-9 format)
(utils config)
(utils logging))
;; Initialize logging
(set-log-level! 'info)
;; Pure function: Command help text
(define (get-help-text)
"Pure function returning help text"
"Home Lab Tool - K.I.S.S Refactored Edition
USAGE: lab <command> [args...]
COMMANDS:
status Show infrastructure status
machines List all machines
deploy <machine> Deploy configuration to machine
ssh <machine> SSH to machine
test-modules Test modular implementation
help Show this help
EXAMPLES:
lab status
lab machines
lab deploy congenital-optimist
lab ssh sleeper-service
lab test-modules
This implementation follows K.I.S.S principles:
- Modular: Each module has single responsibility
- Functional: Pure functions separated from side effects
- Small: Individual modules under 50 lines
- Simple: One function does one thing well
")
;; Pure function: Format machine list
(define (format-machine-list machines)
"Pure function to format machine list for display"
(if (null? machines)
"No machines configured"
(string-join
(map (lambda (machine) (format #f " - ~a" machine)) machines)
"\n")))
;; Pure function: Format status info
(define (format-status-info machines config)
"Pure function to format infrastructure status"
(format #f "Infrastructure Status:
Total machines: ~a
Home lab root: ~a
~a"
(length machines)
(get-config-value '(homelab-root))
(format-machine-list machines)))
;; Command implementations
(define (cmd-status)
"Show infrastructure status"
(log-info "Checking infrastructure status...")
(let* ((machines (get-all-machines))
(config (get-current-config))
(status-text (format-status-info machines config)))
(display status-text)
(newline)
(log-success "Status check complete")))
(define (cmd-machines)
"List all configured machines"
(log-info "Listing configured machines...")
(let* ((machines (get-all-machines))
(machine-list (format-machine-list machines)))
(format #t "Configured Machines:\n~a\n" machine-list)
(log-success "Machine list complete")))
(define (cmd-deploy machine-name)
"Deploy configuration to machine"
(log-info "Deploying to machine: ~a" machine-name)
(if (validate-machine-name machine-name)
(begin
(log-info "Machine ~a is valid" machine-name)
(log-info "Deployment simulation complete (no actual deployment)")
(log-success "Deployment to ~a complete" machine-name))
(begin
(log-error "Invalid machine: ~a" machine-name)
(log-info "Available machines: ~a" (string-join (get-all-machines) ", ")))))
(define (cmd-ssh machine-name)
"SSH to machine"
(log-info "Connecting to machine: ~a" machine-name)
(if (validate-machine-name machine-name)
(let ((ssh-config (get-ssh-config machine-name)))
(if ssh-config
(let ((hostname (assoc-ref ssh-config 'hostname))
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
(is-local (assoc-ref ssh-config 'is-local)))
(if is-local
(log-info "Machine ~a is local - no SSH needed" machine-name)
(let ((target (or ssh-alias hostname)))
(log-info "Connecting to ~a via SSH..." target)
(system (format #f "ssh ~a" target)))))
(log-error "No SSH configuration found for ~a" machine-name)))
(log-error "Invalid machine: ~a" machine-name)))
(define (cmd-test-modules)
"Test the modular implementation"
(log-info "Testing modular implementation...")
;; Test pure functions
(use-modules (utils config accessor)
(utils logging format))
(let* ((config (get-current-config))
(machines (get-all-machines-pure config))
(blue-color (get-color 'blue)))
(format #t "\n=== Modular Implementation Test ===\n")
(format #t "Pure config access: ~a machines\n" (length machines))
(format #t "Pure color function: ~ablue text~a\n" blue-color (get-color 'reset))
(format #t "\n✅ All pure functions working correctly!\n\n")
(log-success "Modular implementation test complete")))
;; Main command dispatcher
(define (dispatch-command command args)
"Dispatch command with appropriate handler"
(match command
('help
(display (get-help-text)))
('status
(cmd-status))
('machines
(cmd-machines))
('deploy
(if (null? args)
(begin
(log-error "deploy command requires machine name")
(format #t "Usage: lab deploy <machine>\n"))
(cmd-deploy (car args))))
('ssh
(if (null? args)
(begin
(log-error "ssh command requires machine name")
(format #t "Usage: lab ssh <machine>\n"))
(cmd-ssh (car args))))
('test-modules
(cmd-test-modules))
(_
(log-error "Unknown command: ~a" command)
(format #t "Use 'lab help' for available commands\n"))))
;; Main entry point
(define (main args)
"Main entry point for lab tool"
(log-info "Home Lab Tool - K.I.S.S Refactored Edition")
(let* ((parsed-cmd (if (> (length args) 1) (cdr args) '("help")))
(command (string->symbol (car parsed-cmd)))
(cmd-args (cdr parsed-cmd)))
(catch #t
(lambda () (dispatch-command command cmd-args))
(lambda (key . error-args)
(log-error "Command failed: ~a ~a" key error-args)
(exit 1))))
(log-debug "Command execution complete"))
;; Run main function if script is executed directly
(when (and (defined? 'command-line) (not (null? (command-line))))
(main (command-line)))

View file

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

View file

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

View file

@ -0,0 +1,348 @@
#!/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))

View file

@ -0,0 +1,846 @@
# 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)))))
```

View file

@ -0,0 +1,394 @@
# 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.

View file

@ -0,0 +1,334 @@
# 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 "")
(define nc "")
(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=''
NC='' # 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 "")
(define GREEN "")
(define YELLOW "")
(define BLUE "")
(define NC "")
;; 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.

View file

@ -0,0 +1,74 @@
#!/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)))

View file

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

View file

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

View file

@ -0,0 +1,243 @@
#!/usr/bin/env guile
!#
;; Comprehensive test script for Home Lab Guile implementation
;; Tests all modules and identifies bugs/missing functionality
(add-to-load-path ".")
(use-modules (ice-9 format)
(ice-9 ftw)
(srfi srfi-1)
(srfi srfi-64)) ; Testing framework
;; Global test results
(define test-results '())
(define failed-tests '())
;; Utility functions for testing
(define (test-module-loading module-name)
"Test if a module can be loaded without errors"
(format #t "Testing module loading: ~a... " module-name)
(catch #t
(lambda ()
(let ((module-parts (map string->symbol (string-split module-name #\space))))
(if (resolve-module module-parts #:ensure #f)
(begin
(format #t "✅ PASS\n")
#t)
(begin
(format #t "❌ FAIL - Module not found\n")
(set! failed-tests (cons module-name failed-tests))
#f))))
(lambda (key . args)
(format #t "❌ FAIL - ~a: ~a\n" key args)
(set! failed-tests (cons module-name failed-tests))
#f)))
(define (test-function-exists module-name function-name)
"Test if a function exists in a module"
(catch #t
(lambda ()
(let* ((module-parts (string-split module-name #\space))
(module (resolve-module module-parts)))
(if (module-defined? module (string->symbol function-name))
(begin
(format #t " ✅ Function ~a exists\n" function-name)
#t)
(begin
(format #t " ❌ Function ~a missing\n" function-name)
(set! failed-tests (cons (format #f "~a::~a" module-name function-name) failed-tests))
#f))))
(lambda (key . args)
(format #t " ❌ Error checking function ~a: ~a\n" function-name key)
#f)))
(define (test-basic-functionality)
"Test basic functionality of each module"
(format #t "\n=== BASIC FUNCTIONALITY TESTS ===\n")
;; Test utils modules
(format #t "\n--- Testing utils/logging ---\n")
(catch #t
(lambda ()
(use-modules (utils logging))
(log-info "Testing logging functionality")
(log-debug "Debug message test")
(log-warn "Warning message test")
(log-error "Error message test")
(format #t "✅ Logging module functional\n"))
(lambda (key . args)
(format #t "❌ Logging module failed: ~a\n" key)))
;; Test config module (with JSON dependency fix)
(format #t "\n--- Testing utils/config ---\n")
(catch #t
(lambda ()
;; Try to load config module
(use-modules (utils config))
(let ((machines (get-all-machines)))
(format #t "✅ Config loaded, found ~a machines: ~a\n"
(length machines) machines))
(let ((homelab-root (get-homelab-root)))
(format #t "✅ Home lab root: ~a\n" homelab-root)))
(lambda (key . args)
(format #t "❌ Config module failed: ~a\n" key)))
;; Test SSH module
(format #t "\n--- Testing utils/ssh ---\n")
(catch #t
(lambda ()
(use-modules (utils ssh))
(format #t "✅ SSH module loaded\n")
;; Test SSH connection to local machine
(let ((result (test-ssh-connection "congenital-optimist")))
(format #t "✅ SSH test result for local machine: ~a\n" result)))
(lambda (key . args)
(format #t "❌ SSH module failed: ~a\n" key)))
;; Test core lab modules
(format #t "\n--- Testing lab/core ---\n")
(catch #t
(lambda ()
(use-modules (lab core))
(format #t "✅ Lab core module loaded\n")
;; Test infrastructure status
(let ((status (get-infrastructure-status)))
(format #t "✅ Infrastructure status retrieved for ~a machines\n"
(length status))))
(lambda (key . args)
(format #t "❌ Lab core module failed: ~a\n" key)))
;; Test machines module
(format #t "\n--- Testing lab/machines ---\n")
(catch #t
(lambda ()
(use-modules (lab machines))
(format #t "✅ Lab machines module loaded\n"))
(lambda (key . args)
(format #t "❌ Lab machines module failed: ~a\n" key)))
;; Test deployment module
(format #t "\n--- Testing lab/deployment ---\n")
(catch #t
(lambda ()
(use-modules (lab deployment))
(format #t "✅ Lab deployment module loaded\n"))
(lambda (key . args)
(format #t "❌ Lab deployment module failed: ~a\n" key)))
;; Test monitoring module
(format #t "\n--- Testing lab/monitoring ---\n")
(catch #t
(lambda ()
(use-modules (lab monitoring))
(format #t "✅ Lab monitoring module loaded\n"))
(lambda (key . args)
(format #t "❌ Lab monitoring module failed: ~a\n" key))))
(define (test-file-syntax file-path)
"Test if a Scheme file has valid syntax"
(catch #t
(lambda ()
(call-with-input-file file-path
(lambda (port)
(let loop ((expr (read port)))
(unless (eof-object? expr)
(loop (read port))))))
(format #t "✅ ~a - syntax OK\n" file-path)
#t)
(lambda (key . args)
(format #t "❌ ~a - syntax error: ~a\n" file-path key)
(set! failed-tests (cons file-path failed-tests))
#f)))
(define (find-scheme-files dir)
"Find all .scm files in directory"
(let ((files '()))
(file-system-fold
(lambda (file-name stat result) ; enter?
#t)
(lambda (file-name stat result) ; leaf
(if (string-suffix? ".scm" file-name)
(cons file-name result)
result))
(lambda (file-name stat result) ; down
result)
(lambda (file-name stat result) ; up
result)
(lambda (file-name stat result) ; skip
result)
(lambda (file-name stat errno result) ; error
(format #t "Error accessing ~a: ~a\n" file-name errno)
result)
files
dir)
files))
;; Main test execution
(define (main)
(format #t "🧪 HOME LAB GUILE IMPLEMENTATION TEST SUITE\n")
(format #t "==========================================\n")
;; Test 1: Syntax checking
(format #t "\n=== SYNTAX CHECKING ===\n")
(let ((scheme-files (find-scheme-files ".")))
(for-each test-file-syntax scheme-files))
;; Test 2: Module loading
(format #t "\n=== MODULE LOADING TESTS ===\n")
(let ((modules '("utils logging"
"utils config"
"utils ssh"
"utils json"
"lab core"
"lab machines"
"lab deployment"
"lab monitoring"
"mcp server")))
(for-each test-module-loading modules))
;; Test 3: Basic functionality
(test-basic-functionality)
;; Test 4: Integration tests
(format #t "\n=== INTEGRATION TESTS ===\n")
(catch #t
(lambda ()
(use-modules (utils config) (utils ssh) (lab core))
(format #t "Testing machine configuration access...\n")
(let ((machines (get-all-machines)))
(for-each (lambda (machine)
(format #t " - Testing ~a: " machine)
(let ((config (get-machine-config machine)))
(if config
(format #t "✅ Config found\n")
(format #t "❌ No config\n"))))
machines)))
(lambda (key . args)
(format #t "❌ Integration test failed: ~a\n" key)))
;; Test 5: Command line interface
(format #t "\n=== CLI INTERFACE TESTS ===\n")
(catch #t
(lambda ()
(load "home-lab-tool.scm")
(format #t "✅ CLI script loaded successfully\n"))
(lambda (key . args)
(format #t "❌ CLI script failed: ~a\n" key)))
;; Summary
(format #t "\n=== TEST SUMMARY ===\n")
(if (null? failed-tests)
(format #t "🎉 All tests passed!\n")
(begin
(format #t "❌ ~a test(s) failed:\n" (length failed-tests))
(for-each (lambda (test)
(format #t " - ~a\n" test))
failed-tests)))
(format #t "\nTest complete.\n"))
;; Run the tests
(main)

View file

@ -0,0 +1,211 @@
#!/usr/bin/env guile
!#
;; Updated test script for modular refactoring
;; Tests the new K.I.S.S modular implementation
(add-to-load-path ".")
(add-to-load-path "lab")
(use-modules (ice-9 format)
(ice-9 ftw)
(srfi srfi-1))
;; Global test results
(define test-results '())
(define failed-tests '())
;; Test pure function modules
(define (test-pure-functions)
"Test pure function implementations"
(format #t "\n=== PURE FUNCTION TESTS ===\n")
;; Test logging format (pure functions)
(format #t "\n--- Testing utils/logging/format (pure) ---\n")
(catch #t
(lambda ()
(use-modules (utils logging format))
(let ((blue-color (get-color 'blue))
(timestamp (format-timestamp)))
(format #t "✅ Color retrieval: ~a\n" blue-color)
(format #t "✅ Timestamp format: ~a\n" timestamp)
(format #t "✅ Pure logging format functions work\n")))
(lambda (key . args)
(format #t "❌ Logging format test failed: ~a\n" key)))
;; Test config defaults (pure data)
(format #t "\n--- Testing utils/config/defaults (pure) ---\n")
(catch #t
(lambda ()
(use-modules (utils config defaults))
(let ((homelab-root (assoc-ref default-config 'homelab-root))
(machines (assoc-ref default-config 'machines)))
(format #t "✅ Default homelab root: ~a\n" homelab-root)
(format #t "✅ Default machines count: ~a\n" (length machines))
(format #t "✅ Pure config defaults work\n")))
(lambda (key . args)
(format #t "❌ Config defaults test failed: ~a\n" key)))
;; Test config accessor (pure functions)
(format #t "\n--- Testing utils/config/accessor (pure) ---\n")
(catch #t
(lambda ()
(use-modules (utils config defaults)
(utils config accessor))
(let* ((config default-config)
(homelab-root (get-config-value-pure config '(homelab-root)))
(machines (get-all-machines-pure config))
(first-machine (if (not (null? machines)) (car machines) "none")))
(format #t "✅ Pure config access: ~a\n" homelab-root)
(format #t "✅ Pure machine list: ~a machines\n" (length machines))
(format #t "✅ First machine: ~a\n" first-machine)
(format #t "✅ Pure config accessor functions work\n")))
(lambda (key . args)
(format #t "❌ Config accessor test failed: ~a\n" key)))
;; Test JSON parse (pure functions)
(format #t "\n--- Testing utils/json/parse (pure) ---\n")
(catch #t
(lambda ()
(use-modules (utils json parse))
(let ((test-json "{\"name\": \"test\", \"value\": 42}")
(invalid-json "{invalid"))
(let ((parsed-valid (parse-json-pure test-json))
(parsed-invalid (parse-json-pure invalid-json)))
(format #t "✅ Valid JSON parsed: ~a\n" (assoc-ref parsed-valid "name"))
(format #t "✅ Invalid JSON handled: ~a\n" (if parsed-invalid "ERROR" "OK"))
(format #t "✅ Pure JSON parsing functions work\n"))))
(lambda (key . args)
(format #t "❌ JSON parse test failed: ~a\n" key)))
;; Test JSON manipulation (pure functions)
(format #t "\n--- Testing utils/json/manipulation (pure) ---\n")
(catch #t
(lambda ()
(use-modules (utils json manipulation))
(let ((obj1 '((a . 1) (b . 2)))
(obj2 '((b . 3) (c . 4))))
(let ((merged (merge-json-objects obj1 obj2))
(value-at-path (json-path-ref '((level1 . ((level2 . "found")))) '(level1 level2))))
(format #t "✅ Merge result: ~a\n" (assoc-ref merged 'b))
(format #t "✅ Path access: ~a\n" value-at-path)
(format #t "✅ Pure JSON manipulation functions work\n"))))
(lambda (key . args)
(format #t "❌ JSON manipulation test failed: ~a\n" key))))
;; Test module facades
(define (test-facade-modules)
"Test facade modules that aggregate functionality"
(format #t "\n=== FACADE MODULE TESTS ===\n")
;; Test new logging facade
(format #t "\n--- Testing utils/logging (facade) ---\n")
(catch #t
(lambda ()
(use-modules (utils logging-new))
(log-info "Test info message")
(log-debug "Test debug message")
(set-log-level! 'debug)
(log-debug "Debug message after level change")
(format #t "✅ Logging facade works\n"))
(lambda (key . args)
(format #t "❌ Logging facade test failed: ~a\n" key)))
;; Test new config facade
(format #t "\n--- Testing utils/config (facade) ---\n")
(catch #t
(lambda ()
(use-modules (utils config-new))
(let ((machines (get-all-machines))
(homelab-root (get-homelab-root)))
(format #t "✅ Config facade - machines: ~a\n" (length machines))
(format #t "✅ Config facade - root: ~a\n" homelab-root)
(format #t "✅ Config facade works\n")))
(lambda (key . args)
(format #t "❌ Config facade test failed: ~a\n" key)))
;; Test new JSON facade
(format #t "\n--- Testing utils/json (facade) ---\n")
(catch #t
(lambda ()
(use-modules (utils json-new))
(let* ((test-obj '((name . "test") (count . 5)))
(json-str (scm->json-string test-obj))
(parsed-back (json-string->scm-safe json-str)))
(format #t "✅ JSON facade - serialization: ~a\n" (if json-str "OK" "FAIL"))
(format #t "✅ JSON facade - round-trip: ~a\n" (assoc-ref parsed-back 'name))
(format #t "✅ JSON facade works\n")))
(lambda (key . args)
(format #t "❌ JSON facade test failed: ~a\n" key))))
;; Test modular structure benefits
(define (test-modular-benefits)
"Test the benefits of modular structure"
(format #t "\n=== MODULAR BENEFITS TESTS ===\n")
;; Test pure function composition
(format #t "\n--- Testing Pure Function Composition ---\n")
(catch #t
(lambda ()
(use-modules (utils config defaults)
(utils config accessor)
(utils logging format))
;; Compose pure functions
(let* ((config default-config)
(machines (get-all-machines-pure config))
(first-machine (if (not (null? machines)) (car machines) #f))
(ssh-config (if first-machine
(get-ssh-config-pure config first-machine)
#f))
(timestamp (format-timestamp)))
(format #t "✅ Functional composition: ~a machines found\n" (length machines))
(format #t "✅ First machine SSH config: ~a\n"
(if ssh-config (assoc-ref ssh-config 'hostname) "none"))
(format #t "✅ Pure function pipeline works\n")))
(lambda (key . args)
(format #t "❌ Pure function composition failed: ~a\n" key)))
;; Test module independence
(format #t "\n--- Testing Module Independence ---\n")
(catch #t
(lambda ()
;; Each module should work independently
(use-modules (utils json parse))
(let ((result1 (parse-json-pure "{\"test\": 1}")))
(use-modules (utils json serialize))
(let ((result2 (scm->json-string-pure '((test . 2)) #f)))
(use-modules (utils logging format))
(let ((result3 (get-color 'green)))
(format #t "✅ Independent module 1: ~a\n" (if result1 "OK" "FAIL"))
(format #t "✅ Independent module 2: ~a\n" (if result2 "OK" "FAIL"))
(format #t "✅ Independent module 3: ~a\n" (if result3 "OK" "FAIL"))
(format #t "✅ Module independence verified\n")))))
(lambda (key . args)
(format #t "❌ Module independence test failed: ~a\n" key))))
;; Main test execution
(define (main)
(format #t "🧪 K.I.S.S MODULAR REFACTORING TEST SUITE\n")
(format #t "==========================================\n")
(test-pure-functions)
(test-facade-modules)
(test-modular-benefits)
;; Summary
(format #t "\n=== TEST SUMMARY ===\n")
(format #t "🎉 K.I.S.S modular refactoring tests complete!\n")
(format #t "\n📊 Refactoring Benefits Demonstrated:\n")
(format #t " ✅ Pure functions enable easy testing\n")
(format #t " ✅ Small modules are easy to understand\n")
(format #t " ✅ Single responsibility principle applied\n")
(format #t " ✅ Functional composition works\n")
(format #t " ✅ Module independence verified\n")
(format #t " ✅ Both pure and impure APIs available\n")
(format #t "\nRefactoring complete! ✨\n"))
;; Run the tests
(main)

View file

@ -0,0 +1,43 @@
#!/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")

View file

@ -0,0 +1,43 @@
;; 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.

View file

@ -0,0 +1,129 @@
;; utils/config.scm - Configuration management for Home Lab Tool
(define-module (utils config)
#:use-module (ice-9 format)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1)
#:use-module (utils logging)
#:use-module (utils json)
#:export (load-config
get-config-value
machine-configs
get-machine-config
get-all-machines
validate-machine-name
get-homelab-root
get-ssh-config))
;; Default configuration
(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")))))
;; Current loaded configuration
(define current-config default-config)
;; Load configuration from file or use defaults
(define (load-config . args)
(let ((config-file (if (null? args)
(string-append (getenv "HOME") "/.config/homelab/config.json")
(car args))))
(if (file-exists? config-file)
(begin
(log-debug "Loading configuration from ~a" config-file)
(catch #t
(lambda ()
(let ((json-data (call-with-input-file config-file get-string-all)))
(set! current-config (json-string->scm-safe json-data))
(log-info "Configuration loaded successfully")))
(lambda (key . args)
(log-warn "Failed to load config file, using defaults: ~a" key)
(set! current-config default-config))))
(begin
(log-debug "No config file found, using defaults")
(set! current-config default-config)))
current-config))
;; Get a configuration value by path
(define (get-config-value path . default)
(let ((result (fold (lambda (key acc)
(if (and acc (list? acc))
(assoc-ref acc key)
#f))
current-config path)))
(if result
result
(if (null? default) #f (car default)))))
;; Get machine configurations
(define (machine-configs)
(get-config-value '(machines)))
;; Get configuration for a specific machine
(define (get-machine-config machine-name)
(let ((machine-symbol (if (symbol? machine-name)
machine-name
(string->symbol machine-name))))
(assoc-ref (machine-configs) machine-symbol)))
;; Get list of all machine names
(define (get-all-machines)
(map (lambda (machine-entry)
(symbol->string (car machine-entry)))
(machine-configs)))
;; Validate that a machine name exists
(define (validate-machine-name machine-name)
(let ((machines (get-all-machines)))
(if (member machine-name machines)
#t
(begin
(log-error "Unknown machine: ~a" machine-name)
(log-error "Available machines: ~a" (string-join machines ", "))
#f))))
;; Get home lab root directory
(define (get-homelab-root)
(get-config-value '(homelab-root) "/home/geir/Home-lab"))
;; Get SSH configuration for a machine
(define (get-ssh-config machine-name)
(let ((machine-config (get-machine-config machine-name)))
(if machine-config
(let ((type (assoc-ref machine-config 'type))
(hostname (assoc-ref machine-config 'hostname))
(ssh-alias (assoc-ref machine-config 'ssh-alias)))
`((type . ,type)
(hostname . ,hostname)
(ssh-alias . ,ssh-alias)
(is-local . ,(eq? type 'local))))
#f)))
;; Initialize configuration on module load
(load-config)

View file

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

View file

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

View file

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

View file

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

View file

@ -0,0 +1,48 @@
;; 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.

View file

@ -0,0 +1,141 @@
;; utils/json.scm - JSON processing utilities for Home Lab Tool
(define-module (utils json)
#:use-module (json)
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (utils logging)
#:export (read-json-file
write-json-file
json-pretty-print
scm->json-string
json-string->scm-safe
validate-json-schema
merge-json-objects))
;; Read JSON from file with error handling
(define (read-json-file filename)
(catch #t
(lambda ()
(log-debug "Reading JSON file: ~a" filename)
(call-with-input-file filename
(lambda (port)
(json->scm port))))
(lambda (key . args)
(log-error "Failed to read JSON file ~a: ~a ~a" filename key args)
#f)))
;; Write Scheme object to JSON file
(define (write-json-file filename obj . options)
(let ((pretty (if (null? options) #t (car options))))
(catch #t
(lambda ()
(log-debug "Writing JSON file: ~a" filename)
(call-with-output-file filename
(lambda (port)
(if pretty
(scm->json obj port #:pretty #t)
(scm->json obj port))))
#t)
(lambda (key . args)
(log-error "Failed to write JSON file ~a: ~a ~a" filename key args)
#f))))
;; Pretty print JSON to current output port
(define (json-pretty-print obj)
(scm->json obj (current-output-port) #:pretty #t)
(newline))
;; Convert Scheme object to JSON string
(define (scm->json-string obj . options)
(let ((pretty (if (null? options) #f (car options))))
(catch #t
(lambda ()
(call-with-output-string
(lambda (port)
(if pretty
(scm->json obj port #:pretty #t)
(scm->json obj port)))))
(lambda (key . args)
(log-error "Failed to convert to JSON: ~a ~a" key args)
#f))))
;; Safely convert JSON string to Scheme with error handling
(define (json-string->scm-safe json-str)
(catch #t
(lambda ()
(json-string->scm json-str))
(lambda (key . args)
(log-error "Failed to parse JSON string: ~a ~a" key args)
#f)))
;; Basic JSON schema validation
(define (validate-json-schema obj schema)
"Validate JSON object against a simple schema.
Schema format: ((required-keys ...) (optional-keys ...) (types ...))"
(let ((required-keys (car schema))
(optional-keys (if (> (length schema) 1) (cadr schema) '()))
(type-specs (if (> (length schema) 2) (caddr schema) '())))
;; Check required keys
(let ((missing-keys (filter (lambda (key)
(not (assoc-ref obj key)))
required-keys)))
(if (not (null? missing-keys))
(begin
(log-error "Missing required keys: ~a" missing-keys)
#f)
(begin
;; Check types if specified
(let ((type-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)))
(if (not (null? type-errors))
(begin
(log-error "Type validation errors: ~a" type-errors)
#f)
#t)))))))
;; Merge two JSON objects (association lists)
(define (merge-json-objects obj1 obj2)
"Merge two JSON objects, with obj2 values taking precedence"
(let ((merged (copy-tree obj1)))
(for-each (lambda (pair)
(let ((key (car pair))
(value (cdr pair)))
(set! merged (assoc-set! merged key value))))
obj2)
merged))
;; Convert nested alist to flat key paths for easier access
(define (flatten-json-paths obj . prefix)
"Convert nested object to flat list of (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)))
;; Get nested value using path list
(define (json-path-ref obj path)
"Get value from nested object using list of keys as path"
(fold (lambda (key acc)
(if (and acc (list? acc))
(assoc-ref acc key)
#f))
obj path))

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -0,0 +1,67 @@
;; 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 '())))))

View file

@ -0,0 +1,42 @@
;; 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.

View file

@ -0,0 +1,91 @@
;; utils/logging.scm - Logging utilities for Home Lab Tool
(define-module (utils logging)
#:use-module (ice-9 format)
#:use-module (ice-9 popen)
#:use-module (srfi srfi-19)
#:export (log-debug
log-info
log-warn
log-error
log-success
set-log-level!
with-spinner))
;; 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")))
;; Current log level
(define current-log-level 'info)
;; Log levels with numeric values for comparison
(define log-levels
'((debug . 0)
(info . 1)
(warn . 2)
(error . 3)))
;; Get color code by name
(define (get-color name)
(assoc-ref color-codes name))
;; Set the current log level
(define (set-log-level! level)
(set! current-log-level level))
;; Check if a message should be logged at current level
(define (should-log? level)
(<= (assoc-ref log-levels current-log-level)
(assoc-ref log-levels level)))
;; Format timestamp for log messages
(define (format-timestamp)
(date->string (current-date) "~H:~M:~S"))
;; Core logging function with color support
(define (log-with-color level color prefix message . args)
(when (should-log? level)
(let ((timestamp (format-timestamp))
(formatted-msg (apply format #f message args))
(color-start (get-color color))
(color-end (get-color 'reset)))
(format (current-error-port) "~a~a[lab]~a ~a ~a~%"
color-start prefix color-end timestamp formatted-msg))))
;; Specific logging functions
(define (log-debug message . args)
(apply log-with-color 'debug 'cyan "DEBUG" message args))
(define (log-info message . args)
(apply log-with-color 'info 'blue "INFO " message args))
(define (log-warn message . args)
(apply log-with-color 'warn 'yellow "WARN " message args))
(define (log-error message . args)
(apply log-with-color 'error 'red "ERROR" message args))
(define (log-success message . args)
(apply log-with-color 'info 'green "SUCCESS" message args))
;; Spinner utility for long-running operations
(define (with-spinner message thunk)
(log-info "~a..." message)
(let ((start-time (current-time)))
(catch #t
(lambda ()
(let ((result (thunk)))
(let ((elapsed (- (current-time) start-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)))))

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -0,0 +1,27 @@
;; 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.

View file

@ -0,0 +1,138 @@
;; utils/ssh.scm - SSH operations for Home Lab Tool
(define-module (utils ssh)
#:use-module (ssh session)
#:use-module (ssh channel)
#:use-module (ssh popen)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1)
#:use-module (utils logging)
#:use-module (utils config)
#:export (test-ssh-connection
run-remote-command
copy-file-to-remote
run-command-with-retry
with-ssh-connection))
;; Test SSH connectivity to a machine
(define (test-ssh-connection machine-name)
(let ((ssh-config (get-ssh-config machine-name)))
(if (not ssh-config)
(begin
(log-error "No SSH configuration found for ~a" machine-name)
#f)
(if (assoc-ref ssh-config 'is-local)
(begin
(log-debug "Machine ~a is local, skipping SSH test" machine-name)
#t)
(let ((hostname (assoc-ref ssh-config 'hostname))
(ssh-alias (assoc-ref ssh-config 'ssh-alias)))
(log-debug "Testing SSH connection to ~a (~a)" machine-name hostname)
(catch #t
(lambda ()
;; Use system ssh command for compatibility with existing configuration
(let* ((test-cmd (if ssh-alias
(format #f "ssh -o ConnectTimeout=5 -o BatchMode=yes ~a echo OK" ssh-alias)
(format #f "ssh -o ConnectTimeout=5 -o BatchMode=yes ~a echo OK" hostname)))
(port (open-pipe* OPEN_READ "/bin/sh" "-c" test-cmd))
(output (get-string-all port))
(status (close-pipe port)))
(if (zero? status)
(begin
(log-debug "SSH connection to ~a successful" machine-name)
#t)
(begin
(log-warn "SSH connection to ~a failed (exit: ~a)" machine-name status)
#f))))
(lambda (key . args)
(log-error "SSH test failed for ~a: ~a ~a" machine-name key args)
#f)))))))
;; Run a command on a remote machine
(define (run-remote-command machine-name command . args)
(let ((ssh-config (get-ssh-config machine-name))
(full-command (if (null? args)
command
(format #f "~a ~a" command (string-join args " ")))))
(if (not ssh-config)
(values #f "No SSH configuration found")
(if (assoc-ref ssh-config 'is-local)
;; Local execution
(begin
(log-debug "Executing locally: ~a" full-command)
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" full-command))
(output (get-string-all port))
(status (close-pipe port)))
(values (zero? status) output)))
;; Remote execution
(let ((ssh-alias (assoc-ref ssh-config 'ssh-alias))
(hostname (assoc-ref ssh-config 'hostname)))
(log-debug "Executing on ~a: ~a" machine-name full-command)
(let* ((ssh-cmd (format #f "ssh ~a '~a'"
(or ssh-alias hostname)
full-command))
(port (open-pipe* OPEN_READ "/bin/sh" "-c" ssh-cmd))
(output (get-string-all port))
(status (close-pipe port)))
(values (zero? status) output)))))))
;; Copy file to remote machine using scp
(define (copy-file-to-remote machine-name local-path remote-path)
(let ((ssh-config (get-ssh-config machine-name)))
(if (not ssh-config)
(begin
(log-error "No SSH configuration found for ~a" machine-name)
#f)
(if (assoc-ref ssh-config 'is-local)
;; Local copy
(begin
(log-debug "Copying locally: ~a -> ~a" local-path remote-path)
(let* ((copy-cmd (format #f "cp '~a' '~a'" local-path remote-path))
(status (system copy-cmd)))
(zero? status)))
;; Remote copy
(let ((ssh-alias (assoc-ref ssh-config 'ssh-alias))
(hostname (assoc-ref ssh-config 'hostname)))
(log-debug "Copying to ~a: ~a -> ~a" machine-name local-path remote-path)
(let* ((scp-cmd (format #f "scp '~a' '~a:~a'"
local-path
(or ssh-alias hostname)
remote-path))
(status (system scp-cmd)))
(if (zero? status)
(begin
(log-debug "File copy successful")
#t)
(begin
(log-error "File copy failed (exit: ~a)" status)
#f))))))))
;; Run command with retry logic
(define (run-command-with-retry machine-name command max-retries . args)
(let loop ((retries 0))
(call-with-values
(lambda () (apply run-remote-command machine-name command args))
(lambda (success output)
(if success
(values #t output)
(if (< retries max-retries)
(begin
(log-warn "Command failed, retrying (~a/~a)..." (+ retries 1) max-retries)
(sleep 2)
(loop (+ retries 1)))
(values #f output)))))))
;; Execute a thunk with SSH connection context
(define (with-ssh-connection machine-name thunk)
(if (test-ssh-connection machine-name)
(catch #t
(lambda () (thunk))
(lambda (key . args)
(log-error "SSH operation failed: ~a ~a" key args)
#f))
(begin
(log-error "Cannot establish SSH connection to ~a" machine-name)
#f)))

View file

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

View file

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

View file

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

View file

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

View file

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