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

moved some files to archive

Browse source
This commit is contained in:
Geir Okkenhaug Jerstad 2025-07-07 14:20:29 +02:00
parent ef4b4b7736
commit db9fadcb0a
25 changed files with 15 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

35
packages/lab-tool/archive/lab-old/config/config.scm Normal file
View file

@ -0,0 +1,35 @@
;; 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"
(let ((hostname (symbol->string machine-name)))
`((hostname . ,hostname)
(user . "sma")
(identity-file . "~/.ssh/id_ed25519_admin")
(is-local . #f)))
(define (get-homelab-root)
"Get home lab root directory"
"/home/geir/Home-lab")

26
packages/lab-tool/archive/lab-old/config/lab-auto-update.service Normal file
View file

@ -0,0 +1,26 @@
[Unit]
Description=Home Lab Auto-Update Service
After=network-online.target
Wants=network-online.target
[Service]
Type=oneshot
User=root
WorkingDirectory=/home/geir/Home-lab
ExecStart=/run/current-system/sw/bin/lab auto-update
Environment=HOME=/root
Environment=PATH=/run/current-system/sw/bin:/usr/bin:/bin
# Logging
StandardOutput=journal
StandardError=journal
SyslogIdentifier=lab-auto-update
# Security settings
NoNewPrivileges=true
ProtectSystem=false
ProtectHome=false
PrivateTmp=true
[Install]
WantedBy=multi-user.target

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

141
packages/lab-tool/archive/lab-old/utils/json.scm Normal file
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))

92
packages/lab-tool/archive/lab-old/utils/logging.scm Normal file
View file

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

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

@ -0,0 +1,188 @@
;; utils/ssh.scm - SSH operations for Home Lab Tool
;; Refactored using functional programming principles
(define-module (utils ssh)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (utils logging)
#:use-module (utils config)
#:use-module (io ssh)
#:use-module (io shell)
#:export (test-ssh-connection
run-remote-command
copy-file-to-remote
run-command-with-retry
with-ssh-connection))
;; Test SSH connectivity to a machine
(define (test-ssh-connection machine-name)
"Test SSH connectivity using functional composition"
(let ((ssh-config (get-ssh-config machine-name)))
(cond
((not ssh-config)
(log-error "No SSH configuration found for ~a" machine-name)
#f)
((assoc-ref ssh-config 'is-local)
(log-debug "Machine ~a is local, skipping SSH test" machine-name)
#t)
(else
(test-remote-ssh-connection machine-name ssh-config)))))
;; Helper: Test remote SSH connection
(define (test-remote-ssh-connection machine-name ssh-config)
"Test remote SSH connection with error handling"
(let* ((hostname (assoc-ref ssh-config 'hostname))
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
(user (assoc-ref ssh-config 'user))
(identity-file (assoc-ref ssh-config 'identity-file))
(target (make-ssh-target user (or ssh-alias hostname)))
(options (make-ssh-options identity-file 5))
(test-cmd (build-ssh-command target options "echo OK")))
(log-debug "Testing SSH connection to ~a (~a) as ~a using key ~a"
machine-name hostname user identity-file)
(catch #t
(lambda ()
(let ((result (execute-with-output test-cmd)))
(if (car result)
(begin
(log-debug "SSH connection to ~a successful" machine-name)
#t)
(begin
(log-warn "SSH connection to ~a failed" machine-name)
#f))))
(lambda (key . args)
(log-error "SSH test failed for ~a: ~a ~a" machine-name key args)
#f))))
;; Run a command on a remote machine
(define (run-remote-command machine-name command . args)
"Run command remotely using functional composition"
(let ((ssh-config (get-ssh-config machine-name))
(full-command (build-full-command command args)))
(cond
((not ssh-config)
(values #f "No SSH configuration found"))
((assoc-ref ssh-config 'is-local)
(execute-local-command full-command))
(else
(execute-remote-command machine-name ssh-config full-command)))))
;; Helper: Build full command string
(define (build-full-command command args)
"Build complete command string from command and arguments"
(if (null? args)
command
(format #f "~a ~a" command (string-join args " "))))
;; Helper: Execute command locally
(define (execute-local-command command)
"Execute command locally and return (success . output)"
(log-debug "Executing locally: ~a" command)
(let ((result (execute-with-output command)))
(values (car result) (cdr result))))
;; Helper: Execute command remotely
(define (execute-remote-command machine-name ssh-config command)
"Execute command remotely using SSH"
(let* ((hostname (assoc-ref ssh-config 'hostname))
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
(user (assoc-ref ssh-config 'user))
(identity-file (assoc-ref ssh-config 'identity-file))
(target (make-ssh-target user (or ssh-alias hostname)))
(options (make-ssh-options identity-file #f))
(ssh-cmd (build-ssh-command target options command)))
(log-debug "Executing remotely on ~a: ~a" machine-name command)
(catch #t
(lambda ()
(let ((result (execute-with-output ssh-cmd)))
(values (car result) (cdr result))))
(lambda (key . args)
(log-error "SSH command failed for ~a: ~a ~a" machine-name key args)
(values #f "")))))
;; Copy file to remote machine using scp
(define (copy-file-to-remote machine-name local-path remote-path)
"Copy file to remote machine using functional composition"
(let ((ssh-config (get-ssh-config machine-name)))
(cond
((not ssh-config)
(log-error "No SSH configuration found for ~a" machine-name)
#f)
((assoc-ref ssh-config 'is-local)
(copy-file-locally local-path remote-path))
(else
(copy-file-remotely machine-name ssh-config local-path remote-path)))))
;; Helper: Copy file locally
(define (copy-file-locally local-path remote-path)
"Copy file locally using cp command"
(log-debug "Copying locally: ~a -> ~a" local-path remote-path)
(let ((copy-cmd (format #f "cp '~a' '~a'" local-path remote-path)))
(execute-command copy-cmd)))
;; Helper: Copy file remotely
(define (copy-file-remotely machine-name ssh-config local-path remote-path)
"Copy file remotely using scp command"
(let* ((hostname (assoc-ref ssh-config 'hostname))
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
(user (assoc-ref ssh-config 'user))
(identity-file (assoc-ref ssh-config 'identity-file))
(target (make-ssh-target user (or ssh-alias hostname)))
(options (make-ssh-options identity-file #f))
(scp-cmd (format #f "scp ~a '~a' '~a:~a'" options local-path target remote-path)))
(log-debug "Copying to ~a: ~a -> ~a as ~a using key ~a"
machine-name local-path remote-path user identity-file)
(let ((success (execute-command scp-cmd)))
(if success
(begin
(log-debug "File copy successful")
#t)
(begin
(log-error "File copy failed")
#f)))))
;; Run command with retry logic
(define (run-command-with-retry machine-name command max-retries . args)
"Run command with retry logic using functional recursion"
(retry-command machine-name command max-retries 0 args))
;; Helper: Retry command implementation
(define (retry-command machine-name command max-retries current-retry args)
"Recursive retry implementation"
(call-with-values
(lambda () (apply run-remote-command machine-name command args))
(lambda (success output)
(cond
(success
(values #t output))
((< current-retry max-retries)
(log-warn "Command failed, retrying (~a/~a)..." (+ current-retry 1) max-retries)
(sleep 2)
(retry-command machine-name command max-retries (+ current-retry 1) args))
(else
(values #f output))))))
;; Execute a thunk with SSH connection context
(define (with-ssh-connection machine-name thunk)
"Execute thunk with SSH connection context using functional composition"
(cond
((test-ssh-connection machine-name)
(execute-with-ssh-context thunk machine-name))
(else
(log-error "Cannot establish SSH connection to ~a" machine-name)
#f)))
;; Helper: Execute thunk with error handling
(define (execute-with-ssh-context thunk machine-name)
"Execute thunk with proper error handling"
(catch #t
(lambda () (thunk))
(lambda (key . args)
(log-error "SSH operation failed: ~a ~a" key args)
#f)))

282
packages/lab-tool/archive/lab/auto-update.scm Normal file
View file

@ -0,0 +1,282 @@
;; lab/auto-update.scm - Auto-update system implementation
(define-module (lab auto-update)
#:use-module (ice-9 format)
#:use-module (ice-9 popen)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19) ; Date/time
#:use-module (utils logging)
#:use-module (utils config)
#:use-module (lab deployment)
#:use-module (lab machines)
#:export (auto-update-system
schedule-auto-update
check-update-health
auto-update-status
get-update-order
update-single-machine))
;; Helper function for option handling (duplicated from deployment module)
(define (option-ref options key default)
"Get option value with default fallback"
(let ((value (assoc-ref options key)))
(if value value default)))
;; Pure function: Generate update log entry
(define (format-update-log-entry timestamp operation status details)
"Pure function to format update log entry"
(format #f "~a: ~a - ~a (~a)" timestamp operation status details))
;; Pure function: Check if system is healthy for updates
(define (system-health-check-pure)
"Pure function returning health check criteria"
'((disk-space-threshold . 90)
(required-services . ("systemd"))
(min-uptime-minutes . 30)))
;; Impure function: Check actual system health
(define (check-update-health)
"Check if system is ready for updates (impure - checks actual system)"
(log-info "Checking system health before update...")
(let* ((health-checks (system-health-check-pure))
(disk-threshold (assoc-ref health-checks 'disk-space-threshold))
(disk-usage (get-disk-usage))
(system-running (system-is-running?))
(uptime-ok (check-minimum-uptime)))
(log-debug "Disk usage: ~a%" disk-usage)
(log-debug "System running: ~a" system-running)
(log-debug "Uptime check: ~a" uptime-ok)
(cond
((> disk-usage disk-threshold)
(log-error "Disk usage too high: ~a% (threshold: ~a%)" disk-usage disk-threshold)
#f)
((not system-running)
(log-error "System not in running state")
#f)
((not uptime-ok)
(log-error "System uptime too low for safe update")
#f)
(else
(log-success "System health check passed")
#t))))
;; Impure function: Get disk usage percentage
(define (get-disk-usage)
"Get root filesystem disk usage percentage"
(let* ((cmd "df / | tail -1 | awk '{print $5}' | sed 's/%//'")
(port (open-pipe* OPEN_READ "/bin/sh" "-c" cmd))
(output (string-trim-both (get-string-all port)))
(status (close-pipe port)))
(if (zero? status)
(string->number output)
95))) ; Return high usage if command fails
;; Impure function: Check if systemd is running
(define (system-is-running?)
"Check if system is in running state"
(let* ((cmd "systemctl is-system-running --quiet")
(status (system cmd)))
(zero? status)))
;; Impure function: Check minimum uptime
(define (check-minimum-uptime)
"Check if system has been running long enough"
(let* ((cmd "cat /proc/uptime | cut -d' ' -f1")
(port (open-pipe* OPEN_READ "/bin/sh" "-c" cmd))
(output (string-trim-both (get-string-all port)))
(status (close-pipe port)))
(if (zero? status)
(let ((uptime-seconds (string->number output)))
(> uptime-seconds 1800)) ; 30 minutes minimum
#f)))
;; Impure function: Write update log
(define (write-update-log operation status details)
"Write update operation to log file"
(let* ((timestamp (date->string (current-date) "~Y-~m-~d ~H:~M:~S"))
(log-entry (format-update-log-entry timestamp operation status details))
(log-file "/var/log/lab-auto-update.log"))
(catch #t
(lambda ()
(call-with-output-file log-file
(lambda (port)
(format port "~a\n" log-entry))
#:append #t))
(lambda (key . args)
(log-error "Failed to write update log: ~a" args)))))
;; Pure function: Determine update order for machines
(define (get-update-order)
"Get machines in update order - orchestrator last"
(let* ((all-machines (get-all-machines))
(current-machine (get-hostname))
(remote-machines (filter (lambda (machine)
(let* ((machine-str (if (symbol? machine)
(symbol->string machine)
machine))
(config (get-machine-config machine)))
(and config
(not (equal? machine-str current-machine))
(not (eq? 'local (assoc-ref config 'type))))))
all-machines))
(local-machines (filter (lambda (machine)
(let* ((machine-str (if (symbol? machine)
(symbol->string machine)
machine))
(config (get-machine-config machine)))
(or (equal? machine-str current-machine)
(eq? 'local (assoc-ref config 'type)))))
all-machines)))
;; Return remote machines first, then local/orchestrator machines
(append remote-machines local-machines)))
;; Impure function: Update a single machine with error handling
(define (update-single-machine machine-name options)
"Update a single machine with proper error handling"
(let* ((machine-str (if (symbol? machine-name)
(symbol->string machine-name)
machine-name))
(is-local (equal? machine-str (get-hostname))))
(log-info "Updating machine: ~a" machine-str)
(write-update-log "machine-update" "started" machine-str)
(catch #t
(lambda ()
(let ((deploy-result (deploy-machine machine-str "switch" options)))
(if deploy-result
(begin
(log-success "Successfully updated ~a" machine-str)
(write-update-log "machine-update" "success" machine-str)
#t)
(begin
(log-error "Failed to update ~a" machine-str)
(write-update-log "machine-update" "failed" machine-str)
#f))))
(lambda (key . args)
(log-error "Exception updating ~a: ~a ~a" machine-str key args)
(write-update-log "machine-update" "error" (format #f "~a: ~a" machine-str key))
#f))))
;; Impure function: Orchestrated auto-update routine
(define (auto-update-system . args)
"Perform orchestrated automatic system update (impure - modifies system)"
(let* ((options (if (null? args) '() (car args)))
(auto-reboot (option-ref options 'auto-reboot #t))
(dry-run (option-ref options 'dry-run #f))
(parallel (option-ref options 'parallel #f))
(current-machine (get-hostname))
(update-order (get-update-order)))
(log-info "Starting orchestrated auto-update from: ~a" current-machine)
(log-info "Update order: ~a" (map (lambda (m) (if (symbol? m) (symbol->string m) m)) update-order))
(write-update-log "orchestrated-update" "started" current-machine)
(if (not (check-update-health))
(begin
(log-error "System health check failed - aborting update")
(write-update-log "orchestrated-update" "aborted" "health check failed")
#f)
(begin
;; Update flake inputs first
(log-info "Updating flake inputs...")
(let ((flake-result (update-flake options)))
(if flake-result
(begin
(log-success "Flake update completed")
(write-update-log "flake-update" "success" "")
;; Update machines in order
(let ((update-results (map (lambda (machine)
(update-single-machine machine options))
update-order)))
(let* ((successful-updates (filter identity update-results))
(failed-updates (- (length update-results) (length successful-updates)))
(all-success (= failed-updates 0)))
(log-info "Update summary: ~a successful, ~a failed"
(length successful-updates) failed-updates)
(if all-success
(begin
(log-success "All machines updated successfully")
(write-update-log "orchestrated-update" "success"
(format #f "~a machines" (length successful-updates)))
;; Schedule reboot of orchestrator if enabled and it was updated
(if (and auto-reboot (not dry-run)
(member current-machine
(map (lambda (m) (if (symbol? m) (symbol->string m) m))
update-order)))
(begin
(log-info "Scheduling orchestrator reboot in 2 minutes...")
(write-update-log "reboot" "scheduled" "orchestrator - 2 minutes")
(system "shutdown -r +2 'Orchestrated auto-update completed - rebooting'")
#t)
(begin
(log-info "Orchestrated update complete - no reboot needed")
(write-update-log "orchestrated-update" "completed" "no reboot")
#t)))
(begin
(log-warn "Some machines failed to update (~a failures)" failed-updates)
(write-update-log "orchestrated-update" "partial-failure"
(format #f "~a failures" failed-updates))
;; Don't reboot orchestrator if there were failures
#f)))))
(begin
(log-error "Flake update failed")
(write-update-log "flake-update" "failed" "")
#f)))))))
;; Impure function: Get current hostname
(define (get-hostname)
"Get current system hostname"
(let* ((cmd "hostname")
(port (open-pipe* OPEN_READ "/bin/sh" "-c" cmd))
(output (string-trim-both (get-string-all port)))
(status (close-pipe port)))
(if (zero? status)
output
"unknown")))
;; Impure function: Show auto-update status
(define (auto-update-status)
"Display auto-update service status and recent logs"
(log-info "Checking auto-update status...")
(let ((log-file "/var/log/lab-auto-update.log"))
(if (file-exists? log-file)
(begin
(format #t "Recent auto-update activity:\n")
(let* ((cmd (format #f "tail -10 ~a" log-file))
(port (open-pipe* OPEN_READ "/bin/sh" "-c" cmd))
(output (get-string-all port))
(status (close-pipe port)))
(if (zero? status)
(display output)
(log-error "Failed to read update log"))))
(log-info "No auto-update log found"))
;; Check systemd timer status
(format #t "\nSystemd timer status:\n")
(let* ((cmd "systemctl status lab-auto-update.timer --no-pager")
(port (open-pipe* OPEN_READ "/bin/sh" "-c" cmd))
(output (get-string-all port))
(status (close-pipe port)))
(display output))))
;; Impure function: Schedule auto-update (for manual testing)
(define (schedule-auto-update minutes)
"Schedule auto-update to run in specified minutes"
(let ((schedule-cmd (format #f "echo 'lab auto-update' | at now + ~a minutes" minutes)))
(log-info "Scheduling auto-update in ~a minutes..." minutes)
(let ((status (system schedule-cmd)))
(if (zero? status)
(log-success "Auto-update scheduled successfully")
(log-error "Failed to schedule auto-update")))))

18
packages/lab-tool/archive/lab/core.scm Normal file
View file

@ -0,0 +1,18 @@
;; lab/core.scm - Core infrastructure operations (impure)
(define-module (lab core)
#:use-module (utils config)
#:use-module (utils ssh)
#:use-module (utils logging)
#:export (get-infrastructure-status))
;; Impure function: Get infrastructure status with side effects
(define (get-infrastructure-status)
"Get status of all machines (impure - has logging side effects)"
(log-info "Checking infrastructure status...")
(let ((machines (get-all-machines)))
(map (lambda (machine)
(let ((status (test-ssh-connection machine)))
`((machine . ,machine)
(status . ,(if status 'online 'offline)))))
machines)))

