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

More work on execution

Browse source
This commit is contained in:
Ray Miller 2025-07-04 17:13:14 +01:00
parent be28e14d3e
commit ae8c24aa63
Signed by: ray
GPG key ID: 043F786C4CD681B8
5 changed files with 129 additions and 99 deletions
Download patch file Download diff file Expand all files Collapse all files

31
examples/inventory.scm
View file

@ -1,23 +1,22 @@
(use-modules (ordo connection) (use-modules (ordo connection)
(ordo inventory)) (ordo inventory))
(list (defhost "little-rascal"
(host #:name "root@little-rascal" #:connection (local-connection)
#:connection (local-connection #:become? #t) #:tags '(#:linux #:guix))
#:tags '(#:linux #:guix))
(host #:name "root@limiting-factor" (defhost "limiting-factor"
#:connection (ssh-connection #:host "limiting-factor" #:user "core" #:become? #t) #:connection (ssh-connection #:host "limiting-factor" #:user "core")
#:tags '(#:linux #:coreos)) #:tags '(#:linux #:coreos))
(host #:name "root@screw-loose" (defhost "screw-loose"
#:connection (ssh-connection #:host "screw-loose" #:user "core" #:become? #t) #:connection (ssh-connection #:host "screw-loose" #:user "core")
#:tags '(#:linux #:coreos)) #:tags '(#:linux #:coreos))
(host #:name "root@control-surface" (defhost "control-surface"
#:connection (ssh-connection #:host "control-surface" #:user "ray" #:become? #t) #:connection (ssh-connection #:host "control-surface" #:user "ray")
#:tags '(#:linux #:debian)) #:tags '(#:linux #:debian))
(host #:name "root@cargo-cult" (defhost "cargo-cult"
#:connection (ssh-connection #:host "cargo-cult" #:user "ray" #:become? #t) #:connection (ssh-connection #:host "cargo-cult" #:user "ray")
#:tags '(#:linux #:synology))) #:tags '(#:linux #:synology))

5
examples/uptime.scm
View file

@ -7,6 +7,9 @@
(define uptime (task #:name "uptime" #:action (cut remote-cmd <> "uptime" #:return car))) (define uptime (task #:name "uptime" #:action (cut remote-cmd <> "uptime" #:return car)))
(define flow (workflow (define flow (workflow
(step #:action uptime #:target "root@limiting-factor" #:continue-on-err? #t))) (execute uptime "limiting-factor" '(#:sudo #t))))
(define resolver (load-inventory "examples/inventory.scm")) (define resolver (load-inventory "examples/inventory.scm"))
;; IDEA: have load-inventory! set an *inventory* parameter and remove the execute methods
;; that take a <host-resolver> argument, making this implicit.

21
ordo/connection.scm
View file

@ -21,6 +21,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
#:use-module (ordo connection base) #:use-module (ordo connection base)
#:use-module (ordo connection local) #:use-module (ordo connection local)
#:use-module (ordo connection ssh) #:use-module (ordo connection ssh)
#:use-module (ordo connection sudo)
#:use-module (ordo logger) #:use-module (ordo logger)
#:use-module (ordo util flatten) #:use-module (ordo util flatten)
#:use-module (ordo util keyword-args) #:use-module (ordo util keyword-args)
@ -42,11 +43,21 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(define (ssh-connection . args) (define (ssh-connection . args)
(apply make <ssh-connection> args)) (apply make <ssh-connection> args))
(define* (call-with-connection conn proc) (define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password)
(dynamic-wind (let ((conn (deep-clone conn)))
(lambda () (setup conn)) (when sudo?
(lambda () (proc conn)) (unless (is-a? conn <sudo-connection>)
(lambda () (teardown conn)))) (raise-exception
(make-exception
(make-programming-error)
(make-exception-with-message (format #f "connection ~a does not support sudo" conn)))))
(set! (become? conn) sudo?)
(set! (become-user conn) sudo-user)
(set! (become-password conn) sudo-password))
(dynamic-wind
(lambda () (setup conn))
(lambda () (proc conn))
(lambda () (teardown conn)))))
(define (remote-cmd conn prog . args) (define (remote-cmd conn prog . args)
(let* ((args options (break keyword? args)) (let* ((args options (break keyword? args))

121
ordo/core.scm
View file

@ -18,6 +18,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(define-module (ordo core) (define-module (ordo core)
#:use-module (ice-9 exceptions) #:use-module (ice-9 exceptions)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 optargs)
#:use-module (oop goops) #:use-module (oop goops)
#:use-module (ordo connection) #:use-module (ordo connection)
#:use-module (ordo inventory) #:use-module (ordo inventory)
@ -34,7 +35,6 @@ this program. If not, see <https://www.gnu.org/licenses/>.
task-action task-action
task-args task-args
task-trigger task-trigger
task-exception-handler
<handler> <handler>
handler handler
@ -65,39 +65,49 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(pre-condition #:init-keyword #:pre-condition #:init-value (const #t) #:getter task-pre-condition) (pre-condition #:init-keyword #:pre-condition #:init-value (const #t) #:getter task-pre-condition)
(action #:init-keyword #:action #:getter task-action) (action #:init-keyword #:action #:getter task-action)
(args #:init-keyword #:args #:init-form (list) #:getter task-args) (args #:init-keyword #:args #:init-form (list) #:getter task-args)
(trigger #:init-keyword #:trigger #:init-form (list) #:getter task-trigger) (trigger #:init-keyword #:trigger #:init-form (list) #:getter task-trigger))
;; TODO: replace the exception handler with a continue-on-error? boolean, and construct
;; an exception handler that logs the error along with the task name
(exception-handler #:init-keyword #:exception-handler #:init-value #f #:getter task-exception-handler))
(define (task . args) (apply make <task> args)) (define (task . args) (apply make <task> args))
(define (task? x) (is-a? x <task>)) (define (task? x) (is-a? x <task>))
(define-method (execute (task <task>) (conn <connection>)) (define-method (execute (task <task>) (conn <connection>))
(define (task-thunk) (if ((task-pre-condition task) conn)
(if ((task-pre-condition task) conn) (let ((result ((task-action task) conn)))
(let ((result ((task-action task) conn))) (cond
(cond ((equal? result #f)
((equal? result #f) (log-msg 'NOTICE (task-name task) " - OK"))
(log-msg 'NOTICE (task-name task) " - OK")) ((equal? result #t)
((equal? result #t) (log-msg 'NOTICE (task-name task) " - CHANGED")
(log-msg 'NOTICE (task-name task) " - CHANGED") (for-each schedule-handler! (task-trigger task)))
(for-each schedule-handler! (task-trigger task))) (else
(else (log-msg 'NOTICE (task-name task) " - " result))))
(log-msg 'NOTICE (task-name task) " - " result)))))) (log-msg 'NOTICE (task-name task) " - SKIPPED")))
(if (task-exception-handler task)
(with-exception-handler (task-exception-handler task) task-thunk #:unwind? #t)
(task-thunk)))
(define-method (execute (task <task>) (host <host>)) (define-method (execute (task <task>) (host <host>) (options <list>))
(log-msg 'NOTICE "Executing task " (task-name task) " on host " (host-name host)) (log-msg 'NOTICE "Executing task " (task-name task) " on host " (host-name host))
(call-with-connection (host-connection host) (cut execute task <>))) (let-keywords
options #t
((sudo? #f)
(sudo-user #f)
(sudo-password #f))
(call-with-connection
(host-connection host)
(cut execute task <> options)
#:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password)))
(define-method (execute (task <task>) (resolver <host-resolver>) target (continue-on-err? <boolean>)) (define-method (execute (task <task>) target (options <list>))
(let ((run-on-host (if continue-on-err? (let-keywords
(lambda (host) (with-exception-handler (cut log-msg 'ERROR <>) (lambda () (execute task host)) #:unwind? #t)) options #t
(lambda (host) (execute task host))))) ((continue-on-error? #f))
(for-each run-on-host (resolve-hosts resolver target)))) (for-each
(if continue-on-error?
(lambda (host)
(with-exception-handler
(lambda (e) (log-msg 'ERROR "Failed to execute " (task-name task) " on host " (host-name host)))
(execute task host options)))
(lambda (host)
(execute task host options)))
(resolve-hosts target))))
(define-class <handler> () (define-class <handler> ()
(name #:init-keyword #:name #:getter handler-name) (name #:init-keyword #:name #:getter handler-name)
@ -153,32 +163,47 @@ in which case it is a no-op."
(log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint)) (log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint))
(for-each (cut execute <> conn) (for-each (cut execute <> conn)
(blueprint-tasks blueprint)) (blueprint-tasks blueprint))
(for-each (cut execute <> conn) (for-each (lambda (handler)
(filter (lambda (handler) (when (hash-table-ref/default (*triggered-handlers*) (handler-name handler) #f)
(hash-table-ref/default (*triggered-handlers*) (handler-name handler) #f)) (execute handler conn)))
(blueprint-handlers blueprint))))) (blueprint-handlers blueprint))))
(define-method (execute (blueprint <blueprint>) (host <host>)) (define-method (execute (blueprint <blueprint>) (host <host>) (options <list>))
(log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint) " on host " (host-name host)) (log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint) " on host " (host-name host))
(call-with-connection (host-connection host) (cut execute blueprint <>))) (let-keywords
options #t
((sudo? #f)
(sudo-user #f)
(sudo-password #f))
(call-with-connection
(host-connection host)
(cut execute blueprint <>)
#:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password)))
(define-method (execute (blueprint <blueprint>) (resolver <host-resolver>) target (continue-on-err? <boolean>)) (define-method (execute (blueprint <blueprint>) target (options <list>))
(let ((run-on-host (if continue-on-err? (let-keywords
(lambda (host) options #t
(with-exception-handler (cut log-msg 'ERROR <>) (lambda () (execute blueprint host)) #:unwind? #t)) ((continue-on-error? #f))
(lambda (host) (for-each
(execute blueprint host))))) (if continue-on-error?
(for-each run-on-host (resolve-hosts resolver target)))) (lambda (host)
(with-exception-handler
(cut log-msg 'ERROR "Failed to execute blueprint " (blueprint-name blueprint) " on host " (host-name host))
(execute blueprint host options)
#:unwind? #t))
(lambda (host)
(execute blueprint host options)))
(resolve-hosts target))))
(define-class <workflow> () ;; (define-class <workflow> ()
(steps #:init-keyword #:steps #:getter workflow-steps)) ;; (steps #:init-keyword #:steps #:getter workflow-steps))
(define* (step #:key action target continue-on-err?) ;; (define* (step #:key action target continue-on-err?)
(lambda (resolver) ;; (lambda (resolver)
(execute action resolver target continue-on-err?))) ;; (execute action resolver target continue-on-err?)))
(define (workflow . steps) ;; (define (workflow . steps)
(make <workflow> #:steps steps)) ;; (make <workflow> #:steps steps))
(define-method (execute (wf <workflow>) (resolver <host-resolver>)) ;; (define-method (execute (wf <workflow>) (resolver <host-resolver>))
(for-each (lambda (step) (step resolver)) (workflow-steps wf))) ;; (for-each (lambda (step) (step resolver)) (workflow-steps wf)))

50
ordo/inventory.scm
View file

@ -26,18 +26,16 @@ this program. If not, see <https://www.gnu.org/licenses/>.
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-69) #:use-module (srfi srfi-69)
#:export (<host> #:export (<host>
host defhost
host? host?
host-name host-name
host-connection host-connection
host-tags host-tags
<host-resolver>
<inventorp>
get-inventory-hosts
resolve-hosts resolve-hosts
load-inventory)) load-inventory!))
(define *inventory* '())
(define-class <host> () (define-class <host> ()
(name #:init-keyword #:name #:getter host-name) (name #:init-keyword #:name #:getter host-name)
@ -46,8 +44,6 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(define (host? h) (is-a? h <host>)) (define (host? h) (is-a? h <host>))
(define (host . args) (apply make <host> args))
(define (tagged-every? wanted-tags) (define (tagged-every? wanted-tags)
(lambda (h) (lambda (h)
(lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags))))
@ -60,28 +56,24 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(lambda (h) (lambda (h)
(string=? (host-name h) hostname))) (string=? (host-name h) hostname)))
(define-class <host-resolver> ()) (define-method (resolve-hosts expr)
(define-class <inventory> (<host-resolver>)
(hosts #:init-keyword #:hosts #:getter get-inventory-hosts))
(define-method (resolve-hosts (inventory <inventory>) expr)
(define hosts (get-inventory-hosts inventory))
(match expr (match expr
("localhost" (list (or (find (named? "localhost") hosts) ("localhost" (list (or (find (named? "localhost") *inventory*)
(host #:name "localhost" #:connection (local-connection))))) (make <host> #:name "localhost" #:connection (local-connection)))))
((? string? hostname) (filter (named? hostname) hosts)) ((? string? hostname) (filter (named? hostname) *inventory*))
('all hosts) ('all *inventory*)
(('tagged tag) (filter (tagged-every? (list tag)) hosts)) (('tagged tag) (filter (tagged-every? (list tag)) *inventory*))
(('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) hosts)) (('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) *inventory*))
(('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) hosts)) (('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) *inventory*))
((. hostnames) (filter (lambda (h) (member (host-name h) hostnames string=?)) hosts)))) ((. hostnames) (filter (lambda (h) (member (host-name h) hostnames string=?)) *inventory*))))
(define (defhost name . args)
(let ((host (apply make <host> #:name name args)))
(set! *inventory* (cons host *inventory*))))
(define (load-inventory filename) (define (load-inventory filename)
(log-msg 'INFO "Loading inventory " filename) (log-msg 'INFO "Loading inventory " filename)
(let* ((hosts (eval-string (call-with-input-file filename get-string-all) (eval-string (call-with-input-file filename get-string-all)
#:file filename)) #:file filename)
(hosts (if (list? hosts) hosts '()))) (when (null? *inventory*)
(when (null? hosts) (log-msg 'NOTICE "Inventory is empty, only localhost will be available")))
(log-msg 'NOTICE "Inventory is empty, only localhost will be available"))
(make <inventory> #:hosts hosts)))