From 17abb6019c7ad460926d67aaab6c20baf7e8b1e0 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 28 Jun 2025 18:12:49 +0100 Subject: [PATCH] Kind of working workflows... --- examples/forgejo.scm | 2 +- examples/inventory.scm | 20 ++--- examples/uptime.scm | 12 +++ ordo/blueprint.scm | 89 --------------------- ordo/connection/ssh.scm | 21 +++-- ordo/connection/sudo.scm | 2 +- ordo/core.scm | 162 ++++++++++++++++++++++++++++++++++++--- ordo/inventory.scm | 37 +++++---- 8 files changed, 213 insertions(+), 132 deletions(-) create mode 100644 examples/uptime.scm delete mode 100644 ordo/blueprint.scm diff --git a/examples/forgejo.scm b/examples/forgejo.scm index ad3d44a..ff6ce1f 100644 --- a/examples/forgejo.scm +++ b/examples/forgejo.scm @@ -1,11 +1,11 @@ (use-modules - (ordo blueprint) (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 diff --git a/examples/inventory.scm b/examples/inventory.scm index 30a2a78..944aa60 100644 --- a/examples/inventory.scm +++ b/examples/inventory.scm @@ -2,22 +2,22 @@ (ordo inventory)) (list - (host #:name "little-rascal" - #:connection (local-connection) + (host #:name "root@little-rascal" + #:connection (local-connection #:become? #t) #:tags '(#:linux #:guix)) - (host #:name "limiting-factor" - #:connection (ssh-connection "limiting-factor" #:user "core") + (host #:name "root@limiting-factor" + #:connection (ssh-connection #:host "limiting-factor" #:user "core" #:become? #t) #:tags '(#:linux #:coreos)) - (host #:name "screw-loose" - #:connection (ssh-connection "screw-loose" #:user "core") + (host #:name "root@screw-loose" + #:connection (ssh-connection #:host "screw-loose" #:user "core" #:become? #t) #:tags '(#:linux #:coreos)) - (host #:name "control-surface" - #:connection (ssh-connection "control-surface" #:user "ray") + (host #:name "root@control-surface" + #:connection (ssh-connection #:host "control-surface" #:user "ray" #:become? #t) #:tags '(#:linux #:debian)) - (host #:name "cargo-cult" - #:connection (ssh-connection "cargo-cult" #:user "ray") + (host #:name "root@cargo-cult" + #:connection (ssh-connection #:host "cargo-cult" #:user "ray" #:become? #t) #:tags '(#:linux #:synology))) diff --git a/examples/uptime.scm b/examples/uptime.scm new file mode 100644 index 0000000..163f6f5 --- /dev/null +++ b/examples/uptime.scm @@ -0,0 +1,12 @@ +(use-modules (ordo core) + (ordo inventory) + (ordo connection) + (ordo logger) + (srfi srfi-26)) + +(define uptime (task #:name "uptime" #:action (cut remote-cmd <> "uptime" #:return car))) + +(define flow (workflow + (step #:action uptime #:target "root@limiting-factor" #:continue-on-err? #t))) + +(define resolver (load-inventory "examples/inventory.scm")) diff --git a/ordo/blueprint.scm b/ordo/blueprint.scm deleted file mode 100644 index 4b803d1..0000000 --- a/ordo/blueprint.scm +++ /dev/null @@ -1,89 +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 blueprint) - #:use-module (ice-9 exceptions) - #:use-module (ice-9 format) - #:use-module (oop goops) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-235) - #:export ( - task - task? - task-name - task-pre-condititon - task-action - task-args - task-trigger - - - handler - handler? - handler-name - handler-action - handler-args - - - blueprint - blueprint? - blueprint-name - blueprint-steps - blueprint-handlers)) - -(define-class () - (name #:init-keyword #:name #:getter task-name) - (pre-condition #:init-keyword #:pre-condition #:getter task-pre-condition) - (action #:init-keyword #:action #:getter task-action) - (args #:init-keyword #:args #:getter task-args) - (trigger #:init-keyword #:trigger #:getter task-trigger)) - -(define (task . args) (apply make args)) -(define (task? x) (is-a? x )) - -(define-class () - (name #:init-keyword #:name #:getter handler-name) - (action #:init-keyword #:action #:getter handler-action) - (args #:init-keyword #:args #:getter handler-args)) - -(define (handler . args) (apply make args)) -(define (handler? x) (is-a? x )) - -(define-class () - (name #:init-keyword #:name #:getter blueprint-name) - (steps #:init-keyword #:steps #:getter blueprint-steps) - (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 ((steps (filter (disjoin task? blueprint?) args)) - (handlers (filter handler? args))) - (validate-triggers name (filter task? steps) handlers) - (make #:name name #:steps steps #:handlers handlers))) diff --git a/ordo/connection/ssh.scm b/ordo/connection/ssh.scm index 2b2d2e6..b659926 100644 --- a/ordo/connection/ssh.scm +++ b/ordo/connection/ssh.scm @@ -32,20 +32,25 @@ this program. If not, see . (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 (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))))) @@ -75,6 +80,6 @@ this program. If not, see . (define-method (teardown (c )) (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..60a95c0 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)) diff --git a/ordo/core.scm b/ordo/core.scm index eb2230a..b7418e9 100644 --- a/ordo/core.scm +++ b/ordo/core.scm @@ -14,27 +14,169 @@ 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 (oop goops) - #:use-module (ordo blueprint) #:use-module (ordo connection) - #:use-module (ordo context) #:use-module (ordo inventory) #:use-module (ordo logger) + #:use-module (ordo util flatten) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:export (execute)) + #:use-module (srfi srfi-69) + #:export ( + task + task? + task-name + task-pre-condition + task-action + task-args + task-trigger + task-exception-handler + + + handler + handler? + handler-name + handler-action + handler-args + + + blueprint + blueprint? + blueprint-name + blueprint-tasks + blueprint-handlers + + + workflow + workflow-steps + + step + + execute)) + +(define-generic execute) + +(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) + (exception-handler #:init-keyword #:exception-handler #:init-value #f #:getter task-exception-handler)) + +(define (task . args) (apply make args)) +(define (task? x) (is-a? x )) + +(define-method (execute (task ) (conn )) + (define (task-thunk) + (if ((task-pre-condition task) conn) + (let ((result ((task-action task) conn))) + (cond + ((equal? result #f) + (log-msg 'NOTICE (task-name task) " - no change")) + ((equal? result #t) + (log-msg 'NOTICE (task-name task) " - ok") + (for-each schedule-handler! (task-trigger task))) + (else + (log-msg 'NOTICE (task-name task) " - " result)))))) + (if (task-exception-handler task) + (with-exception-handler (task-exception-handler task) task-thunk #:unwind? #t) + (task-thunk))) + +(define-method (execute (task ) (host )) + (log-msg 'NOTICE "Executing task " (task-name task) " on host " (host-name host)) + (call-with-connection (host-connection host) (cut execute task <>))) + +(define-method (execute (task ) (resolver ) target (continue-on-err? )) + (let ((run-on-host (if continue-on-err? + (lambda (host) (with-exception-handler (cut log-msg 'ERROR <>) (lambda () (execute task host)) #:unwind? #t)) + (lambda (host) (execute task host))))) + (for-each run-on-host (resolve-hosts resolver target)))) + +(define-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 + (hash-table-set! triggered handler-name #t)))) (define-method (execute (blueprint ) (conn )) - #f - ) + (parameterize ((*triggered-handlers* (make-hash-table))) + (log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint)) + (for-each (cut execute <> conn) + (blueprint-tasks blueprint)) + (for-each (cut execute <> conn) + (filter (lambda (handler) + (hash-table-ref/default (*triggered-handlers*) (handler-name handler) #f)) + (blueprint-handlers blueprint))))) (define-method (execute (blueprint ) (host )) (log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint) " on host " (host-name host)) (call-with-connection (host-connection host) (cut execute blueprint <>))) -(define-method (execute (task ) (conn )) - #f) +(define-method (execute (blueprint ) (resolver ) target (continue-on-err? )) + (let ((run-on-host (if continue-on-err? + (lambda (host) + (with-exception-handler (cut log-msg 'ERROR <>) (lambda () (execute blueprint host)) #:unwind? #t)) + (lambda (host) + (execute blueprint host))))) + (for-each run-on-host (resolve-hosts resolver target)))) -(define-method (execute (task ) (host )) - (log-msg 'NOTICE "Executing task " (task-name task) " on host " (host-name host)) - (call-with-connection (host-connection host) (cut execute task <>))) +(define-class () + (steps #:init-keyword #:steps #:getter workflow-steps)) + +(define* (step #:key action target continue-on-err?) + (lambda (resolver) + (execute action resolver target continue-on-err?))) + +(define (workflow . steps) + (make #:steps steps)) + +(define-method (execute (wf ) (resolver )) + (for-each (lambda (step) (step resolver)) (workflow-steps wf))) diff --git a/ordo/inventory.scm b/ordo/inventory.scm index 41b901b..ba8eb59 100644 --- a/ordo/inventory.scm +++ b/ordo/inventory.scm @@ -31,6 +31,11 @@ this program. If not, see . host-name host-connection host-tags + + + + + get-inventory-hosts resolve-hosts load-inventory)) @@ -55,22 +60,28 @@ this program. If not, see . (lambda (h) (string=? (host-name h) hostname))) -(define (resolve-hosts inventory expr) +(define-class ()) + +(define-class () + (hosts #:init-keyword #:hosts #:getter get-inventory-hosts)) + +(define-method (resolve-hosts (inventory ) expr) + (define hosts (get-inventory-hosts inventory)) (match expr - ("localhost" (list (or (find (named? "localhost") inventory) + ("localhost" (list (or (find (named? "localhost") hosts) (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)))) + ((? string? hostname) (filter (named? hostname) hosts)) + ('all hosts) + (('tagged tag) (filter (tagged-every? (list tag)) hosts)) + (('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) hosts)) + (('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) hosts)) + ((. hostnames) (filter (lambda (h) (member (host-name h) hostnames string=?)) hosts)))) (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) + (let* ((hosts (eval-string (call-with-input-file filename get-string-all) + #:file filename)) + (hosts (if (list? hosts) hosts '()))) + (when (null? hosts) (log-msg 'NOTICE "Inventory is empty, only localhost will be available")) - inventory)) + (make #:hosts hosts)))