moved some files to archive
This commit is contained in:
parent
ef4b4b7736
commit
db9fadcb0a
25 changed files with 15 additions and 0 deletions
282
packages/lab-tool/archive/lab/auto-update.scm
Normal file
282
packages/lab-tool/archive/lab/auto-update.scm
Normal 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
18
packages/lab-tool/archive/lab/core.scm
Normal 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
140
packages/lab-tool/archive/lab/deploy-rs.scm
Normal file
|
@ -0,0 +1,140 @@
|
|||
;; lab/deploy-rs.scm - Deploy-rs based deployment operations (extracted)
|
||||
|
||||
(define-module (lab deploy-rs)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (utils logging)
|
||||
#:use-module (utils config)
|
||||
#:export (deploy-machine-deploy-rs
|
||||
deploy-all-machines-deploy-rs
|
||||
deploy-with-rollback
|
||||
option-ref))
|
||||
|
||||
;; Helper function for option handling
|
||||
(define (option-ref options key default)
|
||||
"Get option value with default fallback"
|
||||
(let ((value (assoc-ref options key)))
|
||||
(if value value default)))
|
||||
|
||||
;; Main deployment function using deploy-rs
|
||||
(define (deploy-machine-deploy-rs machine-name . args)
|
||||
"Deploy configuration to machine using deploy-rs (impure - has side effects)"
|
||||
(let* ((mode (if (null? args) "default" (car args)))
|
||||
(options (if (< (length args) 2) '() (cadr args)))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(skip-checks (option-ref options 'skip-checks #f)))
|
||||
|
||||
(if (not (validate-machine-name machine-name))
|
||||
#f
|
||||
(begin
|
||||
(log-info "Starting deploy-rs deployment: ~a" machine-name)
|
||||
(execute-deploy-rs machine-name mode options)))))
|
||||
|
||||
;; Execute deploy-rs deployment
|
||||
(define (execute-deploy-rs machine-name mode options)
|
||||
"Execute deployment using deploy-rs with automatic rollback"
|
||||
(let* ((homelab-root (get-homelab-root))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(skip-checks (option-ref options 'skip-checks #f))
|
||||
(auto-rollback (option-ref options 'auto-rollback #t))
|
||||
(magic-rollback (option-ref options 'magic-rollback #t)))
|
||||
|
||||
(log-info "Deploying ~a using deploy-rs..." machine-name)
|
||||
|
||||
(if dry-run
|
||||
(begin
|
||||
(log-info "DRY RUN: Would execute deploy-rs for ~a" machine-name)
|
||||
(log-info "Command would be: deploy '.#~a'" machine-name)
|
||||
#t)
|
||||
(let* ((deploy-cmd (build-deploy-command machine-name skip-checks auto-rollback magic-rollback))
|
||||
(start-time (current-time)))
|
||||
|
||||
(log-info "Deploy command: ~a" deploy-cmd)
|
||||
(log-info "Executing deployment with automatic rollback protection...")
|
||||
|
||||
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" deploy-cmd))
|
||||
(output (get-string-all port))
|
||||
(status (close-pipe port))
|
||||
(elapsed (- (current-time) start-time)))
|
||||
|
||||
(if (zero? status)
|
||||
(begin
|
||||
(log-success "Deploy-rs deployment completed successfully in ~as" elapsed)
|
||||
(log-info "Deployment output:")
|
||||
(log-info "~a" output)
|
||||
#t)
|
||||
(begin
|
||||
(log-error "Deploy-rs deployment failed (exit: ~a)" status)
|
||||
(log-error "Error output:")
|
||||
(log-error "~a" output)
|
||||
(log-info "Deploy-rs automatic rollback should have been triggered")
|
||||
#f)))))))
|
||||
|
||||
;; Build deploy-rs command with options
|
||||
(define (build-deploy-command machine-name skip-checks auto-rollback magic-rollback)
|
||||
"Build the deploy-rs command with appropriate flags"
|
||||
(let ((base-cmd (format #f "cd ~a && deploy '.#~a'" (get-homelab-root) machine-name))
|
||||
(flags '()))
|
||||
|
||||
;; Add flags based on options
|
||||
(when skip-checks
|
||||
(set! flags (cons "--skip-checks" flags)))
|
||||
|
||||
(when auto-rollback
|
||||
(set! flags (cons "--auto-rollback=true" flags)))
|
||||
|
||||
(when magic-rollback
|
||||
(set! flags (cons "--magic-rollback=true" flags)))
|
||||
|
||||
;; Combine command with flags
|
||||
(if (null? flags)
|
||||
base-cmd
|
||||
(format #f "~a ~a" base-cmd (string-join (reverse flags) " ")))))
|
||||
|
||||
;; Deploy to all machines
|
||||
(define (deploy-all-machines-deploy-rs . args)
|
||||
"Deploy to all machines using deploy-rs"
|
||||
(let* ((options (if (null? args) '() (car args)))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(machines (get-all-machines)))
|
||||
|
||||
(log-info "Starting deployment to all machines (~a total)" (length machines))
|
||||
|
||||
(let ((results
|
||||
(map (lambda (machine)
|
||||
(log-info "Deploying to ~a..." machine)
|
||||
(let ((result (deploy-machine-deploy-rs machine "default" options)))
|
||||
(if result
|
||||
(log-success "✓ ~a deployed successfully" machine)
|
||||
(log-error "✗ ~a deployment failed" machine))
|
||||
(cons machine result)))
|
||||
machines)))
|
||||
|
||||
;; Summary
|
||||
(let ((successful (filter cdr results))
|
||||
(failed (filter (lambda (r) (not (cdr r))) results)))
|
||||
(log-info "Deployment summary:")
|
||||
(log-info " Successful: ~a/~a machines" (length successful) (length machines))
|
||||
(when (not (null? failed))
|
||||
(log-error " Failed: ~a" (string-join (map car failed) ", ")))
|
||||
|
||||
;; Return true if all succeeded
|
||||
(= (length successful) (length machines))))))
|
||||
|
||||
;; Deploy with explicit rollback testing
|
||||
(define (deploy-with-rollback machine-name . args)
|
||||
"Deploy with explicit rollback capability testing"
|
||||
(let* ((options (if (null? args) '() (car args)))
|
||||
(test-rollback (option-ref options 'test-rollback #f)))
|
||||
|
||||
(log-info "Deploying ~a with rollback testing..." machine-name)
|
||||
|
||||
(if test-rollback
|
||||
(begin
|
||||
(log-info "Testing rollback mechanism (deploy will be reverted)")
|
||||
;; Deploy with magic rollback disabled to test manual rollback
|
||||
(let ((modified-options (cons '(magic-rollback . #f) options)))
|
||||
(execute-deploy-rs machine-name "default" modified-options)))
|
||||
(execute-deploy-rs machine-name "default" options))))
|
66
packages/lab-tool/archive/lab/deployment.scm
Normal file
66
packages/lab-tool/archive/lab/deployment.scm
Normal 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
52
packages/lab-tool/archive/lab/machines.scm
Normal 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
12
packages/lab-tool/archive/lab/monitoring.scm
Normal 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
198
packages/lab-tool/archive/lab/ssh-deploy.scm
Normal file
|
@ -0,0 +1,198 @@
|
|||
;; lab/ssh-deploy.scm - SSH + rsync + nixos-rebuild deployment operations
|
||||
|
||||
(define-module (lab ssh-deploy)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (utils logging)
|
||||
#:use-module (utils config)
|
||||
#:use-module (utils ssh)
|
||||
#:export (deploy-machine-ssh
|
||||
deploy-all-machines-ssh
|
||||
update-flake
|
||||
sync-config-to-machine
|
||||
option-ref))
|
||||
|
||||
;; Helper function for option handling
|
||||
(define (option-ref options key default)
|
||||
"Get option value with default fallback"
|
||||
(let ((value (assoc-ref options key)))
|
||||
(if value value default)))
|
||||
|
||||
;; Main SSH deployment function
|
||||
(define (deploy-machine-ssh machine-name . args)
|
||||
"Deploy configuration to machine using SSH + rsync + nixos-rebuild"
|
||||
(let* ((mode (if (null? args) "default" (car args)))
|
||||
(options (if (< (length args) 2) '() (cadr args)))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(boot-mode (option-ref options 'boot #f)))
|
||||
|
||||
(if (not (validate-machine-name machine-name))
|
||||
#f
|
||||
(begin
|
||||
(log-info "Starting SSH deployment: ~a" machine-name)
|
||||
(execute-ssh-deploy machine-name mode options)))))
|
||||
|
||||
;; Execute SSH-based deployment
|
||||
(define (execute-ssh-deploy machine-name mode options)
|
||||
"Execute deployment using SSH + rsync + nixos-rebuild"
|
||||
(let* ((homelab-root (get-homelab-root))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(boot-mode (option-ref options 'boot #f))
|
||||
(test-mode (option-ref options 'test #f))
|
||||
(remote-path "/tmp/home-lab-config"))
|
||||
|
||||
(log-info "Deploying ~a using SSH + rsync + nixos-rebuild..." machine-name)
|
||||
|
||||
(if dry-run
|
||||
(begin
|
||||
(log-info "DRY RUN: Would sync config and rebuild ~a" machine-name)
|
||||
(log-info "Would execute: rsync + nixos-rebuild --flake /tmp/home-lab-config#~a" machine-name)
|
||||
#t)
|
||||
(let ((start-time (current-time)))
|
||||
|
||||
;; Step 1: Sync configuration to remote machine
|
||||
(log-info "Step 1: Syncing configuration to ~a:~a" machine-name remote-path)
|
||||
(if (sync-config-to-machine machine-name remote-path)
|
||||
;; Step 2: Execute nixos-rebuild on remote machine
|
||||
(begin
|
||||
(log-info "Step 2: Executing nixos-rebuild on ~a" machine-name)
|
||||
(execute-remote-rebuild machine-name remote-path boot-mode test-mode start-time))
|
||||
(begin
|
||||
(log-error "Failed to sync configuration to ~a" machine-name)
|
||||
#f))))))
|
||||
|
||||
;; Sync configuration to remote machine
|
||||
(define (sync-config-to-machine machine-name remote-path)
|
||||
"Sync Home-lab configuration to remote machine using rsync"
|
||||
(let* ((homelab-root (get-homelab-root))
|
||||
(ssh-config (get-ssh-config machine-name)))
|
||||
|
||||
(if (not ssh-config)
|
||||
(begin
|
||||
(log-error "No SSH configuration found for ~a" machine-name)
|
||||
#f)
|
||||
(if (assoc-ref ssh-config 'is-local)
|
||||
;; Local "sync" - just ensure path exists
|
||||
(begin
|
||||
(log-debug "Local machine ~a, copying to ~a" machine-name remote-path)
|
||||
(let* ((cp-cmd (format #f "sudo mkdir -p ~a && sudo cp -r ~a/* ~a/"
|
||||
remote-path homelab-root remote-path))
|
||||
(status (system cp-cmd)))
|
||||
(if (zero? status)
|
||||
(begin
|
||||
(log-debug "Local configuration copied successfully")
|
||||
#t)
|
||||
(begin
|
||||
(log-error "Local configuration copy failed (exit: ~a)" status)
|
||||
#f))))
|
||||
;; Remote sync using rsync
|
||||
(let* ((hostname (assoc-ref ssh-config 'hostname))
|
||||
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
|
||||
(user (assoc-ref ssh-config 'user))
|
||||
(identity-file (assoc-ref ssh-config 'identity-file))
|
||||
(target (if user (format #f "~a@~a" user (or ssh-alias hostname)) (or ssh-alias hostname)))
|
||||
(key-arg (if identity-file (format #f "-i ~a" identity-file) ""))
|
||||
(rsync-cmd (format #f "rsync -avz --delete -e 'ssh ~a' ~a/ ~a:~a/"
|
||||
key-arg homelab-root target remote-path)))
|
||||
|
||||
(log-debug "Rsync command: ~a" rsync-cmd)
|
||||
(let* ((port (open-pipe* OPEN_READ "/bin/sh" "-c" rsync-cmd))
|
||||
(output (get-string-all port))
|
||||
(status (close-pipe port)))
|
||||
|
||||
(if (zero? status)
|
||||
(begin
|
||||
(log-debug "Configuration synced successfully")
|
||||
(log-debug "Rsync output: ~a" output)
|
||||
#t)
|
||||
(begin
|
||||
(log-error "Configuration sync failed (exit: ~a)" status)
|
||||
(log-error "Rsync error: ~a" output)
|
||||
#f))))))))
|
||||
|
||||
;; Execute nixos-rebuild on remote machine
|
||||
(define (execute-remote-rebuild machine-name remote-path boot-mode test-mode start-time)
|
||||
"Execute nixos-rebuild on the remote machine"
|
||||
(let* ((rebuild-mode (cond
|
||||
(test-mode "test")
|
||||
(boot-mode "boot")
|
||||
(else "switch")))
|
||||
(rebuild-cmd (format #f "sudo nixos-rebuild ~a --flake ~a#~a"
|
||||
rebuild-mode remote-path machine-name)))
|
||||
|
||||
(log-info "Executing: ~a" rebuild-cmd)
|
||||
|
||||
(call-with-values
|
||||
(lambda () (run-remote-command machine-name rebuild-cmd))
|
||||
(lambda (success output)
|
||||
(let ((elapsed (- (current-time) start-time)))
|
||||
(if success
|
||||
(begin
|
||||
(log-success "SSH deployment completed successfully in ~as" elapsed)
|
||||
(log-info "Rebuild output:")
|
||||
(log-info "~a" output)
|
||||
#t)
|
||||
(begin
|
||||
(log-error "SSH deployment failed (exit code indicates failure)")
|
||||
(log-error "Rebuild error output:")
|
||||
(log-error "~a" output)
|
||||
#f)))))))
|
||||
|
||||
;; Deploy to all machines using SSH
|
||||
(define (deploy-all-machines-ssh . args)
|
||||
"Deploy to all machines using SSH + rsync + nixos-rebuild"
|
||||
(let* ((options (if (null? args) '() (car args)))
|
||||
(dry-run (option-ref options 'dry-run #f))
|
||||
(machines (get-all-machines)))
|
||||
|
||||
(log-info "Starting SSH deployment to all machines (~a total)" (length machines))
|
||||
|
||||
(let ((results
|
||||
(map (lambda (machine)
|
||||
(log-info "Deploying to ~a..." machine)
|
||||
(let ((result (deploy-machine-ssh machine "default" options)))
|
||||
(if result
|
||||
(log-success "✓ ~a deployed successfully" machine)
|
||||
(log-error "✗ ~a deployment failed" machine))
|
||||
(cons machine result)))
|
||||
machines)))
|
||||
|
||||
;; Summary
|
||||
(let ((successful (filter cdr results))
|
||||
(failed (filter (lambda (r) (not (cdr r))) results)))
|
||||
(log-info "SSH deployment summary:")
|
||||
(log-info " Successful: ~a/~a machines" (length successful) (length machines))
|
||||
(when (not (null? failed))
|
||||
(log-error " Failed: ~a" (string-join (map car failed) ", ")))
|
||||
|
||||
;; Return true if all succeeded
|
||||
(= (length successful) (length machines))))))
|
||||
|
||||
;; Update flake inputs
|
||||
(define (update-flake . args)
|
||||
"Update flake inputs (impure - has side effects)"
|
||||
(let* ((options (if (null? args) '() (car args)))
|
||||
(dry-run (option-ref options 'dry-run #f)))
|
||||
|
||||
(log-info "Updating flake inputs...")
|
||||
|
||||
(if dry-run
|
||||
(begin
|
||||
(log-info "DRY RUN: Would execute: nix flake update")
|
||||
#t)
|
||||
(let* ((homelab-root (get-homelab-root))
|
||||
(update-cmd (format #f "cd ~a && nix flake update" homelab-root))
|
||||
(port (open-pipe* OPEN_READ "/bin/sh" "-c" update-cmd))
|
||||
(output (get-string-all port))
|
||||
(status (close-pipe port)))
|
||||
|
||||
(if (zero? status)
|
||||
(begin
|
||||
(log-success "Flake inputs updated successfully")
|
||||
#t)
|
||||
(begin
|
||||
(log-error "Flake update failed (exit: ~a)" status)
|
||||
(log-error "Error output: ~a" output)
|
||||
#f))))))
|
Loading…
Add table
Add a link
Reference in a new issue