Switch back to records, not goops

2025-01-12 15:28:29 +00:00 · 2025-01-12 15:28:29 +00:00 · 5376ce9f19
commit 5376ce9f19
parent 70543ef7c5
3 changed files with 117 additions and 140 deletions
--- a/modules/ordo.scm
+++ b/modules/ordo.scm
@ -1,20 +1,34 @@
 (define-module (ordo)
  #:use-module (ice-9 exceptions)
  #:use-module (logging logger)
-  #:use-module (oop goops)
  #:use-module (ordo connection)
  #:use-module (srfi srfi-1)  ; list utils
+  #:use-module (srfi srfi-9)  ; records
  #:use-module (srfi srfi-26) ; cut
  #:use-module (srfi srfi-69) ; hash-tables
  #:export (task
-            act
+            task-name
+            task-tags
+            task-action
+            task-condition
+            task-register
+            task-triggers
+            run-task
            play
+            play-name
+            play-vars
+            play-tasks
+            play-connection
+            play-handlers
+            run-play
            playbook
+            playbook-name
+            playbook-vars
+            playbook-plays
+            run-playbook
            $
-            register-act-var
            register-play-var
-            register-playbook-var
-            perform))
+            register-playbook-var))

 (define +filter-tags+ '())

@ -22,19 +36,6 @@
  (or (null? +filter-tags+)
      (not (null? (lset-intersection eqv? +filter-tags+ tags)))))

