ray/ordo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Kind of working workflows...

Browse source
This commit is contained in:
Ray Miller 2025-06-28 18:12:49 +01:00
parent c1cb9aa3db
commit 17abb6019c
Signed by: ray
GPG key ID: 043F786C4CD681B8
8 changed files with 213 additions and 132 deletions
Download patch file Download diff file Expand all files Collapse all files

2
examples/forgejo.scm
View file

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

20
examples/inventory.scm
View file

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

12
examples/uptime.scm Normal file
View file

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

89
ordo/blueprint.scm
View file

@ -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 <https://www.gnu.org/licenses/>.
|#
(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?
task-name
task-pre-condititon
task-action
task-args
task-trigger
<handler>
handler
handler?
handler-name
handler-action
handler-args
<blueprint>
blueprint
blueprint?
blueprint-name
blueprint-steps
blueprint-handlers))
(define-class <task> ()
(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 <task> args))
(define (task? x) (is-a? x <task>))
(define-class <handler> ()
(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 <handler> args))
(define (handler? x) (is-a? x <handler>))
(define-class <blueprint> ()
(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 <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 ((steps (filter (disjoin task? blueprint?) args))
(handlers (filter handler? args)))
(validate-triggers name (filter task? steps) handlers)
(make <blueprint> #:name name #:steps steps #:handlers handlers)))

21
ordo/connection/ssh.scm
View file

@ -32,20 +32,25 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(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 (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)))))
@ -75,6 +80,6 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(define-method (teardown (c <ssh-connection>))
(when (slot-bound? c 'session)
(let ((s (slot-ref c session)))
(let ((s (slot-ref c 'session)))
(when (connected? s)
(disconnect! s)))))

2
ordo/connection/sudo.scm
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))

162
ordo/core.scm
View file

@ -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 <https://www.gnu.org/licenses/>.
|#
(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?
task-name
task-pre-condition
task-action
task-args
task-trigger
task-exception-handler
<handler>
handler
handler?
handler-name
handler-action
handler-args
<blueprint>
blueprint
blueprint?
blueprint-name
blueprint-tasks
blueprint-handlers
<workflow>
workflow
workflow-steps
step
execute))
(define-generic execute)
(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)
(exception-handler #:init-keyword #:exception-handler #:init-value #f #:getter task-exception-handler))
(define (task . args) (apply make <task> args))
(define (task? x) (is-a? x <task>))
(define-method (execute (task <task>) (conn <connection>))
(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 <task>) (host <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 <task>) (resolver <host-resolver>) target (continue-on-err? <boolean>))
(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 <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
(hash-table-set! triggered handler-name #t))))
(define-method (execute (blueprint <blueprint>) (conn <connection>))
#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 <blueprint>) (host <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 <task>) (conn <connection>))
#f)
(define-method (execute (blueprint <blueprint>) (resolver <host-resolver>) target (continue-on-err? <boolean>))
(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 <task>) (host <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 <workflow> ()
(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 <workflow> #:steps steps))
(define-method (execute (wf <workflow>) (resolver <host-resolver>))
(for-each (lambda (step) (step resolver)) (workflow-steps wf)))

37
ordo/inventory.scm
View file

@ -31,6 +31,11 @@ this program. If not, see <https://www.gnu.org/licenses/>.
host-name
host-connection
host-tags
<host-resolver>
<inventorp>
get-inventory-hosts
resolve-hosts
load-inventory))
@ -55,22 +60,28 @@ this program. If not, see <https://www.gnu.org/licenses/>.
(lambda (h)
(string=? (host-name h) hostname)))
(define (resolve-hosts inventory expr)
(define-class <host-resolver> ())
(define-class <inventory> (<host-resolver>)
(hosts #:init-keyword #:hosts #:getter get-inventory-hosts))
(define-method (resolve-hosts (inventory <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 <inventory> #:hosts hosts)))