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)
(ordo inventory))
(list
(host #:name "root@little-rascal"
#:connection (local-connection #:become? #t)
#:tags '(#:linux #:guix))
(defhost "little-rascal"
#:connection (local-connection)
#:tags '(#:linux #:guix))
(host #:name "root@limiting-factor"
#:connection (ssh-connection #:host "limiting-factor" #:user "core" #:become? #t)
#:tags '(#:linux #:coreos))
(defhost "limiting-factor"
#:connection (ssh-connection #:host "limiting-factor" #:user "core")
#:tags '(#:linux #:coreos))
(host #:name "root@screw-loose"
#:connection (ssh-connection #:host "screw-loose" #:user "core" #:become? #t)
#:tags '(#:linux #:coreos))
(defhost "screw-loose"
#:connection (ssh-connection #:host "screw-loose" #:user "core")
#:tags '(#:linux #:coreos))
(host #:name "root@control-surface"
#:connection (ssh-connection #:host "control-surface" #:user "ray" #:become? #t)
#:tags '(#:linux #:debian))
(defhost "control-surface"
#:connection (ssh-connection #:host "control-surface" #:user "ray")
#:tags '(#:linux #:debian))
(host #:name "root@cargo-cult"
#:connection (ssh-connection #:host "cargo-cult" #:user "ray" #:become? #t)
#:tags '(#:linux #:synology)))
(defhost "cargo-cult"
#:connection (ssh-connection #:host "cargo-cult" #:user "ray")
#: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 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"))
;; 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 local)
#:use-module (ordo connection ssh)
#:use-module (ordo connection sudo)
#:use-module (ordo logger)
#:use-module (ordo util flatten)
#:use-module (ordo util keyword-args)
@ -42,11 +43,21 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(define (ssh-connection . args)
(apply make <ssh-connection> args))
(define* (call-with-connection conn proc)
(dynamic-wind
(lambda () (setup conn))
(lambda () (proc conn))
(lambda () (teardown conn))))
(define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password)
(let ((conn (deep-clone conn)))
(when sudo?
(unless (is-a? conn <sudo-connection>)
(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)
(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)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 format)
#:use-module (ice-9 optargs)
#:use-module (oop goops)
#:use-module (ordo connection)
#:use-module (ordo inventory)
@ -34,7 +35,6 @@ this program. If not, see <https://www.gnu.org/licenses/>.
task-action
task-args
task-trigger
task-exception-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)
(action #:init-keyword #:action #:getter task-action)
(args #:init-keyword #:args #:init-form (list) #:getter task-args)
(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))
(trigger #:init-keyword #:trigger #:init-form (list) #:getter task-trigger))
(define (task . args) (apply make <task> args))
(define (task? x) (is-a? x <task>))
(define-method (execute (task <task>) (conn <connection>))
(define (task-thunk)
(if ((task-pre-condition task) conn)
(let ((result ((task-action task) conn)))
(cond
((equal? result #f)
(log-msg 'NOTICE (task-name task) " - OK"))
((equal? result #t)
(log-msg 'NOTICE (task-name task) " - CHANGED")
(for-each schedule-handler! (task-trigger task)))
(else
(log-msg 'NOTICE (task-name task) " - " result))))))
(if (task-exception-handler task)
(with-exception-handler (task-exception-handler task) task-thunk #:unwind? #t)
(task-thunk)))
(if ((task-pre-condition task) conn)
(let ((result ((task-action task) conn)))
(cond
((equal? result #f)
(log-msg 'NOTICE (task-name task) " - OK"))
((equal? result #t)
(log-msg 'NOTICE (task-name task) " - CHANGED")
(for-each schedule-handler! (task-trigger task)))
(else
(log-msg 'NOTICE (task-name task) " - " result))))
(log-msg 'NOTICE (task-name task) " - SKIPPED")))
(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))
(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>))
(let ((run-on-host (if continue-on-err?
(lambda (host) (with-exception-handler (cut log-msg 'ERROR <>) (lambda () (execute task host)) #:unwind? #t))
(lambda (host) (execute task host)))))
(for-each run-on-host (resolve-hosts resolver target))))
(define-method (execute (task <task>) target (options <list>))
(let-keywords
options #t
((continue-on-error? #f))
(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> ()
(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))
(for-each (cut execute <> conn)
(blueprint-tasks blueprint))
(for-each (cut execute <> conn)
(filter (lambda (handler)
(hash-table-ref/default (*triggered-handlers*) (handler-name handler) #f))
(blueprint-handlers blueprint)))))
(for-each (lambda (handler)
(when (hash-table-ref/default (*triggered-handlers*) (handler-name handler) #f)
(execute handler conn)))
(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))
(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>))
(let ((run-on-host (if continue-on-err?
(lambda (host)
(with-exception-handler (cut log-msg 'ERROR <>) (lambda () (execute blueprint host)) #:unwind? #t))
(lambda (host)
(execute blueprint host)))))
(for-each run-on-host (resolve-hosts resolver target))))
(define-method (execute (blueprint <blueprint>) target (options <list>))
(let-keywords
options #t
((continue-on-error? #f))
(for-each
(if continue-on-error?
(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> ()
(steps #:init-keyword #:steps #:getter workflow-steps))
;; (define-class <workflow> ()
;; (steps #:init-keyword #:steps #:getter workflow-steps))
(define* (step #:key action target continue-on-err?)
(lambda (resolver)
(execute action resolver target continue-on-err?)))
;; (define* (step #:key action target continue-on-err?)
;; (lambda (resolver)
;; (execute action resolver target continue-on-err?)))
(define (workflow . steps)
(make <workflow> #:steps steps))
;; (define (workflow . steps)
;; (make <workflow> #:steps steps))
(define-method (execute (wf <workflow>) (resolver <host-resolver>))
(for-each (lambda (step) (step resolver)) (workflow-steps wf)))
;; (define-method (execute (wf <workflow>) (resolver <host-resolver>))
;; (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-69)
#:export (<host>
host
defhost
host?
host-name
host-connection
host-tags
<host-resolver>
<inventorp>
get-inventory-hosts
resolve-hosts
load-inventory))
load-inventory!))
(define *inventory* '())
(define-class <host> ()
(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 . args) (apply make <host> args))
(define (tagged-every? wanted-tags)
(lambda (h)
(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)
(string=? (host-name h) hostname)))
(define-class <host-resolver> ())
(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))
(define-method (resolve-hosts expr)
(match expr
("localhost" (list (or (find (named? "localhost") hosts)
(host #:name "localhost" #:connection (local-connection)))))
((? string? hostname) (filter (named? hostname) hosts))
('all hosts)
(('tagged tag) (filter (tagged-every? (list tag)) hosts))
(('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) hosts))
(('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) hosts))
((. hostnames) (filter (lambda (h) (member (host-name h) hostnames string=?)) hosts))))
("localhost" (list (or (find (named? "localhost") *inventory*)
(make <host> #:name "localhost" #:connection (local-connection)))))
((? string? hostname) (filter (named? hostname) *inventory*))
('all *inventory*)
(('tagged tag) (filter (tagged-every? (list tag)) *inventory*))
(('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) *inventory*))
(('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) *inventory*))
((. 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)
(log-msg 'INFO "Loading inventory " filename)
(let* ((hosts (eval-string (call-with-input-file filename get-string-all)
#:file filename))
(hosts (if (list? hosts) hosts '())))
(when (null? hosts)
(log-msg 'NOTICE "Inventory is empty, only localhost will be available"))
(make <inventory> #:hosts hosts)))
(eval-string (call-with-input-file filename get-string-all)
#:file filename)
(when (null? *inventory*)
(log-msg 'NOTICE "Inventory is empty, only localhost will be available")))