-(define +act-triggers+ #f)
-
-(define (add-act-triggers triggers)
-  (set! +act-triggers+ (apply lset-adjoin equal? (or +act-triggers+ '())
-                              triggers)))
-
-(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 +play-vars+ #f)

 (define (register-play-var var-name)
@ -50,7 +51,7 @@
    (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
+  "Try to resolve var-name as 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)
@ -64,119 +65,98 @@ variable (in that order). Raise an exception if the variable is 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+)))
+  (lookup-var var-name (list +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 +triggers+ #f)

-(define (task . args) (apply make <task> args))
+(define (add-triggers triggers)
+  (set! +triggers+ (apply lset-adjoin equal? (or +triggers+ '())
+                          triggers)))

-(define-method (check-condition (t <task>) (c <connection>))
-  (if (slot-bound? t 'condition)
-      ((task-condition t) c)
-      #t))
+(define-record-type <task>
+  (make-task name tags action condition register triggers)
+  task?
+  (name task-name)
+  (tags task-tags)
+  (action task-action)
+  (condition task-condition)
+  (register task-register)
+  (triggers task-triggers))

-(define-method (perform (t <task>) (c <connection>))
+(define* (task name action #:key (tags '()) (condition (const #t)) (register (const #f)) (triggers '()))
+  (make-task name tags action condition register triggers))
+
+(define (run-task t c)
  (when (check-tags (task-tags t))
-    (if (not (check-condition t c))
+    (if (not ((task-condition t) c))
        (log-msg 'NOTICE "Skipping task " (task-name t) " (precondition not met)")
        (begin
-          (log-msg 'NOTICE "Performing task " (task-name t))
+          (log-msg 'NOTICE "Running task " (task-name t))
          (let ((result ((task-action t) c)))
-            (when (slot-bound? t 'register)
-              ((task-register t) result))
-            (when (slot-bound? t 'triggers)
-              (add-act-triggers (task-triggers t))))))))
+            ((task-register t) result)
+            (add-triggers (task-triggers t)))))))

-(define-class <handler> ()
-  (name #:init-keyword #:name #:getter handler-name)
-  (action #:init-keyword #:action #:getter handler-action))
+(define-record-type <handler>
+  (make-handler name action)
+  handler?
+  (name handler-name)
+  (action handler-action))

-(define (handler . args) (apply make <handler> args))
+(define (handler name action)
+  (make-handler name action))

-(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-record-type <play>
+  (make-play name connection vars tasks handlers)
+  play?
+  (name play-name)
+  (connection play-connection)
+  (vars play-vars)
+  (tasks play-tasks)
+  (handlers play-handlers))

-(define (act . args) (apply make <act> args))
+(define* (play name #:key connection (vars '()) . more)
+  (let ((tasks (filter task? more))
+        (handlers (filter handler? more)))
+    (make-play name connection vars tasks handlers)))

-(define-method (check-condition (a <act>) (c <connection>))
-  (if (slot-bound? a 'condition)
-      ((act-condition a) c)
-      #t))
+(define (run-play p)
+  (log-msg 'NOTICE "Running play " (play-name p))
+  (dynamic-wind
+    (lambda ()
+      (set! +play-vars+ (alist->hash-table (play-vars p) equal?))
+      (init-connection! (play-connection p)))
+    (lambda ()
+      (for-each (cut run-task <> (play-connection p)) (play-tasks p))
+      (for-each (lambda (h)
+                  (when (member (handler-name h) +triggers+)
+                    (log-msg 'INFO "Running handler " (handler-name h))
+                    ((handler-action h) (play-connection p))))
+                (play-handlers p)))
+    (lambda ()
+      (set! +play-vars+ #f)
+      (set! +triggers+ #f)
+      (close-connection! (play-connection p)))))

-(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))
-              (when (slot-bound? a 'handlers)
-                (for-each (lambda (h)
-                            (when (member (handler-name h) +act-triggers+)
-                              (log-msg 'INFO "Running handler " (handler-name h))
-                              ((handler-action h) c)))
-                          (act-handlers a))))
-            (lambda ()
-              (set! +act-vars+ #f)
-              (set! +act-triggers+ #f)))))))
+(define-record-type <playbook>
+  (make-playbook name vars plays)
+  playbook?
+  (name playbook-name)
+  (vars playbook-vars)
+  (plays playbook-plays))

-(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* (playbook name #:key (vars '()) . plays)
+  (make-playbook name vars plays))

-(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)))
-      (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))
+(define* (run-playbook pb #:optional (filter-tags '()))
+  (log-msg 'NOTICE "Running 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?))))
+      (set! +playbook-vars+ (alist->hash-table (playbook-vars pb) equal?)))
    (lambda ()
-      (for-each perform (playbook-plays pb)))
+      (for-each run-play (playbook-plays pb)))
    (lambda ()
      (set! +filter-tags+ '())
      (set! +playbook-vars+ #f))))

-;; TODO: add validate methods for <task>, <act>, <play>, and <playbook>
+;; TODO: add validate methods for <task>, <play>, and <playbook>
--- a/modules/ordo/connection.scm
+++ b/modules/ordo/connection.scm
@ -80,15 +80,16 @@
  (loop (read-line port) '()))

 (define-method (build-command (c <connection>) pwd env prog args)
-  (let ((cmd (list (if (sudo? c) "sudo" "env"))))
-    (chain-when cmd
-                (pwd (append _ (list "--chdir" pwd)))
-                (env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env)))
-                (#t (append _
-                            (list prog)
-                            (map string-shell-quote args)
-                            (list "2>&1")))
-                (#t (string-join _ " ")))))
+  (let ((cmd (chain-when (list (if (sudo? c) "sudo" "env"))
+                         (pwd (append _ (list "--chdir" pwd)))
+                         (env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env)))
+                         (#t (append _
+                                     (list prog)
+                                     (map string-shell-quote args)
+                                     (list "2>&1")))
+                         (#t (string-join _ " ")))))
+    (log-msg 'INFO "Running command: " cmd)
+    cmd))

 (define-method (connection-run (c <local-connection>) pwd env prog args)
  (let* ((cmd (build-command c pwd env prog args))
@ -127,7 +128,7 @@
  (cond
   ((< (length args) 2) default)
   ((equal? (first args) kw) (second args))
-   (else (keyword-arg kw (cddr args)))))
+   (else (keyword-arg kw (cddr args) default))))

 (define (run conn prog . args)
  (let* ((args (flatten args))
--- a/tryme.scm
+++ b/tryme.scm
@ -1,7 +1,5 @@
 (use-modules
 (ice-9 filesystem)
- (logging logger)
- (srfi srfi-26)
 (ordo)
 (ordo connection)
 (ordo logger))
@ -20,24 +18,22 @@
               (when update? "-u")
               #:check? #t)))
      (lambda ()
-        (for-each (cut log-msg 'INFO <>)
-                  (run conn "echo" "rm" "-rf" tmp-dir #:check? #t))))))
+        (run conn "rm" "-rf" tmp-dir #:check? #t)))))

 (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")))))))))))
+  (playbook "Test Playbook"
+            (play "Test play"
+                  #:connection (local-connection)
+                  (task "Get home directory"
+                        (lambda (c) (run c "sh" "-c" "[ -n \"$HOME\" ] && echo $HOME" #:check? #t #:return car))
+                        #:register (register-play-var 'home-dir)
+                        #:tags '(#:always))
+                  (task "Install AWS CLI"
+                        (lambda (c)
+                          (install-aws-cli c
+                                           #:update? #t
+                                           #:install-dir (file-name-join* ($ 'home-dir) ".local" "aws-cli")
+                                           #:bin-dir (file-name-join* ($ 'home-dir) ".local" "bin")))))))

 (setup-logging)
-(perform test-playbook '())
+(run-playbook test-playbook)