From 04a75984cbc865b89ab639670040ff3692803e99 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 11 Jan 2025 21:00:24 +0000 Subject: [PATCH] Refactor to use a core namespace with global vars --- modules/ordo.scm | 167 ++++++++++++++++++++++++++++++++++++ modules/ordo/connection.scm | 43 ++++++++-- tryme.scm | 58 ++++--------- 3 files changed, 222 insertions(+), 46 deletions(-) create mode 100644 modules/ordo.scm diff --git a/modules/ordo.scm b/modules/ordo.scm new file mode 100644 index 0000000..8a95faa --- /dev/null +++ b/modules/ordo.scm @@ -0,0 +1,167 @@ +(define-module (ordo) + #:use-module (ice-9 exceptions) + #:use-module (logging logger) + #:use-module (oop goops) + #:use-module (srfi srfi-1) ; list utils + #:use-module (srfi srfi-26) ; cut + #:use-module (srfi srfi-69) ; hash-tables + #:use-module (ordo connection) + #:export (task + act + play + playbook + $ + register-act-var + register-play-var + register-playbook-var + perform)) + +(define +filter-tags+ '()) + +(define (check-tags tags) + (or (null? +filter-tags+) + (not (null? (lset-intersection eqv? +filter-tags+ tags))))) + +(define +playbook-vars+ #f) + +(define +play-vars+ #f) + +(define +act-vars+ #f) + +(define (register-act-var var-name) + (lambda (v) + (log-msg 'DEBUG "Registering act variable " var-name) + (hash-table-set! +act-vars+ var-name v))) + +(define (register-play-var var-name) + (lambda (v) + (log-msg 'DEBUG "Registering play variable " var-name) + (hash-table-set! +play-vars+ var-name v))) + +(define (register-playbook-var var-name) + (lambda (v) + (log-msg 'DEBUG "Registering playbook variable " var-name) + (hash-table-set! +playbook-vars+ var-name v))) + +(define ($ var-name) + "Try to resolve var-name as an act variable, a play variable, or a playbook +variable (in that order). Raise an exception if the variable is not found." + (define not-found (cons 'not-found '())) + (define (lookup-var var-name vars) + (cond + ((null? vars) + (raise-exception (make-exception + (make-undefined-variable-error) + (make-exception-with-irritants var-name)))) + ((not (car vars)) (lookup-var var-name (cdr vars))) + (else (let ((v (hash-table-ref/default (car vars) var-name not-found))) + (if (eqv? v not-found) + (lookup-var var-name (cdr vars)) + v))))) + (lookup-var var-name (list +act-vars+ +play-vars+ +playbook-vars+))) + +(define-class () + (name #:init-keyword #:name #:getter task-name) + (tags #:init-keyword #:tags #:getter task-tags #:init-form '()) + (action #:init-keyword #:action #:getter task-action) + (condition #:init-keyword #:condition #:getter task-condition) + (register #:init-keyword #:register #:getter task-register) + (triggers #:init-keyword #:triggers #:getter task-triggers)) + +(define (task . args) (apply make args)) + +(define-method (check-condition (t ) (c )) + (if (slot-bound? t 'condition) + ((task-condition t) c) + #t)) + +(define-method (perform (t ) (c )) + (when (check-tags (task-tags t)) + (if (not (check-condition t c)) + (log-msg 'NOTICE "Skipping task " (task-name t) " (precondition not met)") + (begin + (log-msg 'NOTICE "Performing task " (task-name t)) + (let ((result ((task-action t) c))) + (when (slot-bound? t 'register) + ((task-register t) result)) + (when (slot-bound? t 'triggers) + (for-each (lambda (f) (f)) (task-triggers t)))))))) + +(define-class () + (name #:init-keyword #:name #:getter act-name) + (tags #:init-keyword #:tags #:getter act-tags #:init-form '()) + (vars #:init-keyword #:vars #:getter act-vars) + (condition #:init-keyword #:condition #:getter act-condition) + (tasks #:init-keyword #:tasks #:getter act-tasks) + (handlers #:init-keyword #:handlers #:getter act-handlers)) + +(define (act . args) (apply make args)) + +(define-method (check-condition (a ) (c )) + (if (slot-bound? a 'condition) + ((act-condition a) c) + #t)) + +(define-method (perform (a ) (c )) + (when (check-tags (act-tags a)) + (if (not (check-condition a c)) + (log-msg 'NOTICE "Skipping act " (act-name a) " (precondition not met") + (begin + (log-msg 'NOTICE "Performing act " (act-name a)) + (dynamic-wind + (lambda () + (when (slot-bound? a 'vars) + (set! +act-vars+ (alist->hash-table (act-vars a) equal?)))) + (lambda () + (for-each (cut perform <> c) (act-tasks a)) + ;; TODO: run any triggered handlers + ) + (lambda () + (set! +act-vars+ #f))))))) + +(define-class () + (name #:init-keyword #:name #:getter play-name) + (tags #:init-keyword #:tags #:getter play-tags #:init-form '()) + (vars #:init-keyword #:vars #:getter play-vars) + (connection #:init-keyword #:connection #:getter play-connection) + (acts #:init-keyword #:acts #:getter play-acts)) + +(define (play . args) (apply make args)) + +(define-method (perform (p )) + (when (check-tags (play-tags p)) + (log-msg 'NOTICE "Performing play " (play-name p)) + (dynamic-wind + (lambda () + (when (slot-bound? p 'vars) + (set! +play-vars+ (alist->hash-table (play-vars p) equal?))) + (init-connection! (play-connection p))) + (lambda () + (for-each (cut perform <> (play-connection p)) (play-acts p)) + ;; TODO: run any triggered handlers + ) + (lambda () + (set! +play-vars+ #f) + (close-connection! (play-connection p)))))) + +(define-class () + (name #:init-keyword #:name #:getter playbook-name) + (vars #:init-keyword #:vars #:getter playbook-vars) + (plays #:init-keyword #:plays #:getter playbook-plays)) + +(define (playbook . args) (apply make args)) + +(define-method (perform (pb ) (filter-tags )) + (log-msg 'NOTICE "Performing playbook " (playbook-name pb)) + (dynamic-wind + (lambda () + (set! +filter-tags+ filter-tags) + (when (slot-bound? pb 'vars) + (set! +playbook-vars+ (alist->hash-table (playbook-vars pb) equal?)))) + (lambda () + (for-each perform (playbook-plays pb))) + (lambda () + (set! +filter-tags+ '()) + (set! +playbook-vars+ #f)))) + +;; TODO: add validate methods for , , , and diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index afde8d6..b590395 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -19,7 +19,11 @@ connection-run connection-call-with-input-file connection-call-with-output-file - call-with-connection)) + call-with-connection + must + run + must1 + run1)) (define-class () (sudo #:getter sudo? #:init-keyword #:sudo)) @@ -74,12 +78,6 @@ (loop (read-line port) (cons line result)))) (loop (read-line port) '())) -(define (kw-arg kw kwargs) - (cond - ((null? (kwargs)) #f) - ((equal? (car kwargs) kw) (cadr kwargs)) - (else (kw-arg kw (cddr kwargs))))) - (define-method (build-command (c ) pwd env prog args) (let ((cmd (list (if (sudo? c) "sudo" "env")))) (chain-when cmd @@ -123,3 +121,34 @@ (lambda () (init-connection! c)) (lambda () (proc c)) (lambda () (close-connection! c)))) + +(define (keyword-arg kw args) + (cond + ((< (length args) 2) #f) + ((equal? (first args) kw) (second args)) + (else (keyword-arg kw (cddr args))))) + +(define (run conn prog . args) + (let* ((args kwargs (break keyword? args)) + (pwd (keyword-arg #:pwd kwargs)) + (env (keyword-arg #:env kwargs))) + (connection-run conn pwd env prog args))) + +(define (run1 . args) + (let ((out rc (apply run args))) + (values (first out) rc))) + +(define (must conn prog . args) + (let* ((args kwargs (break keyword? args)) + (pwd (keyword-arg #:pwd kwargs)) + (env (keyword-arg #:env kwargs)) + (error-msg (keyword-arg #:error-msg kwargs)) + (out rc (connection-run conn pwd env prog args))) + (if (zero? rc) + out + (error (if error-msg + (format #f "~a: ~a" error-msg out) + (format #f "~a error: ~a" prog out)))))) + +(define (must1 . args) + (first (apply must args))) diff --git a/tryme.scm b/tryme.scm index 6ac494b..8430a66 100644 --- a/tryme.scm +++ b/tryme.scm @@ -1,44 +1,24 @@ (use-modules (ice-9 filesystem) - (ordo condition) + (ordo) (ordo connection) - (ordo context) - (ordo action filesystem) - (ordo play) - (ordo task) - (ordo handler)) + (ordo logger)) -(define test-play - (play "Test play" - #:connection (local-connection) - #:vars '((base-dir . "/home/ray/ordo-test")) - #:tasks (list - (task "Override base dir" - (const "/home/ray/ordo-test-again") - #:register 'base-dir) - (task "Create test directory" - (bind-context-vars - (base-dir) - (action:install-dir base-dir)) - #:condition (bind-context-vars - (base-dir) - (negate (cond:directory? base-dir)))) - (task "Create test file from string content" - (bind-context-vars - (base-dir) - (action:install-file (file-name-join* base-dir "foo") - #:content "Hello, world!\n" - #:mode #o600)) - #:register 'foo) - (task "Get file status" - (bind-context-vars - (foo) - (action:stat foo)) - #:register 'stat-out - #:triggers '(display-stat))) - #:handlers `((display-stat . ,(handler "Display stat" - (bind-context-vars - (foo stat-out) - (lambda _ (pk foo stat-out)))))))) +(define test-playbook + (playbook + #:name "Test Playbook" + #:plays (list + (play + #:name "Test play" + #:connection (local-connection) + #:vars '((base-dir . "/home/ray/ordo-test")) + #:acts (list + (act #:name "Act I" + #:tasks (list + (task #:name "Create base directory" + #:action (lambda (c) (must c "mkdir" "-p" ($ 'base-dir)))) + (task #:name "Create test file" + #:action (lambda (c) (must c "touch" (file-name-join* ($ 'base-dir) "test-file"))))))))))) -(run-play test-play) +(setup-logging) +(perform test-playbook '())