ray/ordo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Switch back to records, not goops

Browse source
This commit is contained in:
Ray Miller 2025-01-12 15:28:29 +00:00
parent 70543ef7c5
commit 5376ce9f19
Signed by: ray
GPG key ID: 043F786C4CD681B8
3 changed files with 117 additions and 140 deletions
Download patch file Download diff file Expand all files Collapse all files

202
modules/ordo.scm
View file

@ -1,20 +1,34 @@
(define-module (ordo) (define-module (ordo)
#:use-module (ice-9 exceptions) #:use-module (ice-9 exceptions)
#:use-module (logging logger) #:use-module (logging logger)
#:use-module (oop goops)
#:use-module (ordo connection) #:use-module (ordo connection)
#:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-1) ; list utils
#:use-module (srfi srfi-9) ; records
#:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-26) ; cut
#:use-module (srfi srfi-69) ; hash-tables #:use-module (srfi srfi-69) ; hash-tables
#:export (task #:export (task
act task-name
task-tags
task-action
task-condition
task-register
task-triggers
run-task
play play
play-name
play-vars
play-tasks
play-connection
play-handlers
run-play
playbook playbook
playbook-name
playbook-vars
playbook-plays
run-playbook
$ $
register-act-var
register-play-var register-play-var
register-playbook-var register-playbook-var))
perform))
(define +filter-tags+ '()) (define +filter-tags+ '())
@ -22,19 +36,6 @@
(or (null? +filter-tags+) (or (null? +filter-tags+)
(not (null? (lset-intersection eqv? +filter-tags+ 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 +play-vars+ #f)
(define (register-play-var var-name) (define (register-play-var var-name)
@ -50,7 +51,7 @@
(hash-table-set! +playbook-vars+ var-name v))) (hash-table-set! +playbook-vars+ var-name v)))
(define ($ var-name) (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." variable (in that order). Raise an exception if the variable is not found."
(define not-found (cons 'not-found '())) (define not-found (cons 'not-found '()))
(define (lookup-var var-name vars) (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) (if (eqv? v not-found)
(lookup-var var-name (cdr vars)) (lookup-var var-name (cdr vars))
v))))) v)))))
(lookup-var var-name (list +act-vars+ +play-vars+ +playbook-vars+))) (lookup-var var-name (list +play-vars+ +playbook-vars+)))
(define-class <task> () (define +triggers+ #f)
(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 (add-triggers triggers)
(set! +triggers+ (apply lset-adjoin equal? (or +triggers+ '())
triggers)))
(define-method (check-condition (t <task>) (c <connection>)) (define-record-type <task>
(if (slot-bound? t 'condition) (make-task name tags action condition register triggers)
((task-condition t) c) task?
#t)) (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)) (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)") (log-msg 'NOTICE "Skipping task " (task-name t) " (precondition not met)")
(begin (begin
(log-msg 'NOTICE "Performing task " (task-name t)) (log-msg 'NOTICE "Running task " (task-name t))
(let ((result ((task-action t) c))) (let ((result ((task-action t) c)))
(when (slot-bound? t 'register) ((task-register t) result)
((task-register t) result)) (add-triggers (task-triggers t)))))))
(when (slot-bound? t 'triggers)
(add-act-triggers (task-triggers t))))))))
(define-class <handler> () (define-record-type <handler>
(name #:init-keyword #:name #:getter handler-name) (make-handler name action)
(action #:init-keyword #:action #:getter handler-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> () (define-record-type <play>
(name #:init-keyword #:name #:getter act-name) (make-play name connection vars tasks handlers)
(tags #:init-keyword #:tags #:getter act-tags #:init-form '()) play?
(vars #:init-keyword #:vars #:getter act-vars) (name play-name)
(condition #:init-keyword #:condition #:getter act-condition) (connection play-connection)
(tasks #:init-keyword #:tasks #:getter act-tasks) (vars play-vars)
(handlers #:init-keyword #:handlers #:getter act-handlers)) (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>)) (define (run-play p)
(if (slot-bound? a 'condition) (log-msg 'NOTICE "Running play " (play-name p))
((act-condition a) c) (dynamic-wind
#t)) (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>)) (define-record-type <playbook>
(when (check-tags (act-tags a)) (make-playbook name vars plays)
(if (not (check-condition a c)) playbook?
(log-msg 'NOTICE "Skipping act " (act-name a) " (precondition not met)") (name playbook-name)
(begin (vars playbook-vars)
(log-msg 'NOTICE "Performing act " (act-name a)) (plays playbook-plays))
(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-class <play> () (define* (playbook name #:key (vars '()) . plays)
(name #:init-keyword #:name #:getter play-name) (make-playbook name vars plays))
(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* (run-playbook pb #:optional (filter-tags '()))
(log-msg 'NOTICE "Running playbook " (playbook-name pb))
(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))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(set! +filter-tags+ filter-tags) (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 () (lambda ()
(for-each perform (playbook-plays pb))) (for-each run-play (playbook-plays pb)))
(lambda () (lambda ()
(set! +filter-tags+ '()) (set! +filter-tags+ '())
(set! +playbook-vars+ #f)))) (set! +playbook-vars+ #f))))
;; TODO: add validate methods for <task>, <act>, <play>, and <playbook> ;; TODO: add validate methods for <task>, <play>, and <playbook>

21
modules/ordo/connection.scm
View file

@ -80,15 +80,16 @@
(loop (read-line port) '())) (loop (read-line port) '()))
(define-method (build-command (c <connection>) pwd env prog args) (define-method (build-command (c <connection>) pwd env prog args)
(let ((cmd (list (if (sudo? c) "sudo" "env")))) (let ((cmd (chain-when (list (if (sudo? c) "sudo" "env"))
(chain-when cmd (pwd (append _ (list "--chdir" pwd)))
(pwd (append _ (list "--chdir" pwd))) (env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env)))
(env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env))) (#t (append _
(#t (append _ (list prog)
(list prog) (map string-shell-quote args)
(map string-shell-quote args) (list "2>&1")))
(list "2>&1"))) (#t (string-join _ " ")))))
(#t (string-join _ " "))))) (log-msg 'INFO "Running command: " cmd)
cmd))
(define-method (connection-run (c <local-connection>) pwd env prog args) (define-method (connection-run (c <local-connection>) pwd env prog args)
(let* ((cmd (build-command c pwd env prog args)) (let* ((cmd (build-command c pwd env prog args))
@ -127,7 +128,7 @@
(cond (cond
((< (length args) 2) default) ((< (length args) 2) default)
((equal? (first args) kw) (second args)) ((equal? (first args) kw) (second args))
(else (keyword-arg kw (cddr args))))) (else (keyword-arg kw (cddr args) default))))
(define (run conn prog . args) (define (run conn prog . args)
(let* ((args (flatten args)) (let* ((args (flatten args))

34
tryme.scm
View file

@ -1,7 +1,5 @@
(use-modules (use-modules
(ice-9 filesystem) (ice-9 filesystem)
(logging logger)
(srfi srfi-26)
(ordo) (ordo)
(ordo connection) (ordo connection)
(ordo logger)) (ordo logger))
@ -20,24 +18,22 @@
(when update? "-u") (when update? "-u")
#:check? #t))) #:check? #t)))
(lambda () (lambda ()
(for-each (cut log-msg 'INFO <>) (run conn "rm" "-rf" tmp-dir #:check? #t)))))
(run conn "echo" "rm" "-rf" tmp-dir #:check? #t))))))
(define test-playbook (define test-playbook
(playbook (playbook "Test Playbook"
#:name "Test Playbook" (play "Test play"
#:plays (list #:connection (local-connection)
(play (task "Get home directory"
#:name "Test play" (lambda (c) (run c "sh" "-c" "[ -n \"$HOME\" ] && echo $HOME" #:check? #t #:return car))
#:connection (local-connection) #:register (register-play-var 'home-dir)
#:vars '((base-dir . "/home/ray/ordo-test")) #:tags '(#:always))
#:acts (list (task "Install AWS CLI"
(act #:name "Act I" (lambda (c)
#:tasks (list (install-aws-cli c
(task #:name "Create base directory" #:update? #t
#:action (lambda (c) (must c "mkdir" "-p" ($ 'base-dir)))) #:install-dir (file-name-join* ($ 'home-dir) ".local" "aws-cli")
(task #:name "Create test file" #:bin-dir (file-name-join* ($ 'home-dir) ".local" "bin")))))))
#:action (lambda (c) (must c "touch" (file-name-join* ($ 'base-dir) "test-file")))))))))))
(setup-logging) (setup-logging)
(perform test-playbook '()) (run-playbook test-playbook)