Refactor to use a core namespace with global vars

2025-01-11 21:00:24 +00:00 · 2025-01-11 21:00:24 +00:00 · 04a75984cb
commit 04a75984cb
parent a65415f846
3 changed files with 222 additions and 46 deletions
--- a/modules/ordo.scm
+++ 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 <task> ()
+  (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 <task> args))
+
+(define-method (check-condition (t <task>) (c <connection>))
+  (if (slot-bound? t 'condition)
+      ((task-condition t) c)
+      #t))
+
+(define-method (perform (t <task>) (c <connection>))
+  (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 <act> ()
+  (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 <act> args))
+
+(define-method (check-condition (a <act>) (c <connection>))
+  (if (slot-bound? a 'condition)
+      ((act-condition a) c)
+      #t))
+
+(define-method (perform (a <act>) (c <connection>))
+  (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 <play> ()
+  (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 <play> args))
+
+(define-method (perform (p <play>))
+  (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 <playbook> ()
+  (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 <playbook> args))
+
+(define-method (perform (pb <playbook>) (filter-tags <list>))
+  (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 <task>, <act>, <play>, and <playbook>
--- 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 <connection> ()
  (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 <connection>) 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)))
--- 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 '())