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

Refactor emacs configuration and clean up lab-tool project

Browse source 
- Reorganized emacs configuration with profiles in modules/development/emacs.nix
- Updated machine configurations to use new emacs module structure
- Cleaned up lab-tool project by removing archive, research, testing, and utils directories
- Streamlined lab-tool to focus on core deployment functionality with deploy-rs
- Added DEVELOPMENT.md documentation for lab-tool

🤖 Generated with [Claude Code](https://claude.ai/code)

Co-Authored-By: Claude <noreply@anthropic.com>
This commit is contained in:
Geir Okkenhaug Jerstad 2025-07-03 17:45:34 +02:00
parent bff56e4ffc
commit 47c2961033
70 changed files with 195 additions and 5688 deletions
Download patch file Download diff file Expand all files Collapse all files

43
packages/lab-tool/utils/config-new.scm
View file

@ -1,43 +0,0 @@
;; utils/config.scm - Configuration management facade
(define-module (utils config)
#:use-module (utils config defaults)
#:use-module (utils config loader)
#:use-module (utils config accessor)
#:use-module (utils config state)
#:re-export (;; State management
get-current-config
set-current-config!
reload-config!
;; Stateful accessors (work with current config)
get-config-value
get-machine-config
get-all-machines
get-ssh-config
validate-machine-name
get-homelab-root
;; Pure accessors (require explicit config parameter)
get-config-value-pure
get-machine-config-pure
get-all-machines-pure
get-ssh-config-pure
validate-machine-name-pure
;; Loading functions
load-config
load-config-from-file
;; Default configuration
default-config))
;; This module acts as a facade for configuration management,
;; aggregating specialized modules that follow single responsibility:
;; - defaults: Pure data definitions
;; - loader: File I/O operations
;; - accessor: Pure configuration value access
;; - state: Mutable state management
;;
;; Both pure and impure functions are available, allowing callers
;; to choose the appropriate level of functional purity.

74
packages/lab-tool/utils/config/accessor.scm
View file

