diff --git a/examples/forgejo.scm b/examples/forgejo.scm
index bada9dd..15742dc 100644
--- a/examples/forgejo.scm
+++ b/examples/forgejo.scm
@@ -1,60 +1,57 @@
(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"))
- (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")))))
+ "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")))))
-(playbook "Install Forgejo on limiting-factor"
- ;; #:vars '((forgejo-version . "11.0.2"))
- (play
- #:host "limiting-factor"
- #:become? #t
- (install-forgejo #:version "11")))
+(execute (install-forgejo #:version "11") "limiting-factor" #:sudo? #t)
diff --git a/examples/inventory.scm b/examples/inventory.scm
index 30a2a78..08b81dd 100644
--- a/examples/inventory.scm
+++ b/examples/inventory.scm
@@ -1,23 +1,22 @@
(use-modules (ordo connection)
(ordo inventory))
-(list
- (host #:name "little-rascal"
- #:connection (local-connection)
- #:tags '(#:linux #:guix))
+(defhost "little-rascal"
+ #:connection (local-connection)
+ #:tags '(#:linux #:guix))
- (host #:name "limiting-factor"
- #:connection (ssh-connection "limiting-factor" #:user "core")
- #:tags '(#:linux #:coreos))
+(defhost "limiting-factor"
+ #:connection (ssh-connection #:host "limiting-factor" #:user "core")
+ #:tags '(#:linux #:coreos))
- (host #:name "screw-loose"
- #:connection (ssh-connection "screw-loose" #:user "core")
- #:tags '(#:linux #:coreos))
+(defhost "screw-loose"
+ #:connection (ssh-connection #:host "screw-loose" #:user "core")
+ #:tags '(#:linux #:coreos))
- (host #:name "control-surface"
- #:connection (ssh-connection "control-surface" #:user "ray")
- #:tags '(#:linux #:debian))
+(defhost "control-surface"
+ #:connection (ssh-connection #:host "control-surface" #:user "ray")
+ #:tags '(#:linux #:debian))
- (host #:name "cargo-cult"
- #:connection (ssh-connection "cargo-cult" #:user "ray")
- #: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
new file mode 100644
index 0000000..c3820e6
--- /dev/null
+++ b/examples/uptime.scm
@@ -0,0 +1,8 @@
+(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 bb87ae3..789a20f 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 connection) #:select (remote-cmd))
- #:use-module (ordo connection base)
+ #:use-module (ordo action remote-cmd)
+ #:use-module ((ordo connection base) #:select (with-remote-output-file))
#:export (create-tmp-dir
install-dir
install-file
diff --git a/ordo/action/quadlet.scm b/ordo/action/quadlet.scm
index 883baf0..24607e6 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 connection)
+ #:use-module (ordo action remote-cmd)
#: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
new file mode 100644
index 0000000..4f2475f
--- /dev/null
+++ b/ordo/action/remote-cmd.scm
@@ -0,0 +1,29 @@
+(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 d8b5eeb..e61229b 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 connection)
+ #:use-module (ordo action remote-cmd)
#: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 1b46d6b..8345885 100644
--- a/ordo/cli/run.scm
+++ b/ordo/cli/run.scm
@@ -16,12 +16,13 @@ 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))
@@ -57,12 +58,12 @@ this program. If not, see .
(arguments
(list
(argument
- (name 'playbook)
+ (name 'workflow)
(handler (cut expand-file-name <> #f #t))
+ (example "examples/uptime.scm")
(test file-exists?))))
- (synopsis "Run a playbook")))
+ (synopsis "Run a workflow")))
(define (handler options)
- (let ((inventory (load-inventory (option-ref options 'inventory)))
- (playbook (load-playbook (option-ref options '(playbook)))))
- (run-playbook playbook inventory)))
+ (load-inventory! (option-ref options 'inventory))
+ (load (option-ref options '(workflow))))
diff --git a/ordo/connection.scm b/ordo/connection.scm
index 4c31470..f729bf9 100644
--- a/ordo/connection.scm
+++ b/ordo/connection.scm
@@ -23,30 +23,23 @@ 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
- remote-cmd)
- #:re-export (remote-exec with-remote-input-file with-remote-output-file))
+ call-with-connection))
(define (connection? c)
(is-a? c ))
-(define (local-connection)
- (make ))
+(define (local-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 (ssh-connection . args)
+ (apply make args))
(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 )
@@ -61,20 +54,3 @@ 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 d853fdb..0f9a017 100644
--- a/ordo/connection/base.scm
+++ b/ordo/connection/base.scm
@@ -17,12 +17,13 @@ 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
@@ -32,6 +33,7 @@ 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)
@@ -44,14 +46,17 @@ this program. If not, see .
(define-method (teardown (c )) #t)
(define-method (build-command (c ) (prog-name ) (prog-args ) (options ))
- (let* ((pwd (keyword-arg options #:pwd))
- (env (keyword-arg options #:env))
- (redirect-err? (keyword-arg options #:redirect-err? #t))
- (xs (remove unspecified?
+ (let-keywords
+ options #t
+ ((pwd #f)
+ (env #f)
+ (shell-quote? #t)
+ (redirect-err? #t))
+ (let ((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
- (map string-shell-quote prog-args)
+ (if shell-quote? (map string-shell-quote prog-args) 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 c4d39ae..7df9676 100644
--- a/ordo/connection/local.scm
+++ b/ordo/connection/local.scm
@@ -25,6 +25,9 @@ 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 2b2d2e6..d06e7f7 100644
--- a/ordo/connection/ssh.scm
+++ b/ordo/connection/ssh.scm
@@ -23,29 +23,40 @@ 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-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)
+ (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)
(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)
- (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 (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)))
(let ((s (slot-ref c 'session)))
(unless (connected? s)
- (connect! s)
- (when (ssh-connection-authenticate-server? s)
+ (when (equal? 'error (connect! s))
+ (error (string-append "Error connecting to " (ssh-connection-host c))))
+ (when (ssh-connection-authenticate-server? c)
(let ((server-auth (authenticate-server s)))
(unless (equal? 'ok server-auth)
(error (format #f "authenticate-server: ~a" server-auth)))))
@@ -53,7 +64,8 @@ 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)))))))
+ (error (format #f "userauth: ~a" user-auth))))))
+ (next-method))
(define-method (remote-exec (c ) (command ))
(let* ((channel (open-remote-input-pipe (slot-ref c 'session) command))
@@ -62,19 +74,21 @@ 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 ))
- (call-with-remote-input-file (sftp-session 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))
(define-method (with-remote-output-file (c ) (filename ) (proc ))
- (call-with-remote-output-file (sftp-session 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))
(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 8271c22..0caac17 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 d12c7c1..a42dfc7 100644
--- a/ordo/core.scm
+++ b/ordo/core.scm
@@ -14,56 +14,187 @@ 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 context)
- #:use-module (ordo handler)
+ #:use-module (ordo connection base)
#:use-module (ordo inventory)
#:use-module (ordo logger)
- #:use-module (ordo playbook)
- #:use-module (ordo play)
- #:use-module (ordo task)
- #:use-module ((srfi srfi-26) #:select (cut)))
+ #: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
-(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)))
+
+ handler
+ handler?
+ handler-name
+ handler-action
+ handler-args
-(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))))
+
+ blueprint
+ blueprint?
+ blueprint-name
+ blueprint-tasks
+ blueprint-handlers
-(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)))
+ 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-generic execute%)
-(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)))
+(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))
diff --git a/ordo/handler.scm b/ordo/handler.scm
deleted file mode 100644
index 883f734..0000000
--- a/ordo/handler.scm
+++ /dev/null
@@ -1,39 +0,0 @@
-#|
-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 354e8e4..36e4137 100644
--- a/ordo/inventory.scm
+++ b/ordo/inventory.scm
@@ -23,27 +23,36 @@ this program. If not, see .
#:use-module ((ordo connection) #:select (local-connection))
#:use-module (ordo logger)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-69)
- #:export (host
+ #:export (
+ defhost
host?
host-name
host-connection
host-tags
- host-vars
+
resolve-hosts
- load-inventory))
+ load-inventory!))
-(define-record-type
- (make-host name connection tags vars)
- host?
- (name host-name)
- (connection host-connection)
- (tags host-tags)
- (vars host-vars))
+(define *inventory* '())
-(define* (host #:key name connection (tags '()) (vars '()))
- (make-host name connection tags (alist->hash-table 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 (tagged-every? wanted-tags)
(lambda (h)
@@ -57,22 +66,11 @@ this program. If not, see .
(lambda (h)
(string=? (host-name h) hostname)))
-(define (resolve-hosts inventory expr)
+(define-method (resolve-hosts expr)
(match expr
- ("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))
+ ((? 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*))))
diff --git a/ordo/play.scm b/ordo/play.scm
deleted file mode 100644
index 326d5c6..0000000
--- a/ordo/play.scm
+++ /dev/null
@@ -1,92 +0,0 @@
-#|
-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
deleted file mode 100644
index b22fc3c..0000000
--- a/ordo/playbook.scm
+++ /dev/null
@@ -1,61 +0,0 @@
-#|
-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
deleted file mode 100644
index 9399317..0000000
--- a/ordo/task.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-#|
-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
deleted file mode 100644
index 95de5eb..0000000
--- a/ordo/util/keyword-args.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-#|
-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))