diff --git a/examples/forgejo.scm b/examples/forgejo.scm
index 15742dc..bada9dd 100644
--- a/examples/forgejo.scm
+++ b/examples/forgejo.scm
@@ -1,57 +1,60 @@
(use-modules
- (ordo core)
((ordo action filesystem) #:prefix fs:)
((ordo action quadlet) #:prefix quadlet:)
((ordo action systemctl) #:prefix systemctl:))
(define* (install-forgejo #:key (version "11"))
- "Create a blueprint to install Forgejo on a CoreOS system"
- (blueprint (format #f "Install forgejo version ~a" version)
- (task "Install configuration directory"
- #:action fs:install-dir
- #:args '(#:path "/etc/forgejo")
- #:trigger '("Restart pod"))
- (task "Install timezone configuration"
- #:action fs:install-file
- #:args '(#:path "/etc/forgejo/timezone" #:local-src "files/timezone")
- #:trigger '("Restart pod"))
- (task "Install localtime configuration"
- #:action fs:install-file
- #:args '(#:path "/etc/forgejo/localtime" #:local-src "files/localtime")
- #:trigger '("Restart pod"))
- (task "Create data volume quadlet"
- #:action quadlet:create-volume
- #:args '(#:name "forgejo" #:description "Forgejo data volume")
- #:trigger '("Reload systemd" "Restart pod"))
- (task "Create pod quadlet"
- #:action quadlet:create-pod
- #:args '(#:name "forgejo"
- #:pod ((PodName . "forge")
- (Volume . "forgejo.volume:U,Z")
- (PodmanArgs . "--userns auto")))
- #:trigger '("Reload systemd" "Restart pod"))
- (task "Create image quadlet"
- #:action quadlet:create-image
- #:args `(#:name "forgejo"
- #:image (Image . ,(format #f "codeberg.org/forgejo/forgejo:~a" version)))
- #:trigger '("Reload systemd" "Restart pod"))
- (task "Create container quadlet"
- #:action quadlet:create-container
- #:args '(#:name "forgejo"
- #:container ((Pod . "forgejo.pod")
- (Image . "forgejo.image")
- (Network . "services.network")
- (Volume . "/etc/forgejo/timezone:/etc/timezone:ro,U,Z")
- (Volume . "/etc/forgejo/localtime:/etc/localtime:ro,U,Z")
- (Environment . "USER_UID=1000")
- (Environment . "USER_GID=1000")
- (Environment . "FORGEJO__service__DISABLE_REGISTRATION=true")
- (Environment . "FORGEJO__webhook__ALLOWED_HOST_LIST=private")))
- #:trigger '("Reload systemd" "Restart pod"))
- (handler "Reload systemd"
- #:action systemctl:daemon-reload)
- (handler "Restart pod"
- #:action systemctl:restart
- #:args '((#:unit . "forgejo-pod.service")))))
+ (list
+ (task "Install configuration directory"
+ #:action fs:install-dir
+ #:args '(#:path "/etc/forgejo")
+ #:trigger '("Restart pod"))
+ (task "Install timezone configuration"
+ #:action fs:install-file
+ #:args '(#:path "/etc/forgejo/timezone" #:local-src "files/timezone")
+ #:trigger '("Restart pod"))
+ (task "Install localtime configuration"
+ #:action fs:install-file
+ #:args '(#:path "/etc/forgejo/localtime" #:local-src "files/localtime")
+ #:trigger '("Restart pod"))
+ (task "Create data volume quadlet"
+ #:action quadlet:create-volume
+ #:args '(#:name "forgejo" #:description "Forgejo data volume")
+ #:trigger '("Reload systemd" "Restart pod"))
+ (task "Create pod quadlet"
+ #:action quadlet:create-pod
+ #:args '(#:name "forgejo"
+ #:pod ((PodName . "forge")
+ (Volume . "forgejo.volume:U,Z")
+ (PodmanArgs . "--userns auto")))
+ #:trigger '("Reload systemd" "Restart pod"))
+ (task "Create image quadlet"
+ #:action quadlet:create-image
+ #:args `(#:name "forgejo"
+ #:image (Image . ,(format #f "codeberg.org/forgejo/forgejo:~a" version)))
+ #:trigger '("Reload systemd" "Restart pod"))
+ (task "Create container quadlet"
+ #:action quadlet:create-container
+ #:args '(#:name "forgejo"
+ #:container ((Pod . "forgejo.pod")
+ (Image . "forgejo.image")
+ (Network . "services.network")
+ (Volume . "/etc/forgejo/timezone:/etc/timezone:ro,U,Z")
+ (Volume . "/etc/forgejo/localtime:/etc/localtime:ro,U,Z")
+ (Environment . "USER_UID=1000")
+ (Environment . "USER_GID=1000")
+ (Environment . "FORGEJO__service__DISABLE_REGISTRATION=true")
+ (Environment . "FORGEJO__webhook__ALLOWED_HOST_LIST=private")))
+ #:trigger '("Reload systemd" "Restart pod"))
+ (handler "Reload systemd"
+ #:action systemctl:daemon-reload)
+ (handler "Restart pod"
+ #:action systemctl:restart-unit
+ #:args '((#:unit . "forgejo-pod.service")))))
-(execute (install-forgejo #:version "11") "limiting-factor" #:sudo? #t)
+(playbook "Install Forgejo on limiting-factor"
+ ;; #:vars '((forgejo-version . "11.0.2"))
+ (play
+ #:host "limiting-factor"
+ #:become? #t
+ (install-forgejo #:version "11")))
diff --git a/examples/inventory.scm b/examples/inventory.scm
index 08b81dd..30a2a78 100644
--- a/examples/inventory.scm
+++ b/examples/inventory.scm
@@ -1,22 +1,23 @@
(use-modules (ordo connection)
(ordo inventory))
-(defhost "little-rascal"
- #:connection (local-connection)
- #:tags '(#:linux #:guix))
+(list
+ (host #:name "little-rascal"
+ #:connection (local-connection)
+ #:tags '(#:linux #:guix))
-(defhost "limiting-factor"
- #:connection (ssh-connection #:host "limiting-factor" #:user "core")
- #:tags '(#:linux #:coreos))
+ (host #:name "limiting-factor"
+ #:connection (ssh-connection "limiting-factor" #:user "core")
+ #:tags '(#:linux #:coreos))
-(defhost "screw-loose"
- #:connection (ssh-connection #:host "screw-loose" #:user "core")
- #:tags '(#:linux #:coreos))
+ (host #:name "screw-loose"
+ #:connection (ssh-connection "screw-loose" #:user "core")
+ #:tags '(#:linux #:coreos))
-(defhost "control-surface"
- #:connection (ssh-connection #:host "control-surface" #:user "ray")
- #:tags '(#:linux #:debian))
+ (host #:name "control-surface"
+ #:connection (ssh-connection "control-surface" #:user "ray")
+ #:tags '(#:linux #:debian))
-(defhost "cargo-cult"
- #:connection (ssh-connection #:host "cargo-cult" #:user "ray")
- #:tags '(#:linux #:synology))
+ (host #:name "cargo-cult"
+ #:connection (ssh-connection "cargo-cult" #:user "ray")
+ #:tags '(#:linux #:synology)))
diff --git a/examples/uptime.scm b/examples/uptime.scm
deleted file mode 100644
index c3820e6..0000000
--- a/examples/uptime.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-(use-modules (ordo core)
- (ordo action remote-cmd))
-
-(execute (task "uptime"
- #:action remote-cmd
- #:args (list "uptime" #:return car #:check? #t))
- 'all
- #:continue-on-error? #t)
diff --git a/ordo/action/filesystem.scm b/ordo/action/filesystem.scm
index 789a20f..bb87ae3 100644
--- a/ordo/action/filesystem.scm
+++ b/ordo/action/filesystem.scm
@@ -23,8 +23,8 @@ this program. If not, see .
#:use-module (srfi srfi-1) ; list utils
#:use-module (srfi srfi-26) ; cut
#:use-module (srfi srfi-71) ; extended let
- #:use-module (ordo action remote-cmd)
- #:use-module ((ordo connection base) #:select (with-remote-output-file))
+ #:use-module ((ordo connection) #:select (remote-cmd))
+ #:use-module (ordo connection base)
#:export (create-tmp-dir
install-dir
install-file
diff --git a/ordo/action/quadlet.scm b/ordo/action/quadlet.scm
index 24607e6..883baf0 100644
--- a/ordo/action/quadlet.scm
+++ b/ordo/action/quadlet.scm
@@ -19,7 +19,7 @@ this program. If not, see .
#:use-module (ice-9 filesystem)
#:use-module (ini)
#:use-module (logging logger)
- #:use-module (ordo action remote-cmd)
+ #:use-module (ordo connection)
#:use-module ((ordo action filesystem) #:prefix fs:)
#:use-module ((srfi srfi-1) #:select (remove))
#:export (create-network
diff --git a/ordo/action/remote-cmd.scm b/ordo/action/remote-cmd.scm
deleted file mode 100644
index 4f2475f..0000000
--- a/ordo/action/remote-cmd.scm
+++ /dev/null
@@ -1,29 +0,0 @@
-(define-module (ordo action remote-cmd)
- #:use-module (ice-9 exceptions)
- #:use-module (ice-9 optargs)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-71)
- #:use-module (ordo connection)
- #:use-module (ordo connection base)
- #:use-module (ordo logger)
- #:use-module (ordo util flatten)
- #:export (remote-cmd))
-
-(define (remote-cmd conn prog . args)
- (let ((args options (break keyword? args)))
- (let-keywords
- options #t
- ((return identity)
- (check? #f))
- (let ((command (build-command conn prog (remove unspecified? (flatten args)) options)))
- (log-msg 'DEBUG "Running command: " command " on connection " (describe conn))
- (let ((out rc (remote-exec conn command)))
- (log-msg 'DEBUG "Command exit code: " rc)
- (if check?
- (if (zero? rc)
- (return out)
- (raise-exception (make-exception
- (make-external-error)
- (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog))
- (make-exception-with-irritants out))))
- (values (return out) rc)))))))
diff --git a/ordo/action/systemctl.scm b/ordo/action/systemctl.scm
index e61229b..d8b5eeb 100644
--- a/ordo/action/systemctl.scm
+++ b/ordo/action/systemctl.scm
@@ -16,7 +16,7 @@ this program. If not, see .
|#
(define-module (ordo action systemctl)
- #:use-module (ordo action remote-cmd)
+ #:use-module (ordo connection)
#:export (daemon-reload stop start restart reload))
(define* (daemon-reload conn #:key user?)
diff --git a/ordo/cli/run.scm b/ordo/cli/run.scm
index 8345885..1b46d6b 100644
--- a/ordo/cli/run.scm
+++ b/ordo/cli/run.scm
@@ -16,13 +16,12 @@ this program. If not, see .
|#
(define-module (ordo cli run)
- #:declarative? #f
#:use-module (config)
#:use-module (config api)
#:use-module (ice-9 filesystem)
- #:use-module (ordo core)
#:use-module (ordo inventory)
#:use-module (ordo logger)
+ #:use-module (ordo playbook)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (config handler))
@@ -58,12 +57,12 @@ this program. If not, see .
(arguments
(list
(argument
- (name 'workflow)
+ (name 'playbook)
(handler (cut expand-file-name <> #f #t))
- (example "examples/uptime.scm")
(test file-exists?))))
- (synopsis "Run a workflow")))
+ (synopsis "Run a playbook")))
(define (handler options)
- (load-inventory! (option-ref options 'inventory))
- (load (option-ref options '(workflow))))
+ (let ((inventory (load-inventory (option-ref options 'inventory)))
+ (playbook (load-playbook (option-ref options '(playbook)))))
+ (run-playbook playbook inventory)))
diff --git a/ordo/connection.scm b/ordo/connection.scm
index f729bf9..4c31470 100644
--- a/ordo/connection.scm
+++ b/ordo/connection.scm
@@ -23,23 +23,30 @@ this program. If not, see .
#: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)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-71)
#:export (connection?
local-connection
ssh-connection
- call-with-connection))
+ call-with-connection
+ remote-cmd)
+ #:re-export (remote-exec with-remote-input-file with-remote-output-file))
(define (connection? c)
(is-a? c ))
-(define (local-connection . args)
- (apply make args))
+(define (local-connection)
+ (make ))
-(define (ssh-connection . args)
- (apply make args))
+(define* (ssh-connection host #:key (user (getlogin)) (password #f) (identity #f) (authenticate-server? #t)
+ (sudo? #f) (sudo-user #f) (sudo-password #f))
+ (make #:user user #:host host #:password password
+ #:identity identity #:authenticate-server? authenticate-server?
+ #:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password))
(define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password)
- (log-msg 'DEBUG "call-with-connection " (describe conn))
(let ((conn (deep-clone conn)))
(when sudo?
(unless (is-a? conn )
@@ -54,3 +61,20 @@ this program. If not, see .
(lambda () (setup conn))
(lambda () (proc conn))
(lambda () (teardown conn)))))
+
+(define (remote-cmd conn prog . args)
+ (let* ((args options (break keyword? args))
+ (args (remove unspecified? (flatten args)))
+ (return (keyword-arg options #:return identity))
+ (check? (keyword-arg options #:check?))
+ (command (build-command conn prog args options)))
+ (log-msg 'INFO "Running command: " command)
+ (let ((out rc (remote-exec conn command)))
+ (log-msg 'INFO "Command exit code: " rc)
+ (if check?
+ (if (zero? rc)
+ (return out)
+ (raise-exception (make-exception
+ (make-external-error)
+ (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog)))))
+ (values (return out) rc)))))
diff --git a/ordo/connection/base.scm b/ordo/connection/base.scm
index 0f9a017..d853fdb 100644
--- a/ordo/connection/base.scm
+++ b/ordo/connection/base.scm
@@ -17,13 +17,12 @@ this program. If not, see .
(define-module (ordo connection base)
#:use-module (ice-9 match)
- #:use-module (ice-9 optargs)
#:use-module (oop goops)
#:use-module (ordo util flatten)
+ #:use-module (ordo util keyword-args)
#:use-module (ordo util shell-quote)
#:use-module ((srfi srfi-1) #:select (remove))
#:export (
- describe
setup
teardown
build-command
@@ -33,7 +32,6 @@ this program. If not, see .
(define-generic setup)
(define-generic teardown)
-(define-generic describe)
(define-generic build-command)
(define-generic remote-exec)
(define-generic with-remote-input-file)
@@ -46,17 +44,14 @@ this program. If not, see .
(define-method (teardown (c )) #t)
(define-method (build-command (c ) (prog-name ) (prog-args ) (options ))
- (let-keywords
- options #t
- ((pwd #f)
- (env #f)
- (shell-quote? #t)
- (redirect-err? #t))
- (let ((xs (remove unspecified?
+ (let* ((pwd (keyword-arg options #:pwd))
+ (env (keyword-arg options #:env))
+ (redirect-err? (keyword-arg options #:redirect-err? #t))
+ (xs (remove unspecified?
(flatten (list "env"
(when pwd (list "--chdir" (string-shell-quote pwd)))
(when env (map (match-lambda ((k . v) (string-append k "=" (string-shell-quote v)))) env))
prog-name
- (if shell-quote? (map string-shell-quote prog-args) prog-args)
+ (map string-shell-quote prog-args)
(when redirect-err? "2>&1"))))))
- (string-join xs " "))))
+ (string-join xs " ")))
diff --git a/ordo/connection/local.scm b/ordo/connection/local.scm
index 7df9676..c4d39ae 100644
--- a/ordo/connection/local.scm
+++ b/ordo/connection/local.scm
@@ -25,9 +25,6 @@ this program. If not, see .
(define-class ())
-(define-method (describe (c ))
- (format #f "local-connection (sudo=~a)" (become? c)))
-
(define-method (remote-exec (c ) (command ))
(let* ((port (open-input-pipe command))
(output (read-lines port))
diff --git a/ordo/connection/ssh.scm b/ordo/connection/ssh.scm
index d06e7f7..2b2d2e6 100644
--- a/ordo/connection/ssh.scm
+++ b/ordo/connection/ssh.scm
@@ -23,40 +23,29 @@ this program. If not, see .
#:use-module (ssh channel)
#:use-module (ssh auth)
#:use-module (ssh popen)
+ #:use-module (ssh sftp)
#:use-module (ordo connection base)
#:use-module (ordo connection sudo)
#:use-module (ordo util read-lines)
- #:use-module (ordo util shell-quote)
#:export ())
(define-class ()
(user #:getter ssh-connection-user #:init-keyword #:user)
(host #:getter ssh-connection-host #:init-keyword #:host)
- (password #:getter ssh-connection-password #:init-keyword #:password #:init-value #f)
- (identity #:getter ssh-connection-identity #:init-keyword #:identity #:init-value #f)
- (timeout #:getter ssh-connection-timeout #:init-keyword #:timeout #:init-value 10)
- (authenticate-server? #:getter ssh-connection-authenticate-server? #:init-keyword #:authenticate-server? #:init-value #t)
+ (password #:getter ssh-connection-password #:init-keyword #:password #:init-val #f)
+ (identity #:getter ssh-connection-identity #:init-keyword #:identity #:init-val #f)
+ (authenticate-server? #:getter ssh-connection-authenticate-server? #:init-keyword #:authenticate-server? #:init-val #t)
(session)
(sftp-session))
-(define-method (describe (c ))
- (format #f "ssh ~a@~a (sudo=~a)"
- (ssh-connection-user c)
- (ssh-connection-host c)
- (become? c)))
-
(define-method (setup (c ))
(unless (slot-bound? c 'session)
- (let ((s (make-session #:user (ssh-connection-user c) #:host (ssh-connection-host c))))
- (session-set! s 'timeout (ssh-connection-timeout c))
- (when (ssh-connection-identity c)
- (session-set! s 'identity (ssh-connection-identity c)))
- (slot-set! c 'session s)))
+ (slot-set! c 'session (make-session #:user (ssh-connection-user c) #:host (ssh-connection-host c)))
+ (when (ssh-connection-identity c) (session-set! (slot-ref c 'session) 'identity (ssh-connection-identity c))))
(let ((s (slot-ref c 'session)))
(unless (connected? s)
- (when (equal? 'error (connect! s))
- (error (string-append "Error connecting to " (ssh-connection-host c))))
- (when (ssh-connection-authenticate-server? c)
+ (connect! s)
+ (when (ssh-connection-authenticate-server? s)
(let ((server-auth (authenticate-server s)))
(unless (equal? 'ok server-auth)
(error (format #f "authenticate-server: ~a" server-auth)))))
@@ -64,8 +53,7 @@ this program. If not, see .
(userauth-password! s (ssh-connection-password c))
(userauth-public-key/auto! s))))
(unless (equal? 'success user-auth)
- (error (format #f "userauth: ~a" user-auth))))))
- (next-method))
+ (error (format #f "userauth: ~a" user-auth)))))))
(define-method (remote-exec (c ) (command ))
(let* ((channel (open-remote-input-pipe (slot-ref c 'session) command))
@@ -74,21 +62,19 @@ this program. If not, see .
(close channel)
(values output exit-status)))
+(define-method (sftp-session (c ))
+ (unless (slot-bound? c 'sftp-session)
+ (slot-set! c 'sftp-session (make-sftp-session (session c))))
+ (slot-ref c 'sftp-session))
+
(define-method (with-remote-input-file (c ) (filename ) (proc ))
- (let* ((channel (open-remote-input-pipe (slot-ref c 'session) (string-append "cat " (string-shell-quote filename))))
- (result (proc channel)))
- (close channel)
- result))
+ (call-with-remote-input-file (sftp-session c) filename proc))
(define-method (with-remote-output-file (c ) (filename ) (proc ))
- (let* ((channel (open-remote-output-pipe (slot-ref c 'session) (string-append "cat >" (string-shell-quote filename))))
- (result (proc channel)))
- (close channel)
- result))
+ (call-with-remote-output-file (sftp-session c) filename proc))
(define-method (teardown (c ))
- (next-method)
(when (slot-bound? c 'session)
- (let ((s (slot-ref c 'session)))
+ (let ((s (slot-ref c session)))
(when (connected? s)
(disconnect! s)))))
diff --git a/ordo/connection/sudo.scm b/ordo/connection/sudo.scm
index 0caac17..8271c22 100644
--- a/ordo/connection/sudo.scm
+++ b/ordo/connection/sudo.scm
@@ -29,7 +29,7 @@ this program. If not, see .
become-password))
(define-class ()
- (become? #:accessor become? #:init-keyword #:become? #:init-form #f)
+ (become? #:accessor become? #:init-keyword become? #:init-form #f)
(become-user #:accessor become-user #:init-keyword #:become-user #:init-form #f)
(become-password #:accessor become-password #:init-keyword #:become-password #:init-form #f)
(password-tmp-file #:accessor password-tmp-file))
@@ -51,10 +51,10 @@ this program. If not, see .
(next-method))
((and (become-user conn) (become-password conn))
- (format #f "cat ~a | sudo -k -S -H -u ~a -- ~a" (string-shell-quote (password-tmp-file conn)) (string-shell-quote (become-user conn)) (next-method)))
+ (format #f "cat ~a - | sudo -k -S -H -u ~a -- ~a" (string-shell-quote (password-tmp-file conn)) (string-shell-quote (become-user conn)) (next-method)))
((become-password conn)
- (format #f "cat ~a | sudo -k -S -H -- ~a" (string-shell-quote (password-tmp-file conn)) (next-method)))
+ (format #f "cat ~a - | sudo -k -S -H -- ~a" (string-shell-quote (password-tmp-file conn)) (next-method)))
((become-user conn)
(format #f "sudo -k -n -H -u ~a -- ~a" (string-shell-quote (become-user conn)) (next-method)))
diff --git a/ordo/core.scm b/ordo/core.scm
index a42dfc7..d12c7c1 100644
--- a/ordo/core.scm
+++ b/ordo/core.scm
@@ -14,187 +14,56 @@ PARTICULAR PURPOSE. See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License along with
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 connection base)
+ #:use-module (ordo context)
+ #:use-module (ordo handler)
#:use-module (ordo inventory)
#:use-module (ordo logger)
- #:use-module (ordo util flatten)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-69)
- #:export (
- task
- task?
- task-name
- task-pre-condition
- task-action
- task-args
- task-trigger
+ #:use-module (ordo playbook)
+ #:use-module (ordo play)
+ #:use-module (ordo task)
+ #:use-module ((srfi srfi-26) #:select (cut)))
-
- handler
- handler?
- handler-name
- handler-action
- handler-args
+(define (run-playbook ctx pb)
+ (log-msg 'NOTICE "Running playbook: " (playbook-name pb))
+ (set-ctx-playbook! ctx pb)
+ (for-each (cut run-play ctx <>) (playbook-plays pb)))
-
- blueprint
- blueprint?
- blueprint-name
- blueprint-tasks
- blueprint-handlers
+(define (run-play ctx p)
+ (log-msg 'NOTICE "Running play: " (play-name p))
+ (set-ctx-play! ctx p)
+ (let ((hosts (resolve-hosts (ctx-inventory ctx) (play-host p))))
+ (if (null? hosts)
+ (log-msg 'WARN "No hosts matched: " (play-host p))
+ (for-each (cut run-host-play ctx p <>) hosts))))
- execute))
+(define (run-host-play ctx p h)
+ (log-msg 'NOTICE "Running play on host: " (host-name h))
+ (set-ctx-host! ctx h)
+ (call-with-connection
+ (host-connection h)
+ (lambda (conn)
+ (dynamic-wind
+ (lambda ()
+ (set-ctx-connection! ctx conn))
+ (lambda ()
+ (for-each (cut run-task ctx <>) (play-tasks p))
+ (for-each (cut run-handler ctx <>) (play-handlers p)))
+ (lambda ()
+ (set-ctx-connection! ctx #f))))
+ #:sudo? (play-sudo? p)
+ #:sudo-user (play-sudo-user p)
+ #:sudo-password (play-sudo-password p)))
-(define-generic execute%)
+(define (run-task ctx t)
+ (if ((task-pre-condition t) ctx)
+ (begin
+ (log-msg 'NOTICE "Running task " (task-name t))
+ ((task-action t) ctx))
+ (log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met")))
-(define-class ()
- (name #:init-keyword #:name #:getter task-name)
- (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))
-
-(define (task name . args) (apply make #:name name args))
-(define (task? x) (is-a? x ))
-
-(define-method (execute% (task ) (conn ))
- (log-msg 'DEBUG "execute task " (task-name task) " on connection")
- (if ((task-pre-condition task) conn)
- (let ((result (apply (task-action task) conn (map (lambda (a) (if (promise? a) (force a) a)) (task-args task)))))
- (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)))
- result)
- (log-msg 'NOTICE (task-name task) " - SKIPPED")))
-
-(define-method (execute% (task ) (host ) (options ))
- (log-msg 'NOTICE "Executing task " (task-name task) " on host " (host-name host))
- (let-keywords
- options #t
- ((sudo? #f)
- (sudo-user #f)
- (sudo-password #f))
- (call-with-connection
- (host-connection host)
- (cut execute% task <>)
- #:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password)))
-
-(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) ": " e))
- (lambda ()
- (execute% task host options))
- #:unwind? #t))
- (lambda (host)
- (execute% task host options)))
- (resolve-hosts target))))
-
-(define-class ()
- (name #:init-keyword #:name #:getter handler-name)
- (action #:init-keyword #:action #:getter handler-action)
- (args #:init-keyword #:args #:init-form (list) #:getter handler-args))
-
-(define (handler . args) (apply make args))
-(define (handler? x) (is-a? x ))
-
-(define-method (execute% (handler ) (conn ))
- (log-msg 'NOTICE "Executing handler " (handler-name handler))
- ((handler-action handler) conn))
-
-(define-class ()
- (name #:init-keyword #:name #:getter blueprint-name)
- (tasks #:init-keyword #:tasks #:getter blueprint-tasks)
- (handlers #:init-keyword #:handlers #:getter blueprint-handlers))
-
-(define (blueprint? x) (is-a? x ))
-
-(define (validate-triggers blueprint-name tasks handlers)
- (let ((handler-names (map handler-name handlers)))
- (for-each (lambda (task)
- (for-each (lambda (trigger)
- (unless (member trigger handler-names)
- (raise-exception
- (make-exception
- (make-programming-error)
- (make-exception-with-message (format #f "Task ~a in blueprint ~a references unknown trigger: ~a"
- blueprint-name (task-name task) trigger))))))
- (task-trigger task)))
- tasks)))
-
-(define (blueprint name . args)
- (let* ((args (flatten args))
- (tasks (filter task? args))
- (handlers (filter handler? args)))
- (validate-triggers name (filter task? tasks) handlers)
- (make #:name name #:tasks tasks #:handlers handlers)))
-
-(define *triggered-handlers* (make-parameter #f))
-
-(define (schedule-handler! handler-name)
- "Schedule a handler to be run after all tasks in a blueprint. This function
-may also be called outside of a blueprint (e.g. when a stand-alone task is run),
-in which case it is a no-op."
- (let ((triggered (*triggered-handlers*)))
- (when triggered
- (log-msg 'DEBUG "Scheduling handler: " handler-name)
- (hash-table-set! triggered handler-name #t))))
-
-(define-method (execute% (blueprint ) (conn ))
- (parameterize ((*triggered-handlers* (make-hash-table)))
- (log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint))
- (for-each (cut execute% <> conn)
- (blueprint-tasks 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 ) (options ))
- (log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint) " on host " (host-name host))
- (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 ) 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) ": " <>)
- (lambda ()
- (execute% blueprint host options))
- #:unwind? #t))
- (lambda (host)
- (execute% blueprint host options)))
- (resolve-hosts target))))
-
-(define (execute task-or-blueprint target . options)
- (execute% task-or-blueprint target options))
+(define (run-handler ctx h)
+ (when (member (ctx-triggers ctx) (handler-name h))
+ (log-msg 'NOTICE "Running handler: " (handler-name h))
+ ((handler-action h) ctx)))
diff --git a/ordo/handler.scm b/ordo/handler.scm
new file mode 100644
index 0000000..883f734
--- /dev/null
+++ b/ordo/handler.scm
@@ -0,0 +1,39 @@
+#|
+This file is part of Ordo.
+
+Copyright (C) 2025 Ray Miller
+
+This program is free software: you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free Software
+Foundation, version 3.
+
+This program is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License along with
+this program. If not, see .
+|#
+
+(define-module (ordo handler)
+ #:use-module (srfi srfi-9)
+ #:use-module (ordo logger)
+ #:export (make-handler
+ handler?
+ handler-name
+ handler-action
+ handler
+ run-handler))
+
+(define-record-type
+ (make-handler name action)
+ handler?
+ (name handler-name)
+ (action handler-action))
+
+(define* (handler #:key name action)
+ (make-handler name action))
+
+(define (run-handler h conn)
+ (log-msg 'NOTICE "Running handler: " (handler-name h))
+ ((handler-action h) conn))
diff --git a/ordo/inventory.scm b/ordo/inventory.scm
index 36e4137..354e8e4 100644
--- a/ordo/inventory.scm
+++ b/ordo/inventory.scm
@@ -23,36 +23,27 @@ this program. If not, see .
#:use-module ((ordo connection) #:select (local-connection))
#:use-module (ordo logger)
#:use-module (srfi srfi-1)
- #:export (
- defhost
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-69)
+ #:export (host
host?
host-name
host-connection
host-tags
-
+ host-vars
resolve-hosts
- load-inventory!))
+ load-inventory))
-(define *inventory* '())
+(define-record-type
+ (make-host name connection tags vars)
+ host?
+ (name host-name)
+ (connection host-connection)
+ (tags host-tags)
+ (vars host-vars))
-(define-class ()
- (name #:init-keyword #:name #:getter host-name)
- (connection #:init-keyword #:connection #:getter host-connection)
- (tags #:init-keyword #:tags #:getter host-tags))
-
-(define (host? h) (is-a? h ))
-
-(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)
- (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")
- (defhost "localhost" #:connection (local-connection))))
+(define* (host #:key name connection (tags '()) (vars '()))
+ (make-host name connection tags (alist->hash-table vars)))
(define (tagged-every? wanted-tags)
(lambda (h)
@@ -66,11 +57,22 @@ this program. If not, see .
(lambda (h)
(string=? (host-name h) hostname)))
-(define-method (resolve-hosts expr)
+(define (resolve-hosts inventory expr)
(match expr
- ((? 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*))))
+ ("localhost" (list (or (find (named? "localhost") inventory)
+ (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 (load-inventory filename)
+ (log-msg 'INFO "Loading inventory " filename)
+ (let* ((inventory (eval-string (call-with-input-file filename get-string-all)
+ #:file filename))
+ (inventory (if (list? inventory) inventory '())))
+ (when (null? inventory)
+ (log-msg 'NOTICE "Inventory is empty, only localhost will be available"))
+ inventory))
diff --git a/ordo/play.scm b/ordo/play.scm
new file mode 100644
index 0000000..326d5c6
--- /dev/null
+++ b/ordo/play.scm
@@ -0,0 +1,92 @@
+#|
+This file is part of Ordo.
+
+Copyright (C) 2025 Ray Miller
+
+This program is free software: you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free Software
+Foundation, version 3.
+
+This program is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License along with
+this program. If not, see .
+|#
+
+(define-module (ordo play)
+ #:use-module (ordo connection)
+ #:use-module (ordo context)
+ #:use-module (ordo handler)
+ #:use-module (ordo inventory)
+ #:use-module (ordo logger)
+ #:use-module (ordo task)
+ #:use-module (ordo util flatten)
+ #:use-module (ordo util keyword-args)
+ #:use-module (srfi srfi-1) ; lists
+ #:use-module (srfi srfi-9) ; records
+ #:use-module (srfi srfi-26) ; cut/cute
+ #:use-module (srfi srfi-69) ; hash tables
+ #:use-module (srfi srfi-71) ; extended let
+ #:export (play
+ play?
+ play-host
+ play-sudo?
+ play-sudo-user
+ play-sudo-password
+ play-vars
+ play-tasks
+ play-handlers
+ run-play
+ trigger-handler!))
+
+(define-record-type
+ (make-play name host sudo? sudo-user sudo-password vars tasks handlers)
+ play?
+ (name play-name)
+ (host play-host)
+ (sudo? play-sudo?)
+ (sudo-user play-sudo-user)
+ (sudo-password play-sudo-password)
+ (vars play-vars)
+ (tasks play-tasks)
+ (handlers play-handlers))
+
+(define (play name . args)
+ (let* ((tasks args (partition task? args))
+ (handlers kwargs (partition handler? args)))
+ (make-play name
+ (keyword-arg #:host kwargs)
+ (keyword-arg #:sudo? kwargs)
+ (keyword-arg #:sudo-user kwargs)
+ (keyword-arg #:sudo-password kwargs)
+ (and=> (keyword-arg #:vars kwargs) alist->hash-table)
+ tasks
+ handlers)))
+
+(define (run-play p)
+ (log-msg 'NOTICE "Running play: " (play-name p))
+ (parameterize ((*play* p))
+ (let ((hosts (resolve-hosts (*inventory*) (play-host p))))
+ (if (null? hosts)
+ (log-msg 'WARN "No hosts matched: " (play-host p))
+ (for-each (cut run-host-play p <>) hosts)))))
+
+(define (run-host-play p h)
+ (log-msg 'NOTICE "Running play on host: " (host-name h))
+ (parameterize ((*host* h)
+ (*triggered-handlers* (make-hash-table)))
+ (call-with-connection
+ (host-connection h)
+ (lambda (conn)
+ (for-each (cut run-task <> conn) (play-tasks p))
+ (for-each (cut run-handler <> conn)
+ (filter (compose (cut hash-table-ref/default *triggered-handlers* <> #f) handler-name)
+ (play-handlers p))))
+ #:sudo? (play-sudo? p)
+ #:sudo-user (play-sudo-user p)
+ #:sudo-password (play-sudo-password p))))
+
+(define (trigger-handler! handler-name)
+ (hash-table-set! *triggered-handlers* handler-name #t))
diff --git a/ordo/playbook.scm b/ordo/playbook.scm
new file mode 100644
index 0000000..b22fc3c
--- /dev/null
+++ b/ordo/playbook.scm
@@ -0,0 +1,61 @@
+#|
+This file is part of Ordo.
+
+Copyright (C) 2025 Ray Miller
+
+This program is free software: you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free Software
+Foundation, version 3.
+
+This program is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License along with
+this program. If not, see .
+|#
+
+(define-module (ordo playbook)
+ #:use-module (ice-9 eval-string)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (ordo context)
+ #:use-module (ordo handler)
+ #:use-module (ordo logger)
+ #:use-module (ordo play)
+ #:use-module (ordo task)
+ #:use-module (ordo util keyword-args)
+ #:use-module (srfi srfi-1) ; lists
+ #:use-module (srfi srfi-9) ; records
+ #:use-module (srfi srfi-26) ; cut/cute
+ #:use-module (srfi srfi-69) ; hash tables
+ #:use-module (srfi srfi-71) ; extended let
+ #:export (
+ playbook
+ playbook?
+ playbook-name
+ playbook-vars
+ playbook-plays
+ load-playbook
+ run-playbook))
+
+(define-record-type
+ (make-playbook name vars plays)
+ playbook?
+ (name playbook-name)
+ (vars playbook-vars)
+ (plays playbook-plays))
+
+(define (playbook name . args)
+ (let ((plays kwargs (partition play? args)))
+ (make-playbook name (alist->hash-table (keyword-arg #:vars kwargs '())) plays)))
+
+(define (load-playbook filename)
+ (log-msg 'INFO "Loading playbook " filename)
+ (eval-string (call-with-input-file filename get-string-all)
+ #:file filename))
+
+(define (run-playbook pb inventory)
+ (log-msg 'NOTICE "Running playbook: " (playbook-name pb))
+ (parameterize ((*inventory* inventory)
+ (*playbook* pb))
+ (for-each run-play (playbook-plays pb))))
diff --git a/ordo/task.scm b/ordo/task.scm
new file mode 100644
index 0000000..9399317
--- /dev/null
+++ b/ordo/task.scm
@@ -0,0 +1,43 @@
+#|
+This file is part of Ordo.
+
+Copyright (C) 2025 Ray Miller
+
+This program is free software: you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free Software
+Foundation, version 3.
+
+This program is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License along with
+this program. If not, see .
+|#
+
+(define-module (ordo task)
+ #:use-module (ordo logger)
+ #:use-module (srfi srfi-9)
+ #:export (task
+ task?
+ task-name
+ task-pre-condition
+ task-action
+ run-task))
+
+(define-record-type
+ (make-task name action pre-condition)
+ task?
+ (name task-name)
+ (pre-condition task-pre-condition)
+ (action task-action))
+
+(define* (task #:key name action (pre-condition (const #t)))
+ (make-task name action pre-condition))
+
+(define (run-task t conn)
+ (if ((task-pre-condition t) conn)
+ (begin
+ (log-msg 'NOTICE "Running task " (task-name t))
+ ((task-action t) conn))
+ (log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met")))
diff --git a/ordo/util/keyword-args.scm b/ordo/util/keyword-args.scm
new file mode 100644
index 0000000..95de5eb
--- /dev/null
+++ b/ordo/util/keyword-args.scm
@@ -0,0 +1,23 @@
+#|
+This file is part of Ordo.
+
+Copyright (C) 2025 Ray Miller
+
+This program is free software: you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free Software
+Foundation, version 3.
+
+This program is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License along with
+this program. If not, see .
+|#
+
+(define-module (ordo util keyword-args)
+ #:use-module ((srfi srfi-1) #:select (member))
+ #:export (keyword-arg))
+
+(define* (keyword-arg args kw #:optional (default #f))
+ (or (and=> (member kw args) cadr) default))