grokking simplicity and refactoring

packages/lab-tool/utils/ssh/connection-test.scm

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

packages/lab-tool/utils/ssh/context.scm

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

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

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

packages/lab-tool/utils/ssh/remote-command.scm

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

packages/lab-tool/utils/ssh/retry.scm

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