diff --git a/bin/ordo.sh b/bin/ordo.sh index f2c6e2a..9ecc787 100755 --- a/bin/ordo.sh +++ b/bin/ordo.sh @@ -2,5 +2,4 @@ MODULES_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )/../modules" &> /dev/null && pwd ) -# guile -L modules --no-auto-compile -e '(@ (ordo cli) main)' -- $PWD/examples/inventory.scm $PWD/examples/basic.scm exec guile -L "${MODULES_DIR}" --no-auto-compile -e '(@ (ordo cli) main)' -- "$@" diff --git a/bin/play.scm b/bin/play.scm deleted file mode 100755 index 103e6c7..0000000 --- a/bin/play.scm +++ /dev/null @@ -1,43 +0,0 @@ -#!/usr/bin/env -S guile --no-auto-compile -e main -s -!# -(use-modules (srfi srfi-11) - (ice-9 getopt-long) - (ice-9 format) - (ordo util filesystem)) - -(define (tar . args) - (unless (zero? (apply system* "tar" args)) - (error (format #f "Non-zero exit from tar ~a" args)))) - -(define* (usage #:optional errmsg) - (with-output-to-port (current-error-port) - (lambda () - (when errmsg - (format #t "Error: ~a~%~%" errmsg)) - (display "Usage: play -t TARGET PLAYBOOK") - (newline))) - (exit (if errmsg EXIT_FAILURE EXIT_SUCCESS))) - -(define (process-options args) - (let* ((option-spec '((help (single-char #\h) (value #f)) - (target (single-char #\t) (value #t) (required? #t)))) - (options (getopt-long args option-spec)) - (help-wanted (option-ref options 'help #f)) - (target (option-ref options 'target #f)) - (args (option-ref options '() '()))) - (cond - (help-wanted (usage)) - ((not (= 1 (length args))) - (usage "Expected exactly one playbook"))) - (values (canonicalize-path (car args)) target))) - -(define (main args) - (let-values (((playbook-path target) (process-options args))) - (define playbook (load playbook-path)) - (define top-dir (dirname (dirname (current-filename)))) - (call-with-temporary-directory - (lambda (tmp-dir) - (define tarball (string-append tmp-dir "/payload.tar")) - (tar "--create" "--file" tarball "--directory" top-dir "modules" "bin") - (tar "--append" "--file" tarball "--transform" "s/.*/playbook.scm/" playbook-path) - (tar "tf" tarball))))) diff --git a/examples/install-aws-cli.scm b/examples/install-aws-cli.scm index 0ee79aa..8ced506 100644 --- a/examples/install-aws-cli.scm +++ b/examples/install-aws-cli.scm @@ -1,33 +1,41 @@ (use-modules (ice-9 filesystem) - (ordo)) + (srfi srfi-71) + (ordo playbook) + (ordo play) + (ordo interceptor) + (ordo connection) + (ordo interceptor create-tmp-dir) + (ordo interceptor require-commands) + (ordo interceptor user-info) + (ordo interceptor download) + (ordo interceptor unzip) + (ordo interceptor command)) +;; This example shows that a function can act a bit like an ansible role by +;; returning a list of interceptors to be added to the caller's interceptor +;; chain. (The list will be flattened to construct the final chain.) (define* (install-aws-cli #:key (url "https://awscli.amazonaws.com/awscli-exe-linux-x86_64.zip") update? install-dir bin-dir) - (let* ((conn (current-connection)) - (tmp-dir (run conn "mktemp" "-d" #:return car #:check? #t))) - (dynamic-wind - (const #t) - (lambda () - (let ((zipfile (file-name-join* tmp-dir (file-basename url)))) - (run conn "wget" "-O" zipfile url #:check? #t) - (run conn "unzip" zipfile "-d" tmp-dir #:check? #t) - (run conn (file-name-join* tmp-dir "aws" "install") - (when install-dir `("-i" ,install-dir)) - (when bin-dir `("-b" ,bin-dir)) - (when update? "-u") - #:check? #t))) - (lambda () - (run conn "rm" "-rf" tmp-dir))))) + (list (require-commands "wget" "unzip") + (create-tmp-dir #:register 'aws-cli-tmp) + (download "download-aws-cli" #:url url #:target-dir (var aws-cli-tmp) #:register 'aws-cli-zipfile) + (unzip "extract-aws-cli" #:file-name (var aws-cli-zipfile) #:target-dir (var aws-cli-tmp)) + (command "run-aws-cli-installer" + (list + (let-vars (aws-cli-tmp) (file-name-join* aws-cli-tmp "aws" "install")) + (when install-dir `("-i" ,install-dir)) + (when bin-dir `("-b" ,bin-dir)) + (when update? "-u") + #:check? #t)))) (playbook #:name "Test Playbook" #:plays (list (play - #:name "Test play" + #:name "Install AWS CLI" #:host "localhost" - #:tasks (list - (task #:name "Install AWS CLI" - #:action (lambda () - (install-aws-cli #:update? #t - #:install-dir (file-name-join* ($ #:fact.home-dir) ".local" "aws-cli") - #:bin-dir (file-name-join* ($ #:fact.home-dir) ".local" "bin")))))))) + #:interceptors (list + (user-info) + (install-aws-cli #:update? #t + #:install-dir (let-vars (user-info) (file-name-join* (assoc-ref user-info #:home-dir) ".local" "aws-cli")) + #:bin-dir (let-vars (user-info) (file-name-join* (assoc-ref user-info #:home-dir) ".local" "bin"))))))) diff --git a/examples/interceptor.scm b/examples/interceptor.scm new file mode 100644 index 0000000..92018a2 --- /dev/null +++ b/examples/interceptor.scm @@ -0,0 +1,34 @@ +(use-modules + (ice-9 filesystem) + (ordo playbook) + (ordo play) + (ordo interceptor) + (ordo interceptor install-file) + (ordo interceptor create-tmp-dir) + (ordo interceptor stat-file) + (ordo interceptor user-info) + (ordo interceptor command) + (ordo interceptor debug)) + +(playbook + #:name "Test some basic filesystem operations" + #:vars '((file-content . "This is shadowed by the play variable.")) + #:plays (list (play + #:name "Basic filesystem operations" + #:host "localhost" + #:vars '((file-content . "Hello, world!\n")) + #:interceptors (list (create-tmp-dir #:register 'tmp-dir) + (user-info) + (debug-vars 'user-info) + (install-file + "install-hello" + #:path (let-vars (tmp-dir) (file-name-join* tmp-dir "hello.txt")) + #:content (var file-content) + #:register 'hello) + (stat-file + "stat-hello" + #:path (var hello) + #:register 'hello-stat) + (command "list-tmp-dir" (list "ls" "-l" (var tmp-dir) #:check? #t) #:register 'dir-list) + (command "list-root-dir" (list "ls" "-l" "/root" #:check? #f) #:register 'root-list) + (debug-vars))))) diff --git a/examples/inventory.scm b/examples/inventory.scm index 01c0a25..00bee3e 100644 --- a/examples/inventory.scm +++ b/examples/inventory.scm @@ -1,4 +1,5 @@ -(use-modules (ordo)) +(use-modules (ordo inventory) + (ordo connection)) (add-host! "little-rascal" (local-connection) diff --git a/examples/ubuntu.scm b/examples/ubuntu.scm new file mode 100644 index 0000000..e993b2c --- /dev/null +++ b/examples/ubuntu.scm @@ -0,0 +1,15 @@ +(use-modules + (ordo playbook) + (ordo play) + (ordo interceptor apt)) + +(playbook + #:name "APT operations" + #:plays (list + (play + #:name "Test APT operations" + #:host '(tagged/any #:ubuntu #:debian) + #:interceptors (list + (apt:update) + (apt:dist-upgrade) + (map apt:install (list "curl" "ca-certificates")))))) diff --git a/modules/ordo.scm b/modules/ordo.scm deleted file mode 100644 index 7c3741f..0000000 --- a/modules/ordo.scm +++ /dev/null @@ -1,10 +0,0 @@ -(define-module (ordo) - #:use-module (ice-9 match) - #:use-module (ordo playbook) - #:use-module (ordo play) - #:use-module (ordo task) - #:use-module (ordo handler) - #:use-module (ordo connection) - #:use-module (ordo context) - #:use-module (ordo logger) - #:re-export (add-host! local-connection ssh-connection current-connection run playbook play task handler $)) diff --git a/modules/ordo/action/apt.scm b/modules/ordo/action/apt.scm deleted file mode 100644 index 6a19462..0000000 --- a/modules/ordo/action/apt.scm +++ /dev/null @@ -1,42 +0,0 @@ -(define-module (ordo action apt) - #:use-module ((ordo connection) #:select (run))) - -(define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive") - ("APT_LISTCHANGES_FRONTEND" . "none"))) - -(define-syntax define-apt-operation - (syntax-rules () - ((define-apt-operation (name args ...) apt-args ...) - (define-public (name conn args ...) - (run conn "apt-get" "-q" "-y" apt-args ... args ... #:env noninteractive-env))) - ((define-apt-operation name apt-args ...) - (define-public (name conn) - (run conn "apt-get" "-q" "-y" apt-args ... #:env noninteractive-env))))) - -(define-apt-operation apt:update "update") - -(define-apt-operation apt:upgrade "upgrade") - -(define-apt-operation apt:dist-upgrade "dist-upgrade") - -(define-apt-operation (apt:install package-name) "install") - -(define-apt-operation (apt:install-minimal package-name) "install" "--no-install-recommends") - -(define-apt-operation (apt:reinstall package-name) "reinstall") - -(define-apt-operation (apt:remove package-name) "remove") - -(define-apt-operation (apt:purge package-name) "purge") - -(define-apt-operation (apt:build-dep package-name) "build-dep") - -(define-apt-operation apt:clean "clean") - -(define-apt-operation apt:autoclean "autoclean") - -(define-apt-operation apt:distclean "distclean") - -(define-apt-operation apt:autoremove "autoremove") - -(define-apt-operation apt:autopurge "autopurge") diff --git a/modules/ordo/action/quadlet.scm b/modules/ordo/action/quadlet.scm new file mode 100644 index 0000000..e1d3f2e --- /dev/null +++ b/modules/ordo/action/quadlet.scm @@ -0,0 +1,41 @@ +(define-module (ordo action quadlet) + #:use-module (ice-9 filesystem) + #:use-module (ini) + #:use-module (logging logger) + #:use-module (ordo connection) + #:use-module (ordo action filesystem) + #:export (create-network-quadlet)) + +(define quadlet-dir "/etc/containers/systemd") + +(define default-install-options '(("WantedBy" . "multi-user.target default.target"))) + +(define (scm->ini-string data) + (with-output-to-string (lambda () (scm->ini data)))) + +(define (build-quadlet quadlet-type name description unit-options quadlet-options install-options) + (let* ((description (or description (string-append "Podman " (string-downcase quadlet-type) " " name))) + (data `(("Unit" ("Description" . ,description) ,@unit-options) + (,(string-titlecase quadlet-type) ,@quadlet-options) + ("Install" ,@(or install-options default-install-options))))) + (scm->ini-string data))) + +(define-syntax define-quadlet-type + (syntax-rules () + ((define-quadlet-type function-name quadlet-type suffix default-install-options) + (define* (function-name conn name #:key description (quadlet-options '()) (unit-options '()) (install-options default-install-options)) + (fs:install-file conn + (file-name-join* quadlet-dir (string-append name suffix)) + #:content (build-quadlet quadlet-type name description quadlet-options unit-options install-options)))))) + +(define-quadlet-type create-network-quadlet "Network" ".network" default-install-options) + +(define-quadlet-type create-pod-quadlet "Pod" ".pod" default-install-options) + +(define-quadlet-type create-container-quadlet "Container" ".container" default-install-options) + +(define-quadlet-type create-volume-quadlet "Volume" ".volume" '()) + +(define-quadlet-type create-build-quadlet "Build" ".build" '()) + +(define-quadlet-type create-image-quadlet "Image" ".image" '()) diff --git a/modules/ordo/cli.scm b/modules/ordo/cli.scm index 64241e6..0038916 100644 --- a/modules/ordo/cli.scm +++ b/modules/ordo/cli.scm @@ -3,7 +3,6 @@ #:use-module (ice-9 match) #:use-module (logging logger) #:use-module (ordo logger) - #:use-module (ordo context) #:use-module (ordo playbook) #:declarative? #f #:export (main)) @@ -12,9 +11,7 @@ (match-let (((_ inventory-path playbook-path) args)) (let ((inventory-path (expand-file-name inventory-path)) (playbook-path (expand-file-name playbook-path))) - (setup-logging #:level 'DEBUG) - (log-msg 'DEBUG "Initializing context") - (init-context!) + (setup-logging #:level 'INFO) (load inventory-path) (log-msg 'DEBUG "Loaded inventory: " inventory-path) (let ((playbook (load playbook-path))) diff --git a/modules/ordo/condition.scm b/modules/ordo/condition.scm index 4834ab6..11e559c 100644 --- a/modules/ordo/condition.scm +++ b/modules/ordo/condition.scm @@ -1,6 +1,7 @@ (define-module (ordo condition) #:use-module (srfi srfi-71) - #:use-module (ordo context) + #:use-module (ordo connection) + #:use-module (ordo interceptor) #:use-module (ordo action filesystem)) (define-public (cond:any preds) @@ -25,15 +26,15 @@ (define-public (cond:command-available? cmd-name) (lambda (ctx) - (let ((_ rc (run "which" `(,cmd-name)))) + (let ((_ rc (run (context-connection ctx) "which" cmd-name))) (zero? rc)))) (define-public (cond:directory? path) (lambda (ctx) - (let ((st ((action:stat path) ctx))) + (let ((st (fs:stat (context-connection ctx) path))) (and st (string=? "directory" (assoc-ref st 'file-type)))))) (define-public (cond:regular-file? path) (lambda (ctx) - (let ((st ((action:stat path) ctx))) + (let ((st (fs:stat (context-connection ctx) path))) (and st (string=? "regular-file" (assoc-ref st 'file-type)))))) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 817f797..4513925 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -50,9 +50,8 @@ (string-join xs " "))) (define (run conn prog . args) - (let* ((args (flatten args)) - (args kwargs (break keyword? args)) - (args (remove unspecified? args)) + (let* ((args kwargs (break keyword? args)) + (args (remove unspecified? (flatten args))) (pwd (keyword-arg kwargs #:pwd)) (env (keyword-arg kwargs #:env)) (return (keyword-arg kwargs #:return identity)) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm deleted file mode 100644 index 2b4dcda..0000000 --- a/modules/ordo/context.scm +++ /dev/null @@ -1,152 +0,0 @@ -(define-module (ordo context) - #:use-module (ice-9 exceptions) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-69) - #:use-module (logging logger) - #:use-module (ordo host) - #:export (init-context! - set-current-connection! - current-connection - current-host - set-current-host! - init-playbook-vars! - get-playbook-var - set-playbook-var! - reset-playbook-vars! - init-play-vars! - get-play-var - set-play-var! - reset-play-vars! - get-command-line-var - set-command-line-var! - $ - reset-play-triggers! - add-play-triggers! - play-triggered? - set-filter-tag! - reset-filter-tags! - check-filter-tags - add-host! - current-inventory)) - -(define *current-context* #f) - -(define-record-type - (make-context) - context? - (connection connection set-connection!) - (hostname hostname set-hostname!) - (command-line-vars command-line-vars set-command-line-vars!) - (play-vars play-vars set-play-vars!) - (play-triggers play-triggers set-play-triggers!) - (playbook-vars playbook-vars set-playbook-vars!) - (filter-tags filter-tags set-filter-tags!) - (inventory inventory set-inventory!)) - -(define (init-context!) - (set! *current-context* (make-context))) - -(define not-found (cons 'not-found '())) - -(define (not-found? x) (eq? x not-found)) - -(define (set-current-connection! conn) - (set-connection! *current-context* conn)) - -(define (current-connection) - (connection *current-context*)) - -(define (set-current-host! hostname) - (set-hostname! *current-context* hostname)) - -(define (current-host) - (hostname *current-context*)) - -(define (init-playbook-vars! alist) - (set-playbook-vars! *current-context* (alist->hash-table alist eqv?))) - -(define (get-playbook-var var-name) - (if (playbook-vars *current-context*) - (hash-table-ref/default (playbook-vars *current-context*) var-name not-found) - not-found)) - -(define (set-playbook-var! var-name val) - (unless (playbook-vars *current-context*) - (set-playbook-vars! *current-context* (make-hash-table eqv?))) - (hash-table-set! (playbook-vars *current-context*) var-name val)) - -(define (reset-playbook-vars!) - (set-playbook-vars! *current-context* #f)) - -(define (init-play-vars! alist) - (set-play-vars! *current-context* (alist->hash-table alist eqv?))) - -(define (get-play-var var-name) - (if (play-vars *current-context*) - (hash-table-ref/default (play-vars *current-context*) var-name not-found) - not-found)) - -(define (set-play-var! var-name val) - (unless (play-vars *current-context*) - (set-play-vars! *current-context* (make-hash-table equal?))) - (hash-table-set! (play-vars *current-context*) var-name val)) - -(define (reset-play-vars!) - (set-play-vars! *current-context* #f)) - -(define (get-command-line-var var-name) - (if (command-line-vars *current-context*) - (hash-table-ref/default (command-line-vars *current-context*) var-name not-found) - not-found)) - -(define (set-command-line-var! var-name val) - (unless (command-line-vars *current-context*) - (set-command-line-vars! *current-context* (make-hash-table eqv?))) - (hash-table-set! (command-line-vars *current-context*) var-name val)) - -(define ($ var-name) - "Try to resolve var-name as a command-line variable, a play variable or a -playbook variable (in that order). Raise an exception if the variable is not -found." - (define (lookup-var procs) - (if (null? procs) - (raise-exception (make-exception - (make-undefined-variable-error) - (make-exception-with-irritants var-name))) - (let ((v ((car procs) var-name))) - (if (not-found? v) - (lookup-var (cdr procs)) - v)))) - (lookup-var (list get-command-line-var get-play-var get-playbook-var))) - -(define (reset-play-triggers!) - (set-play-triggers! *current-context* #f)) - -(define (add-play-triggers! triggers) - (set-play-triggers! *current-context* - (apply lset-adjoin equal? (or (play-triggers *current-context*) '()) - triggers))) - -(define (play-triggered? trigger) - (and=> (play-triggers *current-context*) (cut member trigger <>))) - -(define (set-filter-tag! tag) - (set-filter-tags! *current-context* - (lset-adjoin equal? (or (filter-tags *current-context*) '()) tag))) - -(define (reset-filter-tags!) - (set-filter-tags! *current-context* #f)) - -(define (check-filter-tags tags) - (or (not (filter-tags *current-context*)) - (not (null? (lset-intersection eqv? (filter-tags *current-context*) tags))))) - -(define (current-inventory) - (or (inventory *current-context*) '())) - -(define (add-host! hostname connection . tags) - (log-msg 'DEBUG "Adding host to inventory: " hostname) - (set-inventory! *current-context* (cons (make-host hostname connection tags) - (or (inventory *current-context*) '())))) diff --git a/modules/ordo/facts.scm b/modules/ordo/facts.scm deleted file mode 100644 index 9462e7f..0000000 --- a/modules/ordo/facts.scm +++ /dev/null @@ -1,19 +0,0 @@ -(define-module (ordo facts) - #:use-module ((srfi srfi-88) #:select (string->keyword)) - #:use-module (ordo context) - #:use-module (ordo facts user) - #:export (gather-facts)) - -(define (set-facts! src keys) - (for-each (lambda (k) - (set-play-var! (string->keyword (string-append "fact." k)) - (assoc-ref src (string->keyword k)))) - keys)) - -(define (gather-facts) - (let* ((conn (current-connection)) - (id (fact:id conn)) - (user-name (assoc-ref id #:user-name)) - (pwent (fact:pwent conn user-name))) - (set-facts! id '("user-name" "user-id" "group-name" "group-id" "groups")) - (set-facts! pwent '("gecos" "home-dir" "shell")))) diff --git a/modules/ordo/facts/user.scm b/modules/ordo/facts/user.scm deleted file mode 100644 index 80ce865..0000000 --- a/modules/ordo/facts/user.scm +++ /dev/null @@ -1,32 +0,0 @@ -(define-module (ordo facts user) - #:use-module (rx irregex) - #:use-module (srfi srfi-1) - #:use-module (ordo connection) - #:export (fact:id - fact:pwent)) - -(define (parse-id-output s) - (let ((data (reverse (irregex-fold (irregex '(seq (=> id integer) "(" (=> name (+ alphanumeric)) ")")) - (lambda (_ m accum) - (cons `((#:id . ,(string->number (irregex-match-substring m 'id))) - (#:name . ,(irregex-match-substring m 'name))) - accum)) - '() - s)))) - `((#:user-id . ,(assoc-ref (first data) #:id)) - (#:user-name . ,(assoc-ref (first data) #:name)) - (#:group-id . ,(assoc-ref (second data) #:id)) - (#:group-name . ,(assoc-ref (second data) #:name)) - (#:groups . ,(drop data 2))))) - -(define (fact:id conn) - (run conn "id" #:check? #t #:return (compose parse-id-output car))) - -(define (parse-passwd-entry s) - (map cons - '(#:user-name #:password #:user-id #:group-id #:gecos #:home-dir #:shell) - (string-split s #\:))) - -(define (fact:pwent conn user-name) - (run conn "getent" "passwd" user-name - #:check? #t #:return (compose parse-passwd-entry car))) diff --git a/modules/ordo/handler.scm b/modules/ordo/handler.scm deleted file mode 100644 index 0a6ebba..0000000 --- a/modules/ordo/handler.scm +++ /dev/null @@ -1,25 +0,0 @@ -(define-module (ordo handler) - #:use-module (ice-9 match) - #:use-module (srfi srfi-9) ; records - #:use-module (logging logger) - #:use-module (ordo context) - #:export (handler - handler? - handler-name - handler-action - run-handler)) - -(define-record-type - (make-handler name action) - handler? - (name handler-name) - (action handler-action)) - -(define (handler name action) - (make-handler name action)) - -(define (run-handler h) - (match h - (($ name action) - (log-msg 'NOTICE "Running handler: " name) - (action (current-connection))))) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm new file mode 100644 index 0000000..18cbdd6 --- /dev/null +++ b/modules/ordo/interceptor.scm @@ -0,0 +1,226 @@ +(define-module (ordo interceptor) + #:use-module (ice-9 exceptions) + #:use-module (logging logger) + #:use-module (srfi srfi-1) ; list utils + #:use-module (srfi srfi-9) ; records + #:use-module (srfi srfi-26) ; cut + #:use-module (srfi srfi-69) ; hash tables + #:use-module (srfi srfi-71) ; extended let + #:use-module (srfi srfi-145) ; assume + #:export (interceptor + init-context + context-connection + set-context-connection! + context-error + set-context-error! + context-suppressed + context-vars + set-context-vars! + var-ref + var-set! + var-delete! + let-vars + var + expand-vars + delayed-var-ref? + terminate-when + execute)) + +(define (check-var-name name) + (unless (symbol? name) + (raise-exception (make-exception + (make-assertion-failure) + (make-exception-with-message "Variable name should be a symbol") + (make-exception-with-irritants name))))) + +(define-record-type + (make-context vars stack queue terminators error suppressed) + context? + (connection context-connection set-context-connection!) + (vars context-vars set-context-vars!) + (stack context-stack set-context-stack!) + (queue context-queue set-context-queue!) + (terminators context-terminators set-context-terminators!) + (error context-error set-context-error!) + (suppressed context-suppressed set-context-suppressed!)) + +(define* (init-context #:key (vars '())) + "Initialize a context with optional connection and vars." + (for-each check-var-name (map car vars)) + (make-context + ;; vars + (alist->hash-table vars eqv?) + ;; stack + '() + ;; queue + '() + ;; terminators + '() + ;; error + #f + ;; suppressed errors + '())) + +(define (var-set! ctx name value) + (check-var-name name) + (log-msg 'DEBUG "Setting variable " name " to " value) + (hash-table-set! (context-vars ctx) name value)) + +(define* (var-ref ctx name #:optional default) + (check-var-name name) + (log-msg 'DEBUG "Getting variable " name " with default " default) + (hash-table-ref/default (context-vars ctx) name default)) + +(define (var-delete! ctx name) + (check-var-name name) + (log-msg 'DEBUG "Deleting variable " name) + (hash-table-delete! (context-vars ctx) name)) + +(define-syntax let-vars + (syntax-rules () + ((let-vars (var-name ...) expr exprs ...) + (lambda (ctx) + #((delayed-var-ref? . #t)) + (let ((var-name (hash-table-ref (context-vars ctx) 'var-name)) ...) + expr + exprs ...))))) + +(define-syntax var + (syntax-rules () + ((var var-name) + (let-vars (var-name) var-name)))) + +(define (delayed-var-ref? v) + (and (procedure? v) (procedure-property v 'delayed-var-ref?))) + +(define-syntax expand-vars + (syntax-rules () + ((expand-vars ctx v ...) + (values (if (delayed-var-ref? v) (v ctx) v) ...)))) + +(define-record-type + (make-interceptor name enter leave error) + interceptor? + (name interceptor-name) + (enter interceptor-enter) + (leave interceptor-leave) + (error interceptor-error)) + +(define* (interceptor name #:key enter leave error) + (assume (string? name) "interceptor name should be a string" name) + (make-interceptor name enter leave error)) + +(define-exception-type &interceptor-error &error + make-interceptor-error + interceptor-error? + (interceptor-name interceptor-error-interceptor-name) + (stage interceptor-error-stage) + (cause interceptor-error-cause)) + +(define (enqueue ctx interceptors) + "Add interceptors to the context." + (unless (every interceptor? interceptors) + (error "invalid interceptors")) + (set-context-queue! ctx interceptors)) + +(define (terminate ctx) + "Remove all remaining interceptors from the queue, short-circuiting the + enter stage and running the leave stage." + (set-context-queue! ctx '())) + +(define (check-terminators ctx) + "Check the context terminators and possibly trigger early termination." + (let loop ((terminators (context-terminators ctx))) + (unless (null? terminators) + (let ((t (car terminators))) + (if (t ctx) + (terminate ctx) + (loop (cdr terminators))))))) + +(define (try-enter ctx t) + "Run the interceptor's #:enter function." + (let ((handler (interceptor-enter t))) + (when handler + (log-msg 'NOTICE "Running #:enter function for " (interceptor-name t)) + (with-exception-handler + (lambda (e) + (set-context-error! ctx (make-interceptor-error (interceptor-name t) #:enter e))) + (lambda () (handler ctx)) + #:unwind? #t)))) + +(define (try-leave ctx t) + "Run the interceptor's #:leave function." + (let ((handler (interceptor-leave t))) + (when handler + (log-msg 'NOTICE "Running #:leave function for " (interceptor-name t)) + (with-exception-handler + (lambda (e) + (set-context-error! ctx + (make-interceptor-error (interceptor-name t) #:leave e))) + (lambda () (handler ctx)) + #:unwind? #t)))) + +(define (try-error ctx t err) + "Run the interceptor's #:error function." + (let ((handler (interceptor-error t))) + (when handler + (log-msg 'NOTICE "Running #:error function for " (interceptor-name t)) + (with-exception-handler + (lambda (e) + (log-msg 'WARN "error handler for interceptor '" (interceptor-name t) "' threw error: " e) + (set-context-suppressed! ctx + (cons (make-interceptor-error (interceptor-name t) #:error e) + (context-suppressed ctx)))) + (lambda () (handler ctx)) + #:unwind? #t)))) + +(define (execute-leave ctx) + "Run all the #:leave functions in the queue." + (unless (null? (context-queue ctx)) + (let ((t (car (context-queue ctx))) + (err (context-error ctx))) + ;; Run the error or leave handler, according to whether or not we are + ;; handling an error + (if err + (try-error ctx t err) + (try-leave ctx t)) + ;; Remove the current interceptor from the queue and add it to the stack + (set-context-stack! ctx (cons t (context-stack ctx))) + (set-context-queue! ctx (cdr (context-queue ctx))) + ;; Carry on down the chain + (execute-leave ctx)))) + +(define (execute-enter ctx) + "Run all the #:enter functions in the queue." + (if (null? (context-queue ctx)) + ;; Prepare to leave + (set-context-queue! ctx (context-stack ctx)) + (let ((t (car (context-queue ctx)))) + ;; Run the enter handler for the interceptor + (try-enter ctx t) + ;; Remove the current interceptor from the queue and add it to the stack + (set-context-stack! ctx (cons t (context-stack ctx))) + (set-context-queue! ctx (cdr (context-queue ctx))) + (if (context-error ctx) + ;; If an error was caught, abort the enter phase and set up to run the leave phase + (begin + (set-context-queue! ctx (context-stack ctx)) + (set-context-stack! ctx '())) + ;; Otherwise, check for early termination or carry on down the chain + (begin + (check-terminators ctx) + (execute-enter ctx)))))) + +(define (terminate-when ctx pred) + "Add a predicate for a termination condition to exit the #:enter chain early." + (set-context-terminators! ctx (cons pred (context-terminators ctx)))) + +(define (execute ctx interceptors) + "Execute all the interceptors on the given context." + (log-msg 'DEBUG "Enqueuing interceptors: " (map interceptor-name interceptors)) + (enqueue ctx interceptors) + (log-msg 'DEBUG "Starting #:enter chain: " (map interceptor-name (context-queue ctx))) + (execute-enter ctx) + (log-msg 'DEBUG "Starting #:leave chain: " (map interceptor-name (context-queue ctx))) + (execute-leave ctx) + (and=> (context-error ctx) raise-exception)) diff --git a/modules/ordo/interceptor/apt.scm b/modules/ordo/interceptor/apt.scm new file mode 100644 index 0000000..88d85c5 --- /dev/null +++ b/modules/ordo/interceptor/apt.scm @@ -0,0 +1,49 @@ +(define-module (ordo interceptor apt) + #:use-module (ordo interceptor) + #:use-module ((ordo connection) #:select (run))) + +(define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive") + ("APT_LISTCHANGES_FRONTEND" . "none"))) + +(define-syntax define-apt-interceptor + (syntax-rules () + ((define-apt-interceptor (name arg) apt-args ...) + (define-public (name arg) + (interceptor + (string-append (symbol->string 'name) " " arg) + #:enter (lambda (ctx) + (run (context-connection ctx) "apt-get" "-q" "-y" apt-args ... arg #:env noninteractive-env #:check? #t))))) + ((define-apt-interceptor name apt-args ...) + (define-public (name) + (interceptor + (symbol->string 'name) + #:enter (lambda (ctx) + (run (context-connection ctx) "apt-get" "-q" "-y" apt-args ... #:env noninteractive-env #:check? #t))))))) + +(define-apt-interceptor apt:update "update") + +(define-apt-interceptor apt:upgrade "upgrade") + +(define-apt-interceptor apt:dist-upgrade "dist-upgrade") + +(define-apt-interceptor (apt:install package-name) "install") + +(define-apt-interceptor (apt:install-minimal package-name) "install" "--no-install-recommends") + +(define-apt-interceptor (apt:reinstall package-name) "reinstall") + +(define-apt-interceptor (apt:remove package-name) "remove") + +(define-apt-interceptor (apt:purge package-name) "purge") + +(define-apt-interceptor (apt:build-dep package-name) "build-dep") + +(define-apt-interceptor apt:clean "clean") + +(define-apt-interceptor apt:autoclean "autoclean") + +(define-apt-interceptor apt:distclean "distclean") + +(define-apt-interceptor apt:autoremove "autoremove") + +(define-apt-interceptor apt:autopurge "autopurge") diff --git a/modules/ordo/interceptor/command.scm b/modules/ordo/interceptor/command.scm new file mode 100644 index 0000000..9199c82 --- /dev/null +++ b/modules/ordo/interceptor/command.scm @@ -0,0 +1,22 @@ +(define-module (ordo interceptor command) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo connection) + #:use-module (ordo util flatten) + #:export (command)) + +(define* (command name prog-and-args #:key register) + (assume (string? name) "interceptor name should be a string" name) + (assume (list? prog-and-args) "prog-and-args should be a list" prog-and-args) + (assume (or (not register) (symbol? register)) "register should be a symbol" register) + (interceptor + name + #:enter (lambda (ctx) + (let ((prog-and-args (map (lambda (v) (expand-vars ctx v)) (flatten prog-and-args)))) + (pk prog-and-args) + (call-with-values + (lambda () (apply run (context-connection ctx) prog-and-args)) + (lambda result + (when register + (var-set! ctx register result)))))))) diff --git a/modules/ordo/interceptor/connection.scm b/modules/ordo/interceptor/connection.scm new file mode 100644 index 0000000..5b80078 --- /dev/null +++ b/modules/ordo/interceptor/connection.scm @@ -0,0 +1,22 @@ +(define-module (ordo interceptor connection) + #:use-module (oop goops) + #:use-module (ordo interceptor) + #:use-module (ordo connection) + #:use-module (ordo connection sudo) + #:export (connection)) + +(define* (connection c #:key sudo? sudo-user sudo-password) + "Interceptor to manage the current connection." + (define (cleanup ctx) + (and=> (context-connection ctx) conn:teardown) + (set-context-connection! ctx #f)) + (interceptor + "connection" + #:enter (lambda (ctx) + (let ((c (if sudo? + (make #:connection c #:become-user sudo-user #:become-password sudo-password) + c))) + (conn:setup c) + (set-context-connection! ctx c))) + #:leave cleanup + #:error cleanup)) diff --git a/modules/ordo/interceptor/create-tmp-dir.scm b/modules/ordo/interceptor/create-tmp-dir.scm new file mode 100644 index 0000000..b35cf49 --- /dev/null +++ b/modules/ordo/interceptor/create-tmp-dir.scm @@ -0,0 +1,19 @@ +(define-module (ordo interceptor create-tmp-dir) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo action filesystem) + #:export (create-tmp-dir)) + +(define* (create-tmp-dir #:key (register 'tmp-dir)) + (assume (symbol? register) "register should be a symbol" register) + (define (cleanup ctx) + (and-let* ((tmp-dir (var-ref ctx register))) + (fs:remove (context-connection ctx) tmp-dir #:recurse? #t) + (var-delete! ctx register))) + (interceptor + (format #f "create-tmp-dir ~a" register) + #:enter (lambda (ctx) + (var-set! ctx register (fs:create-tmp-dir (context-connection ctx)))) + #:leave cleanup + #:error cleanup)) diff --git a/modules/ordo/interceptor/debug.scm b/modules/ordo/interceptor/debug.scm new file mode 100644 index 0000000..025f9b8 --- /dev/null +++ b/modules/ordo/interceptor/debug.scm @@ -0,0 +1,16 @@ +(define-module (ordo interceptor debug) + #:use-module (ice-9 pretty-print) + #:use-module ((srfi srfi-1) #:select (concatenate)) + #:use-module ((srfi srfi-69) #:select (hash-table-keys)) + #:use-module (ordo interceptor) + #:export (debug-vars)) + +(define (debug-vars . var-names) + (interceptor + "debug-vars" + #:enter (lambda (ctx) + (let ((var-names (if (null? var-names) + (hash-table-keys (context-vars ctx)) + var-names))) + (pretty-print (map (lambda (v) (list v (var-ref ctx v 'not-found))) + var-names)))))) diff --git a/modules/ordo/interceptor/download.scm b/modules/ordo/interceptor/download.scm new file mode 100644 index 0000000..579963f --- /dev/null +++ b/modules/ordo/interceptor/download.scm @@ -0,0 +1,22 @@ +(define-module (ordo interceptor download) + #:use-module (ice-9 filesystem) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo connection) + #:export (download)) + +(define* (download name #:key url target-dir register) + (assume (string? name) "interceptor name should be a string" name) + (assume (or (string? url) (delayed-var-ref? url)) "url is required and should be a string" url) + (assume (or (not register) (symbol? register)) "register should be a symbol" register) + (interceptor + name + #:enter (lambda (ctx) + (let* ((url target-dir (expand-vars ctx url target-dir)) + (file-name (file-name-join* target-dir (file-basename url)))) + (run (context-connection ctx) "wget" "-O" file-name url #:check? #t) + (when register + (var-set! ctx register file-name)))) + #:leave (lambda (ctx) (when register (var-delete! ctx register))) + #:error (lambda (ctx) (when register (var-delete! ctx register))))) diff --git a/modules/ordo/interceptor/install-file.scm b/modules/ordo/interceptor/install-file.scm new file mode 100644 index 0000000..3732fa2 --- /dev/null +++ b/modules/ordo/interceptor/install-file.scm @@ -0,0 +1,28 @@ +(define-module (ordo interceptor install-file) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo action filesystem) + #:export (install-file)) + +(define* (install-file name #:key path owner group mode content + local-src remote-src backup? register) + (assume path "install path is required") + (assume (or (not register) (symbol? register)) "register should be a symbol" register) + (assume (= 1 (length (filter identity (list content local-src remote-src)))) + "exactly one of content, local-src, or remote-src is required") + (interceptor + name + #:enter (lambda (ctx) + (let ((path (expand-vars ctx path))) + (fs:install-file (context-connection ctx) + path + #:owner (expand-vars ctx owner) + #:group (expand-vars ctx group) + #:mode (expand-vars ctx mode) + #:content (expand-vars ctx content) + #:local-src (expand-vars ctx local-src) + #:remote-src (expand-vars ctx remote-src) + #:backup? (expand-vars ctx backup?)) + (when register + (var-set! ctx register path)))))) diff --git a/modules/ordo/interceptor/require-commands.scm b/modules/ordo/interceptor/require-commands.scm new file mode 100644 index 0000000..f31586c --- /dev/null +++ b/modules/ordo/interceptor/require-commands.scm @@ -0,0 +1,28 @@ +(define-module (ordo interceptor require-commands) + #:use-module (ice-9 exceptions) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo connection) + #:export (require-commands)) + +(define-exception-type &missing-command-error &external-error + make-missing-command-error + missing-command-error? + (command-name missing-command-error-command-name)) + +(define (require-commands . commands) + (assume (every string? commands) "commands should be strings" commands) + (interceptor + (string-append "require-commands " (string-join commands ",")) + #:enter (lambda (ctx) + (for-each (lambda (cmd) + (let ((out rc (run (context-connection ctx) "which" cmd))) + (unless (zero? rc) + (if (string-contains (car out) (format #f "which: no ~a in" cmd)) + (raise-exception (make-missing-command-error cmd)) + (raise-exception (make-exception + (make-external-error) + (make-exception-with-message (string-append "error running which: " (car out))))))))) + commands)))) diff --git a/modules/ordo/interceptor/stat-file.scm b/modules/ordo/interceptor/stat-file.scm new file mode 100644 index 0000000..42b4668 --- /dev/null +++ b/modules/ordo/interceptor/stat-file.scm @@ -0,0 +1,17 @@ +(define-module (ordo interceptor stat-file) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo action filesystem) + #:export (stat-file)) + +(define* (stat-file name #:key path register) + (assume (string? name) "name is required and should be a string" name) + (assume path "path is required" path) + (assume (or (not register) (symbol? register)) "register should be a symbol" register) + (interceptor + name + #:enter (lambda (ctx) + (let* ((path (expand-vars ctx path)) + (st (fs:stat (context-connection ctx) path))) + (when register + (var-set! ctx register st)))))) diff --git a/modules/ordo/interceptor/unzip.scm b/modules/ordo/interceptor/unzip.scm new file mode 100644 index 0000000..d6acf61 --- /dev/null +++ b/modules/ordo/interceptor/unzip.scm @@ -0,0 +1,16 @@ +(define-module (ordo interceptor unzip) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo connection) + #:export (unzip)) + +(define* (unzip name #:key file-name target-dir) + (assume (string? name) "interceptor name is required and should be a string" name) + (assume (or (string? file-name) (delayed-var-ref? file-name)) "file-name is required and should be a string" file-name) + (assume (or (string? target-dir) (delayed-var-ref? target-dir)) "target-dir is required and should be a string" target-dir) + (interceptor + name + #:enter (lambda (ctx) + (let ((file-name target-dir (expand-vars ctx file-name target-dir))) + (run (context-connection ctx) "unzip" file-name "-d" target-dir #:check? #t))))) diff --git a/modules/ordo/interceptor/user-info.scm b/modules/ordo/interceptor/user-info.scm new file mode 100644 index 0000000..291e5c7 --- /dev/null +++ b/modules/ordo/interceptor/user-info.scm @@ -0,0 +1,44 @@ +(define-module (ordo interceptor user-info) + #:use-module (rx irregex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-145) + #:use-module (ordo connection) + #:use-module (ordo interceptor) + #:use-module (ordo util shell-quote) + #:export (user-info)) + +(define (parse-id s) + (let ((data (reverse (irregex-fold (irregex '(seq (=> id integer) "(" (=> name (+ alphanumeric)) ")")) + (lambda (_ m accum) + (cons `((#:id . ,(string->number (irregex-match-substring m 'id))) + (#:name . ,(irregex-match-substring m 'name))) + accum)) + '() + s)))) + `((#:user-id . ,(assoc-ref (first data) #:id)) + (#:user-name . ,(assoc-ref (first data) #:name)) + (#:group-id . ,(assoc-ref (second data) #:id)) + (#:group-name . ,(assoc-ref (second data) #:name)) + (#:groups . ,(drop data 2))))) + +(define (parse-passwd-entry s) + (map cons + '(#:user-name #:password #:user-id #:group-id #:gecos #:home-dir #:shell) + (string-split s #\:))) + +(define* (user-info #:key (register 'user-info)) + (assume (symbol? register) "register should be a symbol" register) + (interceptor + "user-info" + #:enter (lambda (ctx) + (let* ((conn (context-connection ctx)) + (id (run conn "id" + #:check? #t #:return (compose parse-id car))) + (pwent (run conn "getent" "passwd" (string-shell-quote (assoc-ref id #:user-name)) + #:check? #t #:return (compose parse-passwd-entry car)))) + (var-set! ctx register (fold (lambda (key alist) + (acons key (assoc-ref pwent key) alist)) + id + (list #:gecos #:home-dir #:shell))))) + #:leave (lambda (ctx) (var-delete! ctx register)) + #:error (lambda (ctx) (var-delete! ctx register)))) diff --git a/modules/ordo/host.scm b/modules/ordo/inventory.scm similarity index 50% rename from modules/ordo/host.scm rename to modules/ordo/inventory.scm index fa19045..47924ea 100644 --- a/modules/ordo/host.scm +++ b/modules/ordo/inventory.scm @@ -1,15 +1,18 @@ -(define-module (ordo host) +(define-module (ordo inventory) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) - #:use-module (ordo connection) + #:use-module ((ordo connection) #:select (local-connection)) #:export (make-host host? host-name host-connection host-tags + add-host! resolve-hosts)) +(define *inventory* '()) + (define-record-type (make-host name connection tags) host? @@ -17,7 +20,11 @@ (connection host-connection) (tags host-tags)) -(define (tagged-all? wanted-tags) +(define (add-host! name connection . tags) + (set! *inventory* (cons (make-host name connection tags) + *inventory*))) + +(define (tagged-every? wanted-tags) (lambda (h) (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) @@ -29,11 +36,12 @@ (lambda (h) (string=? (host-name h) hostname))) -(define (resolve-hosts inventory) +(define resolve-hosts (match-lambda - ("localhost" (list (or (find (named? "localhost") inventory) + ("localhost" (list (or (find (named? "localhost") *inventory*) (make-host "localhost" (local-connection) '())))) - ((? string? hostname) (filter (named? hostname) inventory)) - ('all inventory) - (('every-tag tag . tags) (filter (tagged-all? (cons tag tags)) inventory)) - (('any-tag tag . tags) (filter (tagged-any? (cons tag tags)) 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*)))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index 7c1f3a4..669027a 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -3,12 +3,10 @@ #:use-module (srfi srfi-26) #:use-module (logging logger) #:use-module (ordo connection) - #:use-module (ordo context) - #:use-module (ordo task) - #:use-module (ordo handler) - #:use-module (ordo context) - #:use-module (ordo host) - #:use-module (ordo facts) + #:use-module (ordo interceptor) + #:use-module (ordo interceptor connection) + #:use-module (ordo inventory) + #:use-module (ordo util flatten) #:export (play play? play-host @@ -16,13 +14,11 @@ play-sudo-user play-sudo-password play-vars - play-tasks - play-handlers - play-gather-facts + play-interceptors run-play)) (define-record-type - (make-play name host sudo? sudo-user sudo-password vars gather-facts tasks handlers) + (make-play name host sudo? sudo-user sudo-password vars interceptors) play? (name play-name) (host play-host) @@ -30,41 +26,24 @@ (sudo-user play-sudo-user) (sudo-password play-sudo-password) (vars play-vars) - (tasks play-tasks) - (handlers play-handlers) - (gather-facts play-gather-facts)) + (interceptors play-interceptors)) -;; TODO: argument validation -(define* (play #:key name host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (gather-facts #t) tasks (handlers '())) - (make-play name host sudo? sudo-user sudo-password vars gather-facts tasks handlers)) +(define* (play #:key name host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (interceptors '())) + (make-play name host sudo? sudo-user sudo-password vars interceptors)) -(define (run-play p) +(define (run-play p playbook-vars) (log-msg 'NOTICE "Running play: " (play-name p)) - (let ((hosts ((resolve-hosts (current-inventory)) (play-host p)))) + (let ((hosts (resolve-hosts (play-host p)))) (if (null? hosts) (log-msg 'WARN "No hosts matched: " (play-host p)) - (for-each (lambda (h) (run-host-play p h)) hosts)))) + (for-each (lambda (h) (run-host-play p h playbook-vars)) hosts)))) -(define (run-host-play p h) +(define (run-host-play p h playbook-vars) (log-msg 'NOTICE "Running play: " (play-name p) " on host: " (host-name h)) - (call-with-connection - (host-connection h) - (play-sudo? p) - (play-sudo-user p) - (play-sudo-password p) - (lambda (conn) - (dynamic-wind - (lambda () - (set-current-connection! conn) - (set-current-host! (host-name h)) - (init-play-vars! (play-vars p))) - (lambda () - (when (play-gather-facts p) (gather-facts)) - (for-each run-task (play-tasks p)) - (for-each run-handler - (filter (compose play-triggered? handler-name) (play-handlers p)))) - (lambda () - (set-current-connection! #f) - (set-current-host! #f) - (reset-play-vars!) - (reset-play-triggers!)))))) + (let ((chain (flatten (cons (connection (host-connection h) + #:sudo? (play-sudo? p) + #:sudo-user (play-sudo-user p) + #:sudo-password (play-sudo-password p)) + (play-interceptors p)))) + (ctx (init-context #:vars (append (play-vars p) playbook-vars)))) + (execute ctx chain))) diff --git a/modules/ordo/playbook.scm b/modules/ordo/playbook.scm index a9df40d..414efbc 100644 --- a/modules/ordo/playbook.scm +++ b/modules/ordo/playbook.scm @@ -1,8 +1,8 @@ (define-module (ordo playbook) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) #:use-module (logging logger) #:use-module (ordo play) - #:use-module (ordo context) #:export (playbook playbook? playbook-name @@ -17,16 +17,10 @@ (vars playbook-vars) (plays playbook-plays)) -;; TODO: argument validation (define* (playbook #:key name (vars '()) plays) (make-playbook name vars plays)) (define (run-playbook pb) (log-msg 'NOTICE "Running playbook: " (playbook-name pb)) - (dynamic-wind - (lambda () - (init-playbook-vars! (playbook-vars pb))) - (lambda () - (for-each run-play (playbook-plays pb))) - (lambda () - (reset-playbook-vars!)))) + (for-each (cut run-play <> (playbook-vars pb)) + (playbook-plays pb))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm deleted file mode 100644 index 460f40f..0000000 --- a/modules/ordo/task.scm +++ /dev/null @@ -1,53 +0,0 @@ -(define-module (ordo task) - #:use-module (ice-9 exceptions) - #:use-module (srfi srfi-9) - #:use-module (logging logger) - #:use-module (ordo context) - #:export (task - task? - task-name - task-tags - task-action - task-condition - task-register-play-var - task-register-playbook-var - task-triggers - run-task)) - -(define-record-type - (make-task name tags action condition register-play-var register-playbook-var triggers) - task? - (name task-name) - (tags task-tags) - (action task-action) - (condition task-condition) - (register-play-var task-register-play-var) - (register-playbook-var task-register-playbook-var) - (triggers task-triggers)) - -(define-syntax assert - (syntax-rules () - ((assert expr message irritant) - (unless expr - (raise-exception (make-exception - (make-assertion-failure) - (make-exception-with-message message) - (make-exception-with-irritants irritant))))))) - -(define* (task #:key name action (tags '()) (condition (const #t)) (register-play-var #f) (register-playbook-var #f) (triggers '())) - (assert (and name (string? name)) "#:name is required and must be a string" name) - (assert (and action (procedure? action)) "#:action is required and must be a procedure" action) - (make-task name tags action condition register-play-var register-playbook-var triggers)) - -(define (run-task t) - (when (check-filter-tags (task-tags t)) - (if (not ((task-condition t))) - (log-msg 'NOTICE "Skipping task: " (task-name t) " (precondition not met)") - (begin - (log-msg 'NOTICE "Running task: " (task-name t)) - (let ((result ((task-action t)))) - (when (task-register-play-var t) - (set-play-var! (task-register-play-var t) result)) - (when (task-register-playbook-var t) - (set-playbook-var! (task-register-playbook-var t) result)) - (add-play-triggers! (task-triggers t)))))))