diff --git a/examples/inventory.scm b/examples/inventory.scm index 944aa60..08b81dd 100644 --- a/examples/inventory.scm +++ b/examples/inventory.scm @@ -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)) diff --git a/examples/uptime.scm b/examples/uptime.scm index 163f6f5..2a4340d 100644 --- a/examples/uptime.scm +++ b/examples/uptime.scm @@ -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 argument, making this implicit. diff --git a/ordo/connection.scm b/ordo/connection.scm index 302bffd..5b22034 100644 --- a/ordo/connection.scm +++ b/ordo/connection.scm @@ -21,6 +21,7 @@ this program. If not, see . #: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 . (define (ssh-connection . args) (apply make 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 ) + (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)) diff --git a/ordo/core.scm b/ordo/core.scm index 2488987..74e69ec 100644 --- a/ordo/core.scm +++ b/ordo/core.scm @@ -18,6 +18,7 @@ this program. If not, see . (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 . task-action task-args task-trigger - task-exception-handler handler @@ -65,39 +65,49 @@ this program. If not, see . (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 args)) (define (task? x) (is-a? x )) (define-method (execute (task ) (conn )) - (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 ) (host )) +(define-method (execute (task ) (host ) (options )) (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 ) (resolver ) target (continue-on-err? )) - (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 ) target (options )) + (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 () (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 ) (host )) +(define-method (execute (blueprint ) (host ) (options )) (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 ) (resolver ) target (continue-on-err? )) - (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 ) target (options )) + (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 () - (steps #:init-keyword #:steps #:getter workflow-steps)) +;; (define-class () +;; (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 #:steps steps)) +;; (define (workflow . steps) +;; (make #:steps steps)) -(define-method (execute (wf ) (resolver )) - (for-each (lambda (step) (step resolver)) (workflow-steps wf))) +;; (define-method (execute (wf ) (resolver )) +;; (for-each (lambda (step) (step resolver)) (workflow-steps wf))) diff --git a/ordo/inventory.scm b/ordo/inventory.scm index ba8eb59..6e8f990 100644 --- a/ordo/inventory.scm +++ b/ordo/inventory.scm @@ -26,18 +26,16 @@ this program. If not, see . #:use-module (srfi srfi-9) #:use-module (srfi srfi-69) #:export ( - host + defhost host? host-name host-connection host-tags - - - - get-inventory-hosts resolve-hosts - load-inventory)) + load-inventory!)) + +(define *inventory* '()) (define-class () (name #:init-keyword #:name #:getter host-name) @@ -46,8 +44,6 @@ this program. If not, see . (define (host? h) (is-a? h )) -(define (host . args) (apply make 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 . (lambda (h) (string=? (host-name h) hostname))) -(define-class ()) - -(define-class () - (hosts #:init-keyword #:hosts #:getter get-inventory-hosts)) - -(define-method (resolve-hosts (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 #: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 #: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 #: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")))