@ -1,74 +0,0 @@
;; utils/config/accessor.scm - Configuration value access (pure functions)
(define-module (utils config accessor)
#:use-module (srfi srfi-1)
#:export (get-config-value-pure
get-machine-config-pure
get-all-machines-pure
get-ssh-config-pure
validate-machine-name-pure))
;; Pure function: Get configuration value by path
;; Input: config alist, path list, optional default value
;; Output: configuration value or default
(define (get-config-value-pure config path . default)
"Pure function to get configuration value by path"
(let ((result (fold (lambda (key acc)
(if (and acc (list? acc))
(assoc-ref acc key)
#f))
config path)))
(if result
result
(if (null? default) #f (car default)))))
;; Pure function: Get machine configurations
;; Input: config alist
;; Output: machines alist
(define (get-machine-configs-pure config)
"Pure function to get machine configurations"
(get-config-value-pure config '(machines)))
;; Pure function: Get configuration for specific machine
;; Input: config alist, machine-name (string or symbol)
;; Output: machine configuration alist or #f
(define (get-machine-config-pure config machine-name)
"Pure function to get machine configuration"
(let ((machine-symbol (if (symbol? machine-name)
machine-name
(string->symbol machine-name)))
(machines (get-machine-configs-pure config)))
(assoc-ref machines machine-symbol)))
;; Pure function: Get list of all machine names
;; Input: config alist
;; Output: list of machine name strings
(define (get-all-machines-pure config)
"Pure function to get all machine names"
(map (lambda (machine-entry)
(symbol->string (car machine-entry)))
(get-machine-configs-pure config)))
;; Pure function: Validate machine name exists
;; Input: config alist, machine-name string
;; Output: #t if valid, #f otherwise
(define (validate-machine-name-pure config machine-name)
"Pure function to validate machine name"
(let ((machines (get-all-machines-pure config)))
(member machine-name machines)))
;; Pure function: Get SSH configuration for machine
;; Input: config alist, machine-name (string or symbol)
;; Output: SSH configuration alist or #f
(define (get-ssh-config-pure config machine-name)
"Pure function to get SSH configuration for machine"
(let ((machine-config (get-machine-config-pure config machine-name)))
(if machine-config
(let ((type (assoc-ref machine-config 'type))
(hostname (assoc-ref machine-config 'hostname))
(ssh-alias (assoc-ref machine-config 'ssh-alias)))
`((type . ,type)
(hostname . ,hostname)
(ssh-alias . ,ssh-alias)
(is-local . ,(eq? type 'local))))
#f)))

35
packages/lab-tool/utils/config/defaults.scm
View file

@ -1,35 +0,0 @@
;; utils/config/defaults.scm - Configuration defaults (pure data)
(define-module (utils config defaults)
#:export (default-config))
;; Pure data: Default configuration structure
(define default-config
`((homelab-root . "/home/geir/Home-lab")
(machines . ((congenital-optimist
(type . local)
(hostname . "localhost")
(services . (workstation development)))
(sleeper-service
(type . remote)
(hostname . "sleeper-service.tail807ea.ts.net")
(ssh-alias . "admin-sleeper")
(services . (nfs zfs storage)))
(grey-area
(type . remote)
(hostname . "grey-area.tail807ea.ts.net")
(ssh-alias . "admin-grey")
(services . (ollama forgejo git)))
(reverse-proxy
(type . remote)
(hostname . "reverse-proxy.tail807ea.ts.net")
(ssh-alias . "admin-reverse")
(services . (nginx proxy ssl)))))
(deployment . ((default-mode . "boot")
(timeout . 300)
(retry-count . 3)))
(monitoring . ((interval . 30)
(timeout . 10)))
(mcp . ((port . 3001)
(host . "localhost")
(log-level . "info")))))

60
packages/lab-tool/utils/config/loader.scm
View file

@ -1,60 +0,0 @@
;; utils/config/loader.scm - Configuration loading (file I/O operations)
(define-module (utils config loader)
#:use-module (ice-9 textual-ports)
#:use-module (utils logging)
#:use-module (utils json)
#:use-module (utils config defaults)
#:export (load-config-from-file
load-config))
;; Pure function: Parse configuration from JSON string
;; Input: json-string
;; Output: parsed configuration alist or #f if invalid
(define (parse-config-json json-string)
"Pure function to parse configuration from JSON string"
(catch #t
(lambda () (json-string->scm-safe json-string))
(lambda (key . args) #f)))
;; Pure function: Validate configuration structure
;; Input: config alist
;; Output: #t if valid, #f otherwise
(define (validate-config config)
"Pure function to validate configuration structure"
(and (list? config)
(assoc-ref config 'homelab-root)
(assoc-ref config 'machines)))
;; Impure function: Load configuration from file
;; Input: file-path string
;; Output: configuration alist or default-config if file doesn't exist/invalid
(define (load-config-from-file file-path)
"Load configuration from file (with side effects: file I/O, logging)"
(if (file-exists? file-path)
(catch #t
(lambda ()
(log-debug "Loading configuration from ~a" file-path)
(let* ((json-data (call-with-input-file file-path get-string-all))
(parsed-config (parse-config-json json-data)))
(if (and parsed-config (validate-config parsed-config))
(begin
(log-info "Configuration loaded successfully")
parsed-config)
(begin
(log-warn "Invalid configuration file, using defaults")
default-config))))
(lambda (key . args)
(log-warn "Failed to load config file, using defaults: ~a" key)
default-config))
(begin
(log-debug "No config file found at ~a, using defaults" file-path)
default-config)))
;; Impure function: Load configuration with default path
(define (load-config . args)
"Load configuration with optional file path"
(let ((config-file (if (null? args)
(string-append (getenv "HOME") "/.config/homelab/config.json")
(car args))))
(load-config-from-file config-file)))

69
packages/lab-tool/utils/config/state.scm
View file

@ -1,69 +0,0 @@
;; utils/config/state.scm - Configuration state management
(define-module (utils config state)
#:use-module (utils config defaults)
#:use-module (utils config loader)
#:use-module (utils config accessor)
#:use-module (utils logging)
#:export (get-current-config
set-current-config!
reload-config!
get-config-value
get-machine-config
get-all-machines
get-ssh-config
validate-machine-name
get-homelab-root))
;; Mutable state: Current loaded configuration
(define current-config default-config)
;; Impure function: Get current configuration
(define (get-current-config)
"Get current loaded configuration"
current-config)
;; Impure function: Set current configuration
(define (set-current-config! config)
"Set current configuration (impure)"
(set! current-config config))
;; Impure function: Reload configuration from file
(define (reload-config! . args)
"Reload configuration from file"
(let ((new-config (apply load-config args)))
(set-current-config! new-config)
new-config))
;; Impure wrappers for pure accessor functions
(define (get-config-value path . default)
"Get configuration value from current config"
(apply get-config-value-pure current-config path default))
(define (get-machine-config machine-name)
"Get machine configuration from current config"
(get-machine-config-pure current-config machine-name))
(define (get-all-machines)
"Get all machine names from current config"
(get-all-machines-pure current-config))
(define (get-ssh-config machine-name)
"Get SSH configuration from current config"
(get-ssh-config-pure current-config machine-name))
(define (validate-machine-name machine-name)
"Validate machine name against current config"
(if (validate-machine-name-pure current-config machine-name)
#t
(begin
(log-error "Unknown machine: ~a" machine-name)
(log-error "Available machines: ~a" (string-join (get-all-machines) ", "))
#f)))
(define (get-homelab-root)
"Get home lab root directory from current config"
(get-config-value '(homelab-root) "/home/geir/Home-lab"))
;; Initialize configuration on module load
(reload-config!)

48
packages/lab-tool/utils/json-new.scm
View file

@ -1,48 +0,0 @@
;; utils/json.scm - JSON utilities facade
(define-module (utils json)
#:use-module (utils json parse)
#:use-module (utils json serialize)
#:use-module (utils json file-io)
#:use-module (utils json validation)
#:use-module (utils json manipulation)
#:use-module (utils json pretty-print)
#:re-export (;; Parsing
parse-json-pure
json-string->scm-safe
;; Serialization
scm->json-string-pure
scm->json-string
;; File I/O (both pure and impure versions)
read-json-file-pure
write-json-file-pure
read-json-file
write-json-file
;; Validation (pure functions)
validate-required-keys
validate-types
validate-json-schema
;; Manipulation (pure functions)
merge-json-objects
flatten-json-paths
json-path-ref
json-path-set
;; Pretty printing
json-pretty-print))
;; This module acts as a facade for JSON functionality,
;; aggregating specialized modules that follow single responsibility:
;; - parse: Pure JSON string parsing
;; - serialize: Pure scheme-to-JSON conversion
;; - file-io: File reading/writing with pure and impure versions
;; - validation: Pure schema validation functions
;; - manipulation: Pure object manipulation functions
;; - pretty-print: Output formatting
;;
;; All functions are designed to be composable and testable,
;; with pure versions available for functional programming patterns.

57
packages/lab-tool/utils/json/file-io.scm
View file

@ -1,57 +0,0 @@
;; utils/json/file-io.scm - JSON file I/O operations
(define-module (utils json file-io)
#:use-module (json)
#:use-module (ice-9 textual-ports)
#:use-module (utils logging)
#:export (read-json-file-pure
write-json-file-pure
read-json-file
write-json-file))
;; Pure function: Read JSON from file without logging
;; Input: filename string
;; Output: parsed object or #f if failed
(define (read-json-file-pure filename)
"Pure function to read JSON from file"
(catch #t
(lambda ()
(call-with-input-file filename
(lambda (port) (json->scm port))))
(lambda (key . args) #f)))
;; Pure function: Write JSON to file without logging
;; Input: filename string, obj (scheme object), pretty boolean
;; Output: #t if successful, #f if failed
(define (write-json-file-pure filename obj pretty)
"Pure function to write JSON to file"
(catch #t
(lambda ()
(call-with-output-file filename
(lambda (port)
(if pretty
(scm->json obj port #:pretty #t)
(scm->json obj port))))
#t)
(lambda (key . args) #f)))
;; Impure wrapper: Read JSON file with logging
(define (read-json-file filename)
"Read JSON from file with logging"
(log-debug "Reading JSON file: ~a" filename)
(let ((result (read-json-file-pure filename)))
(if result
(log-debug "Successfully read JSON file: ~a" filename)
(log-error "Failed to read JSON file: ~a" filename))
result))
;; Impure wrapper: Write JSON file with logging
(define (write-json-file filename obj . options)
"Write JSON to file with logging"
(let ((pretty (if (null? options) #t (car options))))
(log-debug "Writing JSON file: ~a" filename)
(let ((result (write-json-file-pure filename obj pretty)))
(if result
(log-debug "Successfully wrote JSON file: ~a" filename)
(log-error "Failed to write JSON file: ~a" filename))
result)))

63
packages/lab-tool/utils/json/manipulation.scm
View file

@ -1,63 +0,0 @@
;; utils/json/manipulation.scm - Pure JSON manipulation functions
(define-module (utils json manipulation)
#:use-module (srfi srfi-1)
#:export (merge-json-objects
flatten-json-paths
json-path-ref
json-path-set))
;; Pure function: Merge two JSON objects
;; Input: obj1 (alist), obj2 (alist)
;; Output: merged alist with obj2 values taking precedence
(define (merge-json-objects obj1 obj2)
"Pure function to merge two JSON objects"
(let ((merged (copy-tree obj1)))
(fold (lambda (pair acc)
(let ((key (car pair))
(value (cdr pair)))
(assoc-set! acc key value)))
merged
obj2)))
;; Pure function: Convert nested alist to flat key paths
;; Input: obj (nested alist), optional prefix (list of keys)
;; Output: list of (path . value) pairs
(define (flatten-json-paths obj . prefix)
"Pure function to flatten nested object to path-value pairs"
(let ((current-prefix (if (null? prefix) '() (car prefix))))
(fold (lambda (pair acc)
(let ((key (car pair))
(value (cdr pair)))
(let ((new-path (append current-prefix (list key))))
(if (and (list? value) (not (null? value)) (pair? (car value)))
;; Nested object - recurse
(append (flatten-json-paths value new-path) acc)
;; Leaf value
(cons (cons new-path value) acc)))))
'()
obj)))
;; Pure function: Get nested value using path
;; Input: obj (nested alist), path (list of keys)
;; Output: value at path or #f if not found
(define (json-path-ref obj path)
"Pure function to get value from nested object using key path"
(fold (lambda (key acc)
(if (and acc (list? acc))
(assoc-ref acc key)
#f))
obj path))
;; Pure function: Set nested value using path
;; Input: obj (nested alist), path (list of keys), value
;; Output: new alist with value set at path
(define (json-path-set obj path value)
"Pure function to set value in nested object using key path"
(if (null? path)
value
(let* ((key (car path))
(rest-path (cdr path))
(current-value (assoc-ref obj key))
(new-value (json-path-set (or current-value '()) rest-path value)))
(assoc-set! (copy-tree obj) key new-value))))

21
packages/lab-tool/utils/json/parse.scm
View file

@ -1,21 +0,0 @@
;; utils/json/parse.scm - Pure JSON parsing functions
(define-module (utils json parse)
#:use-module (json)
#:export (json-string->scm-safe
parse-json-pure))
;; Pure function: Safely parse JSON string
;; Input: json-string
;; Output: parsed scheme object or #f if invalid
(define (parse-json-pure json-string)
"Pure function to parse JSON string without side effects"
(catch #t
(lambda ()
(if (string? json-string)
(json-string->scm json-string)
#f))
(lambda (key . args) #f)))
;; Alias for compatibility
(define json-string->scm-safe parse-json-pure)

13
packages/lab-tool/utils/json/pretty-print.scm
View file

@ -1,13 +0,0 @@
;; utils/json/pretty-print.scm - JSON pretty printing
(define-module (utils json pretty-print)
#:use-module (json)
#:export (json-pretty-print))
;; Impure function: Pretty print JSON to current output port
;; Input: obj (scheme object)
;; Output: unspecified (side effect: prints to current-output-port)
(define (json-pretty-print obj)
"Pretty print JSON object to current output port"
(scm->json obj (current-output-port) #:pretty #t)
(newline))

27
packages/lab-tool/utils/json/serialize.scm
View file

@ -1,27 +0,0 @@
;; utils/json/serialize.scm - Pure JSON serialization functions
(define-module (utils json serialize)
#:use-module (json)
#:use-module (ice-9 textual-ports)
#:export (scm->json-string-pure
scm->json-string))
;; Pure function: Convert scheme object to JSON string
;; Input: obj (scheme object), pretty (boolean)
;; Output: JSON string or #f if conversion fails
(define (scm->json-string-pure obj pretty)
"Pure function to convert scheme object to JSON string"
(catch #t
(lambda ()
(call-with-output-string
(lambda (port)
(if pretty
(scm->json obj port #:pretty #t)
(scm->json obj port)))))
(lambda (key . args) #f)))
;; Wrapper with optional pretty parameter
(define (scm->json-string obj . options)
"Convert scheme object to JSON string with optional pretty printing"
(let ((pretty (if (null? options) #f (car options))))
(scm->json-string-pure obj pretty)))

67
packages/lab-tool/utils/json/validation.scm
View file

@ -1,67 +0,0 @@
;; utils/json/validation.scm - Pure JSON validation functions
(define-module (utils json validation)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:export (validate-required-keys
validate-types
validate-json-schema))
;; Pure function: Check for required keys
;; Input: obj (alist), required-keys (list of symbols)
;; Output: list of missing keys (empty if all present)
(define (get-missing-keys obj required-keys)
"Pure function to find missing required keys"
(filter (lambda (key)
(not (assoc-ref obj key)))
required-keys))
;; Pure function: Validate required keys
;; Input: obj (alist), required-keys (list of symbols)
;; Output: #t if all present, #f otherwise
(define (validate-required-keys obj required-keys)
"Pure function to validate required keys are present"
(null? (get-missing-keys obj required-keys)))
;; Pure function: Check type specifications
;; Input: obj (alist), type-specs (list of (key expected-type) pairs)
;; Output: list of type error messages (empty if all valid)
(define (get-type-errors obj type-specs)
"Pure function to find type validation errors"
(filter-map
(lambda (type-spec)
(let ((key (car type-spec))
(expected-type (cadr type-spec)))
(let ((value (assoc-ref obj key)))
(if (and value (not (eq? (type-of value) expected-type)))
(format #f "Key ~a: expected ~a, got ~a"
key expected-type (type-of value))
#f))))
type-specs))
;; Pure function: Validate types
;; Input: obj (alist), type-specs (list of (key expected-type) pairs)
;; Output: #t if all types valid, #f otherwise
(define (validate-types obj type-specs)
"Pure function to validate object types"
(null? (get-type-errors obj type-specs)))
;; Pure function: Complete schema validation
;; Input: obj (alist), schema (list with required-keys, optional-keys, types)
;; Output: (values valid? error-messages)
(define (validate-json-schema obj schema)
"Pure function to validate JSON object against schema"
(let ((required-keys (car schema))
(optional-keys (if (> (length schema) 1) (cadr schema) '()))
(type-specs (if (> (length schema) 2) (caddr schema) '())))
(let ((missing-keys (get-missing-keys obj required-keys))
(type-errors (get-type-errors obj type-specs)))
(if (or (not (null? missing-keys)) (not (null? type-errors)))
(values #f (append
(if (not (null? missing-keys))
(list (format #f "Missing required keys: ~a" missing-keys))
'())
type-errors))
(values #t '())))))

42
packages/lab-tool/utils/logging-new.scm
View file

@ -1,42 +0,0 @@
;; utils/logging.scm - Logging facade (aggregates modular components)
(define-module (utils logging)
#:use-module (utils logging format)
#:use-module (utils logging level)
#:use-module (utils logging state)
#:use-module (utils logging output)
#:use-module (utils logging core)
#:use-module (utils logging spinner)
#:re-export (;; Core logging functions
log-debug
log-info
log-warn
log-error
log-success
;; State management
get-current-log-level
set-log-level!
should-log?
;; Pure functions (for testing and functional composition)
should-log-pure
validate-log-level
format-timestamp
format-log-message
get-color
log-message-pure
;; Utilities
with-spinner))
;; This module acts as a facade for logging functionality,
;; aggregating specialized modules that follow single responsibility:
;; - format: Pure formatting functions and color codes
;; - level: Pure log level management and validation
;; - state: Mutable state management for current log level
;; - output: Pure output formatting and port writing
;; - core: Main logging functions with side effects
;; - spinner: Progress indication for long operations
;;
;; Both pure and impure functions are available for maximum flexibility.

38
packages/lab-tool/utils/logging/core.scm
View file

@ -1,38 +0,0 @@
;; utils/logging/core.scm - Core logging functions
(define-module (utils logging core)
#:use-module (utils logging state)
#:use-module (utils logging output)
#:export (log-with-color
log-debug
log-info
log-warn
log-error
log-success))
;; Impure function: Core logging with color and level checking
(define (log-with-color level color prefix message . args)
"Log message with color if level is appropriate"
(when (should-log? level)
(log-to-port (current-error-port) level color prefix message args)))
;; Specific logging functions - each does one thing well
(define (log-debug message . args)
"Log debug message"
(apply log-with-color 'debug 'cyan "DEBUG" message args))
(define (log-info message . args)
"Log info message"
(apply log-with-color 'info 'blue "INFO " message args))
(define (log-warn message . args)
"Log warning message"
(apply log-with-color 'warn 'yellow "WARN " message args))
(define (log-error message . args)
"Log error message"
(apply log-with-color 'error 'red "ERROR" message args))
(define (log-success message . args)
"Log success message"
(apply log-with-color 'info 'green "SUCCESS" message args))

42
packages/lab-tool/utils/logging/format.scm
View file

@ -1,42 +0,0 @@
;; utils/logging/format.scm - Pure logging formatting functions
(define-module (utils logging format)
#:use-module (ice-9 format)
#:use-module (srfi srfi-19)
#:export (format-timestamp
format-log-message
get-color
color-codes))
;; Pure data: ANSI color codes
(define color-codes
'((reset . "\x1b[0m")
(bold . "\x1b[1m")
(red . "\x1b[31m")
(green . "\x1b[32m")
(yellow . "\x1b[33m")
(blue . "\x1b[34m")
(magenta . "\x1b[35m")
(cyan . "\x1b[36m")))
;; Pure function: Get color code by name
(define (get-color name)
"Pure function to get ANSI color code"
(assoc-ref color-codes name))
;; Pure function: Format timestamp
(define (format-timestamp)
"Pure function to format current timestamp"
(date->string (current-date) "~H:~M:~S"))
;; Pure function: Format complete log message
;; Input: level symbol, color symbol, prefix string, message string, args list
;; Output: formatted log message string
(define (format-log-message level color prefix message args)
"Pure function to format a complete log message"
(let ((timestamp (format-timestamp))
(formatted-msg (apply format #f message args))
(color-start (get-color color))
(color-end (get-color 'reset)))
(format #f "~a~a[lab]~a ~a ~a~%"
color-start prefix color-end timestamp formatted-msg)))

30
packages/lab-tool/utils/logging/level.scm
View file

@ -1,30 +0,0 @@
;; utils/logging/level.scm - Pure log level management
(define-module (utils logging level)
#:export (log-levels
should-log-pure
validate-log-level))
;; Pure data: Log levels with numeric values for comparison
(define log-levels
'((debug . 0)
(info . 1)
(warn . 2)
(error . 3)))
;; Pure function: Check if message should be logged at given levels
;; Input: current-level symbol, message-level symbol
;; Output: #t if should log, #f otherwise
(define (should-log-pure current-level message-level)
"Pure function to determine if message should be logged"
(let ((current-value (assoc-ref log-levels current-level))
(message-value (assoc-ref log-levels message-level)))
(and current-value message-value
(<= current-value message-value))))
;; Pure function: Validate log level
;; Input: level symbol
;; Output: #t if valid, #f otherwise
(define (validate-log-level level)
"Pure function to validate log level"
(assoc-ref log-levels level))

23
packages/lab-tool/utils/logging/output.scm
View file

@ -1,23 +0,0 @@
;; utils/logging/output.scm - Pure logging output functions
(define-module (utils logging output)
#:use-module (utils logging format)
#:use-module (utils logging level)
#:export (log-message-pure
log-to-port))
;; Pure function: Create log message without side effects
;; Input: level, color, prefix, message, args
;; Output: formatted log message string
(define (log-message-pure level color prefix message args)
"Pure function to create formatted log message"
(format-log-message level color prefix message args))
;; Impure function: Write log message to port
;; Input: port, level, color, prefix, message, args
;; Output: unspecified (side effect: writes to port)
(define (log-to-port port level color prefix message args)
"Write formatted log message to specified port"
(let ((formatted-message (log-message-pure level color prefix message args)))
(display formatted-message port)
(force-output port)))

27
packages/lab-tool/utils/logging/spinner.scm
View file

@ -1,27 +0,0 @@
;; utils/logging/spinner.scm - Spinner utility for long operations
(define-module (utils logging spinner)
#:use-module (utils logging core)
#:export (with-spinner))
;; Pure function: Calculate elapsed time
;; Input: start-time, end-time
;; Output: elapsed seconds
(define (calculate-elapsed start-time end-time)
"Pure function to calculate elapsed time"
(- end-time start-time))
;; Impure function: Execute operation with spinner logging
(define (with-spinner message thunk)
"Execute operation with progress logging"
(log-info "~a..." message)
(let ((start-time (current-time)))
(catch #t
(lambda ()
(let ((result (thunk)))
(let ((elapsed (calculate-elapsed start-time (current-time))))
(log-success "~a completed in ~as" message elapsed))
result))
(lambda (key . args)
(log-error "~a failed: ~a ~a" message key args)
(throw key args)))))

27
packages/lab-tool/utils/logging/state.scm
View file

@ -1,27 +0,0 @@
;; utils/logging/state.scm - Logging state management
(define-module (utils logging state)
#:use-module (utils logging level)
#:export (get-current-log-level
set-log-level!
should-log?))
;; Mutable state: Current log level
(define current-log-level 'info)
;; Impure function: Get current log level
(define (get-current-log-level)
"Get current log level"
current-log-level)
;; Impure function: Set log level with validation
(define (set-log-level! level)
"Set current log level (with validation)"
(if (validate-log-level level)
(set! current-log-level level)
(error "Invalid log level" level)))
;; Impure function: Check if message should be logged
(define (should-log? level)
"Check if message should be logged at current level"
(should-log-pure current-log-level level))

27
packages/lab-tool/utils/ssh-new.scm
View file

@ -1,27 +0,0 @@
;; utils/ssh.scm - SSH operations facade (aggregates modular components)
(define-module (utils ssh)
#:use-module (utils ssh connection-test)
#:use-module (utils ssh remote-command)
#:use-module (utils ssh file-copy)
#:use-module (utils ssh retry)
#:use-module (utils ssh context)
#:re-export (test-ssh-connection
run-remote-command
run-remote-command-pure
copy-file-to-remote
copy-file-pure
run-command-with-retry
with-retry
with-ssh-connection))
;; This module acts as a facade, re-exporting functions from specialized modules
;; Each sub-module follows the single responsibility principle:
;; - connection-test: SSH connectivity testing
;; - remote-command: Command execution on remote machines
;; - file-copy: File transfer operations
;; - retry: Retry logic and error recovery
;; - context: Connection context management
;;
;; Pure functions are exported alongside their impure wrappers,
;; allowing callers to choose the appropriate level of abstraction.

41
packages/lab-tool/utils/ssh/connection-test.scm
View file

@ -1,41 +0,0 @@
;; utils/ssh/connection-test.scm - Pure SSH connection testing
(define-module (utils ssh connection-test)
#:use-module (ice-9 popen)
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 format)
#:use-module (utils logging)
#:use-module (utils config)
#:export (test-ssh-connection-pure
test-ssh-connection))
;; Pure function: Test SSH connectivity to a machine
;; Input: ssh-config alist
;; Output: #t if connection successful, #f otherwise
(define (test-ssh-connection-pure ssh-config)
"Pure function to test SSH connection given ssh-config"
(let ((hostname (assoc-ref ssh-config 'hostname))
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
(is-local (assoc-ref ssh-config 'is-local)))
(if is-local
#t ; Local connections always succeed
(let* ((target (or ssh-alias hostname))
(test-cmd (format #f "ssh -o ConnectTimeout=5 -o BatchMode=yes ~a echo OK" target))
(port (open-pipe* OPEN_READ "/bin/sh" "-c" test-cmd))
(output (get-string-all port))
(status (close-pipe port)))
(zero? status)))))
;; Impure wrapper: Test SSH connection with logging and config lookup
(define (test-ssh-connection machine-name)
"Test SSH connectivity to a machine (with side effects: logging, config lookup)"
(let ((ssh-config (get-ssh-config machine-name)))
(if (not ssh-config)
(begin
(log-error "No SSH configuration found for ~a" machine-name)
#f)
(let ((result (test-ssh-connection-pure ssh-config)))
(if result
(log-debug "SSH connection to ~a successful" machine-name)
(log-warn "SSH connection to ~a failed" machine-name))
result))))

33
packages/lab-tool/utils/ssh/context.scm
View file

@ -1,33 +0,0 @@
;; utils/ssh/context.scm - SSH context management
(define-module (utils ssh context)
#:use-module (ice-9 format)
#:use-module (utils logging)
#:use-module (utils ssh connection-test)
#:export (with-connection-context
with-ssh-connection))
;; Pure function: Execute operation with connection validation
;; Input: connection-validator (thunk -> boolean), operation (thunk)
;; Output: result of operation or #f if connection invalid
(define (with-connection-context connection-validator operation)
"Pure function to execute operation with connection context"
(if (connection-validator)
(catch #t
operation
(lambda (key . args)
(values #f (format #f "Operation failed: ~a ~a" key args))))
(values #f "Connection validation failed")))
;; Impure wrapper: Execute with SSH connection context and logging
(define (with-ssh-connection machine-name thunk)
"Execute operation with SSH connection context (with side effects: logging)"
(let ((connection-validator (lambda () (test-ssh-connection machine-name))))
(call-with-values
(lambda () (with-connection-context connection-validator thunk))
(lambda (success result)
(if success
result
(begin
(log-error "SSH operation failed for ~a: ~a" machine-name result)
#f))))))

50
packages/lab-tool/utils/ssh/file-copy.scm
View file

@ -1,50 +0,0 @@
;; utils/ssh/file-copy.scm - Pure file copying operations
(define-module (utils ssh file-copy)
#:use-module (ice-9 format)
#:use-module (utils logging)
#:use-module (utils config)
#:export (copy-file-pure
build-copy-context
copy-file-to-remote))
;; Pure function: Copy file with given copy context
;; Input: copy-context alist, local-path string, remote-path string
;; Output: #t if successful, #f otherwise
(define (copy-file-pure copy-context local-path remote-path)
"Pure function to copy file given copy context"
(let ((is-local (assoc-ref copy-context 'is-local))
(target (assoc-ref copy-context 'target)))
(let* ((copy-cmd (if is-local
(format #f "cp '~a' '~a'" local-path remote-path)
(format #f "scp '~a' '~a:~a'" local-path target remote-path)))
(status (system copy-cmd)))
(zero? status))))
;; Pure function: Build copy context from ssh-config
(define (build-copy-context ssh-config)
"Pure function to build copy context from ssh-config"
(let ((hostname (assoc-ref ssh-config 'hostname))
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
(is-local (assoc-ref ssh-config 'is-local)))
`((is-local . ,is-local)
(target . ,(or ssh-alias hostname)))))
;; Impure wrapper: Copy file to remote with logging and config lookup
(define (copy-file-to-remote machine-name local-path remote-path)
"Copy file to remote machine (with side effects: logging, config lookup)"
(let ((ssh-config (get-ssh-config machine-name)))
(if (not ssh-config)
(begin
(log-error "No SSH configuration found for ~a" machine-name)
#f)
(let* ((copy-context (build-copy-context ssh-config))
(is-local (assoc-ref copy-context 'is-local)))
(log-debug "Copying ~a: ~a -> ~a"
(if is-local "locally" (format #f "to ~a" machine-name))
local-path remote-path)
(let ((result (copy-file-pure copy-context local-path remote-path)))
(if result
(log-debug "File copy successful")
(log-error "File copy failed"))
result)))))

58
packages/lab-tool/utils/ssh/remote-command.scm
View file

@ -1,58 +0,0 @@
;; utils/ssh/remote-command.scm - Pure remote command execution
(define-module (utils ssh remote-command)
#:use-module (ice-9 popen)
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (utils logging)
#:use-module (utils config)
#:export (run-remote-command-pure
execute-command-pure
build-execution-context
run-remote-command))
;; Pure function: Execute command with given execution context
;; Input: execution-context alist, command string, args list
;; Output: (values success? output-string)
(define (execute-command-pure execution-context command args)
"Pure function to execute command in given context"
(let ((is-local (assoc-ref execution-context 'is-local))
(target (assoc-ref execution-context 'target))
(full-command (if (null? args)
command
(format #f "~a ~a" command (string-join args " ")))))
(let* ((exec-cmd (if is-local
full-command
(format #f "ssh ~a '~a'" target full-command)))
(port (open-pipe* OPEN_READ "/bin/sh" "-c" exec-cmd))
(output (get-string-all port))
(status (close-pipe port)))
(values (zero? status) output))))
;; Pure function: Build execution context from ssh-config
(define (build-execution-context ssh-config)
"Pure function to build execution context from ssh-config"
(let ((hostname (assoc-ref ssh-config 'hostname))
(ssh-alias (assoc-ref ssh-config 'ssh-alias))
(is-local (assoc-ref ssh-config 'is-local)))
`((is-local . ,is-local)
(target . ,(or ssh-alias hostname)))))
;; Pure wrapper: Run remote command with pure functions
(define (run-remote-command-pure ssh-config command args)
"Pure function to run remote command given ssh-config"
(let ((exec-context (build-execution-context ssh-config)))
(execute-command-pure exec-context command args)))
;; Impure wrapper: Run remote command with logging and config lookup
(define (run-remote-command machine-name command . args)
"Run command on remote machine (with side effects: logging, config lookup)"
(let ((ssh-config (get-ssh-config machine-name)))
(if (not ssh-config)
(begin
(log-error "No SSH configuration found for ~a" machine-name)
(values #f "No SSH configuration found"))
(begin
(log-debug "Executing on ~a: ~a ~a" machine-name command (string-join args " "))
(run-remote-command-pure ssh-config command args)))))

45
packages/lab-tool/utils/ssh/retry.scm
View file

@ -1,45 +0,0 @@
;; utils/ssh/retry.scm - Pure retry logic
(define-module (utils ssh retry)
#:use-module (utils logging)
#:use-module (utils ssh remote-command)
#:export (with-retry
run-command-with-retry))
;; Pure function: Retry operation with exponential backoff
;; Input: operation (thunk), max-retries number, delay-fn (retry-count -> seconds)
;; Output: result of operation or #f if all retries failed
(define (with-retry operation max-retries . delay-fn)
"Pure retry logic - operation should return (values success? result)"
(let ((delay-func (if (null? delay-fn)
(lambda (retry) (* retry 2)) ; Default: exponential backoff
(car delay-fn))))
(let loop ((retries 0))
(call-with-values operation
(lambda (success result)
(if success
(values #t result)
(if (< retries max-retries)
(begin
(sleep (delay-func retries))
(loop (+ retries 1)))
(values #f result))))))))
;; Impure wrapper: Run command with retry and logging
(define (run-command-with-retry machine-name command max-retries . args)
"Run command with retry logic (with side effects: logging)"
(let ((operation (lambda ()
(apply run-remote-command machine-name command args))))
(let loop ((retries 0))
(call-with-values operation
(lambda (success output)
(if success
(values #t output)
(if (< retries max-retries)
(begin
(log-warn "Command failed, retrying (~a/~a)..." (+ retries 1) max-retries)
(sleep 2)
(loop (+ retries 1)))
(begin
(log-error "Command failed after ~a retries" max-retries)
(values #f output))))))))))