Compare commits

...
Sign in to create a new pull request.

13 commits

Author SHA1 Message Date
1efa10ef07
Don't require #:name keyword to create task 2025-07-06 17:06:33 +01:00
f83fde7ad7
Fixes to SSH/sudo handling 2025-07-06 17:06:17 +01:00
3d4a83fd37
Remove workflow from forgejo example 2025-07-06 15:00:41 +01:00
66a2a887fd
Update run to work with new syntax 2025-07-06 15:00:30 +01:00
69f50fbadb
Simplify handling of localhost in inventory 2025-07-06 15:00:16 +01:00
93c5cad460
Simplify example 2025-07-06 14:43:14 +01:00
e9eb8681e4
Use ice-9 optargs rather than our own keyword-args 2025-07-06 14:27:37 +01:00
9068953967
Fix handling of task arguments 2025-07-06 14:06:06 +01:00
78beb037e7
Fixes and simplifications
* Move remote-cmd from connection to an action module.
* Inventory now populates a global variable instead of returning a list.
* Added a `describe` method to connections.
* Cleaned up execute/continue-on-error etc.
* Removed workflow class.
2025-07-05 16:29:59 +01:00
ae8c24aa63
More work on execution 2025-07-04 17:13:14 +01:00
be28e14d3e
Clearer logging 2025-07-04 16:01:05 +01:00
17abb6019c
Kind of working workflows... 2025-06-28 18:12:49 +01:00
c1cb9aa3db
Start to experiment with blueprints 2025-06-23 22:21:37 +01:00
20 changed files with 373 additions and 470 deletions

View file

@ -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)

View file

@ -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))

8
examples/uptime.scm Normal file
View file

@ -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)

View file

@ -23,8 +23,8 @@ this program. If not, see <https://www.gnu.org/licenses/>.
#: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

View file

@ -19,7 +19,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
#: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

View file

@ -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)))))))

View file

@ -16,7 +16,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|#
(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?)

View file

@ -16,12 +16,13 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|#
(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 <https://www.gnu.org/licenses/>.
(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))))

View file

@ -23,30 +23,23 @@ this program. If not, see <https://www.gnu.org/licenses/>.
#: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 <connection>))
(define (local-connection)
(make <local-connection>))
(define (local-connection . args)
(apply make <local-connection> args))
(define* (ssh-connection host #:key (user (getlogin)) (password #f) (identity #f) (authenticate-server? #t)
(sudo? #f) (sudo-user #f) (sudo-password #f))
(make <ssh-connection> #: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 <ssh-connection> 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 <sudo-connection>)
@ -61,20 +54,3 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(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)))))

View file

@ -17,12 +17,13 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(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 (<connection>
describe
setup
teardown
build-command
@ -32,6 +33,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(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 <https://www.gnu.org/licenses/>.
(define-method (teardown (c <connection>)) #t)
(define-method (build-command (c <connection>) (prog-name <string>) (prog-args <list>) (options <list>))
(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 " "))))

View file

@ -25,6 +25,9 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(define-class <local-connection> (<sudo-connection>))
(define-method (describe (c <local-connection>))
(format #f "local-connection (sudo=~a)" (become? c)))
(define-method (remote-exec (c <local-connection>) (command <string>))
(let* ((port (open-input-pipe command))
(output (read-lines port))

View file

@ -23,29 +23,40 @@ this program. If not, see <https://www.gnu.org/licenses/>.
#: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 (<ssh-connection>))
(define-class <ssh-connection> (<sudo-connection>)
(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 <ssh-connection>))
(format #f "ssh ~a@~a (sudo=~a)"
(ssh-connection-user c)
(ssh-connection-host c)
(become? c)))
(define-method (setup (c <ssh-connection>))
(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 <https://www.gnu.org/licenses/>.
(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 <ssh-connection>) (command <string>))
(let* ((channel (open-remote-input-pipe (slot-ref c 'session) command))
@ -62,19 +74,21 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(close channel)
(values output exit-status)))
(define-method (sftp-session (c <ssh-connection>))
(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 <ssh-connection>) (filename <string>) (proc <procedure>))
(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 <ssh-connection>) (filename <string>) (proc <procedure>))
(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 <ssh-connection>))
(next-method)
(when (slot-bound? c 'session)
(let ((s (slot-ref c session)))
(let ((s (slot-ref c 'session)))
(when (connected? s)
(disconnect! s)))))

View file

@ -29,7 +29,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
become-password))
(define-class <sudo-connection> (<connection>)
(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 <https://www.gnu.org/licenses/>.
(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)))

View file

@ -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 <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 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?
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?
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?
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 <task> ()
(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 <task> #:name name args))
(define (task? x) (is-a? x <task>))
(define-method (execute% (task <task>) (conn <connection>))
(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 <task>) (host <host>) (options <list>))
(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 <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) ": " e))
(lambda ()
(execute% task host options))
#:unwind? #t))
(lambda (host)
(execute% task host options)))
(resolve-hosts target))))
(define-class <handler> ()
(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 <handler> args))
(define (handler? x) (is-a? x <handler>))
(define-method (execute% (handler <handler>) (conn <connection>))
(log-msg 'NOTICE "Executing handler " (handler-name handler))
((handler-action handler) conn))
(define-class <blueprint> ()
(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 <blueprint>))
(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 <blueprint> #: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 <blueprint>) (conn <connection>))
(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 <blueprint>) (host <host>) (options <list>))
(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 <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) ": " <>)
(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))

View file

@ -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 <https://www.gnu.org/licenses/>.
|#
(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 <handler>
(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))

View file

@ -23,27 +23,36 @@ this program. If not, see <https://www.gnu.org/licenses/>.
#: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 (<host>
defhost
host?
host-name
host-connection
host-tags
host-vars
resolve-hosts
load-inventory))
load-inventory!))
(define-record-type <host>
(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 <host> ()
(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 <host>))
(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)
(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 <https://www.gnu.org/licenses/>.
(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*))))

View file

@ -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 <https://www.gnu.org/licenses/>.
|#
(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 <play>
(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))

View file

@ -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 <https://www.gnu.org/licenses/>.
|#
(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?
playbook-name
playbook-vars
playbook-plays
load-playbook
run-playbook))
(define-record-type <playbook>
(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))))

View file

@ -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 <https://www.gnu.org/licenses/>.
|#
(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 <task>
(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")))

View file

@ -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 <https://www.gnu.org/licenses/>.
|#
(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))