140
packages/lab-tool/archive/lab/deploy-rs.scm Normal file
View file

@ -0,0 +1,140 @@
;; lab/deploy-rs.scm - Deploy-rs based deployment operations (extracted)
(define-module (lab deploy-rs)
#:use-module (ice-9 format)
#:use-module (ice-9 popen)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1)
#:use-module (utils logging)
#:use-module (utils config)
#:export (deploy-machine-deploy-rs
deploy-all-machines-deploy-rs
deploy-with-rollback
option-ref))
;; Helper function for option handling
(define (option-ref options key default)
"Get option value with default fallback"
(let ((value (assoc-ref options key)))
(if value value default)))
;; Main deployment function using deploy-rs
(define (deploy-machine-deploy-rs machine-name . args)
"Deploy configuration to machine using deploy-rs (impure - has side effects)"
(let* ((mode (if (null? args) "default" (car args)))
(options (if (< (length args) 2) '() (cadr args)))
(dry-run (option-ref options 'dry-run #f))
(skip-checks (option-ref options 'skip-checks #f)))
(if (not (validate-machine-name machine-name))
#f
(begin
(log-info "Starting deploy-rs deployment: ~a" machine-name)
(execute-deploy-rs machine-name mode options)))))
;; Execute deploy-rs deployment
(define (execute-deploy-rs machine-name mode options)
"Execute deployment using deploy-rs with automatic rollback"
(let* ((homelab-root (get-homelab-root))
(dry-run (option-ref options 'dry-run #f))
(skip-checks (option-ref options 'skip-checks #f))
(auto-rollback (option-ref options 'auto-rollback #t))
(magic-rollback (option-ref options 'magic-rollback #t)))
(log-info "Deploying ~a using deploy-rs..." machine-name)
(if dry-run
(begin
(log-info "DRY RUN: Would execute deploy-rs for ~a" machine-name)
(log-info "Command would be: deploy '.#~a'" machine-name)
#t)
(let* ((deploy-cmd (build-deploy-command machine-name skip-checks auto-rollback magic-rollback))
(start-time (current-time)))
(log-info "Deploy command: ~a" deploy-cmd)
(log-info "Executing deployment with automatic rollback protection...")
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" deploy-cmd))
(output (get-string-all port))
(status (close-pipe port))
(elapsed (- (current-time) start-time)))
(if (zero? status)
(begin
(log-success "Deploy-rs deployment completed successfully in ~as" elapsed)
(log-info "Deployment output:")
(log-info "~a" output)
#t)
(begin
(log-error "Deploy-rs deployment failed (exit: ~a)" status)
(log-error "Error output:")
(log-error "~a" output)
(log-info "Deploy-rs automatic rollback should have been triggered")
#f)))))))
;; Build deploy-rs command with options
(define (build-deploy-command machine-name skip-checks auto-rollback magic-rollback)
"Build the deploy-rs command with appropriate flags"
(let ((base-cmd (format #f "cd ~a && deploy '.#~a'" (get-homelab-root) machine-name))
(flags '()))
;; Add flags based on options
(when skip-checks
(set! flags (cons "--skip-checks" flags)))
(when auto-rollback
(set! flags (cons "--auto-rollback=true" flags)))
(when magic-rollback
(set! flags (cons "--magic-rollback=true" flags)))
;; Combine command with flags
(if (null? flags)
base-cmd
(format #f "~a ~a" base-cmd (string-join (reverse flags) " ")))))
;; Deploy to all machines
(define (deploy-all-machines-deploy-rs . args)
"Deploy to all machines using deploy-rs"
(let* ((options (if (null? args) '() (car args)))
(dry-run (option-ref options 'dry-run #f))
(machines (get-all-machines)))
(log-info "Starting deployment to all machines (~a total)" (length machines))
(let ((results
(map (lambda (machine)
(log-info "Deploying to ~a..." machine)
(let ((result (deploy-machine-deploy-rs machine "default" options)))
(if result
(log-success "✓ ~a deployed successfully" machine)
(log-error "✗ ~a deployment failed" machine))
(cons machine result)))
machines)))
;; Summary
(let ((successful (filter cdr results))
(failed (filter (lambda (r) (not (cdr r))) results)))
(log-info "Deployment summary:")
(log-info " Successful: ~a/~a machines" (length successful) (length machines))
(when (not (null? failed))
(log-error " Failed: ~a" (string-join (map car failed) ", ")))
;; Return true if all succeeded
(= (length successful) (length machines))))))
;; Deploy with explicit rollback testing
(define (deploy-with-rollback machine-name . args)
"Deploy with explicit rollback capability testing"
(let* ((options (if (null? args) '() (car args)))
(test-rollback (option-ref options 'test-rollback #f)))
(log-info "Deploying ~a with rollback testing..." machine-name)
(if test-rollback
(begin
(log-info "Testing rollback mechanism (deploy will be reverted)")
;; Deploy with magic rollback disabled to test manual rollback
(let ((modified-options (cons '(magic-rollback . #f) options)))
(execute-deploy-rs machine-name "default" modified-options)))
(execute-deploy-rs machine-name "default" options))))

66
packages/lab-tool/archive/lab/deployment.scm Normal file
View file

@ -0,0 +1,66 @@
;; lab/deployment.scm - Unified deployment operations (SSH + rsync by default)
(define-module (lab deployment)
#:use-module (ice-9 format)
#:use-module (ice-9 popen)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1)
#:use-module (utils logging)
#:use-module (utils config)
#:use-module (lab ssh-deploy)
#:use-module (lab deploy-rs)
#:export (deploy-machine
update-flake
deploy-all-machines
deploy-with-rollback
option-ref))
;; Helper function for option handling (re-exported from ssh-deploy)
(define (option-ref options key default)
"Get option value with default fallback"
(let ((value (assoc-ref options key)))
(if value value default)))
;; Main deployment function - SSH by default, deploy-rs optional
(define (deploy-machine machine-name . args)
"Deploy configuration to machine using SSH + rsync (default) or deploy-rs (optional)"
(let* ((mode (if (null? args) "default" (car args)))
(options (if (< (length args) 2) '() (cadr args)))
(use-deploy-rs (option-ref options 'use-deploy-rs #f)))
(if (not (validate-machine-name machine-name))
#f
(if use-deploy-rs
(begin
(log-info "Using deploy-rs deployment method")
(deploy-machine-deploy-rs machine-name mode options))
(begin
(log-info "Using SSH + rsync deployment method")
(deploy-machine-ssh machine-name mode options))))))
;; Deploy to all machines - delegate to appropriate module
(define (deploy-all-machines . args)
"Deploy to all machines using SSH + rsync (default) or deploy-rs (optional)"
(let* ((options (if (null? args) '() (car args)))
(use-deploy-rs (option-ref options 'use-deploy-rs #f)))
(if use-deploy-rs
(begin
(log-info "Using deploy-rs for all machines")
(deploy-all-machines-deploy-rs options))
(begin
(log-info "Using SSH + rsync for all machines")
(deploy-all-machines-ssh options)))))
;; Deploy with rollback testing - only available with deploy-rs
(define (deploy-with-rollback machine-name . args)
"Deploy with explicit rollback capability testing (deploy-rs only)"
(let* ((options (if (null? args) '() (car args)))
(modified-options (cons '(use-deploy-rs . #t) options)))
(log-info "Rollback testing requires deploy-rs - switching to deploy-rs mode")
(deploy-with-rollback machine-name modified-options)))
;; Update flake inputs - delegate to ssh-deploy module
(define update-flake
(@ (lab ssh-deploy) update-flake))

52
packages/lab-tool/archive/lab/machines.scm Normal file
View file

@ -0,0 +1,52 @@
;; lab/machines.scm - Machine management (impure)
(define-module (lab machines)
#:use-module (utils config)
#:use-module (utils logging)
#:use-module (utils ssh)
#:export (list-machines
get-machine-info
check-machine-health
discover-machines))
;; Impure function: List all machines with logging
(define (list-machines)
"List all configured machines (impure - has logging side effects)"
(log-debug "Listing machines...")
(get-all-machines))
;; Impure function: Get machine information
(define (get-machine-info machine-name)
"Get detailed machine information (impure - has logging side effects)"
(log-debug "Getting info for machine: ~a" machine-name)
(let ((config (get-machine-config machine-name))
(ssh-config (get-ssh-config machine-name)))
(if config
`((name . ,machine-name)
(config . ,config)
(ssh . ,ssh-config))
#f)))
;; Impure function: Check machine health
(define (check-machine-health machine-name)
"Check machine health status (impure - has side effects)"
(log-debug "Checking health for ~a..." machine-name)
(let* ((ssh-status (test-ssh-connection machine-name))
(config (get-machine-config machine-name))
(services (if config (assoc-ref config 'services) '())))
`((machine . ,machine-name)
(ssh-connectivity . ,ssh-status)
(services-configured . ,(length services))
(status . ,(if ssh-status 'healthy 'unhealthy)))))
;; Impure function: Discover machines on network
(define (discover-machines)
"Discover machines on the network (impure - has side effects)"
(log-info "Discovering machines...")
(let ((machines (list-machines)))
(map (lambda (machine)
(let ((health (check-machine-health machine)))
(log-debug "Machine ~a: ~a" machine (assoc-ref health 'status))
health))
machines)))

12
packages/lab-tool/archive/lab/monitoring.scm Normal file
View file

@ -0,0 +1,12 @@
;; lab/monitoring.scm - Infrastructure monitoring (impure)
(define-module (lab monitoring)
#:use-module (utils logging)
#:export (monitor-infrastructure))
;; Impure function: Monitor infrastructure health
(define (monitor-infrastructure)
"Monitor infrastructure health (impure - has side effects)"
(log-info "Starting infrastructure monitoring...")
(log-warn "Monitoring not yet implemented")
#f)

198
packages/lab-tool/archive/lab/ssh-deploy.scm Normal file
View file

@ -0,0 +1,198 @@
;; lab/ssh-deploy.scm - SSH + rsync + nixos-rebuild deployment operations
(define-module (lab ssh-deploy)
#:use-module (ice-9 format)
#:use-module (ice-9 popen)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1)
#:use-module (utils logging)
#:use-module (utils config)
#:use-module (utils ssh)
#:export (deploy-machine-ssh
deploy-all-machines-ssh
update-flake
sync-config-to-machine
option-ref))
;; Helper function for option handling
(define (option-ref options key default)
"Get option value with default fallback"
(let ((value (assoc-ref options key)))
(if value value default)))
;; Main SSH deployment function
(define (deploy-machine-ssh machine-name . args)
"Deploy configuration to machine using SSH + rsync + nixos-rebuild"
(let* ((mode (if (null? args) "default" (car args)))
(options (if (< (length args) 2) '() (cadr args)))
(dry-run (option-ref options 'dry-run #f))
(boot-mode (option-ref options 'boot #f)))
(if (not (validate-machine-name machine-name))
#f
(begin
(log-info "Starting SSH deployment: ~a" machine-name)
(execute-ssh-deploy machine-name mode options)))))
;; Execute SSH-based deployment
(define (execute-ssh-deploy machine-name mode options)
"Execute deployment using SSH + rsync + nixos-rebuild"
(let* ((homelab-root (get-homelab-root))
(dry-run (option-ref options 'dry-run #f))
(boot-mode (option-ref options 'boot #f))
(test-mode (option-ref options 'test #f))
(remote-path "/tmp/home-lab-config"))
(log-info "Deploying ~a using SSH + rsync + nixos-rebuild..." machine-name)
(if dry-run
(begin
(log-info "DRY RUN: Would sync config and rebuild ~a" machine-name)
(log-info "Would execute: rsync + nixos-rebuild --flake /tmp/home-lab-config#~a" machine-name)
#t)
(let ((start-time (current-time)))
;; Step 1: Sync configuration to remote machine
(log-info "Step 1: Syncing configuration to ~a:~a" machine-name remote-path)
(if (sync-config-to-machine machine-name remote-path)
;; Step 2: Execute nixos-rebuild on remote machine
(begin
(log-info "Step 2: Executing nixos-rebuild on ~a" machine-name)
(execute-remote-rebuild machine-name remote-path boot-mode test-mode start-time))
(begin
(log-error "Failed to sync configuration to ~a" machine-name)
#f))))))
;; Sync configuration to remote machine
(define (sync-config-to-machine machine-name remote-path)
"Sync Home-lab configuration to remote machine using rsync"
(let* ((homelab-root (get-homelab-root))
(ssh-config (get-ssh-config machine-name)))
(if (not ssh-config)
(begin
(log-error "No SSH configuration found for ~a" machine-name)
#f)
(if (assoc-ref ssh-config 'is-local)
;; Local "sync" - just ensure path exists
(begin
(log-debug "Local machine ~a, copying to ~a" machine-name remote-path)
(let* ((cp-cmd (format #f "sudo mkdir -p ~a && sudo cp -r ~a/* ~a/"
remote-path homelab-root remote-path))
(status (system cp-cmd)))
(if (zero? status)
(begin
(log-debug "Local configuration copied successfully")
#t)
(begin
(log-error "Local configuration copy failed (exit: ~a)" status)
#f))))
;; Remote sync using rsync
(let* ((hostname (assoc-ref ssh-config 'hostname))
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
(user (assoc-ref ssh-config 'user))
(identity-file (assoc-ref ssh-config 'identity-file))
(target (if user (format #f "~a@~a" user (or ssh-alias hostname)) (or ssh-alias hostname)))
(key-arg (if identity-file (format #f "-i ~a" identity-file) ""))
(rsync-cmd (format #f "rsync -avz --delete -e 'ssh ~a' ~a/ ~a:~a/"
key-arg homelab-root target remote-path)))
(log-debug "Rsync command: ~a" rsync-cmd)
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" rsync-cmd))
(output (get-string-all port))
(status (close-pipe port)))
(if (zero? status)
(begin
(log-debug "Configuration synced successfully")
(log-debug "Rsync output: ~a" output)
#t)
(begin
(log-error "Configuration sync failed (exit: ~a)" status)
(log-error "Rsync error: ~a" output)
#f))))))))
;; Execute nixos-rebuild on remote machine
(define (execute-remote-rebuild machine-name remote-path boot-mode test-mode start-time)
"Execute nixos-rebuild on the remote machine"
(let* ((rebuild-mode (cond
(test-mode "test")
(boot-mode "boot")
(else "switch")))
(rebuild-cmd (format #f "sudo nixos-rebuild ~a --flake ~a#~a"
rebuild-mode remote-path machine-name)))
(log-info "Executing: ~a" rebuild-cmd)
(call-with-values
(lambda () (run-remote-command machine-name rebuild-cmd))
(lambda (success output)
(let ((elapsed (- (current-time) start-time)))
(if success
(begin
(log-success "SSH deployment completed successfully in ~as" elapsed)
(log-info "Rebuild output:")
(log-info "~a" output)
#t)
(begin
(log-error "SSH deployment failed (exit code indicates failure)")
(log-error "Rebuild error output:")
(log-error "~a" output)
#f)))))))
;; Deploy to all machines using SSH
(define (deploy-all-machines-ssh . args)
"Deploy to all machines using SSH + rsync + nixos-rebuild"
(let* ((options (if (null? args) '() (car args)))
(dry-run (option-ref options 'dry-run #f))
(machines (get-all-machines)))
(log-info "Starting SSH deployment to all machines (~a total)" (length machines))
(let ((results
(map (lambda (machine)
(log-info "Deploying to ~a..." machine)
(let ((result (deploy-machine-ssh machine "default" options)))
(if result
(log-success "✓ ~a deployed successfully" machine)
(log-error "✗ ~a deployment failed" machine))
(cons machine result)))
machines)))
;; Summary
(let ((successful (filter cdr results))
(failed (filter (lambda (r) (not (cdr r))) results)))
(log-info "SSH deployment summary:")
(log-info " Successful: ~a/~a machines" (length successful) (length machines))
(when (not (null? failed))
(log-error " Failed: ~a" (string-join (map car failed) ", ")))
;; Return true if all succeeded
(= (length successful) (length machines))))))
;; Update flake inputs
(define (update-flake . args)
"Update flake inputs (impure - has side effects)"
(let* ((options (if (null? args) '() (car args)))
(dry-run (option-ref options 'dry-run #f)))
(log-info "Updating flake inputs...")
(if dry-run
(begin
(log-info "DRY RUN: Would execute: nix flake update")
#t)
(let* ((homelab-root (get-homelab-root))
(update-cmd (format #f "cd ~a && nix flake update" homelab-root))
(port (open-pipe* OPEN_READ "/bin/sh" "-c" update-cmd))
(output (get-string-all port))
(status (close-pipe port)))
(if (zero? status)
(begin
(log-success "Flake inputs updated successfully")
#t)
(begin
(log-error "Flake update failed (exit: ~a)" status)
(log-error "Error output: ~a" output)
#f))))))