Compare commits
13 commits
main
...
blueprints
Author | SHA1 | Date | |
---|---|---|---|
1efa10ef07 | |||
f83fde7ad7 | |||
3d4a83fd37 | |||
66a2a887fd | |||
69f50fbadb | |||
93c5cad460 | |||
e9eb8681e4 | |||
9068953967 | |||
78beb037e7 | |||
ae8c24aa63 | |||
be28e14d3e | |||
17abb6019c | |||
c1cb9aa3db |
20 changed files with 373 additions and 470 deletions
|
@ -1,60 +1,57 @@
|
|||
(use-modules
|
||||
(ordo core)
|
||||
((ordo action filesystem) #:prefix fs:)
|
||||
((ordo action quadlet) #:prefix quadlet:)
|
||||
((ordo action systemctl) #:prefix systemctl:))
|
||||
|
||||
(define* (install-forgejo #:key (version "11"))
|
||||
(list
|
||||
(task "Install configuration directory"
|
||||
#:action fs:install-dir
|
||||
#:args '(#:path "/etc/forgejo")
|
||||
#:trigger '("Restart pod"))
|
||||
(task "Install timezone configuration"
|
||||
#:action fs:install-file
|
||||
#:args '(#:path "/etc/forgejo/timezone" #:local-src "files/timezone")
|
||||
#:trigger '("Restart pod"))
|
||||
(task "Install localtime configuration"
|
||||
#:action fs:install-file
|
||||
#:args '(#:path "/etc/forgejo/localtime" #:local-src "files/localtime")
|
||||
#:trigger '("Restart pod"))
|
||||
(task "Create data volume quadlet"
|
||||
#:action quadlet:create-volume
|
||||
#:args '(#:name "forgejo" #:description "Forgejo data volume")
|
||||
#:trigger '("Reload systemd" "Restart pod"))
|
||||
(task "Create pod quadlet"
|
||||
#:action quadlet:create-pod
|
||||
#:args '(#:name "forgejo"
|
||||
#:pod ((PodName . "forge")
|
||||
(Volume . "forgejo.volume:U,Z")
|
||||
(PodmanArgs . "--userns auto")))
|
||||
#:trigger '("Reload systemd" "Restart pod"))
|
||||
(task "Create image quadlet"
|
||||
#:action quadlet:create-image
|
||||
#:args `(#:name "forgejo"
|
||||
#:image (Image . ,(format #f "codeberg.org/forgejo/forgejo:~a" version)))
|
||||
#:trigger '("Reload systemd" "Restart pod"))
|
||||
(task "Create container quadlet"
|
||||
#:action quadlet:create-container
|
||||
#:args '(#:name "forgejo"
|
||||
#:container ((Pod . "forgejo.pod")
|
||||
(Image . "forgejo.image")
|
||||
(Network . "services.network")
|
||||
(Volume . "/etc/forgejo/timezone:/etc/timezone:ro,U,Z")
|
||||
(Volume . "/etc/forgejo/localtime:/etc/localtime:ro,U,Z")
|
||||
(Environment . "USER_UID=1000")
|
||||
(Environment . "USER_GID=1000")
|
||||
(Environment . "FORGEJO__service__DISABLE_REGISTRATION=true")
|
||||
(Environment . "FORGEJO__webhook__ALLOWED_HOST_LIST=private")))
|
||||
#:trigger '("Reload systemd" "Restart pod"))
|
||||
(handler "Reload systemd"
|
||||
#:action systemctl:daemon-reload)
|
||||
(handler "Restart pod"
|
||||
#:action systemctl:restart-unit
|
||||
#:args '((#:unit . "forgejo-pod.service")))))
|
||||
"Create a blueprint to install Forgejo on a CoreOS system"
|
||||
(blueprint (format #f "Install forgejo version ~a" version)
|
||||
(task "Install configuration directory"
|
||||
#:action fs:install-dir
|
||||
#:args '(#:path "/etc/forgejo")
|
||||
#:trigger '("Restart pod"))
|
||||
(task "Install timezone configuration"
|
||||
#:action fs:install-file
|
||||
#:args '(#:path "/etc/forgejo/timezone" #:local-src "files/timezone")
|
||||
#:trigger '("Restart pod"))
|
||||
(task "Install localtime configuration"
|
||||
#:action fs:install-file
|
||||
#:args '(#:path "/etc/forgejo/localtime" #:local-src "files/localtime")
|
||||
#:trigger '("Restart pod"))
|
||||
(task "Create data volume quadlet"
|
||||
#:action quadlet:create-volume
|
||||
#:args '(#:name "forgejo" #:description "Forgejo data volume")
|
||||
#:trigger '("Reload systemd" "Restart pod"))
|
||||
(task "Create pod quadlet"
|
||||
#:action quadlet:create-pod
|
||||
#:args '(#:name "forgejo"
|
||||
#:pod ((PodName . "forge")
|
||||
(Volume . "forgejo.volume:U,Z")
|
||||
(PodmanArgs . "--userns auto")))
|
||||
#:trigger '("Reload systemd" "Restart pod"))
|
||||
(task "Create image quadlet"
|
||||
#:action quadlet:create-image
|
||||
#:args `(#:name "forgejo"
|
||||
#:image (Image . ,(format #f "codeberg.org/forgejo/forgejo:~a" version)))
|
||||
#:trigger '("Reload systemd" "Restart pod"))
|
||||
(task "Create container quadlet"
|
||||
#:action quadlet:create-container
|
||||
#:args '(#:name "forgejo"
|
||||
#:container ((Pod . "forgejo.pod")
|
||||
(Image . "forgejo.image")
|
||||
(Network . "services.network")
|
||||
(Volume . "/etc/forgejo/timezone:/etc/timezone:ro,U,Z")
|
||||
(Volume . "/etc/forgejo/localtime:/etc/localtime:ro,U,Z")
|
||||
(Environment . "USER_UID=1000")
|
||||
(Environment . "USER_GID=1000")
|
||||
(Environment . "FORGEJO__service__DISABLE_REGISTRATION=true")
|
||||
(Environment . "FORGEJO__webhook__ALLOWED_HOST_LIST=private")))
|
||||
#:trigger '("Reload systemd" "Restart pod"))
|
||||
(handler "Reload systemd"
|
||||
#:action systemctl:daemon-reload)
|
||||
(handler "Restart pod"
|
||||
#:action systemctl:restart
|
||||
#:args '((#:unit . "forgejo-pod.service")))))
|
||||
|
||||
(playbook "Install Forgejo on limiting-factor"
|
||||
;; #:vars '((forgejo-version . "11.0.2"))
|
||||
(play
|
||||
#:host "limiting-factor"
|
||||
#:become? #t
|
||||
(install-forgejo #:version "11")))
|
||||
(execute (install-forgejo #:version "11") "limiting-factor" #:sudo? #t)
|
||||
|
|
|
@ -1,23 +1,22 @@
|
|||
(use-modules (ordo connection)
|
||||
(ordo inventory))
|
||||
|
||||
(list
|
||||
(host #:name "little-rascal"
|
||||
#:connection (local-connection)
|
||||
#:tags '(#:linux #:guix))
|
||||
(defhost "little-rascal"
|
||||
#:connection (local-connection)
|
||||
#:tags '(#:linux #:guix))
|
||||
|
||||
(host #:name "limiting-factor"
|
||||
#:connection (ssh-connection "limiting-factor" #:user "core")
|
||||
#:tags '(#:linux #:coreos))
|
||||
(defhost "limiting-factor"
|
||||
#:connection (ssh-connection #:host "limiting-factor" #:user "core")
|
||||
#:tags '(#:linux #:coreos))
|
||||
|
||||
(host #:name "screw-loose"
|
||||
#:connection (ssh-connection "screw-loose" #:user "core")
|
||||
#:tags '(#:linux #:coreos))
|
||||
(defhost "screw-loose"
|
||||
#:connection (ssh-connection #:host "screw-loose" #:user "core")
|
||||
#:tags '(#:linux #:coreos))
|
||||
|
||||
(host #:name "control-surface"
|
||||
#:connection (ssh-connection "control-surface" #:user "ray")
|
||||
#:tags '(#:linux #:debian))
|
||||
(defhost "control-surface"
|
||||
#:connection (ssh-connection #:host "control-surface" #:user "ray")
|
||||
#:tags '(#:linux #:debian))
|
||||
|
||||
(host #:name "cargo-cult"
|
||||
#:connection (ssh-connection "cargo-cult" #:user "ray")
|
||||
#:tags '(#:linux #:synology)))
|
||||
(defhost "cargo-cult"
|
||||
#:connection (ssh-connection #:host "cargo-cult" #:user "ray")
|
||||
#:tags '(#:linux #:synology))
|
||||
|
|
8
examples/uptime.scm
Normal file
8
examples/uptime.scm
Normal file
|
@ -0,0 +1,8 @@
|
|||
(use-modules (ordo core)
|
||||
(ordo action remote-cmd))
|
||||
|
||||
(execute (task "uptime"
|
||||
#:action remote-cmd
|
||||
#:args (list "uptime" #:return car #:check? #t))
|
||||
'all
|
||||
#:continue-on-error? #t)
|
|
@ -23,8 +23,8 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
#:use-module (srfi srfi-1) ; list utils
|
||||
#:use-module (srfi srfi-26) ; cut
|
||||
#:use-module (srfi srfi-71) ; extended let
|
||||
#:use-module ((ordo connection) #:select (remote-cmd))
|
||||
#:use-module (ordo connection base)
|
||||
#:use-module (ordo action remote-cmd)
|
||||
#:use-module ((ordo connection base) #:select (with-remote-output-file))
|
||||
#:export (create-tmp-dir
|
||||
install-dir
|
||||
install-file
|
||||
|
|
|
@ -19,7 +19,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
#:use-module (ice-9 filesystem)
|
||||
#:use-module (ini)
|
||||
#:use-module (logging logger)
|
||||
#:use-module (ordo connection)
|
||||
#:use-module (ordo action remote-cmd)
|
||||
#:use-module ((ordo action filesystem) #:prefix fs:)
|
||||
#:use-module ((srfi srfi-1) #:select (remove))
|
||||
#:export (create-network
|
||||
|
|
29
ordo/action/remote-cmd.scm
Normal file
29
ordo/action/remote-cmd.scm
Normal file
|
@ -0,0 +1,29 @@
|
|||
(define-module (ordo action remote-cmd)
|
||||
#:use-module (ice-9 exceptions)
|
||||
#:use-module (ice-9 optargs)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-71)
|
||||
#:use-module (ordo connection)
|
||||
#:use-module (ordo connection base)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (ordo util flatten)
|
||||
#:export (remote-cmd))
|
||||
|
||||
(define (remote-cmd conn prog . args)
|
||||
(let ((args options (break keyword? args)))
|
||||
(let-keywords
|
||||
options #t
|
||||
((return identity)
|
||||
(check? #f))
|
||||
(let ((command (build-command conn prog (remove unspecified? (flatten args)) options)))
|
||||
(log-msg 'DEBUG "Running command: " command " on connection " (describe conn))
|
||||
(let ((out rc (remote-exec conn command)))
|
||||
(log-msg 'DEBUG "Command exit code: " rc)
|
||||
(if check?
|
||||
(if (zero? rc)
|
||||
(return out)
|
||||
(raise-exception (make-exception
|
||||
(make-external-error)
|
||||
(make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog))
|
||||
(make-exception-with-irritants out))))
|
||||
(values (return out) rc)))))))
|
|
@ -16,7 +16,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
|#
|
||||
|
||||
(define-module (ordo action systemctl)
|
||||
#:use-module (ordo connection)
|
||||
#:use-module (ordo action remote-cmd)
|
||||
#:export (daemon-reload stop start restart reload))
|
||||
|
||||
(define* (daemon-reload conn #:key user?)
|
||||
|
|
|
@ -16,12 +16,13 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
|#
|
||||
|
||||
(define-module (ordo cli run)
|
||||
#:declarative? #f
|
||||
#:use-module (config)
|
||||
#:use-module (config api)
|
||||
#:use-module (ice-9 filesystem)
|
||||
#:use-module (ordo core)
|
||||
#:use-module (ordo inventory)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (ordo playbook)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:export (config handler))
|
||||
|
@ -57,12 +58,12 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
(arguments
|
||||
(list
|
||||
(argument
|
||||
(name 'playbook)
|
||||
(name 'workflow)
|
||||
(handler (cut expand-file-name <> #f #t))
|
||||
(example "examples/uptime.scm")
|
||||
(test file-exists?))))
|
||||
(synopsis "Run a playbook")))
|
||||
(synopsis "Run a workflow")))
|
||||
|
||||
(define (handler options)
|
||||
(let ((inventory (load-inventory (option-ref options 'inventory)))
|
||||
(playbook (load-playbook (option-ref options '(playbook)))))
|
||||
(run-playbook playbook inventory)))
|
||||
(load-inventory! (option-ref options 'inventory))
|
||||
(load (option-ref options '(workflow))))
|
||||
|
|
|
@ -23,30 +23,23 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
#:use-module (ordo connection ssh)
|
||||
#:use-module (ordo connection sudo)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (ordo util flatten)
|
||||
#:use-module (ordo util keyword-args)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-71)
|
||||
#:export (connection?
|
||||
local-connection
|
||||
ssh-connection
|
||||
call-with-connection
|
||||
remote-cmd)
|
||||
#:re-export (remote-exec with-remote-input-file with-remote-output-file))
|
||||
call-with-connection))
|
||||
|
||||
(define (connection? c)
|
||||
(is-a? c <connection>))
|
||||
|
||||
(define (local-connection)
|
||||
(make <local-connection>))
|
||||
(define (local-connection . args)
|
||||
(apply make <local-connection> args))
|
||||
|
||||
(define* (ssh-connection host #:key (user (getlogin)) (password #f) (identity #f) (authenticate-server? #t)
|
||||
(sudo? #f) (sudo-user #f) (sudo-password #f))
|
||||
(make <ssh-connection> #:user user #:host host #:password password
|
||||
#:identity identity #:authenticate-server? authenticate-server?
|
||||
#:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password))
|
||||
(define (ssh-connection . args)
|
||||
(apply make <ssh-connection> args))
|
||||
|
||||
(define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password)
|
||||
(log-msg 'DEBUG "call-with-connection " (describe conn))
|
||||
(let ((conn (deep-clone conn)))
|
||||
(when sudo?
|
||||
(unless (is-a? conn <sudo-connection>)
|
||||
|
@ -61,20 +54,3 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
(lambda () (setup conn))
|
||||
(lambda () (proc conn))
|
||||
(lambda () (teardown conn)))))
|
||||
|
||||
(define (remote-cmd conn prog . args)
|
||||
(let* ((args options (break keyword? args))
|
||||
(args (remove unspecified? (flatten args)))
|
||||
(return (keyword-arg options #:return identity))
|
||||
(check? (keyword-arg options #:check?))
|
||||
(command (build-command conn prog args options)))
|
||||
(log-msg 'INFO "Running command: " command)
|
||||
(let ((out rc (remote-exec conn command)))
|
||||
(log-msg 'INFO "Command exit code: " rc)
|
||||
(if check?
|
||||
(if (zero? rc)
|
||||
(return out)
|
||||
(raise-exception (make-exception
|
||||
(make-external-error)
|
||||
(make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog)))))
|
||||
(values (return out) rc)))))
|
||||
|
|
|
@ -17,12 +17,13 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
|
||||
(define-module (ordo connection base)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 optargs)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (ordo util flatten)
|
||||
#:use-module (ordo util keyword-args)
|
||||
#:use-module (ordo util shell-quote)
|
||||
#:use-module ((srfi srfi-1) #:select (remove))
|
||||
#:export (<connection>
|
||||
describe
|
||||
setup
|
||||
teardown
|
||||
build-command
|
||||
|
@ -32,6 +33,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
|
||||
(define-generic setup)
|
||||
(define-generic teardown)
|
||||
(define-generic describe)
|
||||
(define-generic build-command)
|
||||
(define-generic remote-exec)
|
||||
(define-generic with-remote-input-file)
|
||||
|
@ -44,14 +46,17 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
(define-method (teardown (c <connection>)) #t)
|
||||
|
||||
(define-method (build-command (c <connection>) (prog-name <string>) (prog-args <list>) (options <list>))
|
||||
(let* ((pwd (keyword-arg options #:pwd))
|
||||
(env (keyword-arg options #:env))
|
||||
(redirect-err? (keyword-arg options #:redirect-err? #t))
|
||||
(xs (remove unspecified?
|
||||
(let-keywords
|
||||
options #t
|
||||
((pwd #f)
|
||||
(env #f)
|
||||
(shell-quote? #t)
|
||||
(redirect-err? #t))
|
||||
(let ((xs (remove unspecified?
|
||||
(flatten (list "env"
|
||||
(when pwd (list "--chdir" (string-shell-quote pwd)))
|
||||
(when env (map (match-lambda ((k . v) (string-append k "=" (string-shell-quote v)))) env))
|
||||
prog-name
|
||||
(map string-shell-quote prog-args)
|
||||
(if shell-quote? (map string-shell-quote prog-args) prog-args)
|
||||
(when redirect-err? "2>&1"))))))
|
||||
(string-join xs " ")))
|
||||
(string-join xs " "))))
|
||||
|
|
|
@ -25,6 +25,9 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
|
||||
(define-class <local-connection> (<sudo-connection>))
|
||||
|
||||
(define-method (describe (c <local-connection>))
|
||||
(format #f "local-connection (sudo=~a)" (become? c)))
|
||||
|
||||
(define-method (remote-exec (c <local-connection>) (command <string>))
|
||||
(let* ((port (open-input-pipe command))
|
||||
(output (read-lines port))
|
||||
|
|
|
@ -23,29 +23,40 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
#:use-module (ssh channel)
|
||||
#:use-module (ssh auth)
|
||||
#:use-module (ssh popen)
|
||||
#:use-module (ssh sftp)
|
||||
#:use-module (ordo connection base)
|
||||
#:use-module (ordo connection sudo)
|
||||
#:use-module (ordo util read-lines)
|
||||
#:use-module (ordo util shell-quote)
|
||||
#:export (<ssh-connection>))
|
||||
|
||||
(define-class <ssh-connection> (<sudo-connection>)
|
||||
(user #:getter ssh-connection-user #:init-keyword #:user)
|
||||
(host #:getter ssh-connection-host #:init-keyword #:host)
|
||||
(password #:getter ssh-connection-password #:init-keyword #:password #:init-val #f)
|
||||
(identity #:getter ssh-connection-identity #:init-keyword #:identity #:init-val #f)
|
||||
(authenticate-server? #:getter ssh-connection-authenticate-server? #:init-keyword #:authenticate-server? #:init-val #t)
|
||||
(password #:getter ssh-connection-password #:init-keyword #:password #:init-value #f)
|
||||
(identity #:getter ssh-connection-identity #:init-keyword #:identity #:init-value #f)
|
||||
(timeout #:getter ssh-connection-timeout #:init-keyword #:timeout #:init-value 10)
|
||||
(authenticate-server? #:getter ssh-connection-authenticate-server? #:init-keyword #:authenticate-server? #:init-value #t)
|
||||
(session)
|
||||
(sftp-session))
|
||||
|
||||
(define-method (describe (c <ssh-connection>))
|
||||
(format #f "ssh ~a@~a (sudo=~a)"
|
||||
(ssh-connection-user c)
|
||||
(ssh-connection-host c)
|
||||
(become? c)))
|
||||
|
||||
(define-method (setup (c <ssh-connection>))
|
||||
(unless (slot-bound? c 'session)
|
||||
(slot-set! c 'session (make-session #:user (ssh-connection-user c) #:host (ssh-connection-host c)))
|
||||
(when (ssh-connection-identity c) (session-set! (slot-ref c 'session) 'identity (ssh-connection-identity c))))
|
||||
(let ((s (make-session #:user (ssh-connection-user c) #:host (ssh-connection-host c))))
|
||||
(session-set! s 'timeout (ssh-connection-timeout c))
|
||||
(when (ssh-connection-identity c)
|
||||
(session-set! s 'identity (ssh-connection-identity c)))
|
||||
(slot-set! c 'session s)))
|
||||
(let ((s (slot-ref c 'session)))
|
||||
(unless (connected? s)
|
||||
(connect! s)
|
||||
(when (ssh-connection-authenticate-server? s)
|
||||
(when (equal? 'error (connect! s))
|
||||
(error (string-append "Error connecting to " (ssh-connection-host c))))
|
||||
(when (ssh-connection-authenticate-server? c)
|
||||
(let ((server-auth (authenticate-server s)))
|
||||
(unless (equal? 'ok server-auth)
|
||||
(error (format #f "authenticate-server: ~a" server-auth)))))
|
||||
|
@ -53,7 +64,8 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
(userauth-password! s (ssh-connection-password c))
|
||||
(userauth-public-key/auto! s))))
|
||||
(unless (equal? 'success user-auth)
|
||||
(error (format #f "userauth: ~a" user-auth)))))))
|
||||
(error (format #f "userauth: ~a" user-auth))))))
|
||||
(next-method))
|
||||
|
||||
(define-method (remote-exec (c <ssh-connection>) (command <string>))
|
||||
(let* ((channel (open-remote-input-pipe (slot-ref c 'session) command))
|
||||
|
@ -62,19 +74,21 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
(close channel)
|
||||
(values output exit-status)))
|
||||
|
||||
(define-method (sftp-session (c <ssh-connection>))
|
||||
(unless (slot-bound? c 'sftp-session)
|
||||
(slot-set! c 'sftp-session (make-sftp-session (session c))))
|
||||
(slot-ref c 'sftp-session))
|
||||
|
||||
(define-method (with-remote-input-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-remote-input-file (sftp-session c) filename proc))
|
||||
(let* ((channel (open-remote-input-pipe (slot-ref c 'session) (string-append "cat " (string-shell-quote filename))))
|
||||
(result (proc channel)))
|
||||
(close channel)
|
||||
result))
|
||||
|
||||
(define-method (with-remote-output-file (c <ssh-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-remote-output-file (sftp-session c) filename proc))
|
||||
(let* ((channel (open-remote-output-pipe (slot-ref c 'session) (string-append "cat >" (string-shell-quote filename))))
|
||||
(result (proc channel)))
|
||||
(close channel)
|
||||
result))
|
||||
|
||||
(define-method (teardown (c <ssh-connection>))
|
||||
(next-method)
|
||||
(when (slot-bound? c 'session)
|
||||
(let ((s (slot-ref c session)))
|
||||
(let ((s (slot-ref c 'session)))
|
||||
(when (connected? s)
|
||||
(disconnect! s)))))
|
||||
|
|
|
@ -29,7 +29,7 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
become-password))
|
||||
|
||||
(define-class <sudo-connection> (<connection>)
|
||||
(become? #:accessor become? #:init-keyword become? #:init-form #f)
|
||||
(become? #:accessor become? #:init-keyword #:become? #:init-form #f)
|
||||
(become-user #:accessor become-user #:init-keyword #:become-user #:init-form #f)
|
||||
(become-password #:accessor become-password #:init-keyword #:become-password #:init-form #f)
|
||||
(password-tmp-file #:accessor password-tmp-file))
|
||||
|
@ -51,10 +51,10 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
(next-method))
|
||||
|
||||
((and (become-user conn) (become-password conn))
|
||||
(format #f "cat ~a - | sudo -k -S -H -u ~a -- ~a" (string-shell-quote (password-tmp-file conn)) (string-shell-quote (become-user conn)) (next-method)))
|
||||
(format #f "cat ~a | sudo -k -S -H -u ~a -- ~a" (string-shell-quote (password-tmp-file conn)) (string-shell-quote (become-user conn)) (next-method)))
|
||||
|
||||
((become-password conn)
|
||||
(format #f "cat ~a - | sudo -k -S -H -- ~a" (string-shell-quote (password-tmp-file conn)) (next-method)))
|
||||
(format #f "cat ~a | sudo -k -S -H -- ~a" (string-shell-quote (password-tmp-file conn)) (next-method)))
|
||||
|
||||
((become-user conn)
|
||||
(format #f "sudo -k -n -H -u ~a -- ~a" (string-shell-quote (become-user conn)) (next-method)))
|
||||
|
|
219
ordo/core.scm
219
ordo/core.scm
|
@ -14,56 +14,187 @@ PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
|||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo core)
|
||||
#:use-module (ice-9 exceptions)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (ice-9 optargs)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (ordo connection)
|
||||
#:use-module (ordo context)
|
||||
#:use-module (ordo handler)
|
||||
#:use-module (ordo connection base)
|
||||
#:use-module (ordo inventory)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (ordo playbook)
|
||||
#:use-module (ordo play)
|
||||
#:use-module (ordo task)
|
||||
#:use-module ((srfi srfi-26) #:select (cut)))
|
||||
#:use-module (ordo util flatten)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-69)
|
||||
#:export (<task>
|
||||
task
|
||||
task?
|
||||
task-name
|
||||
task-pre-condition
|
||||
task-action
|
||||
task-args
|
||||
task-trigger
|
||||
|
||||
(define (run-playbook ctx pb)
|
||||
(log-msg 'NOTICE "Running playbook: " (playbook-name pb))
|
||||
(set-ctx-playbook! ctx pb)
|
||||
(for-each (cut run-play ctx <>) (playbook-plays pb)))
|
||||
<handler>
|
||||
handler
|
||||
handler?
|
||||
handler-name
|
||||
handler-action
|
||||
handler-args
|
||||
|
||||
(define (run-play ctx p)
|
||||
(log-msg 'NOTICE "Running play: " (play-name p))
|
||||
(set-ctx-play! ctx p)
|
||||
(let ((hosts (resolve-hosts (ctx-inventory ctx) (play-host p))))
|
||||
(if (null? hosts)
|
||||
(log-msg 'WARN "No hosts matched: " (play-host p))
|
||||
(for-each (cut run-host-play ctx p <>) hosts))))
|
||||
<blueprint>
|
||||
blueprint
|
||||
blueprint?
|
||||
blueprint-name
|
||||
blueprint-tasks
|
||||
blueprint-handlers
|
||||
|
||||
(define (run-host-play ctx p h)
|
||||
(log-msg 'NOTICE "Running play on host: " (host-name h))
|
||||
(set-ctx-host! ctx h)
|
||||
(call-with-connection
|
||||
(host-connection h)
|
||||
(lambda (conn)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set-ctx-connection! ctx conn))
|
||||
(lambda ()
|
||||
(for-each (cut run-task ctx <>) (play-tasks p))
|
||||
(for-each (cut run-handler ctx <>) (play-handlers p)))
|
||||
(lambda ()
|
||||
(set-ctx-connection! ctx #f))))
|
||||
#:sudo? (play-sudo? p)
|
||||
#:sudo-user (play-sudo-user p)
|
||||
#:sudo-password (play-sudo-password p)))
|
||||
execute))
|
||||
|
||||
(define (run-task ctx t)
|
||||
(if ((task-pre-condition t) ctx)
|
||||
(begin
|
||||
(log-msg 'NOTICE "Running task " (task-name t))
|
||||
((task-action t) ctx))
|
||||
(log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met")))
|
||||
(define-generic execute%)
|
||||
|
||||
(define (run-handler ctx h)
|
||||
(when (member (ctx-triggers ctx) (handler-name h))
|
||||
(log-msg 'NOTICE "Running handler: " (handler-name h))
|
||||
((handler-action h) ctx)))
|
||||
(define-class <task> ()
|
||||
(name #:init-keyword #:name #:getter task-name)
|
||||
(pre-condition #:init-keyword #:pre-condition #:init-value (const #t) #:getter task-pre-condition)
|
||||
(action #:init-keyword #:action #:getter task-action)
|
||||
(args #:init-keyword #:args #:init-form (list) #:getter task-args)
|
||||
(trigger #:init-keyword #:trigger #:init-form (list) #:getter task-trigger))
|
||||
|
||||
(define (task name . args) (apply make <task> #:name name args))
|
||||
(define (task? x) (is-a? x <task>))
|
||||
|
||||
(define-method (execute% (task <task>) (conn <connection>))
|
||||
(log-msg 'DEBUG "execute task " (task-name task) " on connection")
|
||||
(if ((task-pre-condition task) conn)
|
||||
(let ((result (apply (task-action task) conn (map (lambda (a) (if (promise? a) (force a) a)) (task-args task)))))
|
||||
(cond
|
||||
((equal? result #f)
|
||||
(log-msg 'NOTICE (task-name task) " - OK"))
|
||||
((equal? result #t)
|
||||
(log-msg 'NOTICE (task-name task) " - CHANGED")
|
||||
(for-each schedule-handler! (task-trigger task)))
|
||||
(else
|
||||
(log-msg 'NOTICE (task-name task) " - " result)))
|
||||
result)
|
||||
(log-msg 'NOTICE (task-name task) " - SKIPPED")))
|
||||
|
||||
(define-method (execute% (task <task>) (host <host>) (options <list>))
|
||||
(log-msg 'NOTICE "Executing task " (task-name task) " on host " (host-name host))
|
||||
(let-keywords
|
||||
options #t
|
||||
((sudo? #f)
|
||||
(sudo-user #f)
|
||||
(sudo-password #f))
|
||||
(call-with-connection
|
||||
(host-connection host)
|
||||
(cut execute% task <>)
|
||||
#:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password)))
|
||||
|
||||
(define-method (execute% (task <task>) target (options <list>))
|
||||
(let-keywords
|
||||
options #t
|
||||
((continue-on-error? #f))
|
||||
(for-each
|
||||
(if continue-on-error?
|
||||
(lambda (host)
|
||||
(with-exception-handler
|
||||
(lambda (e) (log-msg 'ERROR "Failed to execute " (task-name task) " on host " (host-name host) ": " e))
|
||||
(lambda ()
|
||||
(execute% task host options))
|
||||
#:unwind? #t))
|
||||
(lambda (host)
|
||||
(execute% task host options)))
|
||||
(resolve-hosts target))))
|
||||
|
||||
(define-class <handler> ()
|
||||
(name #:init-keyword #:name #:getter handler-name)
|
||||
(action #:init-keyword #:action #:getter handler-action)
|
||||
(args #:init-keyword #:args #:init-form (list) #:getter handler-args))
|
||||
|
||||
(define (handler . args) (apply make <handler> args))
|
||||
(define (handler? x) (is-a? x <handler>))
|
||||
|
||||
(define-method (execute% (handler <handler>) (conn <connection>))
|
||||
(log-msg 'NOTICE "Executing handler " (handler-name handler))
|
||||
((handler-action handler) conn))
|
||||
|
||||
(define-class <blueprint> ()
|
||||
(name #:init-keyword #:name #:getter blueprint-name)
|
||||
(tasks #:init-keyword #:tasks #:getter blueprint-tasks)
|
||||
(handlers #:init-keyword #:handlers #:getter blueprint-handlers))
|
||||
|
||||
(define (blueprint? x) (is-a? x <blueprint>))
|
||||
|
||||
(define (validate-triggers blueprint-name tasks handlers)
|
||||
(let ((handler-names (map handler-name handlers)))
|
||||
(for-each (lambda (task)
|
||||
(for-each (lambda (trigger)
|
||||
(unless (member trigger handler-names)
|
||||
(raise-exception
|
||||
(make-exception
|
||||
(make-programming-error)
|
||||
(make-exception-with-message (format #f "Task ~a in blueprint ~a references unknown trigger: ~a"
|
||||
blueprint-name (task-name task) trigger))))))
|
||||
(task-trigger task)))
|
||||
tasks)))
|
||||
|
||||
(define (blueprint name . args)
|
||||
(let* ((args (flatten args))
|
||||
(tasks (filter task? args))
|
||||
(handlers (filter handler? args)))
|
||||
(validate-triggers name (filter task? tasks) handlers)
|
||||
(make <blueprint> #:name name #:tasks tasks #:handlers handlers)))
|
||||
|
||||
(define *triggered-handlers* (make-parameter #f))
|
||||
|
||||
(define (schedule-handler! handler-name)
|
||||
"Schedule a handler to be run after all tasks in a blueprint. This function
|
||||
may also be called outside of a blueprint (e.g. when a stand-alone task is run),
|
||||
in which case it is a no-op."
|
||||
(let ((triggered (*triggered-handlers*)))
|
||||
(when triggered
|
||||
(log-msg 'DEBUG "Scheduling handler: " handler-name)
|
||||
(hash-table-set! triggered handler-name #t))))
|
||||
|
||||
(define-method (execute% (blueprint <blueprint>) (conn <connection>))
|
||||
(parameterize ((*triggered-handlers* (make-hash-table)))
|
||||
(log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint))
|
||||
(for-each (cut execute% <> conn)
|
||||
(blueprint-tasks blueprint))
|
||||
(for-each (lambda (handler)
|
||||
(when (hash-table-ref/default (*triggered-handlers*) (handler-name handler) #f)
|
||||
(execute% handler conn)))
|
||||
(blueprint-handlers blueprint))))
|
||||
|
||||
(define-method (execute% (blueprint <blueprint>) (host <host>) (options <list>))
|
||||
(log-msg 'NOTICE "Executing blueprint " (blueprint-name blueprint) " on host " (host-name host))
|
||||
(let-keywords
|
||||
options #t
|
||||
((sudo? #f)
|
||||
(sudo-user #f)
|
||||
(sudo-password #f))
|
||||
(call-with-connection
|
||||
(host-connection host)
|
||||
(cut execute% blueprint <>)
|
||||
#:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password)))
|
||||
|
||||
(define-method (execute% (blueprint <blueprint>) target (options <list>))
|
||||
(let-keywords
|
||||
options #t
|
||||
((continue-on-error? #f))
|
||||
(for-each
|
||||
(if continue-on-error?
|
||||
(lambda (host)
|
||||
(with-exception-handler
|
||||
(cut log-msg 'ERROR "Failed to execute blueprint " (blueprint-name blueprint) " on host " (host-name host) ": " <>)
|
||||
(lambda ()
|
||||
(execute% blueprint host options))
|
||||
#:unwind? #t))
|
||||
(lambda (host)
|
||||
(execute% blueprint host options)))
|
||||
(resolve-hosts target))))
|
||||
|
||||
(define (execute task-or-blueprint target . options)
|
||||
(execute% task-or-blueprint target options))
|
||||
|
|
|
@ -1,39 +0,0 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo handler)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (ordo logger)
|
||||
#:export (make-handler
|
||||
handler?
|
||||
handler-name
|
||||
handler-action
|
||||
handler
|
||||
run-handler))
|
||||
|
||||
(define-record-type <handler>
|
||||
(make-handler name action)
|
||||
handler?
|
||||
(name handler-name)
|
||||
(action handler-action))
|
||||
|
||||
(define* (handler #:key name action)
|
||||
(make-handler name action))
|
||||
|
||||
(define (run-handler h conn)
|
||||
(log-msg 'NOTICE "Running handler: " (handler-name h))
|
||||
((handler-action h) conn))
|
|
@ -23,27 +23,36 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
#:use-module ((ordo connection) #:select (local-connection))
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-69)
|
||||
#:export (host
|
||||
#:export (<host>
|
||||
defhost
|
||||
host?
|
||||
host-name
|
||||
host-connection
|
||||
host-tags
|
||||
host-vars
|
||||
|
||||
resolve-hosts
|
||||
load-inventory))
|
||||
load-inventory!))
|
||||
|
||||
(define-record-type <host>
|
||||
(make-host name connection tags vars)
|
||||
host?
|
||||
(name host-name)
|
||||
(connection host-connection)
|
||||
(tags host-tags)
|
||||
(vars host-vars))
|
||||
(define *inventory* '())
|
||||
|
||||
(define* (host #:key name connection (tags '()) (vars '()))
|
||||
(make-host name connection tags (alist->hash-table vars)))
|
||||
(define-class <host> ()
|
||||
(name #:init-keyword #:name #:getter host-name)
|
||||
(connection #:init-keyword #:connection #:getter host-connection)
|
||||
(tags #:init-keyword #:tags #:getter host-tags))
|
||||
|
||||
(define (host? h) (is-a? h <host>))
|
||||
|
||||
(define (defhost name . args)
|
||||
(let ((host (apply make <host> #:name name args)))
|
||||
(set! *inventory* (cons host *inventory*))))
|
||||
|
||||
(define (load-inventory! filename)
|
||||
(log-msg 'INFO "Loading inventory " filename)
|
||||
(eval-string (call-with-input-file filename get-string-all)
|
||||
#:file filename)
|
||||
(when (null? *inventory*)
|
||||
(log-msg 'NOTICE "Inventory is empty, only localhost will be available")
|
||||
(defhost "localhost" #:connection (local-connection))))
|
||||
|
||||
(define (tagged-every? wanted-tags)
|
||||
(lambda (h)
|
||||
|
@ -57,22 +66,11 @@ this program. If not, see <https://www.gnu.org/licenses/>.
|
|||
(lambda (h)
|
||||
(string=? (host-name h) hostname)))
|
||||
|
||||
(define (resolve-hosts inventory expr)
|
||||
(define-method (resolve-hosts expr)
|
||||
(match expr
|
||||
("localhost" (list (or (find (named? "localhost") inventory)
|
||||
(host #:name "localhost" #:connection (local-connection)))))
|
||||
((? string? hostname) (filter (named? hostname) inventory))
|
||||
('all inventory)
|
||||
(('tagged tag) (filter (tagged-every? (list tag)) inventory))
|
||||
(('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) inventory))
|
||||
(('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) inventory))
|
||||
((. hostnames) (filter (lambda (h) (member (host-name h) hostnames string=?)) inventory))))
|
||||
|
||||
(define (load-inventory filename)
|
||||
(log-msg 'INFO "Loading inventory " filename)
|
||||
(let* ((inventory (eval-string (call-with-input-file filename get-string-all)
|
||||
#:file filename))
|
||||
(inventory (if (list? inventory) inventory '())))
|
||||
(when (null? inventory)
|
||||
(log-msg 'NOTICE "Inventory is empty, only localhost will be available"))
|
||||
inventory))
|
||||
((? string? hostname) (filter (named? hostname) *inventory*))
|
||||
('all *inventory*)
|
||||
(('tagged tag) (filter (tagged-every? (list tag)) *inventory*))
|
||||
(('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) *inventory*))
|
||||
(('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) *inventory*))
|
||||
((. hostnames) (filter (lambda (h) (member (host-name h) hostnames string=?)) *inventory*))))
|
||||
|
|
|
@ -1,92 +0,0 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo play)
|
||||
#:use-module (ordo connection)
|
||||
#:use-module (ordo context)
|
||||
#:use-module (ordo handler)
|
||||
#:use-module (ordo inventory)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (ordo task)
|
||||
#:use-module (ordo util flatten)
|
||||
#:use-module (ordo util keyword-args)
|
||||
#:use-module (srfi srfi-1) ; lists
|
||||
#:use-module (srfi srfi-9) ; records
|
||||
#:use-module (srfi srfi-26) ; cut/cute
|
||||
#:use-module (srfi srfi-69) ; hash tables
|
||||
#:use-module (srfi srfi-71) ; extended let
|
||||
#:export (play
|
||||
play?
|
||||
play-host
|
||||
play-sudo?
|
||||
play-sudo-user
|
||||
play-sudo-password
|
||||
play-vars
|
||||
play-tasks
|
||||
play-handlers
|
||||
run-play
|
||||
trigger-handler!))
|
||||
|
||||
(define-record-type <play>
|
||||
(make-play name host sudo? sudo-user sudo-password vars tasks handlers)
|
||||
play?
|
||||
(name play-name)
|
||||
(host play-host)
|
||||
(sudo? play-sudo?)
|
||||
(sudo-user play-sudo-user)
|
||||
(sudo-password play-sudo-password)
|
||||
(vars play-vars)
|
||||
(tasks play-tasks)
|
||||
(handlers play-handlers))
|
||||
|
||||
(define (play name . args)
|
||||
(let* ((tasks args (partition task? args))
|
||||
(handlers kwargs (partition handler? args)))
|
||||
(make-play name
|
||||
(keyword-arg #:host kwargs)
|
||||
(keyword-arg #:sudo? kwargs)
|
||||
(keyword-arg #:sudo-user kwargs)
|
||||
(keyword-arg #:sudo-password kwargs)
|
||||
(and=> (keyword-arg #:vars kwargs) alist->hash-table)
|
||||
tasks
|
||||
handlers)))
|
||||
|
||||
(define (run-play p)
|
||||
(log-msg 'NOTICE "Running play: " (play-name p))
|
||||
(parameterize ((*play* p))
|
||||
(let ((hosts (resolve-hosts (*inventory*) (play-host p))))
|
||||
(if (null? hosts)
|
||||
(log-msg 'WARN "No hosts matched: " (play-host p))
|
||||
(for-each (cut run-host-play p <>) hosts)))))
|
||||
|
||||
(define (run-host-play p h)
|
||||
(log-msg 'NOTICE "Running play on host: " (host-name h))
|
||||
(parameterize ((*host* h)
|
||||
(*triggered-handlers* (make-hash-table)))
|
||||
(call-with-connection
|
||||
(host-connection h)
|
||||
(lambda (conn)
|
||||
(for-each (cut run-task <> conn) (play-tasks p))
|
||||
(for-each (cut run-handler <> conn)
|
||||
(filter (compose (cut hash-table-ref/default *triggered-handlers* <> #f) handler-name)
|
||||
(play-handlers p))))
|
||||
#:sudo? (play-sudo? p)
|
||||
#:sudo-user (play-sudo-user p)
|
||||
#:sudo-password (play-sudo-password p))))
|
||||
|
||||
(define (trigger-handler! handler-name)
|
||||
(hash-table-set! *triggered-handlers* handler-name #t))
|
|
@ -1,61 +0,0 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo playbook)
|
||||
#:use-module (ice-9 eval-string)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (ordo context)
|
||||
#:use-module (ordo handler)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (ordo play)
|
||||
#:use-module (ordo task)
|
||||
#:use-module (ordo util keyword-args)
|
||||
#:use-module (srfi srfi-1) ; lists
|
||||
#:use-module (srfi srfi-9) ; records
|
||||
#:use-module (srfi srfi-26) ; cut/cute
|
||||
#:use-module (srfi srfi-69) ; hash tables
|
||||
#:use-module (srfi srfi-71) ; extended let
|
||||
#:export (<playbook>
|
||||
playbook
|
||||
playbook?
|
||||
playbook-name
|
||||
playbook-vars
|
||||
playbook-plays
|
||||
load-playbook
|
||||
run-playbook))
|
||||
|
||||
(define-record-type <playbook>
|
||||
(make-playbook name vars plays)
|
||||
playbook?
|
||||
(name playbook-name)
|
||||
(vars playbook-vars)
|
||||
(plays playbook-plays))
|
||||
|
||||
(define (playbook name . args)
|
||||
(let ((plays kwargs (partition play? args)))
|
||||
(make-playbook name (alist->hash-table (keyword-arg #:vars kwargs '())) plays)))
|
||||
|
||||
(define (load-playbook filename)
|
||||
(log-msg 'INFO "Loading playbook " filename)
|
||||
(eval-string (call-with-input-file filename get-string-all)
|
||||
#:file filename))
|
||||
|
||||
(define (run-playbook pb inventory)
|
||||
(log-msg 'NOTICE "Running playbook: " (playbook-name pb))
|
||||
(parameterize ((*inventory* inventory)
|
||||
(*playbook* pb))
|
||||
(for-each run-play (playbook-plays pb))))
|
|
@ -1,43 +0,0 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo task)
|
||||
#:use-module (ordo logger)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:export (task
|
||||
task?
|
||||
task-name
|
||||
task-pre-condition
|
||||
task-action
|
||||
run-task))
|
||||
|
||||
(define-record-type <task>
|
||||
(make-task name action pre-condition)
|
||||
task?
|
||||
(name task-name)
|
||||
(pre-condition task-pre-condition)
|
||||
(action task-action))
|
||||
|
||||
(define* (task #:key name action (pre-condition (const #t)))
|
||||
(make-task name action pre-condition))
|
||||
|
||||
(define (run-task t conn)
|
||||
(if ((task-pre-condition t) conn)
|
||||
(begin
|
||||
(log-msg 'NOTICE "Running task " (task-name t))
|
||||
((task-action t) conn))
|
||||
(log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met")))
|
|
@ -1,23 +0,0 @@
|
|||
#|
|
||||
This file is part of Ordo.
|
||||
|
||||
Copyright (C) 2025 Ray Miller
|
||||
|
||||
This program is free software: you can redistribute it and/or modify it under
|
||||
the terms of the GNU General Public License as published by the Free Software
|
||||
Foundation, version 3.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT ANY
|
||||
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along with
|
||||
this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|#
|
||||
|
||||
(define-module (ordo util keyword-args)
|
||||
#:use-module ((srfi srfi-1) #:select (member))
|
||||
#:export (keyword-arg))
|
||||
|
||||
(define* (keyword-arg args kw #:optional (default #f))
|
||||
(or (and=> (member kw args) cadr) default))
|
Loading…
Add table
Add a link
Reference in a new issue