From c1cb9aa3db137e3115871d3a5c423b30c2509a95 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 23 Jun 2025 22:21:37 +0100 Subject: [PATCH 01/13] Start to experiment with blueprints --- examples/forgejo.scm | 104 +++++++++++++++++++++---------------------- ordo/blueprint.scm | 89 ++++++++++++++++++++++++++++++++++++ ordo/connection.scm | 34 +++++--------- ordo/core.scm | 59 +++++++----------------- ordo/handler.scm | 39 ---------------- ordo/inventory.scm | 20 ++++----- ordo/play.scm | 92 -------------------------------------- ordo/playbook.scm | 61 ------------------------- ordo/task.scm | 43 ------------------ 9 files changed, 174 insertions(+), 367 deletions(-) create mode 100644 ordo/blueprint.scm delete mode 100644 ordo/handler.scm delete mode 100644 ordo/play.scm delete mode 100644 ordo/playbook.scm delete mode 100644 ordo/task.scm diff --git a/examples/forgejo.scm b/examples/forgejo.scm index bada9dd..ad3d44a 100644 --- a/examples/forgejo.scm +++ b/examples/forgejo.scm @@ -1,60 +1,58 @@ (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")) - (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"))))) + (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"))) +(workflow + (execute (install-forgejo #:version "11") "root@limiting-factor")) diff --git a/ordo/blueprint.scm b/ordo/blueprint.scm new file mode 100644 index 0000000..4b803d1 --- /dev/null +++ b/ordo/blueprint.scm @@ -0,0 +1,89 @@ +#| +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.scm b/ordo/connection.scm index 4c31470..302bffd 100644 --- a/ordo/connection.scm +++ b/ordo/connection.scm @@ -21,7 +21,6 @@ this program. If not, see . #:use-module (ordo connection base) #:use-module (ordo connection local) #: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) @@ -32,35 +31,22 @@ this program. If not, see . ssh-connection call-with-connection remote-cmd) - #:re-export (remote-exec with-remote-input-file with-remote-output-file)) + #:re-export ( remote-exec with-remote-input-file with-remote-output-file)) (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) - (let ((conn (deep-clone conn))) - (when sudo? - (unless (is-a? conn ) - (raise-exception - (make-exception - (make-programming-error) - (make-exception-with-message (format #f "connection ~a does not support sudo" conn))))) - (set! (become? conn) sudo?) - (set! (become-user conn) sudo-user) - (set! (become-password conn) sudo-password)) - (dynamic-wind - (lambda () (setup conn)) - (lambda () (proc conn)) - (lambda () (teardown conn))))) +(define* (call-with-connection conn proc) + (dynamic-wind + (lambda () (setup conn)) + (lambda () (proc conn)) + (lambda () (teardown conn)))) (define (remote-cmd conn prog . args) (let* ((args options (break keyword? args)) diff --git a/ordo/core.scm b/ordo/core.scm index d12c7c1..eb2230a 100644 --- a/ordo/core.scm +++ b/ordo/core.scm @@ -15,55 +15,26 @@ 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 (oop goops) + #:use-module (ordo blueprint) #:use-module (ordo connection) #:use-module (ordo context) - #:use-module (ordo handler) #: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 (srfi srfi-26) + #:export (execute)) -(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))) +(define-method (execute (blueprint ) (conn )) + #f + ) -(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)))) +(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 (run-host-play ctx p h) - (log-msg 'NOTICE "Running play on host: " (host-name h)) - (set-ctx-host! ctx h) - (call-with-connection - (host-connection h) - (lambda (conn) - (dynamic-wind - (lambda () - (set-ctx-connection! ctx conn)) - (lambda () - (for-each (cut run-task ctx <>) (play-tasks p)) - (for-each (cut run-handler ctx <>) (play-handlers p))) - (lambda () - (set-ctx-connection! ctx #f)))) - #:sudo? (play-sudo? p) - #:sudo-user (play-sudo-user p) - #:sudo-password (play-sudo-password p))) +(define-method (execute (task ) (conn )) + #f) -(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 (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-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 <>))) 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..41b901b 100644 --- a/ordo/inventory.scm +++ b/ordo/inventory.scm @@ -25,25 +25,23 @@ this program. If not, see . #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-69) - #:export (host + #:export ( + host host? host-name host-connection host-tags - host-vars resolve-hosts 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-class () + (name #:init-keyword #:name #:getter host-name) + (connection #:init-keyword #:connection #:getter host-connection) + (tags #:init-keyword #:tags #:getter host-tags)) -(define* (host #:key name connection (tags '()) (vars '())) - (make-host name connection tags (alist->hash-table vars))) +(define (host? h) (is-a? h )) + +(define (host . args) (apply make args)) (define (tagged-every? wanted-tags) (lambda (h) 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"))) From 17abb6019c7ad460926d67aaab6c20baf7e8b1e0 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 28 Jun 2025 18:12:49 +0100 Subject: [PATCH 02/13] 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))) From be28e14d3e33e040fdddadd59c01e284d2776f88 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 4 Jul 2025 16:01:05 +0100 Subject: [PATCH 03/13] Clearer logging --- ordo/core.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ordo/core.scm b/ordo/core.scm index b7418e9..2488987 100644 --- a/ordo/core.scm +++ b/ordo/core.scm @@ -66,6 +66,8 @@ this program. If not, see . (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) + ;; TODO: replace the exception handler with a continue-on-error? boolean, and construct + ;; an exception handler that logs the error along with the task name (exception-handler #:init-keyword #:exception-handler #:init-value #f #:getter task-exception-handler)) (define (task . args) (apply make args)) @@ -77,9 +79,9 @@ this program. If not, see . (let ((result ((task-action task) conn))) (cond ((equal? result #f) - (log-msg 'NOTICE (task-name task) " - no change")) + (log-msg 'NOTICE (task-name task) " - OK")) ((equal? result #t) - (log-msg 'NOTICE (task-name task) " - ok") + (log-msg 'NOTICE (task-name task) " - CHANGED") (for-each schedule-handler! (task-trigger task))) (else (log-msg 'NOTICE (task-name task) " - " result)))))) From ae8c24aa63fee29fd7f62218f09386488bf8f877 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 4 Jul 2025 17:13:14 +0100 Subject: [PATCH 04/13] More work on execution --- examples/inventory.scm | 31 +++++------ examples/uptime.scm | 5 +- ordo/connection.scm | 21 +++++-- ordo/core.scm | 121 +++++++++++++++++++++++++---------------- ordo/inventory.scm | 50 +++++++---------- 5 files changed, 129 insertions(+), 99 deletions(-) diff --git a/examples/inventory.scm b/examples/inventory.scm index 944aa60..08b81dd 100644 --- a/examples/inventory.scm +++ b/examples/inventory.scm @@ -1,23 +1,22 @@ (use-modules (ordo connection) (ordo inventory)) -(list - (host #:name "root@little-rascal" - #:connection (local-connection #:become? #t) - #:tags '(#:linux #:guix)) +(defhost "little-rascal" + #:connection (local-connection) + #:tags '(#:linux #:guix)) - (host #:name "root@limiting-factor" - #:connection (ssh-connection #:host "limiting-factor" #:user "core" #:become? #t) - #:tags '(#:linux #:coreos)) +(defhost "limiting-factor" + #:connection (ssh-connection #:host "limiting-factor" #:user "core") + #:tags '(#:linux #:coreos)) - (host #:name "root@screw-loose" - #:connection (ssh-connection #:host "screw-loose" #:user "core" #:become? #t) - #:tags '(#:linux #:coreos)) +(defhost "screw-loose" + #:connection (ssh-connection #:host "screw-loose" #:user "core") + #:tags '(#:linux #:coreos)) - (host #:name "root@control-surface" - #:connection (ssh-connection #:host "control-surface" #:user "ray" #:become? #t) - #:tags '(#:linux #:debian)) +(defhost "control-surface" + #:connection (ssh-connection #:host "control-surface" #:user "ray") + #:tags '(#:linux #:debian)) - (host #:name "root@cargo-cult" - #:connection (ssh-connection #:host "cargo-cult" #:user "ray" #:become? #t) - #: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 index 163f6f5..2a4340d 100644 --- a/examples/uptime.scm +++ b/examples/uptime.scm @@ -7,6 +7,9 @@ (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))) + (execute uptime "limiting-factor" '(#:sudo #t)))) (define resolver (load-inventory "examples/inventory.scm")) + +;; IDEA: have load-inventory! set an *inventory* parameter and remove the execute methods +;; that take a argument, making this implicit. diff --git a/ordo/connection.scm b/ordo/connection.scm index 302bffd..5b22034 100644 --- a/ordo/connection.scm +++ b/ordo/connection.scm @@ -21,6 +21,7 @@ this program. If not, see . #:use-module (ordo connection base) #:use-module (ordo connection local) #: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) @@ -42,11 +43,21 @@ this program. If not, see . (define (ssh-connection . args) (apply make args)) -(define* (call-with-connection conn proc) - (dynamic-wind - (lambda () (setup conn)) - (lambda () (proc conn)) - (lambda () (teardown conn)))) +(define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password) + (let ((conn (deep-clone conn))) + (when sudo? + (unless (is-a? conn ) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message (format #f "connection ~a does not support sudo" conn))))) + (set! (become? conn) sudo?) + (set! (become-user conn) sudo-user) + (set! (become-password conn) sudo-password)) + (dynamic-wind + (lambda () (setup conn)) + (lambda () (proc conn)) + (lambda () (teardown conn))))) (define (remote-cmd conn prog . args) (let* ((args options (break keyword? args)) diff --git a/ordo/core.scm b/ordo/core.scm index 2488987..74e69ec 100644 --- a/ordo/core.scm +++ b/ordo/core.scm @@ -18,6 +18,7 @@ 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 inventory) @@ -34,7 +35,6 @@ this program. If not, see . task-action task-args task-trigger - task-exception-handler handler @@ -65,39 +65,49 @@ this program. If not, see . (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) - ;; TODO: replace the exception handler with a continue-on-error? boolean, and construct - ;; an exception handler that logs the error along with the task name - (exception-handler #:init-keyword #:exception-handler #:init-value #f #:getter task-exception-handler)) + (trigger #:init-keyword #:trigger #:init-form (list) #:getter task-trigger)) (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) " - 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)))))) - (if (task-exception-handler task) - (with-exception-handler (task-exception-handler task) task-thunk #:unwind? #t) - (task-thunk))) + (if ((task-pre-condition task) conn) + (let ((result ((task-action task) conn))) + (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)))) + (log-msg 'NOTICE (task-name task) " - SKIPPED"))) -(define-method (execute (task ) (host )) +(define-method (execute (task ) (host ) (options )) (log-msg 'NOTICE "Executing task " (task-name task) " on host " (host-name host)) - (call-with-connection (host-connection host) (cut execute task <>))) + (let-keywords + options #t + ((sudo? #f) + (sudo-user #f) + (sudo-password #f)) + (call-with-connection + (host-connection host) + (cut execute task <> options) + #:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password))) -(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-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))) + (execute task host options))) + (lambda (host) + (execute task host options))) + (resolve-hosts target)))) (define-class () (name #:init-keyword #:name #:getter handler-name) @@ -153,32 +163,47 @@ in which case it is a no-op." (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))))) + (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 )) +(define-method (execute (blueprint ) (host ) (options )) (log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint) " on host " (host-name host)) - (call-with-connection (host-connection host) (cut execute blueprint <>))) + (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 ) (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 (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)) + (execute blueprint host options) + #:unwind? #t)) + (lambda (host) + (execute blueprint host options))) + (resolve-hosts target)))) -(define-class () - (steps #:init-keyword #:steps #:getter workflow-steps)) +;; (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* (step #:key action target continue-on-err?) +;; (lambda (resolver) +;; (execute action resolver target continue-on-err?))) -(define (workflow . steps) - (make #:steps steps)) +;; (define (workflow . steps) +;; (make #:steps steps)) -(define-method (execute (wf ) (resolver )) - (for-each (lambda (step) (step resolver)) (workflow-steps wf))) +;; (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 ba8eb59..6e8f990 100644 --- a/ordo/inventory.scm +++ b/ordo/inventory.scm @@ -26,18 +26,16 @@ this program. If not, see . #:use-module (srfi srfi-9) #:use-module (srfi srfi-69) #:export ( - host + defhost host? host-name host-connection host-tags - - - - get-inventory-hosts resolve-hosts - load-inventory)) + load-inventory!)) + +(define *inventory* '()) (define-class () (name #:init-keyword #:name #:getter host-name) @@ -46,8 +44,6 @@ this program. If not, see . (define (host? h) (is-a? h )) -(define (host . args) (apply make args)) - (define (tagged-every? wanted-tags) (lambda (h) (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) @@ -60,28 +56,24 @@ this program. If not, see . (lambda (h) (string=? (host-name h) hostname))) -(define-class ()) - -(define-class () - (hosts #:init-keyword #:hosts #:getter get-inventory-hosts)) - -(define-method (resolve-hosts (inventory ) expr) - (define hosts (get-inventory-hosts inventory)) +(define-method (resolve-hosts expr) (match expr - ("localhost" (list (or (find (named? "localhost") hosts) - (host #:name "localhost" #:connection (local-connection))))) - ((? 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)))) + ("localhost" (list (or (find (named? "localhost") *inventory*) + (make #: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 (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) - (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")) - (make #:hosts hosts))) + (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"))) From 78beb037e741f718023e2013e3973d56b77f53ab Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 5 Jul 2025 16:29:59 +0100 Subject: [PATCH 05/13] 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. --- examples/uptime.scm | 11 +++---- ordo/action/filesystem.scm | 4 +-- ordo/action/quadlet.scm | 2 +- ordo/action/remote-cmd.scm | 27 +++++++++++++++++ ordo/action/systemctl.scm | 2 +- ordo/connection.scm | 25 ++-------------- ordo/connection/base.scm | 2 ++ ordo/connection/local.scm | 3 ++ ordo/connection/ssh.scm | 6 ++++ ordo/core.scm | 61 ++++++++++++++++---------------------- ordo/inventory.scm | 24 +++++++-------- 11 files changed, 84 insertions(+), 83 deletions(-) create mode 100644 ordo/action/remote-cmd.scm diff --git a/examples/uptime.scm b/examples/uptime.scm index 2a4340d..1afda2a 100644 --- a/examples/uptime.scm +++ b/examples/uptime.scm @@ -1,15 +1,12 @@ (use-modules (ordo core) (ordo inventory) - (ordo connection) + (ordo action remote-cmd) (ordo logger) (srfi srfi-26)) (define uptime (task #:name "uptime" #:action (cut remote-cmd <> "uptime" #:return car))) -(define flow (workflow - (execute uptime "limiting-factor" '(#:sudo #t)))) -(define resolver (load-inventory "examples/inventory.scm")) - -;; IDEA: have load-inventory! set an *inventory* parameter and remove the execute methods -;; that take a argument, making this implicit. +;;(setup-logging! #:level 'DEBUG) +;;(load-inventory! "examples/inventory.scm") +;;(execute uptime 'all '()) 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..dbb14a5 --- /dev/null +++ b/ordo/action/remote-cmd.scm @@ -0,0 +1,27 @@ +(define-module (ordo action remote-cmd) + #:use-module (ice-9 exceptions) + #: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) + #:use-module (ordo util keyword-args) + #:export (remote-cmd)) + +(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 '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))))) + (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/connection.scm b/ordo/connection.scm index 5b22034..f729bf9 100644 --- a/ordo/connection.scm +++ b/ordo/connection.scm @@ -23,16 +23,11 @@ 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 )) @@ -44,6 +39,7 @@ this program. If not, see . (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 ) @@ -58,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..330c8f9 100644 --- a/ordo/connection/base.scm +++ b/ordo/connection/base.scm @@ -23,6 +23,7 @@ this program. If not, see . #: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) 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 b659926..bb3635d 100644 --- a/ordo/connection/ssh.scm +++ b/ordo/connection/ssh.scm @@ -39,6 +39,12 @@ this program. If not, see . (session) (sftp-session)) +(define-method (describe (c )) + (format #f "ssh ~a@~a (sudo=~a)" + (ssh-connection-user c) + (ssh-connection-host c) + (become? c))) + (define-method (setup (c )) (unless (slot-bound? c 'session) (let ((s (make-session #:user (ssh-connection-user c) #:host (ssh-connection-host c)))) diff --git a/ordo/core.scm b/ordo/core.scm index 74e69ec..52e9cd7 100644 --- a/ordo/core.scm +++ b/ordo/core.scm @@ -21,6 +21,7 @@ this program. If not, see . #:use-module (ice-9 optargs) #:use-module (oop goops) #:use-module (ordo connection) + #:use-module (ordo connection base) #:use-module (ordo inventory) #:use-module (ordo logger) #:use-module (ordo util flatten) @@ -50,15 +51,9 @@ this program. If not, see . blueprint-tasks blueprint-handlers - - workflow - workflow-steps - - step - execute)) -(define-generic execute) +(define-generic execute%) (define-class () (name #:init-keyword #:name #:getter task-name) @@ -70,7 +65,8 @@ this program. If not, see . (define (task . args) (apply make args)) (define (task? x) (is-a? x )) -(define-method (execute (task ) (conn )) +(define-method (execute% (task ) (conn )) + (log-msg 'DEBUG "execute task " (task-name task) " on connection") (if ((task-pre-condition task) conn) (let ((result ((task-action task) conn))) (cond @@ -83,7 +79,7 @@ this program. If not, see . (log-msg 'NOTICE (task-name task) " - " result)))) (log-msg 'NOTICE (task-name task) " - SKIPPED"))) -(define-method (execute (task ) (host ) (options )) +(define-method (execute% (task ) (host ) (options )) (log-msg 'NOTICE "Executing task " (task-name task) " on host " (host-name host)) (let-keywords options #t @@ -92,10 +88,10 @@ this program. If not, see . (sudo-password #f)) (call-with-connection (host-connection host) - (cut execute task <> options) + (cut execute% task <>) #:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password))) -(define-method (execute (task ) target (options )) +(define-method (execute% (task ) target (options )) (let-keywords options #t ((continue-on-error? #f)) @@ -103,10 +99,12 @@ this program. If not, see . (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))) - (execute task host options))) + (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))) + (execute% task host options))) (resolve-hosts target)))) (define-class () @@ -117,7 +115,7 @@ this program. If not, see . (define (handler . args) (apply make args)) (define (handler? x) (is-a? x )) -(define-method (execute (handler ) (conn )) +(define-method (execute% (handler ) (conn )) (log-msg 'NOTICE "Executing handler " (handler-name handler)) ((handler-action handler) conn)) @@ -158,17 +156,17 @@ in which case it is a no-op." (when triggered (hash-table-set! triggered handler-name #t)))) -(define-method (execute (blueprint ) (conn )) +(define-method (execute% (blueprint ) (conn )) (parameterize ((*triggered-handlers* (make-hash-table))) (log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint)) - (for-each (cut execute <> conn) + (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))) + (execute% handler conn))) (blueprint-handlers blueprint)))) -(define-method (execute (blueprint ) (host ) (options )) +(define-method (execute% (blueprint ) (host ) (options )) (log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint) " on host " (host-name host)) (let-keywords options #t @@ -177,10 +175,10 @@ in which case it is a no-op." (sudo-password #f)) (call-with-connection (host-connection host) - (cut execute blueprint <>) + (cut execute% blueprint <>) #:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password))) -(define-method (execute (blueprint ) target (options )) +(define-method (execute% (blueprint ) target (options )) (let-keywords options #t ((continue-on-error? #f)) @@ -188,22 +186,13 @@ in which case it is a no-op." (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)) - (execute blueprint host options) + (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))) + (execute% blueprint host options))) (resolve-hosts target)))) -;; (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))) +(define (execute task-or-blueprint target . options) + (execute% task-or-blueprint target options)) diff --git a/ordo/inventory.scm b/ordo/inventory.scm index 6e8f990..d82e161 100644 --- a/ordo/inventory.scm +++ b/ordo/inventory.scm @@ -23,8 +23,6 @@ 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 ( defhost host? @@ -44,6 +42,17 @@ this program. If not, see . (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"))) + (define (tagged-every? wanted-tags) (lambda (h) (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) @@ -66,14 +75,3 @@ this program. If not, see . (('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 (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"))) From 9068953967199a357a5448c4999de9ffde23d72e Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 6 Jul 2025 14:06:06 +0100 Subject: [PATCH 06/13] Fix handling of task arguments --- ordo/core.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ordo/core.scm b/ordo/core.scm index 52e9cd7..6e65ff9 100644 --- a/ordo/core.scm +++ b/ordo/core.scm @@ -68,7 +68,7 @@ this program. If not, see . (define-method (execute% (task ) (conn )) (log-msg 'DEBUG "execute task " (task-name task) " on connection") (if ((task-pre-condition task) conn) - (let ((result ((task-action 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")) From e9eb8681e474244f0f73acc868c3376b46e7d3d2 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 6 Jul 2025 14:27:37 +0100 Subject: [PATCH 07/13] Use ice-9 optargs rather than our own keyword-args --- ordo/action/remote-cmd.scm | 34 ++++++++++++++++++---------------- ordo/connection/base.scm | 17 ++++++++++------- ordo/core.scm | 4 +++- ordo/util/keyword-args.scm | 23 ----------------------- 4 files changed, 31 insertions(+), 47 deletions(-) delete mode 100644 ordo/util/keyword-args.scm diff --git a/ordo/action/remote-cmd.scm b/ordo/action/remote-cmd.scm index dbb14a5..4f2475f 100644 --- a/ordo/action/remote-cmd.scm +++ b/ordo/action/remote-cmd.scm @@ -1,27 +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) - #:use-module (ordo util keyword-args) #:export (remote-cmd)) (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 '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))))) - (values (return out) rc))))) + (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/connection/base.scm b/ordo/connection/base.scm index 330c8f9..0f9a017 100644 --- a/ordo/connection/base.scm +++ b/ordo/connection/base.scm @@ -17,9 +17,9 @@ 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 ( @@ -46,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/core.scm b/ordo/core.scm index 6e65ff9..e2026d4 100644 --- a/ordo/core.scm +++ b/ordo/core.scm @@ -76,7 +76,8 @@ this program. If not, see . (log-msg 'NOTICE (task-name task) " - CHANGED") (for-each schedule-handler! (task-trigger task))) (else - (log-msg 'NOTICE (task-name task) " - " result)))) + (log-msg 'NOTICE (task-name task) " - " result))) + result) (log-msg 'NOTICE (task-name task) " - SKIPPED"))) (define-method (execute% (task ) (host ) (options )) @@ -154,6 +155,7 @@ 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 )) 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)) From 93c5cad46053d3098caaace1657ffdf279679703 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 6 Jul 2025 14:43:14 +0100 Subject: [PATCH 08/13] Simplify example --- examples/uptime.scm | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/examples/uptime.scm b/examples/uptime.scm index 1afda2a..bbca00b 100644 --- a/examples/uptime.scm +++ b/examples/uptime.scm @@ -1,12 +1,8 @@ (use-modules (ordo core) - (ordo inventory) - (ordo action remote-cmd) - (ordo logger) - (srfi srfi-26)) + (ordo action remote-cmd)) -(define uptime (task #:name "uptime" #:action (cut remote-cmd <> "uptime" #:return car))) - - -;;(setup-logging! #:level 'DEBUG) -;;(load-inventory! "examples/inventory.scm") -;;(execute uptime 'all '()) +(execute (task #:name "uptime" + #:action remote-cmd + #:args (list "uptime" #:return car #:check? #t)) + 'all + #:continue-on-error? #t) From 69f50fbadb71fdf4800f1117ab1509ab83f9f79e Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 6 Jul 2025 15:00:16 +0100 Subject: [PATCH 09/13] Simplify handling of localhost in inventory --- ordo/inventory.scm | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ordo/inventory.scm b/ordo/inventory.scm index d82e161..36e4137 100644 --- a/ordo/inventory.scm +++ b/ordo/inventory.scm @@ -51,7 +51,8 @@ this program. If not, see . (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"))) + (log-msg 'NOTICE "Inventory is empty, only localhost will be available") + (defhost "localhost" #:connection (local-connection)))) (define (tagged-every? wanted-tags) (lambda (h) @@ -67,8 +68,6 @@ this program. If not, see . (define-method (resolve-hosts expr) (match expr - ("localhost" (list (or (find (named? "localhost") *inventory*) - (make #:name "localhost" #:connection (local-connection))))) ((? string? hostname) (filter (named? hostname) *inventory*)) ('all *inventory*) (('tagged tag) (filter (tagged-every? (list tag)) *inventory*)) From 66a2a887fd5beabbcfc2dcfe46b650eb3b732d12 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 6 Jul 2025 15:00:30 +0100 Subject: [PATCH 10/13] Update run to work with new syntax --- ordo/cli/run.scm | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) 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)))) From 3d4a83fd37c3b470761f6fadff446a728d4026f9 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 6 Jul 2025 15:00:41 +0100 Subject: [PATCH 11/13] Remove workflow from forgejo example --- examples/forgejo.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/examples/forgejo.scm b/examples/forgejo.scm index ff6ce1f..15742dc 100644 --- a/examples/forgejo.scm +++ b/examples/forgejo.scm @@ -54,5 +54,4 @@ #:action systemctl:restart #:args '((#:unit . "forgejo-pod.service"))))) -(workflow - (execute (install-forgejo #:version "11") "root@limiting-factor")) +(execute (install-forgejo #:version "11") "limiting-factor" #:sudo? #t) From f83fde7ad7c3eb82c24c32b6c18936f14f3a58cc Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 6 Jul 2025 17:06:17 +0100 Subject: [PATCH 12/13] Fixes to SSH/sudo handling --- ordo/connection/ssh.scm | 21 ++++++++++++--------- ordo/connection/sudo.scm | 4 ++-- 2 files changed, 14 insertions(+), 11 deletions(-) diff --git a/ordo/connection/ssh.scm b/ordo/connection/ssh.scm index bb3635d..d06e7f7 100644 --- a/ordo/connection/ssh.scm +++ b/ordo/connection/ssh.scm @@ -23,10 +23,10 @@ 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 () @@ -64,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)) @@ -73,18 +74,20 @@ 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))) (when (connected? s) diff --git a/ordo/connection/sudo.scm b/ordo/connection/sudo.scm index 60a95c0..0caac17 100644 --- a/ordo/connection/sudo.scm +++ b/ordo/connection/sudo.scm @@ -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))) From 1efa10ef07876888da603756d70f24ce8247495c Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 6 Jul 2025 17:06:33 +0100 Subject: [PATCH 13/13] Don't require #:name keyword to create task --- examples/uptime.scm | 2 +- ordo/core.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/examples/uptime.scm b/examples/uptime.scm index bbca00b..c3820e6 100644 --- a/examples/uptime.scm +++ b/examples/uptime.scm @@ -1,7 +1,7 @@ (use-modules (ordo core) (ordo action remote-cmd)) -(execute (task #:name "uptime" +(execute (task "uptime" #:action remote-cmd #:args (list "uptime" #:return car #:check? #t)) 'all diff --git a/ordo/core.scm b/ordo/core.scm index e2026d4..a42dfc7 100644 --- a/ordo/core.scm +++ b/ordo/core.scm @@ -62,7 +62,7 @@ this program. If not, see . (args #:init-keyword #:args #:init-form (list) #:getter task-args) (trigger #:init-keyword #:trigger #:init-form (list) #:getter task-trigger)) -(define (task . args) (apply make args)) +(define (task name . args) (apply make #:name name args)) (define (task? x) (is-a? x )) (define-method (execute% (task ) (conn ))