From 3e1b3e3f374c784f673c75018a31af1beff2d9ac Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 14 Jul 2024 17:11:24 +0100 Subject: [PATCH 01/83] Initial check-in. --- ordo/task.scm | 10 ++++++++++ ordo/task/command.scm | 17 +++++++++++++++++ ordo/util/run.scm | 30 ++++++++++++++++++++++++++++++ 3 files changed, 57 insertions(+) create mode 100644 ordo/task.scm create mode 100644 ordo/task/command.scm create mode 100644 ordo/util/run.scm diff --git a/ordo/task.scm b/ordo/task.scm new file mode 100644 index 0000000..2d10793 --- /dev/null +++ b/ordo/task.scm @@ -0,0 +1,10 @@ +(define-module (ordo task) + #:use-module (srfi srfi-9) + #:export (make-task task? task-name task-prerequisite-data set-task-prerequisite-data! task-action set-task-action!)) + +(define-record-type + (make-task name prerequisite-data action) + task? + (name task-name) + (prerequisite-data task-prerequisite-data set-task-prerequisite-data!) + (action task-action set-task-action!)) diff --git a/ordo/task/command.scm b/ordo/task/command.scm new file mode 100644 index 0000000..181d3cc --- /dev/null +++ b/ordo/task/command.scm @@ -0,0 +1,17 @@ +(define-module (ordo task command) + #:use-module (ice-9 format) + #:use-module (srfi srfi-11) + #:use-module (ordo task) + #:use-module (ordo util run) + #:export (task-command)) + + +(define* (task-command name cmd #:optional (args '()) + #:key (fail-ok? #f) (stdin #f) (cwd #f) (env #f)) + (make-task name + #f + (lambda () + (let-values (((exit-code output) (run cmd args #:stdin stdin #:cwd cwd #:env env #:combine-output #t))) + (if (or fail-ok? (zero? exit-code)) + (values exit-code output) + (error (format #f "Error running ~a (exit ~d): ~a" cmd exit-code output))))))) diff --git a/ordo/util/run.scm b/ordo/util/run.scm new file mode 100644 index 0000000..c394bc7 --- /dev/null +++ b/ordo/util/run.scm @@ -0,0 +1,30 @@ +(define-module (ordo util run) + #:use-module (ice-9 textual-ports) + #:export (run with-cwd)) + +(define-syntax with-cwd + (syntax-rules () + ((_ new-dir body ...) + (let ((original-dir (getcwd))) + (dynamic-wind + (lambda () (chdir new-dir)) + (lambda () body ...) + (lambda () (chdir original-dir))))))) + +(define* (run cmd #:optional (args '()) #:key (combine-output #f) (env #f) (stdin #f) (cwd #f)) + (if cwd + (with-cwd cwd (run cmd args #:combine-output combine-output #:env env #:stdin stdin)) + (let* ((input-pipe (pipe)) + (output-pipe (pipe)) + (pid (spawn cmd (cons cmd args) + #:input (car input-pipe) + #:output (cdr output-pipe) + #:error (if combine-output (cdr output-pipe) (current-error-port)) + #:environment (or env (environ))))) + (close-port (cdr output-pipe)) + (close-port (car input-pipe)) + (when stdin (put-string (cdr input-pipe) stdin)) + (close-port (cdr input-pipe)) + (let ((output (get-string-all (car output-pipe)))) + (close-port (car output-pipe)) + (values (cdr (waitpid pid)) output))))) From b29156d5571acb5e4751038850807541546e637e Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Tue, 16 Jul 2024 16:26:09 +0100 Subject: [PATCH 02/83] Temporary directories and the start of play. --- bin/play.scm | 42 +++++++++++++++++ modules/ordo/task.scm | 60 +++++++++++++++++++++++++ {ordo => modules/ordo}/task/command.scm | 10 ++--- modules/ordo/task/file.scm | 4 ++ {ordo => modules/ordo}/util/run.scm | 0 modules/ordo/util/tmpdir.scm | 36 +++++++++++++++ ordo/task.scm | 10 ----- playbooks/tryme.scm | 3 ++ 8 files changed, 150 insertions(+), 15 deletions(-) create mode 100755 bin/play.scm create mode 100644 modules/ordo/task.scm rename {ordo => modules/ordo}/task/command.scm (73%) create mode 100644 modules/ordo/task/file.scm rename {ordo => modules/ordo}/util/run.scm (100%) create mode 100644 modules/ordo/util/tmpdir.scm delete mode 100644 ordo/task.scm create mode 100644 playbooks/tryme.scm diff --git a/bin/play.scm b/bin/play.scm new file mode 100755 index 0000000..8ff84d0 --- /dev/null +++ b/bin/play.scm @@ -0,0 +1,42 @@ +#!/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 tmpdir)) + +(define (collect-files tarball dir . files) + (let* ((mode (if (file-exists? tarball) "--append" "--create")) + (rc (apply system* "tar" mode "--gzip" "--directory" dir "--file" tarball files))) + (unless (zero? rc) + (error (string-append "Error collecting files"))))) + +(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 (car args) target))) + +(define (main args) + (let-values (((playbook-path target) (process-options args))) + (define playbook (load (canonicalize-path playbook-path))) + (define top-dir (dirname (dirname (current-filename)))) + (define tmp-dir (create-temporary-directory)) + (define tarball (string-append tmp-dir "/payload.tar.gz")) + (collect-files tarball top-dir "modules" "bin"))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm new file mode 100644 index 0000000..f41af1e --- /dev/null +++ b/modules/ordo/task.scm @@ -0,0 +1,60 @@ +(define-module (ordo task) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (make-task task? task-name task-prerequisite-data task-want-skip task-action task-seq)) + +;; Task +;; name - a descriptive name for the task +;; prerequisite-data - list of prerequisite data (local data +;; that must be copied to the remote host +;; in order for the task to run) +;; want-skip - function of no args that should return #t if the +;; the task should be skipped +;; action - function of no args that runs the task +(define-record-type + (make-task name prerequisite-data want-skip action) + task? + (want-skip task-want-skip) + (name task-name) + (prerequisite-data task-prerequisite-data) + (action task-action)) + +(define (combine-prerequisite-data tasks) + ;; TODO: work out what the equality operator should be, which + ;; will depend on how we represent prerequisite data + (apply lset-union = (map task-prerequisite-data tasks))) + +;; Combine the want-skips functions from a sequence of tasks. +;; If any task has no want-skip function, the combined task cannot +;; be skipped, so simply return #f. Otherwise, return a function that +;; will only return #t if every task's want-skip function returns true. +;; TODO: With this approach, if the top-level want-skip funciton returns +;; #f (so the task action sequence runs), some of the tests will be repeated. +;; Is it preferable always to have the top-level return #f and simply run +;; the subtasks? +(define (combine-want-skips tasks) + (let ((skips (map task-want-skip tasks))) + (if (every identity skips) + (lambda () (every identity (map (lambda (f) (f)) skips))) + #f))) + +;; Return a function that will apply each of the task actions +;; in order. +;; TODO: would it be better to store the list of actions and +;; implement a task runner that would run either a single task +;; or a sequence of tasks with appropriate logging? +;; TODO: the implementation below does not handle skipping +;; tasks in the sequence, this would be handled by a task runner. +(define (combine-actions tasks) + (let ((actions (map task-action tasks))) + (lambda () + (for-each (lambda (f) (f)) actions)))) + +;; Return a task consists of a sequence of other tasks. +(define (task-seq name task . task*) + (let ((tasks (cons task task*))) + (make-task + name + (combine-prerequisite-data tasks) + (combine-want-skips tasks) + (combine-actions tasks)))) diff --git a/ordo/task/command.scm b/modules/ordo/task/command.scm similarity index 73% rename from ordo/task/command.scm rename to modules/ordo/task/command.scm index 181d3cc..6e9462d 100644 --- a/ordo/task/command.scm +++ b/modules/ordo/task/command.scm @@ -3,13 +3,13 @@ #:use-module (srfi srfi-11) #:use-module (ordo task) #:use-module (ordo util run) - #:export (task-command)) + #:export (command)) - -(define* (task-command name cmd #:optional (args '()) - #:key (fail-ok? #f) (stdin #f) (cwd #f) (env #f)) +(define* (command name cmd #:optional (args '()) + #:key (fail-ok? #f) (stdin #f) (cwd #f) (env #f) (skip? #f)) (make-task name - #f + '() + skip? (lambda () (let-values (((exit-code output) (run cmd args #:stdin stdin #:cwd cwd #:env env #:combine-output #t))) (if (or fail-ok? (zero? exit-code)) diff --git a/modules/ordo/task/file.scm b/modules/ordo/task/file.scm new file mode 100644 index 0000000..c766485 --- /dev/null +++ b/modules/ordo/task/file.scm @@ -0,0 +1,4 @@ +(define-module (ordo task file) + #:use-module (ordo task)) + +(define (file )) diff --git a/ordo/util/run.scm b/modules/ordo/util/run.scm similarity index 100% rename from ordo/util/run.scm rename to modules/ordo/util/run.scm diff --git a/modules/ordo/util/tmpdir.scm b/modules/ordo/util/tmpdir.scm new file mode 100644 index 0000000..6f16aec --- /dev/null +++ b/modules/ordo/util/tmpdir.scm @@ -0,0 +1,36 @@ +(define-module (ordo util tmpdir) + #:use-module (system foreign) + #:use-module (srfi srfi-11) + #:use-module (ice-9 format) + #:export (create-temporary-directory)) + +;; This is based on reading guix/build/syscalls.scm but less general +;; than their implementation. +(define mkdtemp! + (let* ((ptr (dynamic-func "mkdtemp" (dynamic-link))) + (proc (pointer->procedure '* ptr '(*) #:return-errno? #t))) + (lambda (tmpl) + (let-values (((result err) (proc (string->pointer tmpl)))) + (when (null-pointer? result) + (error (format #f "mkdtemp! ~a: ~a" tmpl (strerror err)))) + (pointer->string result))))) + +(define (create-temporary-directory) + (let* ((directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory "/ordo.XXXXXX"))) + (mkdtemp! template))) + +;; This is borrowed from guix/util.scm +;; TODO: we also need to borrow their delete-file-recursively +;; (define (call-with-temporary-directory proc) +;; "Call PROC with a name of a temporary directory; close the directory and +;; delete it when leaving the dynamic extent of this call." +;; (let* ((directory (or (getenv "TMPDIR") "/tmp")) +;; (template (string-append directory "/ordo.XXXXXX")) +;; (tmp-dir (mkdtemp! template))) +;; (dynamic-wind +;; (const #t) +;; (lambda () +;; (proc tmp-dir)) +;; (lambda () +;; (false-if-exception (delete-file-recursively tmp-dir)))))) diff --git a/ordo/task.scm b/ordo/task.scm deleted file mode 100644 index 2d10793..0000000 --- a/ordo/task.scm +++ /dev/null @@ -1,10 +0,0 @@ -(define-module (ordo task) - #:use-module (srfi srfi-9) - #:export (make-task task? task-name task-prerequisite-data set-task-prerequisite-data! task-action set-task-action!)) - -(define-record-type - (make-task name prerequisite-data action) - task? - (name task-name) - (prerequisite-data task-prerequisite-data set-task-prerequisite-data!) - (action task-action set-task-action!)) diff --git a/playbooks/tryme.scm b/playbooks/tryme.scm new file mode 100644 index 0000000..72fd903 --- /dev/null +++ b/playbooks/tryme.scm @@ -0,0 +1,3 @@ +(define x 7) + +(lambda () (* x x)) From 4ebd83491c5a5ddce10ec5111a76e6001fdca875 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 17 Jul 2024 17:12:36 +0100 Subject: [PATCH 03/83] Some refactoring and new functionality. * Rename util/run to util/process. * Rename `run` to `capture` to better reflect functionality. * Implement `with-env`. * Rename util/tmpdir to util/filesystem. * Implement `delete-file-recursively`. * Implement `call-with-temporary-directory`. * Flesh out creation of tarball for transfer to remote system. --- bin/play.scm | 23 ++++---- modules/ordo/task/command.scm | 2 +- modules/ordo/util/filesystem.scm | 63 ++++++++++++++++++++++ modules/ordo/util/{run.scm => process.scm} | 23 +++++++- modules/ordo/util/tmpdir.scm | 36 ------------- 5 files changed, 97 insertions(+), 50 deletions(-) create mode 100644 modules/ordo/util/filesystem.scm rename modules/ordo/util/{run.scm => process.scm} (53%) delete mode 100644 modules/ordo/util/tmpdir.scm diff --git a/bin/play.scm b/bin/play.scm index 8ff84d0..103e6c7 100755 --- a/bin/play.scm +++ b/bin/play.scm @@ -3,13 +3,11 @@ (use-modules (srfi srfi-11) (ice-9 getopt-long) (ice-9 format) - (ordo util tmpdir)) + (ordo util filesystem)) -(define (collect-files tarball dir . files) - (let* ((mode (if (file-exists? tarball) "--append" "--create")) - (rc (apply system* "tar" mode "--gzip" "--directory" dir "--file" tarball files))) - (unless (zero? rc) - (error (string-append "Error collecting files"))))) +(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) @@ -31,12 +29,15 @@ (help-wanted (usage)) ((not (= 1 (length args))) (usage "Expected exactly one playbook"))) - (values (car args) target))) + (values (canonicalize-path (car args)) target))) (define (main args) (let-values (((playbook-path target) (process-options args))) - (define playbook (load (canonicalize-path playbook-path))) + (define playbook (load playbook-path)) (define top-dir (dirname (dirname (current-filename)))) - (define tmp-dir (create-temporary-directory)) - (define tarball (string-append tmp-dir "/payload.tar.gz")) - (collect-files tarball top-dir "modules" "bin"))) + (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/modules/ordo/task/command.scm b/modules/ordo/task/command.scm index 6e9462d..52a68bf 100644 --- a/modules/ordo/task/command.scm +++ b/modules/ordo/task/command.scm @@ -2,7 +2,7 @@ #:use-module (ice-9 format) #:use-module (srfi srfi-11) #:use-module (ordo task) - #:use-module (ordo util run) + #:use-module (ordo util process) #:export (command)) (define* (command name cmd #:optional (args '()) diff --git a/modules/ordo/util/filesystem.scm b/modules/ordo/util/filesystem.scm new file mode 100644 index 0000000..65f6f28 --- /dev/null +++ b/modules/ordo/util/filesystem.scm @@ -0,0 +1,63 @@ +(define-module (ordo util filesystem) + #:use-module (system foreign) + #:use-module (srfi srfi-11) + #:use-module (ice-9 format) + #:use-module (ice-9 ftw) + #:export (delete-file-recursively + create-temporary-directory + call-with-temporary-directory)) + +(define* (delete-file-recursively filename #:key (verbose #f)) + (define dev (stat:dev (stat filename))) + (define (enter? name stat result) + (= (stat:dev stat) dev)) + (define (leaf name stat result) + (if (false-if-exception (delete-file name)) + (and verbose (format #t "delete-file ~a OK~%" name)) + (format (current-error-port) "warning: delete-file ~a failed~%" name)) + result) + (define (down name stat result) + result) + (define (up name stat result) + (if (false-if-exception (rmdir name)) + (and verbose (format #t "rmdir ~a OK~%" name)) + (format (current-error-port) "warning: rmdir ~a failed~%" name)) + result) + (define (skip name state result) + result) + (define (error name stat errno result) + (format (current-error-port) "warning: ~a: ~a~%" + name (strerror errno)) + result) + (file-system-fold enter? leaf down up skip error #f filename)) + + +;; This is based on reading guix/build/syscalls.scm but less general +;; than their implementation. +(define mkdtemp! + (let* ((ptr (dynamic-func "mkdtemp" (dynamic-link))) + (proc (pointer->procedure '* ptr '(*) #:return-errno? #t))) + (lambda (tmpl) + (let-values (((result err) (proc (string->pointer tmpl)))) + (when (null-pointer? result) + (error (format #f "mkdtemp! ~a: ~a" tmpl (strerror err)))) + (pointer->string result))))) + +(define (create-temporary-directory) + (let* ((directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory "/ordo.XXXXXX"))) + (mkdtemp! template))) + +;; This is borrowed from guix/util.scm +(define (call-with-temporary-directory proc) + "Call PROC with a name of a temporary directory; close the directory and +delete it when leaving the dynamic extent of this call." + (let* ((directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory "/ordo.XXXXXX")) + (tmp-dir (mkdtemp! template))) + (dynamic-wind + (const #t) + (lambda () + (proc tmp-dir)) + (lambda () + (false-if-exception (delete-file-recursively tmp-dir)))))) diff --git a/modules/ordo/util/run.scm b/modules/ordo/util/process.scm similarity index 53% rename from modules/ordo/util/run.scm rename to modules/ordo/util/process.scm index c394bc7..f3e87e7 100644 --- a/modules/ordo/util/run.scm +++ b/modules/ordo/util/process.scm @@ -1,4 +1,4 @@ -(define-module (ordo util run) +(define-module (ordo util process) #:use-module (ice-9 textual-ports) #:export (run with-cwd)) @@ -11,7 +11,26 @@ (lambda () body ...) (lambda () (chdir original-dir))))))) -(define* (run cmd #:optional (args '()) #:key (combine-output #f) (env #f) (stdin #f) (cwd #f)) +;; Not needed for CAPTURE, which supports an environment override, +;; but might be useful for SYSTEM and SYSTEM* +(define-syntax with-env + (syntax-rules () + ((_ new-env body ...) + (let ((original-env (environ))) + (dynamic-wind + (lambda () (environ new-env)) + (lambda () body ...) + (lambda () (environ original-env))))))) + +;; Run a command and capture the output. Currently this only supports +;; text input and output. If necessary, we could use the (rnrs io ports) +;; module and use PUT-BYTEVECTOR / GET-BYTEVECTOR-ALL and examine the type +;; of STDIN to determine whether to call PUT-STRING or PUT-BYTEVECTOR. For +;; STDOUT, we'd need to add a #:binary argument so the caller could indicate +;; they are expecting binary output. Not implemented yet incase YAGNI. +(define* (capture cmd + #:optional (args '()) + #:key (combine-output #f) (env #f) (stdin #f) (cwd #f)) (if cwd (with-cwd cwd (run cmd args #:combine-output combine-output #:env env #:stdin stdin)) (let* ((input-pipe (pipe)) diff --git a/modules/ordo/util/tmpdir.scm b/modules/ordo/util/tmpdir.scm deleted file mode 100644 index 6f16aec..0000000 --- a/modules/ordo/util/tmpdir.scm +++ /dev/null @@ -1,36 +0,0 @@ -(define-module (ordo util tmpdir) - #:use-module (system foreign) - #:use-module (srfi srfi-11) - #:use-module (ice-9 format) - #:export (create-temporary-directory)) - -;; This is based on reading guix/build/syscalls.scm but less general -;; than their implementation. -(define mkdtemp! - (let* ((ptr (dynamic-func "mkdtemp" (dynamic-link))) - (proc (pointer->procedure '* ptr '(*) #:return-errno? #t))) - (lambda (tmpl) - (let-values (((result err) (proc (string->pointer tmpl)))) - (when (null-pointer? result) - (error (format #f "mkdtemp! ~a: ~a" tmpl (strerror err)))) - (pointer->string result))))) - -(define (create-temporary-directory) - (let* ((directory (or (getenv "TMPDIR") "/tmp")) - (template (string-append directory "/ordo.XXXXXX"))) - (mkdtemp! template))) - -;; This is borrowed from guix/util.scm -;; TODO: we also need to borrow their delete-file-recursively -;; (define (call-with-temporary-directory proc) -;; "Call PROC with a name of a temporary directory; close the directory and -;; delete it when leaving the dynamic extent of this call." -;; (let* ((directory (or (getenv "TMPDIR") "/tmp")) -;; (template (string-append directory "/ordo.XXXXXX")) -;; (tmp-dir (mkdtemp! template))) -;; (dynamic-wind -;; (const #t) -;; (lambda () -;; (proc tmp-dir)) -;; (lambda () -;; (false-if-exception (delete-file-recursively tmp-dir)))))) From 522f75ffac4b13a24f16e9f797104c234269dbdf Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 17 Jul 2024 17:19:54 +0100 Subject: [PATCH 04/83] Fix exports for util/process. --- modules/ordo/util/process.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/ordo/util/process.scm b/modules/ordo/util/process.scm index f3e87e7..ed63346 100644 --- a/modules/ordo/util/process.scm +++ b/modules/ordo/util/process.scm @@ -1,6 +1,6 @@ (define-module (ordo util process) #:use-module (ice-9 textual-ports) - #:export (run with-cwd)) + #:export (with-cwd with-env capture)) (define-syntax with-cwd (syntax-rules () From 2a8fb2ce5b5b543589244271008643bcb2f00268 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 17 Jul 2024 17:25:29 +0100 Subject: [PATCH 05/83] Simplify call-with-temporary-directory. --- modules/ordo/util/filesystem.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/modules/ordo/util/filesystem.scm b/modules/ordo/util/filesystem.scm index 65f6f28..5f3d14f 100644 --- a/modules/ordo/util/filesystem.scm +++ b/modules/ordo/util/filesystem.scm @@ -52,9 +52,7 @@ (define (call-with-temporary-directory proc) "Call PROC with a name of a temporary directory; close the directory and delete it when leaving the dynamic extent of this call." - (let* ((directory (or (getenv "TMPDIR") "/tmp")) - (template (string-append directory "/ordo.XXXXXX")) - (tmp-dir (mkdtemp! template))) + (let ((tmp-dir (create-temporary-directory))) (dynamic-wind (const #t) (lambda () From 6f217e006e7af05e942ae718dbc67c714ce02d74 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Thu, 15 Aug 2024 16:16:53 +0100 Subject: [PATCH 06/83] Make a start on prerequisite data. --- .gitignore | 2 ++ modules/ordo/prerequisite-data.scm | 17 +++++++++++++++++ modules/ordo/util/filesystem.scm | 2 ++ 3 files changed, 21 insertions(+) create mode 100644 .gitignore create mode 100644 modules/ordo/prerequisite-data.scm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..10c26b5 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +scratch/ +/.dir-locals.el diff --git a/modules/ordo/prerequisite-data.scm b/modules/ordo/prerequisite-data.scm new file mode 100644 index 0000000..6a8d5f4 --- /dev/null +++ b/modules/ordo/prerequisite-data.scm @@ -0,0 +1,17 @@ +(define-module (ordo prerequisite-data) + #:use-module (oop goops)) + +(define-class ()) + +(define-class () + (path #:init-keyword #:path #:getter get-path)) + +(define-method (equal? (x ) (y )) + (equal? (get-path x) (get-path y))) + +(define (local-file path) + (make #:path path)) + +(define-class () + (handler #:init-keyword #:handler #:getter get-handler) + (args #:init-keyword #:args :getter get-args)) diff --git a/modules/ordo/util/filesystem.scm b/modules/ordo/util/filesystem.scm index 5f3d14f..3b70ffb 100644 --- a/modules/ordo/util/filesystem.scm +++ b/modules/ordo/util/filesystem.scm @@ -34,6 +34,8 @@ ;; This is based on reading guix/build/syscalls.scm but less general ;; than their implementation. +;; TODO: why is this needed? The guile standard library has mkdtemp +;; that seems to do the same thing. (define mkdtemp! (let* ((ptr (dynamic-func "mkdtemp" (dynamic-link))) (proc (pointer->procedure '* ptr '(*) #:return-errno? #t))) From cac302e7392377b09cac756f50a5cd1ac6107ced Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 3 Jan 2025 11:32:23 +0000 Subject: [PATCH 07/83] Make a start on connection --- .gitignore | 3 +++ README.md | 27 +++++++++++++++++++++++ manifest.scm | 26 ++++++++++++++++++++++ modules/ordo/connection.scm | 41 +++++++++++++++++++++++++++++++++++ modules/ordo/util/process.scm | 13 +++++++++++ 5 files changed, 110 insertions(+) create mode 100644 README.md create mode 100644 manifest.scm create mode 100644 modules/ordo/connection.scm diff --git a/.gitignore b/.gitignore index 10c26b5..6ee0974 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,5 @@ scratch/ /.dir-locals.el +/gnu +*-tarball-pack.tar.gz +/mybin diff --git a/README.md b/README.md new file mode 100644 index 0000000..ce944c7 --- /dev/null +++ b/README.md @@ -0,0 +1,27 @@ +# Ordo + +Ordo ab chao: from chaos, comes order. + +## Installing Dependencies + +On a Guix system, you can simply run: + +``` bash +guix package -m manifest.scm +``` + +If Guix is not available where you plan to run ordo, but you have access to a +system running Guix, you can create a tarball containing all the dependencies: + +``` bash +guix pack -RR -m manifest.scm +``` + +Copy the tarball to your system and unpack it (somewhere). + +Find the name of the profile in the tarball and use that to configure paths etc. + +``` bash +export GUIX_PROFILE=$(realpath gnu/store/*-profile) +source "${GUIX_PROFILE}/etc/profile" +``` diff --git a/manifest.scm b/manifest.scm new file mode 100644 index 0000000..f8f834c --- /dev/null +++ b/manifest.scm @@ -0,0 +1,26 @@ +(specifications->manifest '("git" + "git-crypt" + "git-lfs" + "gnupg" + "guile" + "guile-config" + "guile-dsv" + "guile-file-names" + "guile-filesystem" + "guile-gcrypt" + "guile-gnutls" + "guile-ini" + "guile-irregex" + "guile-json" + "guile-lib" + "guile-libyaml" + "guile-quickcheck" + "guile-readline" + "guile-semver" + "guile-sqlite3" + "guile-srfi-145" + "guile-srfi-158" + "guile-srfi-197" + "guile-srfi-235" + "guile-ssh" + "password-store")) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm new file mode 100644 index 0000000..7812419 --- /dev/null +++ b/modules/ordo/connection.scm @@ -0,0 +1,41 @@ +(define-module (ordo connection) + #:use-module (oop goops) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ssh session) + #:use-module (ssh auth) + #:use-module (ssh popen) + #:use-module (srfi srfi-197)) + +(define-class () + (sudo? #:init-value #f #:getter sudo? #:init-keyword #:sudo?)) + +(define-class ()) + +(define-class () + (user #:getter get-user #:init-keyword #:user) + (host #:getter get-host #:init-keyword #:host) + (session #:getter get-session #:setter set-session!)) + +(define-method (init! (c )) + c) + +(define-method (init! (c )) + (unless (slot-bound? c 'session) + (let ((session (make-session #:user (get-user c) #:host (get-host c)))) + (connect! session) + (userauth-public-key/auto! s) + (set-session! c session))) + c) + +(define (build-command pwd env prog args sudo?) + (let ((cmd (list (if sudo? "sudo" "env")))) + (chain-when cmd + (pwd (append _ (list "--chdir" pwd))) + (env (append _ (map (lambda (x) (format #f "~a=~a" (car x) (cdr x))) env))) + (#t (append _ (list prog))) + (args (append _ args))))) + +(define-method (run (c ) pwd env prog args)) + +(define-method (run (c ) pwd env prog args)) diff --git a/modules/ordo/util/process.scm b/modules/ordo/util/process.scm index ed63346..810a42f 100644 --- a/modules/ordo/util/process.scm +++ b/modules/ordo/util/process.scm @@ -47,3 +47,16 @@ (let ((output (get-string-all (car output-pipe)))) (close-port (car output-pipe)) (values (cdr (waitpid pid)) output))))) + +;; Possibly nicer way to do this, suggested by dsmith on IRC: https://bpa.st/3JYTA +;; (use-modules (ice-9 popen) +;; (ice-9 rdelim) +;; (ice-9 receive)) + +;; (define (filter text) +;; (receive (from to pids) (pipeline '(("the-command"))) +;; (write text to) +;; (close to) +;; (read-line from))) + +;; See also https://github.com/ray1729/ordo/blob/main/modules/ordo/util/process.scm From d7b49f2b3bf7a0a05639c36747cff4f7cd777757 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 3 Jan 2025 17:46:21 +0000 Subject: [PATCH 08/83] Implement connection methods --- modules/ordo/connection.scm | 170 +++++++++++++++++++++++++++++++++--- 1 file changed, 160 insertions(+), 10 deletions(-) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 7812419..c4b48ae 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -1,32 +1,64 @@ (define-module (ordo connection) #:use-module (oop goops) + #:use-module (ice-9 format) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) + #:use-module (ice-9 string-fun) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 textual-ports) #:use-module (ssh session) + #:use-module (ssh channel) #:use-module (ssh auth) #:use-module (ssh popen) - #:use-module (srfi srfi-197)) + #:use-module (srfi srfi-1) ;; list operations + #:use-module (srfi srfi-71) ;; extended let (multiple values) + #:use-module (srfi srfi-197) ;; chain + #:export (local-connection + ssh-connection + init! + close! + run + command-available? + read-binary-file + read-text-file + write-binary-file + write-text-file + copy-port)) (define-class () (sudo? #:init-value #f #:getter sudo? #:init-keyword #:sudo?)) (define-class ()) +(define* (local-connection #:key (sudo? #f)) + (make #:sudo? sudo?)) + (define-class () (user #:getter get-user #:init-keyword #:user) (host #:getter get-host #:init-keyword #:host) (session #:getter get-session #:setter set-session!)) -(define-method (init! (c )) - c) +(define* (ssh-connection user host #:key (sudo? #f)) + (make #:user user #:host host #:sudo? sudo?)) + +(define-method (init! (c )) #t) + +(define-method (close! (c )) #t) (define-method (init! (c )) (unless (slot-bound? c 'session) - (let ((session (make-session #:user (get-user c) #:host (get-host c)))) - (connect! session) - (userauth-public-key/auto! s) - (set-session! c session))) - c) + (set-session! c (make-session #:user (get-user c) #:host (get-host c)))) + (let ((s (get-session c))) + (unless (connected? s) + (connect! s) + (userauth-public-key/auto! s))) + #t) + +(define-method (close! (c )) + (when (slot-bound? c 'session) + (let ((s (get-session c))) + (when (connected? s) + (disconnect! s))))) (define (build-command pwd env prog args sudo?) (let ((cmd (list (if sudo? "sudo" "env")))) @@ -36,6 +68,124 @@ (#t (append _ (list prog))) (args (append _ args))))) -(define-method (run (c ) pwd env prog args)) +(define (read-lines port) + (define (loop line result) + (if (eof-object? line) (reverse result) (loop (read-line port) (cons line result)))) + (loop (read-line port) '())) -(define-method (run (c ) pwd env prog args)) +(define-method (%run (c ) pwd env prog args) + (let* ((cmd (build-command pwd env prog args (sudo? c))) + (port (apply open-pipe* OPEN_READ cmd)) + (output (read-lines port)) + (exit-status (status:exit-val (close-pipe port)))) + (values output exit-status))) + +(define-method (%run (c ) pwd env prog args) + (let* ((cmd (build-command pwd env prog args (sudo? c))) + (channel (apply open-remote-input-pipe* (get-session c) cmd)) + (output (read-lines channel)) + (exit-status (channel-get-exit-status channel))) + (close channel) + (values output exit-status))) + +(define (find-kw-arg kw kwargs) + (let loop ((kwargs kwargs)) + (cond + ((null? kwargs) #f) + ((equal? (car kwargs) kw) (cadr kwargs)) + (else (loop (cddr kwargs)))))) + +(define (run c prog . rest) + (let ((args (take-while (negate keyword?) rest)) + (kwargs (drop-while (negate keyword?) rest))) + (unless (even? (length kwargs)) + (error "keyword arguments require a value")) + (let ((pwd (find-kw-arg #:pwd kwargs)) + (env (find-kw-arg #:env kwargs))) + (%run c pwd env prog args)))) + +(define (command-available? c command) + (let ((_ rc (run c "which" command))) + (zero? rc))) + +;; These functions for reading and writing files are using cat (with output +;; redirection for writing) rather than opening the files directly so that the +;; command can be invoked under sudo when necessary. + +(define-method (read-file (c ) (path ) (reader )) + (let* ((cmd (build-command #f #f "cat" (list path) (sudo? c))) + (port (apply open-pipe* OPEN_READ cmd)) + (output (reader port)) + (exit-status (status:exit-val (close-pipe port)))) + (unless (zero? exit-status) + (error (format #f "error reading local text file ~a" path))) + output)) + +(define-method (read-file (c ) (path ) (reader )) + (let* ((cmd (build-command #f #f "cat" (list path) (sudo? c))) + (channel (apply open-remote-input-pipe* (get-session c) cmd)) + (output (reader channel)) + (exit-status (channel-get-exit-status channel))) + (close channel) + (unless (zero? exit-status) + (error (format #f "error reading text file ~a@~a:~a" (get-user c) (get-host c) path))) + output)) + +(define (read-text-file c path) + (read-file c path get-string-all)) + +(define (read-binary-file c path) + (read-file c path get-bytevector-all)) + +(define (shell-quote s) + "Quote string S for sh-compatible shells." + (string-append "'" (string-replace-substring s "'" "'\\''") "'")) + +;; These methods for writing files require the file content to be read into memory. They +;; are useful for small files, but prefer COPY-FILE for larger ones. + +(define-method (write-file (c ) (path ) (writer ) content) + (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote path))) (sudo? c))) + (port (apply open-pipe* OPEN_WRITE cmd))) + (writer port content) + (unless (zero? (status:exit-val (close-pipe port))) + (error (format #f "error writing local text file ~a" path))))) + +(define-method (write-file (c ) (path ) (writer ) content) + (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote path))) (sudo? c))) + (channel (apply open-remote-output-pipe* (get-session c) cmd))) + (writer channel content) + (channel-send-eof channel) + (let ((exit-status (channel-get-exit-status channel))) + (close channel) + (unless (zero? exit-status) + (error (format #f "error writing text file ~a@~a:~a" (get-user c) (get-host c) path)))))) + +(define (write-text-file c path content) + (write-file c path put-string content)) + +(define (write-binary-file c path content) + (write-file c path put-bytevector content)) + +(define-method (copy-port (c ) (src ) (dest-path )) + (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote dest-path))) (sudo? c))) + (dport (apply open-pipe* OPEN_WRITE cmd))) + (let loop ((data (get-bytevector-some src))) + (unless (eof-object? data) + (put-bytevector dport data) + (loop (get-bytevector-some src)))) + (unless (zero? (status:exit-val (close-pipe dport))) + (error (format #f "error copying file to ~a" dest-path))))) + +(define-method (copy-port (c ) (src ) (dest-path )) + (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote dest-path))) (sudo? c))) + (channel (apply open-remote-output-pipe* (get-session c) cmd))) + (let loop ((data (get-bytevector-some src))) + (unless (eof-object? data) + (put-bytevector channel data) + (loop (get-bytevector-some src)))) + (channel-send-eof channel) + (let ((exit-status (channel-get-exit-status channel))) + (close channel) + (unless (zero? exit-status) + (error (format #f "error copying file to ~a@~a:~a" (get-user c) (get-host c) dest-path)))))) From 61524f3e795a508a3943faef4814efd7a2b2e1f5 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 4 Jan 2025 12:03:43 +0000 Subject: [PATCH 09/83] Implement utility for shell quoting. This is a port of Perl's String::ShellQuote, see https://metacpan.org/release/ROSCH/String-ShellQuote-1.04/source --- modules/ordo/util/shell-quote.scm | 53 +++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 modules/ordo/util/shell-quote.scm diff --git a/modules/ordo/util/shell-quote.scm b/modules/ordo/util/shell-quote.scm new file mode 100644 index 0000000..6333264 --- /dev/null +++ b/modules/ordo/util/shell-quote.scm @@ -0,0 +1,53 @@ +;; This file is part of Ordo. +;; +;; Shell quoting implementation is based on Perl's String::ShellQuote +;; Copyright (c) 1997 Roderick Schertler. +;; +;; Guile implementation Copyright (c) 2025 Ray Miller. +;; +;; Ordo 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, either version 3 of the License, or (at your option) +;; any later version. +;; +;; Ordo 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 +;; Ordo. If not, see . + +(define-module (ordo util shell-quote) + #:use-module (rx irregex) + #:use-module ((srfi srfi-197) #:select (chain)) + #:export (shell-quote-string)) + +(define unsafe-characters (irregex '(~ (or alphanumeric ("!%+,\\-./:=@^"))))) + +(define (needs-escape? s) + (irregex-search unsafe-characters s)) + +(define (escape s) + (define (squash-quotes m) + (let ((n (/ (- (irregex-match-end-index m) + (irregex-match-start-index m)) + 4))) + (list->string (append + '(#\' #\") + (make-list n #\') + '(#\" #\'))))) + (chain s + ;; ' -> '\'' + (irregex-replace/all (irregex "'") _ "'\\''") + ;; make multiple ' in a row look simpler + ;; '\'''\'''\'' -> '"'''"' + (irregex-replace/all (irregex '(>= 2 "'\\''")) _ squash-quotes) + ;; wrap in single quotes + (string-append "'" _ "'") + ;; kill leading/trailing pair of single quotes + (irregex-replace (irregex '(seq bos "''")) _ "") + (irregex-replace (irregex '(seq "''" eos)) _ ""))) + +(define (shell-quote-string s) + "Quote strings for passing through the shell" + (if (needs-escape? s) (escape s) s)) From 428c6ed4a5cb48f24fa5dd1ee4376722491f8f82 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 4 Jan 2025 12:13:40 +0000 Subject: [PATCH 10/83] Shell quote zero-length strings. --- modules/ordo/util/shell-quote.scm | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/modules/ordo/util/shell-quote.scm b/modules/ordo/util/shell-quote.scm index 6333264..84268e7 100644 --- a/modules/ordo/util/shell-quote.scm +++ b/modules/ordo/util/shell-quote.scm @@ -27,15 +27,16 @@ (define (needs-escape? s) (irregex-search unsafe-characters s)) +(define (squash-quotes m) + (let ((n (/ (- (irregex-match-end-index m) + (irregex-match-start-index m)) + 4))) + (list->string (append + '(#\' #\") + (make-list n #\') + '(#\" #\'))))) + (define (escape s) - (define (squash-quotes m) - (let ((n (/ (- (irregex-match-end-index m) - (irregex-match-start-index m)) - 4))) - (list->string (append - '(#\' #\") - (make-list n #\') - '(#\" #\'))))) (chain s ;; ' -> '\'' (irregex-replace/all (irregex "'") _ "'\\''") @@ -50,4 +51,7 @@ (define (shell-quote-string s) "Quote strings for passing through the shell" - (if (needs-escape? s) (escape s) s)) + (cond + ((zero? (string-length s)) "''") + ((needs-escape? s) (escape s)) + (else s))) From d5593f4e3d2b96132fa1314840a5c3d10baa1de2 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 5 Jan 2025 12:13:10 +0000 Subject: [PATCH 11/83] Rework connection handling * Capture stderr from run * Simplify remote file handling --- modules/ordo/connection.scm | 211 ++++++++++-------------------- modules/ordo/util/shell-quote.scm | 4 +- 2 files changed, 73 insertions(+), 142 deletions(-) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index c4b48ae..11c8295 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -1,191 +1,122 @@ (define-module (ordo connection) #:use-module (oop goops) - #:use-module (ice-9 format) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) - #:use-module (ice-9 string-fun) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-1) ; list operations + #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module (ssh session) #:use-module (ssh channel) #:use-module (ssh auth) #:use-module (ssh popen) - #:use-module (srfi srfi-1) ;; list operations - #:use-module (srfi srfi-71) ;; extended let (multiple values) - #:use-module (srfi srfi-197) ;; chain + #:use-module (ssh sftp) + #:use-module (ordo util shell-quote) #:export (local-connection ssh-connection - init! - close! - run - command-available? - read-binary-file - read-text-file - write-binary-file - write-text-file - copy-port)) + init-connection! + close-connection! + connection-run + connection-call-with-input-file + connection-call-with-output-file + call-with-connection)) -(define-class () - (sudo? #:init-value #f #:getter sudo? #:init-keyword #:sudo?)) +(define-class ()) (define-class ()) -(define* (local-connection #:key (sudo? #f)) - (make #:sudo? sudo?)) +(define (local-connection) + (make )) (define-class () (user #:getter get-user #:init-keyword #:user) (host #:getter get-host #:init-keyword #:host) - (session #:getter get-session #:setter set-session!)) + (session #:getter get-session #:setter set-session!) + (sftp-session #:getter get-sftp-session #:setter set-sftp-session!)) -(define* (ssh-connection user host #:key (sudo? #f)) - (make #:user user #:host host #:sudo? sudo?)) +(define (ssh-connection user host) + (make #:user user #:host host)) -(define-method (init! (c )) #t) +(define-method (init-connection! (c )) #f) -(define-method (close! (c )) #t) +(define-method (close-connection! (c )) #f) -(define-method (init! (c )) +(define-method (init-connection! (c )) (unless (slot-bound? c 'session) (set-session! c (make-session #:user (get-user c) #:host (get-host c)))) (let ((s (get-session c))) (unless (connected? s) (connect! s) - (userauth-public-key/auto! s))) + (let ((server-auth (authenticate-server s))) + (unless (equal? 'ok server-auth) + (error (format #f "authenticate-server: ~a" server-auth)))) + (let ((user-auth (userauth-public-key/auto! s))) + (unless (equal? 'success user-auth) + (error (format #f "userauth-public-key: ~a" user-auth)))))) #t) -(define-method (close! (c )) +(define-method (sftp-session (c )) + (unless (slot-bound? c 'sftp-session) + (set-sftp-session! c (make-sftp-session (get-session c)))) + (get-sftp-session c)) + +(define-method (close-connection! (c )) (when (slot-bound? c 'session) (let ((s (get-session c))) (when (connected? s) (disconnect! s))))) -(define (build-command pwd env prog args sudo?) +(define (read-lines port) + (define (loop line result) + (if (eof-object? line) + (reverse result) + (loop (read-line port) (cons line result)))) + (loop (read-line port) '())) + +(define (kw-arg kw kwargs) + (cond + ((null? (kwargs)) #f) + ((equal? (car kwargs) kw) (cadr kwargs)) + (else (kw-arg kw (cddr kwargs))))) + +(define (build-command pwd env sudo? prog args) (let ((cmd (list (if sudo? "sudo" "env")))) (chain-when cmd (pwd (append _ (list "--chdir" pwd))) - (env (append _ (map (lambda (x) (format #f "~a=~a" (car x) (cdr x))) env))) - (#t (append _ (list prog))) - (args (append _ args))))) + (env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env))) + (#t (append _ + (list prog) + (map string-shell-quote args) + (list "2>&1"))) + (#t (string-join _ " "))))) -(define (read-lines port) - (define (loop line result) - (if (eof-object? line) (reverse result) (loop (read-line port) (cons line result)))) - (loop (read-line port) '())) - -(define-method (%run (c ) pwd env prog args) - (let* ((cmd (build-command pwd env prog args (sudo? c))) - (port (apply open-pipe* OPEN_READ cmd)) +(define-method (connection-run (c ) pwd env sudo? prog args) + (let* ((cmd (build-command pwd env sudo? prog args)) + (port (open-input-pipe cmd)) (output (read-lines port)) (exit-status (status:exit-val (close-pipe port)))) (values output exit-status))) -(define-method (%run (c ) pwd env prog args) - (let* ((cmd (build-command pwd env prog args (sudo? c))) - (channel (apply open-remote-input-pipe* (get-session c) cmd)) +(define-method (connection-run (c ) pwd env sudo? prog args) + (let* ((cmd (build-command pwd env sudo? prog args)) + (channel (open-remote-input-pipe (get-session c) cmd)) (output (read-lines channel)) (exit-status (channel-get-exit-status channel))) (close channel) (values output exit-status))) -(define (find-kw-arg kw kwargs) - (let loop ((kwargs kwargs)) - (cond - ((null? kwargs) #f) - ((equal? (car kwargs) kw) (cadr kwargs)) - (else (loop (cddr kwargs)))))) +(define-method (connection-call-with-input-file (c ) (filename ) (proc )) + (call-with-input-file filename proc)) -(define (run c prog . rest) - (let ((args (take-while (negate keyword?) rest)) - (kwargs (drop-while (negate keyword?) rest))) - (unless (even? (length kwargs)) - (error "keyword arguments require a value")) - (let ((pwd (find-kw-arg #:pwd kwargs)) - (env (find-kw-arg #:env kwargs))) - (%run c pwd env prog args)))) +(define-method (connection-call-with-input-file (c ) (filename ) (proc )) + (call-with-remote-input-file (sftp-session c) filename proc)) -(define (command-available? c command) - (let ((_ rc (run c "which" command))) - (zero? rc))) +(define-method (connection-call-with-output-file (c ) (filename ) (proc )) + (call-with-output-file filename proc)) -;; These functions for reading and writing files are using cat (with output -;; redirection for writing) rather than opening the files directly so that the -;; command can be invoked under sudo when necessary. +(define-method (connection-call-with-output-file (c ) (filename ) (proc )) + (call-with-remote-output-file (sftp-session c) filename proc)) -(define-method (read-file (c ) (path ) (reader )) - (let* ((cmd (build-command #f #f "cat" (list path) (sudo? c))) - (port (apply open-pipe* OPEN_READ cmd)) - (output (reader port)) - (exit-status (status:exit-val (close-pipe port)))) - (unless (zero? exit-status) - (error (format #f "error reading local text file ~a" path))) - output)) - -(define-method (read-file (c ) (path ) (reader )) - (let* ((cmd (build-command #f #f "cat" (list path) (sudo? c))) - (channel (apply open-remote-input-pipe* (get-session c) cmd)) - (output (reader channel)) - (exit-status (channel-get-exit-status channel))) - (close channel) - (unless (zero? exit-status) - (error (format #f "error reading text file ~a@~a:~a" (get-user c) (get-host c) path))) - output)) - -(define (read-text-file c path) - (read-file c path get-string-all)) - -(define (read-binary-file c path) - (read-file c path get-bytevector-all)) - -(define (shell-quote s) - "Quote string S for sh-compatible shells." - (string-append "'" (string-replace-substring s "'" "'\\''") "'")) - -;; These methods for writing files require the file content to be read into memory. They -;; are useful for small files, but prefer COPY-FILE for larger ones. - -(define-method (write-file (c ) (path ) (writer ) content) - (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote path))) (sudo? c))) - (port (apply open-pipe* OPEN_WRITE cmd))) - (writer port content) - (unless (zero? (status:exit-val (close-pipe port))) - (error (format #f "error writing local text file ~a" path))))) - -(define-method (write-file (c ) (path ) (writer ) content) - (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote path))) (sudo? c))) - (channel (apply open-remote-output-pipe* (get-session c) cmd))) - (writer channel content) - (channel-send-eof channel) - (let ((exit-status (channel-get-exit-status channel))) - (close channel) - (unless (zero? exit-status) - (error (format #f "error writing text file ~a@~a:~a" (get-user c) (get-host c) path)))))) - -(define (write-text-file c path content) - (write-file c path put-string content)) - -(define (write-binary-file c path content) - (write-file c path put-bytevector content)) - -(define-method (copy-port (c ) (src ) (dest-path )) - (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote dest-path))) (sudo? c))) - (dport (apply open-pipe* OPEN_WRITE cmd))) - (let loop ((data (get-bytevector-some src))) - (unless (eof-object? data) - (put-bytevector dport data) - (loop (get-bytevector-some src)))) - (unless (zero? (status:exit-val (close-pipe dport))) - (error (format #f "error copying file to ~a" dest-path))))) - -(define-method (copy-port (c ) (src ) (dest-path )) - (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote dest-path))) (sudo? c))) - (channel (apply open-remote-output-pipe* (get-session c) cmd))) - (let loop ((data (get-bytevector-some src))) - (unless (eof-object? data) - (put-bytevector channel data) - (loop (get-bytevector-some src)))) - (channel-send-eof channel) - (let ((exit-status (channel-get-exit-status channel))) - (close channel) - (unless (zero? exit-status) - (error (format #f "error copying file to ~a@~a:~a" (get-user c) (get-host c) dest-path)))))) +(define (call-with-connection c proc) + (dynamic-wind + (lambda () (init-connection! c)) + (lambda () (proc c)) + (lambda () (close-connection! c)))) diff --git a/modules/ordo/util/shell-quote.scm b/modules/ordo/util/shell-quote.scm index 84268e7..5de60fa 100644 --- a/modules/ordo/util/shell-quote.scm +++ b/modules/ordo/util/shell-quote.scm @@ -20,7 +20,7 @@ (define-module (ordo util shell-quote) #:use-module (rx irregex) #:use-module ((srfi srfi-197) #:select (chain)) - #:export (shell-quote-string)) + #:export (string-shell-quote)) (define unsafe-characters (irregex '(~ (or alphanumeric ("!%+,\\-./:=@^"))))) @@ -49,7 +49,7 @@ (irregex-replace (irregex '(seq bos "''")) _ "") (irregex-replace (irregex '(seq "''" eos)) _ ""))) -(define (shell-quote-string s) +(define (string-shell-quote s) "Quote strings for passing through the shell" (cond ((zero? (string-length s)) "''") From c290a5caeae3f0349301c0efdd23b7063fd4bed8 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 5 Jan 2025 17:43:09 +0000 Subject: [PATCH 12/83] Implement tasks and plays --- modules/ordo/action/filesystem.scm | 64 +++++++++++++++++++++++++ modules/ordo/connection.scm | 36 +++++++++----- modules/ordo/context.scm | 40 ++++++++++++++++ modules/ordo/play.scm | 18 +++++++ modules/ordo/task.scm | 77 +++++++++--------------------- tryme.scm | 21 ++++++++ 6 files changed, 191 insertions(+), 65 deletions(-) create mode 100644 modules/ordo/action/filesystem.scm create mode 100644 modules/ordo/context.scm create mode 100644 modules/ordo/play.scm create mode 100644 tryme.scm diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm new file mode 100644 index 0000000..c4c01b6 --- /dev/null +++ b/modules/ordo/action/filesystem.scm @@ -0,0 +1,64 @@ +(define-module (ordo action filesystem) + #:use-module (ice-9 binary-ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-26) ; cut + #:use-module (srfi srfi-71) ; extended let + #:use-module ((srfi srfi-197) #:select (chain-when)) + #:use-module (ordo connection) + #:use-module (ordo context) + #:export (create-temporary-directory + install-directory + install-file)) + +(define* (create-temporary-directory #:key tmpdir suffix template) + (lambda (conn ctx) + (connection-must conn "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template))) + (#t (resolve-context-refs ctx _)))))) + +(define* (install-directory path #:key owner group mode) + (lambda (conn ctx) + (connection-must conn "install" (chain-when + '("--directory") + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (#t (append _ `(,path))) + (#t (resolve-context-refs ctx _)))))) + +;; Helper not intended for use outside of this module +(define (upload-tmp-file conn ctx) + (lambda (input-port) + (let ((tmp-path (car (connection-must conn "mktemp" `("-p" ,(get-context-scratch-dir ctx)))))) + (connection-call-with-output-file conn tmp-path + (lambda (output-port) + (let loop ((data (get-bytevector-some input-port))) + (unless (eof-object? data) + (put-bytevector output-port data) + (loop (get-bytevector-some input-port)))) + (close-port output-port))) + tmp-path))) + +;; Because we might need sudo to install the remote file, we first +;; upload the source to a temporary file. +(define* (install-file path #:key owner group mode content local-src remote-src backup?) + (when (not (= 1 (length (filter identity (list content local-src remote-src))))) + (error "exactly one of #:content, #:local-src, or #:remote-src is required")) + (lambda (conn ctx) + (let ((remote-src (cond + (remote-src remote-src) + (local-src (call-with-input-file local-src (upload-tmp-file conn ctx))) + ((string? content) (call-with-input-string content (upload-tmp-file conn ctx))) + ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn ctx))) + (else (error "unsupported type for #:content"))))) + (connection-must conn "install" (chain-when + '() + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append _ (list remote-src path))) + (#t (resolve-context-refs ctx _))))))) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 11c8295..71884ee 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -3,6 +3,7 @@ #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) ; list operations + #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module (ssh session) #:use-module (ssh channel) @@ -15,16 +16,18 @@ init-connection! close-connection! connection-run + connection-must connection-call-with-input-file connection-call-with-output-file call-with-connection)) -(define-class ()) +(define-class () + (sudo #:getter sudo? #:init-keyword #:sudo)) (define-class ()) -(define (local-connection) - (make )) +(define* (local-connection #:key (sudo? #f)) + (make #:sudo sudo?)) (define-class () (user #:getter get-user #:init-keyword #:user) @@ -32,8 +35,8 @@ (session #:getter get-session #:setter set-session!) (sftp-session #:getter get-sftp-session #:setter set-sftp-session!)) -(define (ssh-connection user host) - (make #:user user #:host host)) +(define* (ssh-connection user host #:key (sudo? #f)) + (make #:user user #:host host #:sudo sudo?)) (define-method (init-connection! (c )) #f) @@ -77,8 +80,8 @@ ((equal? (car kwargs) kw) (cadr kwargs)) (else (kw-arg kw (cddr kwargs))))) -(define (build-command pwd env sudo? prog args) - (let ((cmd (list (if sudo? "sudo" "env")))) +(define-method (build-command (c ) pwd env prog args) + (let ((cmd (list (if (sudo? c) "sudo" "env")))) (chain-when cmd (pwd (append _ (list "--chdir" pwd))) (env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env))) @@ -88,21 +91,32 @@ (list "2>&1"))) (#t (string-join _ " "))))) -(define-method (connection-run (c ) pwd env sudo? prog args) - (let* ((cmd (build-command pwd env sudo? prog args)) +(define-method (run% (c ) pwd env prog args) + (let* ((cmd (build-command c pwd env prog args)) (port (open-input-pipe cmd)) (output (read-lines port)) (exit-status (status:exit-val (close-pipe port)))) (values output exit-status))) -(define-method (connection-run (c ) pwd env sudo? prog args) - (let* ((cmd (build-command pwd env sudo? prog args)) +(define-method (run% (c ) pwd env prog args) + (let* ((cmd (build-command c pwd env prog args)) (channel (open-remote-input-pipe (get-session c) cmd)) (output (read-lines channel)) (exit-status (channel-get-exit-status channel))) (close channel) (values output exit-status))) +(define* (connection-run c prog args #:key (env #f) (pwd #f)) + (run% c pwd env prog args)) + +(define* (connection-must c prog args #:key (env #f) (pwd #f) (error-msg #f)) + (let ((out rc (connection-run c prog args #:env env #:pwd pwd))) + (if (zero? rc) + out + (error (if error-msg + (format #f "~a: ~a" error-msg out) + (format #f "~a error: ~a" prog out)))))) + (define-method (connection-call-with-input-file (c ) (filename ) (proc )) (call-with-input-file filename proc)) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm new file mode 100644 index 0000000..b9ff1b6 --- /dev/null +++ b/modules/ordo/context.scm @@ -0,0 +1,40 @@ +(define-module (ordo context) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:export (make-context + context? + get-context-scratch-dir + set-context-scratch-dir! + add-context-triggers! + register-context-var! + context-ref + resolve-context-ref + resolve-context-refs)) + +(define-record-type + (make-context) + context? + (scratch-dir get-context-scratch-dir set-context-scratch-dir!) + (vars get-context-vars set-context-vars!) + (triggers get-context-triggers set-context-triggers!)) + +(define-record-type + (context-ref name) + context-ref? + (name var-name)) + +(define (resolve-context-ref ctx v) + (if (context-ref? v) + (assoc-ref (get-context-vars ctx) (var-name v)) + v)) + +(define (resolve-context-refs ctx args) + (map (cut resolve-context-ref ctx <>) args)) + +(define (add-context-triggers! ctx triggers) + (when triggers + (set-context-triggers! ctx (fold cons (or (get-context-triggers ctx) '()) triggers)))) + +(define (register-context-var! ctx var-name val) + (set-context-vars! ctx (assoc-set! (get-context-vars ctx) var-name val))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm new file mode 100644 index 0000000..c805926 --- /dev/null +++ b/modules/ordo/play.scm @@ -0,0 +1,18 @@ +(define-module (ordo play) + #:use-module (srfi srfi-26) ; cut + #:use-module (ordo connection) + #:use-module (ordo context) + #:use-module (ordo task) + #:export (play)) + +(define (play conn tasks) + (call-with-connection + conn + (lambda (c) + (let ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) + (ctx (make-context))) + (set-context-scratch-dir! ctx tmp-dir) + (dynamic-wind + (const #t) + (lambda () (for-each (cut run-task c ctx <>) tasks)) + (lambda () (connection-must c "rm" `("-rf" ,tmp-dir)))))))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index f41af1e..b93ff8f 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -1,60 +1,29 @@ (define-module (ordo task) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:export (make-task task? task-name task-prerequisite-data task-want-skip task-action task-seq)) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) ; list utils + #:use-module (srfi srfi-9) ; records + #:use-module (srfi srfi-26) ; cut + #:use-module (ordo context) + #:export (task run-task)) -;; Task -;; name - a descriptive name for the task -;; prerequisite-data - list of prerequisite data (local data -;; that must be copied to the remote host -;; in order for the task to run) -;; want-skip - function of no args that should return #t if the -;; the task should be skipped -;; action - function of no args that runs the task (define-record-type - (make-task name prerequisite-data want-skip action) + (make-task description action register triggers) task? - (want-skip task-want-skip) - (name task-name) - (prerequisite-data task-prerequisite-data) - (action task-action)) + (description get-description set-description!) + (action get-action set-action!) + (register get-register set-regiseter!) + (triggers get-triggers set-triggers!)) -(define (combine-prerequisite-data tasks) - ;; TODO: work out what the equality operator should be, which - ;; will depend on how we represent prerequisite data - (apply lset-union = (map task-prerequisite-data tasks))) +(define* (task description action #:key register triggers) + (make-task description action register triggers)) -;; Combine the want-skips functions from a sequence of tasks. -;; If any task has no want-skip function, the combined task cannot -;; be skipped, so simply return #f. Otherwise, return a function that -;; will only return #t if every task's want-skip function returns true. -;; TODO: With this approach, if the top-level want-skip funciton returns -;; #f (so the task action sequence runs), some of the tests will be repeated. -;; Is it preferable always to have the top-level return #f and simply run -;; the subtasks? -(define (combine-want-skips tasks) - (let ((skips (map task-want-skip tasks))) - (if (every identity skips) - (lambda () (every identity (map (lambda (f) (f)) skips))) - #f))) - -;; Return a function that will apply each of the task actions -;; in order. -;; TODO: would it be better to store the list of actions and -;; implement a task runner that would run either a single task -;; or a sequence of tasks with appropriate logging? -;; TODO: the implementation below does not handle skipping -;; tasks in the sequence, this would be handled by a task runner. -(define (combine-actions tasks) - (let ((actions (map task-action tasks))) - (lambda () - (for-each (lambda (f) (f)) actions)))) - -;; Return a task consists of a sequence of other tasks. -(define (task-seq name task . task*) - (let ((tasks (cons task task*))) - (make-task - name - (combine-prerequisite-data tasks) - (combine-want-skips tasks) - (combine-actions tasks)))) +(define (run-task conn ctx task) + (match task + (($ description action register triggers) + (format #t "START ~a~%" description) + (let ((result (action conn ctx))) + (when register + (register-context-var! ctx register result)) + (when triggers + (add-context-triggers! ctx triggers)) + (format #t "END~%"))))) diff --git a/tryme.scm b/tryme.scm new file mode 100644 index 0000000..a321bc4 --- /dev/null +++ b/tryme.scm @@ -0,0 +1,21 @@ +(use-modules + (ordo connection) + (ordo action filesystem) + (ordo play) + (ordo task)) + +(define (tryme) + (play (local-connection) + (list + (task "Create test directory" + (install-directory "/home/ray/ordo-test")) + (task "Create test file from string content" + (install-file "/home/ray/ordo-test/foo" #:content "Hello, world!\n")) + (task "Create test file from local source" + (install-file "/home/ray/ordo-test/bar" #:local-src "/home/ray/ordo-test/foo")) + (task "Create test file from remote source" + (install-file "/home/ray/ordo-test/baz" #:remote-src "/home/ray/ordo-test/bar")) + (task "Expect this to fail" + (install-file "/root/ordo.txt" #:content "Hello from Ordo!"))))) + +(tryme) From 297d779ea4bf73f99c0d3a5185fa1c735da12d15 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 5 Jan 2025 18:24:33 +0000 Subject: [PATCH 13/83] Implement trigger handlers --- modules/ordo/context.scm | 4 ++++ modules/ordo/play.scm | 41 ++++++++++++++++++++++++++++++++++++---- modules/ordo/task.scm | 20 ++++++++++++++------ tryme.scm | 29 ++++++++++++++-------------- 4 files changed, 70 insertions(+), 24 deletions(-) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm index b9ff1b6..c106e3e 100644 --- a/modules/ordo/context.scm +++ b/modules/ordo/context.scm @@ -7,6 +7,10 @@ get-context-scratch-dir set-context-scratch-dir! add-context-triggers! + get-context-triggers + set-context-triggers! + get-context-vars + set-context-vars! register-context-var! context-ref resolve-context-ref diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index c805926..99f14f1 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -1,18 +1,51 @@ (define-module (ordo play) + #:use-module (srfi srfi-1) ; list utils + #:use-module (srfi srfi-9) ; records #:use-module (srfi srfi-26) ; cut #:use-module (ordo connection) #:use-module (ordo context) #:use-module (ordo task) - #:export (play)) + #:export (play run-play)) -(define (play conn tasks) +(define-record-type + (make-play description connection tasks handlers) + play? + (connection get-play-connection) + (description get-play-description) + (tasks get-play-tasks) + (handlers get-play-handlers)) + +(define* (play description #:key connection tasks (handlers '())) + (unless connection (error "connection is required")) + (unless tasks (error "tasks are required")) + (for-each (lambda (task) + (for-each (lambda (trigger) + (unless (assoc-ref handlers trigger) + (error (format #f "task \"~a\" references an undefined trigger: ~a" + (get-task-description task) + trigger)))) + (get-task-triggers task))) + tasks) + (make-play description connection tasks handlers)) + +(define (run-trigger conn ctx handlers trigger) + (let ((handler (assoc-ref handlers trigger))) + (unless handler + (error (format #f "no handler defined for trigger ~a" trigger))) + (run-task conn ctx handler))) + +(define (run-play play) + (format #t "Running play ~a~%" (get-play-description play)) (call-with-connection - conn + (get-play-connection play) (lambda (c) (let ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) (ctx (make-context))) (set-context-scratch-dir! ctx tmp-dir) (dynamic-wind (const #t) - (lambda () (for-each (cut run-task c ctx <>) tasks)) + (lambda () + (for-each (cut run-task c ctx <>) (get-play-tasks play)) + (for-each (cut run-trigger c ctx (get-play-handlers play) <>) + (delete-duplicates (get-context-triggers ctx)))) (lambda () (connection-must c "rm" `("-rf" ,tmp-dir)))))))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index b93ff8f..b20073e 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -4,17 +4,25 @@ #:use-module (srfi srfi-9) ; records #:use-module (srfi srfi-26) ; cut #:use-module (ordo context) - #:export (task run-task)) + #:export (task + task? + get-task-description + set-task-description! + get-task-register + set-task-register! + get-task-triggers + set-task-triggers! + run-task)) (define-record-type (make-task description action register triggers) task? - (description get-description set-description!) - (action get-action set-action!) - (register get-register set-regiseter!) - (triggers get-triggers set-triggers!)) + (description get-task-description set-task-description!) + (action get-task-action set-task-action!) + (register get-task-register set-task-regiseter!) + (triggers get-task-triggers set-task-triggers!)) -(define* (task description action #:key register triggers) +(define* (task description action #:key (register #f) (triggers '())) (make-task description action register triggers)) (define (run-task conn ctx task) diff --git a/tryme.scm b/tryme.scm index a321bc4..1199a63 100644 --- a/tryme.scm +++ b/tryme.scm @@ -4,18 +4,19 @@ (ordo play) (ordo task)) -(define (tryme) - (play (local-connection) - (list - (task "Create test directory" - (install-directory "/home/ray/ordo-test")) - (task "Create test file from string content" - (install-file "/home/ray/ordo-test/foo" #:content "Hello, world!\n")) - (task "Create test file from local source" - (install-file "/home/ray/ordo-test/bar" #:local-src "/home/ray/ordo-test/foo")) - (task "Create test file from remote source" - (install-file "/home/ray/ordo-test/baz" #:remote-src "/home/ray/ordo-test/bar")) - (task "Expect this to fail" - (install-file "/root/ordo.txt" #:content "Hello from Ordo!"))))) +(define test-play + (play "Test play" + #:connection (local-connection) + #:tasks (list + (task "Create test directory" + (install-directory "/home/ray/ordo-test")) + (task "Create test file from string content" + (install-file "/home/ray/ordo-test/foo" #:content "Hello, world!\n")) + (task "Create test file from local source" + (install-file "/home/ray/ordo-test/bar" #:local-src "/home/ray/ordo-test/foo")) + (task "Create test file from remote source" + (install-file "/home/ray/ordo-test/baz" #:remote-src "/home/ray/ordo-test/bar") + #:triggers `(frobnicate))) + #:handlers `((frobnicate . ,(task "Frobnicate" (const #t)))))) -(tryme) +;;(run-play test-play) From 52f011267be56846a64b8203e9a06d3966031018 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 5 Jan 2025 19:10:42 +0000 Subject: [PATCH 14/83] Some refactoring * Don't export record field setters (unless required) * Remove get- prefix from record getters * Introduce handlers (simplified tasks) --- modules/ordo/action/filesystem.scm | 2 +- modules/ordo/context.scm | 30 ++++++++++--------- modules/ordo/handler.scm | 26 +++++++++++++++++ modules/ordo/play.scm | 47 +++++++++++++++++------------- modules/ordo/task.scm | 23 +++++++-------- tryme.scm | 12 +++++--- 6 files changed, 89 insertions(+), 51 deletions(-) create mode 100644 modules/ordo/handler.scm diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index c4c01b6..b27c2b8 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -32,7 +32,7 @@ ;; Helper not intended for use outside of this module (define (upload-tmp-file conn ctx) (lambda (input-port) - (let ((tmp-path (car (connection-must conn "mktemp" `("-p" ,(get-context-scratch-dir ctx)))))) + (let ((tmp-path (car (connection-must conn "mktemp" `("-p" ,(context-scratch-dir ctx)))))) (connection-call-with-output-file conn tmp-path (lambda (output-port) (let loop ((data (get-bytevector-some input-port))) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm index c106e3e..4c5f155 100644 --- a/modules/ordo/context.scm +++ b/modules/ordo/context.scm @@ -2,26 +2,26 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) - #:export (make-context + #:export (context context? - get-context-scratch-dir - set-context-scratch-dir! + context-scratch-dir add-context-triggers! get-context-triggers - set-context-triggers! - get-context-vars - set-context-vars! + context-triggered? register-context-var! context-ref resolve-context-ref resolve-context-refs)) (define-record-type - (make-context) + (make-context scratch-dir vars) context? - (scratch-dir get-context-scratch-dir set-context-scratch-dir!) - (vars get-context-vars set-context-vars!) - (triggers get-context-triggers set-context-triggers!)) + (scratch-dir context-scratch-dir set-context-scratch-dir!) + (vars context-vars set-context-vars!) + (triggers context-triggers set-context-triggers!)) + +(define* (context #:key scratch-dir init-vars) + (make-context scratch-dir init-vars)) (define-record-type (context-ref name) @@ -30,7 +30,7 @@ (define (resolve-context-ref ctx v) (if (context-ref? v) - (assoc-ref (get-context-vars ctx) (var-name v)) + (assoc-ref (context-vars ctx) (var-name v)) v)) (define (resolve-context-refs ctx args) @@ -38,7 +38,11 @@ (define (add-context-triggers! ctx triggers) (when triggers - (set-context-triggers! ctx (fold cons (or (get-context-triggers ctx) '()) triggers)))) + (set-context-triggers! ctx + (apply lset-adjoin equal? (or (context-triggers ctx) '()) triggers)))) + +(define (context-triggered? ctx trigger) + (find (lambda (t) (equal? t trigger)) (context-triggers ctx))) (define (register-context-var! ctx var-name val) - (set-context-vars! ctx (assoc-set! (get-context-vars ctx) var-name val))) + (set-context-vars! ctx (assoc-set! (context-vars ctx) var-name val))) diff --git a/modules/ordo/handler.scm b/modules/ordo/handler.scm new file mode 100644 index 0000000..d156d6c --- /dev/null +++ b/modules/ordo/handler.scm @@ -0,0 +1,26 @@ +(define-module (ordo handler) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) ; list utils + #:use-module (srfi srfi-9) ; records + #:use-module (srfi srfi-26) ; cut + #:use-module (ordo context) + #:export (handler + handler? + handler-description + handler-action + run-handler)) + +(define-record-type + (make-handler description action) + handler? + (description handler-description) + (action handler-action)) + +(define* (handler description action) + (make-handler description action)) + +(define (run-handler conn ctx handler) + (match handler + (($ description action) + (format #t "RUNNING HANDLER ~a~%" description) + (action conn ctx)))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index 99f14f1..e480bfe 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -1,51 +1,58 @@ (define-module (ordo play) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-9) ; records #:use-module (srfi srfi-26) ; cut #:use-module (ordo connection) #:use-module (ordo context) #:use-module (ordo task) + #:use-module (ordo handler) #:export (play run-play)) (define-record-type - (make-play description connection tasks handlers) + (make-play description connection vars tasks handlers) play? - (connection get-play-connection) - (description get-play-description) - (tasks get-play-tasks) - (handlers get-play-handlers)) + (connection play-connection) + (vars play-vars) + (description play-description) + (tasks play-tasks) + (handlers play-handlers)) -(define* (play description #:key connection tasks (handlers '())) +(define* (play description #:key connection tasks (vars '()) (handlers '())) + ;; TODO: validation could be better - check for non-empty tasks list, check + ;; type of connection, tasks, and handlers, etc. (unless connection (error "connection is required")) (unless tasks (error "tasks are required")) (for-each (lambda (task) (for-each (lambda (trigger) (unless (assoc-ref handlers trigger) (error (format #f "task \"~a\" references an undefined trigger: ~a" - (get-task-description task) + (task-description task) trigger)))) - (get-task-triggers task))) + (task-triggers task))) tasks) - (make-play description connection tasks handlers)) + (make-play description connection vars tasks handlers)) (define (run-trigger conn ctx handlers trigger) - (let ((handler (assoc-ref handlers trigger))) - (unless handler + (let ((h (assoc-ref handlers trigger))) + (unless h (error (format #f "no handler defined for trigger ~a" trigger))) - (run-task conn ctx handler))) + (run-handler conn ctx h))) (define (run-play play) - (format #t "Running play ~a~%" (get-play-description play)) + (format #t "RUNNING PLAY ~a~%" (play-description play)) (call-with-connection - (get-play-connection play) + (play-connection play) (lambda (c) - (let ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) - (ctx (make-context))) - (set-context-scratch-dir! ctx tmp-dir) + (let* ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) + (ctx (context #:scratch-dir tmp-dir #:init-vars (play-vars play)))) (dynamic-wind (const #t) (lambda () - (for-each (cut run-task c ctx <>) (get-play-tasks play)) - (for-each (cut run-trigger c ctx (get-play-handlers play) <>) - (delete-duplicates (get-context-triggers ctx)))) + (for-each (cut run-task c ctx <>) (play-tasks play)) + (for-each (match-lambda + ((name . handler) + (when (context-triggered? ctx name) + (run-handler c ctx handler)))) + (play-handlers play))) (lambda () (connection-must c "rm" `("-rf" ,tmp-dir)))))))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index b20073e..4e2529f 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -6,21 +6,19 @@ #:use-module (ordo context) #:export (task task? - get-task-description - set-task-description! - get-task-register - set-task-register! - get-task-triggers - set-task-triggers! + task-description + task-action + task-register + task-triggers run-task)) (define-record-type (make-task description action register triggers) task? - (description get-task-description set-task-description!) - (action get-task-action set-task-action!) - (register get-task-register set-task-regiseter!) - (triggers get-task-triggers set-task-triggers!)) + (description task-description) + (action task-action) + (register task-register) + (triggers task-triggers)) (define* (task description action #:key (register #f) (triggers '())) (make-task description action register triggers)) @@ -28,10 +26,9 @@ (define (run-task conn ctx task) (match task (($ description action register triggers) - (format #t "START ~a~%" description) + (format #t "RUNNING TASK ~a~%" description) (let ((result (action conn ctx))) (when register (register-context-var! ctx register result)) (when triggers - (add-context-triggers! ctx triggers)) - (format #t "END~%"))))) + (add-context-triggers! ctx triggers)))))) diff --git a/tryme.scm b/tryme.scm index 1199a63..91511ed 100644 --- a/tryme.scm +++ b/tryme.scm @@ -2,7 +2,8 @@ (ordo connection) (ordo action filesystem) (ordo play) - (ordo task)) + (ordo task) + (ordo handler)) (define test-play (play "Test play" @@ -13,10 +14,13 @@ (task "Create test file from string content" (install-file "/home/ray/ordo-test/foo" #:content "Hello, world!\n")) (task "Create test file from local source" - (install-file "/home/ray/ordo-test/bar" #:local-src "/home/ray/ordo-test/foo")) + (install-file "/home/ray/ordo-test/bar" #:local-src "/home/ray/ordo-test/foo") + #:triggers '(fritz)) (task "Create test file from remote source" (install-file "/home/ray/ordo-test/baz" #:remote-src "/home/ray/ordo-test/bar") - #:triggers `(frobnicate))) - #:handlers `((frobnicate . ,(task "Frobnicate" (const #t)))))) + #:triggers '(frobnicate))) + #:handlers `((frobnicate . ,(handler "Frobnicate" (const #t))) + (fritz . ,(handler "Fritz" (const #t))) + (frotz . ,(handler "Frotz" (const #t)))))) ;;(run-play test-play) From 679d2552a9729bbbe3b1cc7ffe58d70689123a73 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 5 Jan 2025 19:12:53 +0000 Subject: [PATCH 15/83] Delete obsolete implementation files --- modules/ordo/prerequisite-data.scm | 17 -------- modules/ordo/task/command.scm | 17 -------- modules/ordo/task/file.scm | 4 -- modules/ordo/util/filesystem.scm | 63 ------------------------------ modules/ordo/util/process.scm | 62 ----------------------------- playbooks/tryme.scm | 3 -- 6 files changed, 166 deletions(-) delete mode 100644 modules/ordo/prerequisite-data.scm delete mode 100644 modules/ordo/task/command.scm delete mode 100644 modules/ordo/task/file.scm delete mode 100644 modules/ordo/util/filesystem.scm delete mode 100644 modules/ordo/util/process.scm delete mode 100644 playbooks/tryme.scm diff --git a/modules/ordo/prerequisite-data.scm b/modules/ordo/prerequisite-data.scm deleted file mode 100644 index 6a8d5f4..0000000 --- a/modules/ordo/prerequisite-data.scm +++ /dev/null @@ -1,17 +0,0 @@ -(define-module (ordo prerequisite-data) - #:use-module (oop goops)) - -(define-class ()) - -(define-class () - (path #:init-keyword #:path #:getter get-path)) - -(define-method (equal? (x ) (y )) - (equal? (get-path x) (get-path y))) - -(define (local-file path) - (make #:path path)) - -(define-class () - (handler #:init-keyword #:handler #:getter get-handler) - (args #:init-keyword #:args :getter get-args)) diff --git a/modules/ordo/task/command.scm b/modules/ordo/task/command.scm deleted file mode 100644 index 52a68bf..0000000 --- a/modules/ordo/task/command.scm +++ /dev/null @@ -1,17 +0,0 @@ -(define-module (ordo task command) - #:use-module (ice-9 format) - #:use-module (srfi srfi-11) - #:use-module (ordo task) - #:use-module (ordo util process) - #:export (command)) - -(define* (command name cmd #:optional (args '()) - #:key (fail-ok? #f) (stdin #f) (cwd #f) (env #f) (skip? #f)) - (make-task name - '() - skip? - (lambda () - (let-values (((exit-code output) (run cmd args #:stdin stdin #:cwd cwd #:env env #:combine-output #t))) - (if (or fail-ok? (zero? exit-code)) - (values exit-code output) - (error (format #f "Error running ~a (exit ~d): ~a" cmd exit-code output))))))) diff --git a/modules/ordo/task/file.scm b/modules/ordo/task/file.scm deleted file mode 100644 index c766485..0000000 --- a/modules/ordo/task/file.scm +++ /dev/null @@ -1,4 +0,0 @@ -(define-module (ordo task file) - #:use-module (ordo task)) - -(define (file )) diff --git a/modules/ordo/util/filesystem.scm b/modules/ordo/util/filesystem.scm deleted file mode 100644 index 3b70ffb..0000000 --- a/modules/ordo/util/filesystem.scm +++ /dev/null @@ -1,63 +0,0 @@ -(define-module (ordo util filesystem) - #:use-module (system foreign) - #:use-module (srfi srfi-11) - #:use-module (ice-9 format) - #:use-module (ice-9 ftw) - #:export (delete-file-recursively - create-temporary-directory - call-with-temporary-directory)) - -(define* (delete-file-recursively filename #:key (verbose #f)) - (define dev (stat:dev (stat filename))) - (define (enter? name stat result) - (= (stat:dev stat) dev)) - (define (leaf name stat result) - (if (false-if-exception (delete-file name)) - (and verbose (format #t "delete-file ~a OK~%" name)) - (format (current-error-port) "warning: delete-file ~a failed~%" name)) - result) - (define (down name stat result) - result) - (define (up name stat result) - (if (false-if-exception (rmdir name)) - (and verbose (format #t "rmdir ~a OK~%" name)) - (format (current-error-port) "warning: rmdir ~a failed~%" name)) - result) - (define (skip name state result) - result) - (define (error name stat errno result) - (format (current-error-port) "warning: ~a: ~a~%" - name (strerror errno)) - result) - (file-system-fold enter? leaf down up skip error #f filename)) - - -;; This is based on reading guix/build/syscalls.scm but less general -;; than their implementation. -;; TODO: why is this needed? The guile standard library has mkdtemp -;; that seems to do the same thing. -(define mkdtemp! - (let* ((ptr (dynamic-func "mkdtemp" (dynamic-link))) - (proc (pointer->procedure '* ptr '(*) #:return-errno? #t))) - (lambda (tmpl) - (let-values (((result err) (proc (string->pointer tmpl)))) - (when (null-pointer? result) - (error (format #f "mkdtemp! ~a: ~a" tmpl (strerror err)))) - (pointer->string result))))) - -(define (create-temporary-directory) - (let* ((directory (or (getenv "TMPDIR") "/tmp")) - (template (string-append directory "/ordo.XXXXXX"))) - (mkdtemp! template))) - -;; This is borrowed from guix/util.scm -(define (call-with-temporary-directory proc) - "Call PROC with a name of a temporary directory; close the directory and -delete it when leaving the dynamic extent of this call." - (let ((tmp-dir (create-temporary-directory))) - (dynamic-wind - (const #t) - (lambda () - (proc tmp-dir)) - (lambda () - (false-if-exception (delete-file-recursively tmp-dir)))))) diff --git a/modules/ordo/util/process.scm b/modules/ordo/util/process.scm deleted file mode 100644 index 810a42f..0000000 --- a/modules/ordo/util/process.scm +++ /dev/null @@ -1,62 +0,0 @@ -(define-module (ordo util process) - #:use-module (ice-9 textual-ports) - #:export (with-cwd with-env capture)) - -(define-syntax with-cwd - (syntax-rules () - ((_ new-dir body ...) - (let ((original-dir (getcwd))) - (dynamic-wind - (lambda () (chdir new-dir)) - (lambda () body ...) - (lambda () (chdir original-dir))))))) - -;; Not needed for CAPTURE, which supports an environment override, -;; but might be useful for SYSTEM and SYSTEM* -(define-syntax with-env - (syntax-rules () - ((_ new-env body ...) - (let ((original-env (environ))) - (dynamic-wind - (lambda () (environ new-env)) - (lambda () body ...) - (lambda () (environ original-env))))))) - -;; Run a command and capture the output. Currently this only supports -;; text input and output. If necessary, we could use the (rnrs io ports) -;; module and use PUT-BYTEVECTOR / GET-BYTEVECTOR-ALL and examine the type -;; of STDIN to determine whether to call PUT-STRING or PUT-BYTEVECTOR. For -;; STDOUT, we'd need to add a #:binary argument so the caller could indicate -;; they are expecting binary output. Not implemented yet incase YAGNI. -(define* (capture cmd - #:optional (args '()) - #:key (combine-output #f) (env #f) (stdin #f) (cwd #f)) - (if cwd - (with-cwd cwd (run cmd args #:combine-output combine-output #:env env #:stdin stdin)) - (let* ((input-pipe (pipe)) - (output-pipe (pipe)) - (pid (spawn cmd (cons cmd args) - #:input (car input-pipe) - #:output (cdr output-pipe) - #:error (if combine-output (cdr output-pipe) (current-error-port)) - #:environment (or env (environ))))) - (close-port (cdr output-pipe)) - (close-port (car input-pipe)) - (when stdin (put-string (cdr input-pipe) stdin)) - (close-port (cdr input-pipe)) - (let ((output (get-string-all (car output-pipe)))) - (close-port (car output-pipe)) - (values (cdr (waitpid pid)) output))))) - -;; Possibly nicer way to do this, suggested by dsmith on IRC: https://bpa.st/3JYTA -;; (use-modules (ice-9 popen) -;; (ice-9 rdelim) -;; (ice-9 receive)) - -;; (define (filter text) -;; (receive (from to pids) (pipeline '(("the-command"))) -;; (write text to) -;; (close to) -;; (read-line from))) - -;; See also https://github.com/ray1729/ordo/blob/main/modules/ordo/util/process.scm diff --git a/playbooks/tryme.scm b/playbooks/tryme.scm deleted file mode 100644 index 72fd903..0000000 --- a/playbooks/tryme.scm +++ /dev/null @@ -1,3 +0,0 @@ -(define x 7) - -(lambda () (* x x)) From 87f243b16a459737c0af9a6ebc23952f2520d59d Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 5 Jan 2025 19:19:28 +0000 Subject: [PATCH 16/83] Some notes on vars --- tryme.scm | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tryme.scm b/tryme.scm index 91511ed..8185bd7 100644 --- a/tryme.scm +++ b/tryme.scm @@ -5,6 +5,21 @@ (ordo task) (ordo handler)) +;; TODO: Consider how vars might be used in task args Currently a task argument +;; can be a context refrence, for example we could write: +;; +;; (install-directory (context-ref 'base-dir)) +;; +;; but there's no way to nest these, so we this will not work: +;; +;; (install-file (file-name-join (context-ref 'base-dir) "foo")) +;; +;; Maybe we could implement something like: +;; +;; (install-file (context-fn (file-name-join (context-ref 'base-dir) "foo"))) +;; +;; where context-fn is some syntax that returns (lambda (ctx) ...) + (define test-play (play "Test play" #:connection (local-connection) From b7e4b9dc74c5eaef8983e5ff1ac74866f2b2a04a Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 6 Jan 2025 17:47:43 +0000 Subject: [PATCH 17/83] An attempt at a task macro. This is not complete: need to resolve context references. --- modules/ordo/task.scm | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index 4e2529f..60c3619 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -20,9 +20,18 @@ (register task-register) (triggers task-triggers)) -(define* (task description action #:key (register #f) (triggers '())) +(define* (task% description action #:key (register #f) (triggers '())) (make-task description action register triggers)) +(define-syntax task + (syntax-rules () + ((_ description (action arg ...) kwarg ...) + (task% + description + (lambda (conn ctx) + (action conn ctx (assoc-ref ctx arg) ...)) + kwarg ...)))) + (define (run-task conn ctx task) (match task (($ description action register triggers) From f2f88ce0dc5e1a5e54c322a70db27bacdea35543 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 6 Jan 2025 20:49:42 +0000 Subject: [PATCH 18/83] Try to make context vars nestable in task action args --- modules/ordo/action/filesystem.scm | 25 +++++++++++-------------- modules/ordo/context.scm | 21 +++++++-------------- modules/ordo/task.scm | 2 +- 3 files changed, 19 insertions(+), 29 deletions(-) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index b27c2b8..2ed5548 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -11,28 +11,26 @@ install-file)) (define* (create-temporary-directory #:key tmpdir suffix template) - (lambda (conn ctx) + (lambda (conn) (connection-must conn "mktemp" (chain-when '("--directory") (tmpdir (append _ `("--tmpdir" tmpdir))) (suffix (append _ `("--suffix" suffix))) - (template (append _ `(template))) - (#t (resolve-context-refs ctx _)))))) + (template (append _ `(template))))))) (define* (install-directory path #:key owner group mode) - (lambda (conn ctx) + (lambda (conn) (connection-must conn "install" (chain-when '("--directory") (owner (append _ `("--owner" ,owner))) (group (append _ `("--group" ,group))) (mode (append _ `("--mode" ,mode))) - (#t (append _ `(,path))) - (#t (resolve-context-refs ctx _)))))) + (#t (append _ `(,path))))))) ;; Helper not intended for use outside of this module -(define (upload-tmp-file conn ctx) +(define (upload-tmp-file conn) (lambda (input-port) - (let ((tmp-path (car (connection-must conn "mktemp" `("-p" ,(context-scratch-dir ctx)))))) + (let ((tmp-path (car (connection-must conn "mktemp")))) (connection-call-with-output-file conn tmp-path (lambda (output-port) (let loop ((data (get-bytevector-some input-port))) @@ -47,12 +45,12 @@ (define* (install-file path #:key owner group mode content local-src remote-src backup?) (when (not (= 1 (length (filter identity (list content local-src remote-src))))) (error "exactly one of #:content, #:local-src, or #:remote-src is required")) - (lambda (conn ctx) + (lambda (conn) (let ((remote-src (cond (remote-src remote-src) - (local-src (call-with-input-file local-src (upload-tmp-file conn ctx))) - ((string? content) (call-with-input-string content (upload-tmp-file conn ctx))) - ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn ctx))) + (local-src (call-with-input-file local-src (upload-tmp-file conn))) + ((string? content) (call-with-input-string content (upload-tmp-file conn))) + ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn))) (else (error "unsupported type for #:content"))))) (connection-must conn "install" (chain-when '() @@ -60,5 +58,4 @@ (group (append _ `("--group" ,group))) (mode (append _ `("--mode" ,mode))) (backup? (append _ '("--backup" "numbered"))) - (#t (append _ (list remote-src path))) - (#t (resolve-context-refs ctx _))))))) + (#t (append _ (list remote-src path)))))))) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm index 4c5f155..3172394 100644 --- a/modules/ordo/context.scm +++ b/modules/ordo/context.scm @@ -9,8 +9,6 @@ get-context-triggers context-triggered? register-context-var! - context-ref - resolve-context-ref resolve-context-refs)) (define-record-type @@ -23,18 +21,13 @@ (define* (context #:key scratch-dir init-vars) (make-context scratch-dir init-vars)) -(define-record-type - (context-ref name) - context-ref? - (name var-name)) - -(define (resolve-context-ref ctx v) - (if (context-ref? v) - (assoc-ref (context-vars ctx) (var-name v)) - v)) - -(define (resolve-context-refs ctx args) - (map (cut resolve-context-ref ctx <>) args)) +(define-syntax resolve-context-refs + (syntax-rules ($) + ((_ ctx ($ x)) + (assoc-ref (context-vars ctx) x)) + ((_ ctx (f x ...)) + (f (resolve-context-refs ctx x) ...)) + ((_ ctx x) x))) (define (add-context-triggers! ctx triggers) (when triggers diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index 60c3619..1c97fa2 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -29,7 +29,7 @@ (task% description (lambda (conn ctx) - (action conn ctx (assoc-ref ctx arg) ...)) + (action conn (resolve-context-refs ctx arg) ...)) kwarg ...)))) (define (run-task conn ctx task) From b463a828bebccf115d25a94f84b77ab8565dd066 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 6 Jan 2025 21:38:32 +0000 Subject: [PATCH 19/83] Fix task action handling Refactor actions to remove context --- modules/ordo/action/filesystem.scm | 3 +-- modules/ordo/task.scm | 11 ++++++----- tryme.scm | 2 +- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 2ed5548..bc10cc6 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -5,7 +5,6 @@ #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module (ordo connection) - #:use-module (ordo context) #:export (create-temporary-directory install-directory install-file)) @@ -30,7 +29,7 @@ ;; Helper not intended for use outside of this module (define (upload-tmp-file conn) (lambda (input-port) - (let ((tmp-path (car (connection-must conn "mktemp")))) + (let ((tmp-path (car (connection-must conn "mktemp" '())))) (connection-call-with-output-file conn tmp-path (lambda (output-port) (let loop ((data (get-bytevector-some input-port))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index 1c97fa2..ee1b100 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -28,15 +28,16 @@ ((_ description (action arg ...) kwarg ...) (task% description - (lambda (conn ctx) - (action conn (resolve-context-refs ctx arg) ...)) + (lambda (ctx) + (action (resolve-context-refs ctx arg) ...)) kwarg ...)))) -(define (run-task conn ctx task) - (match task +(define (run-task conn ctx t) + (match t (($ description action register triggers) (format #t "RUNNING TASK ~a~%" description) - (let ((result (action conn ctx))) + (pk 'action action) + (let ((result ((action ctx) conn))) (when register (register-context-var! ctx register result)) (when triggers diff --git a/tryme.scm b/tryme.scm index 8185bd7..316bcf7 100644 --- a/tryme.scm +++ b/tryme.scm @@ -38,4 +38,4 @@ (fritz . ,(handler "Fritz" (const #t))) (frotz . ,(handler "Frotz" (const #t)))))) -;;(run-play test-play) +(run-play test-play) From 12c45b628ccea43192696a3e6983f8792847a4ee Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 6 Jan 2025 21:44:20 +0000 Subject: [PATCH 20/83] Update handlers to resolve context refs --- modules/ordo/handler.scm | 16 ++++++++++++---- modules/ordo/task.scm | 1 - 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/modules/ordo/handler.scm b/modules/ordo/handler.scm index d156d6c..14ee08a 100644 --- a/modules/ordo/handler.scm +++ b/modules/ordo/handler.scm @@ -16,11 +16,19 @@ (description handler-description) (action handler-action)) -(define* (handler description action) +(define* (handler% description action) (make-handler description action)) -(define (run-handler conn ctx handler) - (match handler +(define-syntax handler + (syntax-rules () + ((_ description (action arg ...)) + (handler% + description + (lambda (ctx) + (action (resolve-context-refs ctx arg) ...)))))) + +(define (run-handler conn ctx h) + (match h (($ description action) (format #t "RUNNING HANDLER ~a~%" description) - (action conn ctx)))) + ((action ctx) conn)))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index ee1b100..b2a48ba 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -36,7 +36,6 @@ (match t (($ description action register triggers) (format #t "RUNNING TASK ~a~%" description) - (pk 'action action) (let ((result ((action ctx) conn))) (when register (register-context-var! ctx register result)) From af16ee29b674691a3a32620467a959710d56ebed Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 6 Jan 2025 22:08:33 +0000 Subject: [PATCH 21/83] Test vars and overrides --- modules/ordo/action/filesystem.scm | 2 ++ modules/ordo/context.scm | 1 + tryme.scm | 31 ++++++++++++------------------ 3 files changed, 15 insertions(+), 19 deletions(-) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index bc10cc6..d731d24 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -19,6 +19,7 @@ (define* (install-directory path #:key owner group mode) (lambda (conn) + (format #t "install-directory ~a~%" path) (connection-must conn "install" (chain-when '("--directory") (owner (append _ `("--owner" ,owner))) @@ -45,6 +46,7 @@ (when (not (= 1 (length (filter identity (list content local-src remote-src))))) (error "exactly one of #:content, #:local-src, or #:remote-src is required")) (lambda (conn) + (format #t "install-file ~a~%" path) (let ((remote-src (cond (remote-src remote-src) (local-src (call-with-input-file local-src (upload-tmp-file conn))) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm index 3172394..92c66df 100644 --- a/modules/ordo/context.scm +++ b/modules/ordo/context.scm @@ -21,6 +21,7 @@ (define* (context #:key scratch-dir init-vars) (make-context scratch-dir init-vars)) +;; TODO: (resolve-content-refs ctx (lambda (x) x)) fails (define-syntax resolve-context-refs (syntax-rules ($) ((_ ctx ($ x)) diff --git a/tryme.scm b/tryme.scm index 316bcf7..d899983 100644 --- a/tryme.scm +++ b/tryme.scm @@ -1,38 +1,31 @@ (use-modules + (ice-9 filesystem) (ordo connection) (ordo action filesystem) (ordo play) (ordo task) (ordo handler)) -;; TODO: Consider how vars might be used in task args Currently a task argument -;; can be a context refrence, for example we could write: -;; -;; (install-directory (context-ref 'base-dir)) -;; -;; but there's no way to nest these, so we this will not work: -;; -;; (install-file (file-name-join (context-ref 'base-dir) "foo")) -;; -;; Maybe we could implement something like: -;; -;; (install-file (context-fn (file-name-join (context-ref 'base-dir) "foo"))) -;; -;; where context-fn is some syntax that returns (lambda (ctx) ...) - (define test-play (play "Test play" #:connection (local-connection) + #:vars '((base-dir . "/home/ray/ordo-test")) #:tasks (list + (task "Override base dir" + (const "/home/ray/ordo-test-again") + #:register 'base-dir) (task "Create test directory" - (install-directory "/home/ray/ordo-test")) + (install-directory ($ 'base-dir))) (task "Create test file from string content" - (install-file "/home/ray/ordo-test/foo" #:content "Hello, world!\n")) + (install-file (file-name-join* ($ 'base-dir) "foo") + #:content "Hello, world!\n")) (task "Create test file from local source" - (install-file "/home/ray/ordo-test/bar" #:local-src "/home/ray/ordo-test/foo") + (install-file (file-name-join* ($ 'base-dir) "bar") + #:local-src (file-name-join* ($ 'base-dir) "foo")) #:triggers '(fritz)) (task "Create test file from remote source" - (install-file "/home/ray/ordo-test/baz" #:remote-src "/home/ray/ordo-test/bar") + (install-file (file-name-join* ($ 'base-dir) "baz") + #:remote-src (file-name-join* ($ 'base-dir) "bar")) #:triggers '(frobnicate))) #:handlers `((frobnicate . ,(handler "Frobnicate" (const #t))) (fritz . ,(handler "Fritz" (const #t))) From b4cdfc341ad4b5965b980a3cd1e229fa1bd774aa Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Tue, 7 Jan 2025 18:09:10 +0000 Subject: [PATCH 22/83] Support for context vars without macros --- modules/ordo/action/filesystem.scm | 71 +++++++++++++++--------------- modules/ordo/connection.scm | 3 +- modules/ordo/context.scm | 25 +++++------ modules/ordo/handler.scm | 15 ++----- modules/ordo/play.scm | 23 +++++----- modules/ordo/task.scm | 15 ++----- tryme.scm | 33 +++++++++++--- 7 files changed, 91 insertions(+), 94 deletions(-) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index d731d24..855eb85 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -5,33 +5,34 @@ #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module (ordo connection) + #:use-module (ordo context) #:export (create-temporary-directory install-directory install-file)) -(define* (create-temporary-directory #:key tmpdir suffix template) - (lambda (conn) - (connection-must conn "mktemp" (chain-when - '("--directory") - (tmpdir (append _ `("--tmpdir" tmpdir))) - (suffix (append _ `("--suffix" suffix))) - (template (append _ `(template))))))) +(define* (create-temporary-directory ctx #:key tmpdir suffix template) + (connection-must (context-connection ctx) + "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template)))))) -(define* (install-directory path #:key owner group mode) - (lambda (conn) - (format #t "install-directory ~a~%" path) - (connection-must conn "install" (chain-when - '("--directory") - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (#t (append _ `(,path))))))) +(define* (install-directory ctx path #:key owner group mode) + (connection-must (context-connection ctx) + "install" (chain-when + '("--directory") + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (#t (append _ `(,path)))))) ;; Helper not intended for use outside of this module -(define (upload-tmp-file conn) +(define (upload-tmp-file ctx) (lambda (input-port) - (let ((tmp-path (car (connection-must conn "mktemp" '())))) - (connection-call-with-output-file conn tmp-path + (let ((tmp-path (car (connection-must (context-connection ctx) + "mktemp" `("-p" ,(context-scratch-dir ctx)))))) + (connection-call-with-output-file (context-connection ctx) tmp-path (lambda (output-port) (let loop ((data (get-bytevector-some input-port))) (unless (eof-object? data) @@ -42,21 +43,21 @@ ;; Because we might need sudo to install the remote file, we first ;; upload the source to a temporary file. -(define* (install-file path #:key owner group mode content local-src remote-src backup?) +(define* (install-file ctx path #:key owner group mode content local-src remote-src backup?) (when (not (= 1 (length (filter identity (list content local-src remote-src))))) (error "exactly one of #:content, #:local-src, or #:remote-src is required")) - (lambda (conn) - (format #t "install-file ~a~%" path) - (let ((remote-src (cond - (remote-src remote-src) - (local-src (call-with-input-file local-src (upload-tmp-file conn))) - ((string? content) (call-with-input-string content (upload-tmp-file conn))) - ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn))) - (else (error "unsupported type for #:content"))))) - (connection-must conn "install" (chain-when - '() - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (backup? (append _ '("--backup" "numbered"))) - (#t (append _ (list remote-src path)))))))) + (format #t "install-file ~a~%" path) + (let ((remote-src (cond + (remote-src remote-src) + (local-src (call-with-input-file local-src (upload-tmp-file ctx))) + ((string? content) (call-with-input-string content (upload-tmp-file ctx))) + ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx))) + (else (error "unsupported type for #:content"))))) + (connection-must (context-connection ctx) + "install" (chain-when + '() + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append _ (list remote-src path))))))) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 71884ee..57fff62 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -11,7 +11,8 @@ #:use-module (ssh popen) #:use-module (ssh sftp) #:use-module (ordo util shell-quote) - #:export (local-connection + #:export ( + local-connection ssh-connection init-connection! close-connection! diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm index 92c66df..a698199 100644 --- a/modules/ordo/context.scm +++ b/modules/ordo/context.scm @@ -2,33 +2,30 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) - #:export (context + #:export (make-context context? + context-connection context-scratch-dir + set-context-scratch-dir! add-context-triggers! get-context-triggers context-triggered? register-context-var! - resolve-context-refs)) + context-ref)) (define-record-type - (make-context scratch-dir vars) + (make-context connection vars scratch-dir) context? + (connection context-connection) (scratch-dir context-scratch-dir set-context-scratch-dir!) (vars context-vars set-context-vars!) (triggers context-triggers set-context-triggers!)) -(define* (context #:key scratch-dir init-vars) - (make-context scratch-dir init-vars)) - -;; TODO: (resolve-content-refs ctx (lambda (x) x)) fails -(define-syntax resolve-context-refs - (syntax-rules ($) - ((_ ctx ($ x)) - (assoc-ref (context-vars ctx) x)) - ((_ ctx (f x ...)) - (f (resolve-context-refs ctx x) ...)) - ((_ ctx x) x))) +(define (context-ref ctx var-name) + (let ((kv (assoc var-name (context-vars ctx)))) + (if kv + (cdr kv) + (error (format #f "failed to resolve context reference: ~a" var-name))))) (define (add-context-triggers! ctx triggers) (when triggers diff --git a/modules/ordo/handler.scm b/modules/ordo/handler.scm index 14ee08a..a7ddf41 100644 --- a/modules/ordo/handler.scm +++ b/modules/ordo/handler.scm @@ -16,19 +16,10 @@ (description handler-description) (action handler-action)) -(define* (handler% description action) - (make-handler description action)) +(define handler make-handler) -(define-syntax handler - (syntax-rules () - ((_ description (action arg ...)) - (handler% - description - (lambda (ctx) - (action (resolve-context-refs ctx arg) ...)))))) - -(define (run-handler conn ctx h) +(define (run-handler ctx h) (match h (($ description action) (format #t "RUNNING HANDLER ~a~%" description) - ((action ctx) conn)))) + (action ctx)))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index e480bfe..f3ebc0e 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -1,4 +1,5 @@ (define-module (ordo play) + #:use-module (oop goops) #:use-module (ice-9 match) #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-9) ; records @@ -19,10 +20,11 @@ (handlers play-handlers)) (define* (play description #:key connection tasks (vars '()) (handlers '())) - ;; TODO: validation could be better - check for non-empty tasks list, check - ;; type of connection, tasks, and handlers, etc. (unless connection (error "connection is required")) - (unless tasks (error "tasks are required")) + (unless (is-a? connection ) (error (format #f "invalid connection: ~a" connection))) + (unless (and tasks (not (null? tasks))) (error "tasks are required")) + (unless (every task? tasks) (error "invalid tasks")) + (unless (every (compose handler? cdr) handlers) (error "invalid handlers")) (for-each (lambda (task) (for-each (lambda (trigger) (unless (assoc-ref handlers trigger) @@ -31,13 +33,7 @@ trigger)))) (task-triggers task))) tasks) - (make-play description connection vars tasks handlers)) - -(define (run-trigger conn ctx handlers trigger) - (let ((h (assoc-ref handlers trigger))) - (unless h - (error (format #f "no handler defined for trigger ~a" trigger))) - (run-handler conn ctx h))) + (make-play description connection (fold (match-lambda* (((k . v) accum) (alist-cons k v accum))) '() vars) tasks handlers)) (define (run-play play) (format #t "RUNNING PLAY ~a~%" (play-description play)) @@ -45,14 +41,15 @@ (play-connection play) (lambda (c) (let* ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) - (ctx (context #:scratch-dir tmp-dir #:init-vars (play-vars play)))) + (ctx (make-context c (play-vars play) tmp-dir))) + (pk ctx) (dynamic-wind (const #t) (lambda () - (for-each (cut run-task c ctx <>) (play-tasks play)) + (for-each (cut run-task ctx <>) (play-tasks play)) (for-each (match-lambda ((name . handler) (when (context-triggered? ctx name) - (run-handler c ctx handler)))) + (run-handler ctx handler)))) (play-handlers play))) (lambda () (connection-must c "rm" `("-rf" ,tmp-dir)))))))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index b2a48ba..a307d0a 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -20,23 +20,14 @@ (register task-register) (triggers task-triggers)) -(define* (task% description action #:key (register #f) (triggers '())) +(define* (task description action #:key (register #f) (triggers '())) (make-task description action register triggers)) -(define-syntax task - (syntax-rules () - ((_ description (action arg ...) kwarg ...) - (task% - description - (lambda (ctx) - (action (resolve-context-refs ctx arg) ...)) - kwarg ...)))) - -(define (run-task conn ctx t) +(define (run-task ctx t) (match t (($ description action register triggers) (format #t "RUNNING TASK ~a~%" description) - (let ((result ((action ctx) conn))) + (let ((result (action ctx))) (when register (register-context-var! ctx register result)) (when triggers diff --git a/tryme.scm b/tryme.scm index d899983..8f2ac87 100644 --- a/tryme.scm +++ b/tryme.scm @@ -1,11 +1,26 @@ (use-modules (ice-9 filesystem) (ordo connection) + (ordo context ) (ordo action filesystem) (ordo play) (ordo task) (ordo handler)) +;; uname -a => Linux little-rascal 6.11.10-gnu #1 SMP PREEMPT_DYNAMIC 1 x86_64 GNU/Linux +;; kernel name: Linux +;; node name: little-rascal +;; kernel release: 6.11.10-gnu +;; kernel version: #1 +;; machine: SMP PREEMPT_DYNAMIC +;; processor: 1 +;; hardware platform: x86_64 +;; operating system: GNU/Linux +;; +;; Linux toolbox 6.12.6-200.fc41.x86_64 #1 SMP PREEMPT_DYNAMIC Thu Dec 19 21:06:34 UTC 2024 x86_64 x86_64 x86_64 GNU/Linux +;; uname --kernel-name --nodename --kernel-release --machine --operating-system +;; Linux little-rascal 6.11.10-gnu x86_64 GNU/Linux + (define test-play (play "Test play" #:connection (local-connection) @@ -15,17 +30,21 @@ (const "/home/ray/ordo-test-again") #:register 'base-dir) (task "Create test directory" - (install-directory ($ 'base-dir))) + (lambda (ctx) + (install-directory ctx (context-ref ctx 'base-dir)))) (task "Create test file from string content" - (install-file (file-name-join* ($ 'base-dir) "foo") - #:content "Hello, world!\n")) + (lambda (ctx) + (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "foo") + #:content "Hello, world!\n"))) (task "Create test file from local source" - (install-file (file-name-join* ($ 'base-dir) "bar") - #:local-src (file-name-join* ($ 'base-dir) "foo")) + (lambda (ctx) + (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "bar") + #:local-src (file-name-join* (context-ref ctx 'base-dir) "foo"))) #:triggers '(fritz)) (task "Create test file from remote source" - (install-file (file-name-join* ($ 'base-dir) "baz") - #:remote-src (file-name-join* ($ 'base-dir) "bar")) + (lambda (ctx) + (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "baz") + #:remote-src (file-name-join* (context-ref ctx 'base-dir) "bar"))) #:triggers '(frobnicate))) #:handlers `((frobnicate . ,(handler "Frobnicate" (const #t))) (fritz . ,(handler "Fritz" (const #t))) From 5360e73d6024b539edd92c62d848a558405b931a Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 8 Jan 2025 09:13:19 +0000 Subject: [PATCH 23/83] Add macro to simplify task context references --- modules/ordo/action/filesystem.scm | 64 +++++++++++++++--------------- modules/ordo/context.scm | 10 ++++- modules/ordo/play.scm | 1 - tryme.scm | 23 ++++++----- 4 files changed, 54 insertions(+), 44 deletions(-) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 855eb85..7eb6a35 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -10,22 +10,24 @@ install-directory install-file)) -(define* (create-temporary-directory ctx #:key tmpdir suffix template) - (connection-must (context-connection ctx) - "mktemp" (chain-when - '("--directory") - (tmpdir (append _ `("--tmpdir" tmpdir))) - (suffix (append _ `("--suffix" suffix))) - (template (append _ `(template)))))) +(define* (create-temporary-directory #:key tmpdir suffix template) + (lambda (ctx) + (connection-must (context-connection ctx) + "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template))))))) -(define* (install-directory ctx path #:key owner group mode) - (connection-must (context-connection ctx) - "install" (chain-when - '("--directory") - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (#t (append _ `(,path)))))) +(define* (install-directory path #:key owner group mode) + (lambda (ctx) + (connection-must (context-connection ctx) + "install" (chain-when + '("--directory") + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (#t (append _ `(,path))))))) ;; Helper not intended for use outside of this module (define (upload-tmp-file ctx) @@ -43,21 +45,21 @@ ;; Because we might need sudo to install the remote file, we first ;; upload the source to a temporary file. -(define* (install-file ctx path #:key owner group mode content local-src remote-src backup?) +(define* (install-file path #:key owner group mode content local-src remote-src backup?) (when (not (= 1 (length (filter identity (list content local-src remote-src))))) (error "exactly one of #:content, #:local-src, or #:remote-src is required")) - (format #t "install-file ~a~%" path) - (let ((remote-src (cond - (remote-src remote-src) - (local-src (call-with-input-file local-src (upload-tmp-file ctx))) - ((string? content) (call-with-input-string content (upload-tmp-file ctx))) - ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx))) - (else (error "unsupported type for #:content"))))) - (connection-must (context-connection ctx) - "install" (chain-when - '() - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (backup? (append _ '("--backup" "numbered"))) - (#t (append _ (list remote-src path))))))) + (lambda (ctx) + (let ((remote-src (cond + (remote-src remote-src) + (local-src (call-with-input-file local-src (upload-tmp-file ctx))) + ((string? content) (call-with-input-string content (upload-tmp-file ctx))) + ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx))) + (else (error "unsupported type for #:content"))))) + (connection-must (context-connection ctx) + "install" (chain-when + '() + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append _ (list remote-src path)))))))) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm index a698199..bc07882 100644 --- a/modules/ordo/context.scm +++ b/modules/ordo/context.scm @@ -11,7 +11,8 @@ get-context-triggers context-triggered? register-context-var! - context-ref)) + context-ref + bind-context-vars)) (define-record-type (make-context connection vars scratch-dir) @@ -37,3 +38,10 @@ (define (register-context-var! ctx var-name val) (set-context-vars! ctx (assoc-set! (context-vars ctx) var-name val))) + +(define-syntax bind-context-vars + (syntax-rules () + ((bind-context-vars (var-name ...) proc) + (lambda (ctx) + (let ((var-name (context-ref ctx (quote var-name))) ...) + (proc ctx)))))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index f3ebc0e..9bb8639 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -42,7 +42,6 @@ (lambda (c) (let* ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) (ctx (make-context c (play-vars play) tmp-dir))) - (pk ctx) (dynamic-wind (const #t) (lambda () diff --git a/tryme.scm b/tryme.scm index 8f2ac87..7428ac8 100644 --- a/tryme.scm +++ b/tryme.scm @@ -30,21 +30,22 @@ (const "/home/ray/ordo-test-again") #:register 'base-dir) (task "Create test directory" - (lambda (ctx) - (install-directory ctx (context-ref ctx 'base-dir)))) + (bind-context-vars + (base-dir) + (install-directory base-dir))) (task "Create test file from string content" - (lambda (ctx) - (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "foo") - #:content "Hello, world!\n"))) + (bind-context-vars + (base-dir) + (install-file (file-name-join* base-dir "foo") #:content "Hello, world!\n"))) (task "Create test file from local source" - (lambda (ctx) - (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "bar") - #:local-src (file-name-join* (context-ref ctx 'base-dir) "foo"))) + (bind-context-vars + (base-dir) + (install-file (file-name-join* base-dir "bar") #:local-src (file-name-join* base-dir "foo"))) #:triggers '(fritz)) (task "Create test file from remote source" - (lambda (ctx) - (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "baz") - #:remote-src (file-name-join* (context-ref ctx 'base-dir) "bar"))) + (bind-context-vars + (base-dir) + (install-file (file-name-join* base-dir "baz") #:remote-src (file-name-join* base-dir "bar"))) #:triggers '(frobnicate))) #:handlers `((frobnicate . ,(handler "Frobnicate" (const #t))) (fritz . ,(handler "Fritz" (const #t))) From 7f73a9b7de217fc54cfaa7e10187180e6910c169 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 8 Jan 2025 09:35:22 +0000 Subject: [PATCH 24/83] Clean up validation of play arguments --- modules/ordo/play.scm | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index 9bb8639..8e5e606 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -19,12 +19,19 @@ (tasks play-tasks) (handlers play-handlers)) -(define* (play description #:key connection tasks (vars '()) (handlers '())) - (unless connection (error "connection is required")) - (unless (is-a? connection ) (error (format #f "invalid connection: ~a" connection))) - (unless (and tasks (not (null? tasks))) (error "tasks are required")) - (unless (every task? tasks) (error "invalid tasks")) - (unless (every (compose handler? cdr) handlers) (error "invalid handlers")) +(define (validate-connection connection) + (unless (and connection (is-a? connection )) + (error (format #f "invalid connection: ~a" connection)))) + +(define (validate-tasks tasks) + (unless (and tasks (not (null? tasks)) (every task? tasks)) + (error (format #f "invalid tasks: ~a" tasks)))) + +(define (validate-handlers handlers) + (unless (every (lambda (h) (and (pair? h) (handler? (cdr h)))) handlers) + (error (format #f "invalid handlers: ~a" handlers)))) + +(define (validate-triggers tasks handlers) (for-each (lambda (task) (for-each (lambda (trigger) (unless (assoc-ref handlers trigger) @@ -32,7 +39,13 @@ (task-description task) trigger)))) (task-triggers task))) - tasks) + tasks)) + +(define* (play description #:key connection tasks (vars '()) (handlers '())) + (validate-connection connection) + (validate-tasks tasks) + (validate-handlers handlers) + (validate-triggers tasks handlers) (make-play description connection (fold (match-lambda* (((k . v) accum) (alist-cons k v accum))) '() vars) tasks handlers)) (define (run-play play) From 3153469a2cddd2134fa7fcb4662485d1f7fad00e Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 8 Jan 2025 09:56:12 +0000 Subject: [PATCH 25/83] Validate play vars --- modules/ordo/play.scm | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index 8e5e606..aa2036c 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -31,6 +31,10 @@ (unless (every (lambda (h) (and (pair? h) (handler? (cdr h)))) handlers) (error (format #f "invalid handlers: ~a" handlers)))) +(define (validate-vars vars) + (unless (every pair? vars) + (error (format #f "invalid vars: ~a" vars)))) + (define (validate-triggers tasks handlers) (for-each (lambda (task) (for-each (lambda (trigger) @@ -46,6 +50,10 @@ (validate-tasks tasks) (validate-handlers handlers) (validate-triggers tasks handlers) + (validate-vars vars) + ;; Reconstruct the vars here because, when a quoted list is passed in the + ;; play, it can result in an error (expected mutable pair) from assoc-set! + ;; from register-context-var!. (make-play description connection (fold (match-lambda* (((k . v) accum) (alist-cons k v accum))) '() vars) tasks handlers)) (define (run-play play) From 93820dc307b937429bd39343688c97b0391e3037 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 8 Jan 2025 18:27:46 +0000 Subject: [PATCH 26/83] Some refactoring, and implement stat Add convenience functions run and must to the context module, and remove the similar functions from connection. In the connection module, rename %run to connection-run now that that function has moved to context. --- modules/ordo/action/filesystem.scm | 69 +++++++++++++++++++----------- modules/ordo/connection.scm | 16 +------ modules/ordo/context.scm | 19 +++++++- modules/ordo/play.scm | 8 ++-- tryme.scm | 23 ++++------ 5 files changed, 78 insertions(+), 57 deletions(-) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 7eb6a35..76b094e 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -1,6 +1,8 @@ (define-module (ordo action filesystem) #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) @@ -8,32 +10,30 @@ #:use-module (ordo context) #:export (create-temporary-directory install-directory - install-file)) + install-file + fs:stat)) (define* (create-temporary-directory #:key tmpdir suffix template) (lambda (ctx) - (connection-must (context-connection ctx) - "mktemp" (chain-when - '("--directory") - (tmpdir (append _ `("--tmpdir" tmpdir))) - (suffix (append _ `("--suffix" suffix))) - (template (append _ `(template))))))) + (must ctx "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template))))))) (define* (install-directory path #:key owner group mode) (lambda (ctx) - (connection-must (context-connection ctx) - "install" (chain-when - '("--directory") - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (#t (append _ `(,path))))))) + (must ctx "install" (chain-when + '("--directory") + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (#t (append _ `(,path))))))) ;; Helper not intended for use outside of this module (define (upload-tmp-file ctx) (lambda (input-port) - (let ((tmp-path (car (connection-must (context-connection ctx) - "mktemp" `("-p" ,(context-scratch-dir ctx)))))) + (let ((tmp-path (first (must ctx "mktemp" `("-p" ,(context-scratch-dir ctx)))))) (connection-call-with-output-file (context-connection ctx) tmp-path (lambda (output-port) (let loop ((data (get-bytevector-some input-port))) @@ -55,11 +55,32 @@ ((string? content) (call-with-input-string content (upload-tmp-file ctx))) ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx))) (else (error "unsupported type for #:content"))))) - (connection-must (context-connection ctx) - "install" (chain-when - '() - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (backup? (append _ '("--backup" "numbered"))) - (#t (append _ (list remote-src path)))))))) + (must ctx "install" (chain-when + '() + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append _ (list remote-src path))))) + path))) + +(define (fs:stat path) + (define (parse-stat-result s) + (match-let* (((file-type user group . rest) (string-split s #\:)) + ((uid gid size mode atime mtime ctime) (map string->number rest))) + `((file-type . ,file-type) + (user . ,user) + (group . ,group) + (uid . ,uid) + (gid . ,gid) + (size . ,size) + (mode . ,mode) + (atime . ,atime) + (mtime . ,mtime) + (ctime . ,ctime)))) + (lambda (ctx) + (let ((result rc (run ctx "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path)))) + (cond + ((zero? rc) (parse-stat-result (first result))) + ((string-contains? (first result) "No such file or directory") #f) + (else (error (format #f "stat ~a: ~a" path (first result)))))))) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 57fff62..afde8d6 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -17,7 +17,6 @@ init-connection! close-connection! connection-run - connection-must connection-call-with-input-file connection-call-with-output-file call-with-connection)) @@ -92,14 +91,14 @@ (list "2>&1"))) (#t (string-join _ " "))))) -(define-method (run% (c ) pwd env prog args) +(define-method (connection-run (c ) pwd env prog args) (let* ((cmd (build-command c pwd env prog args)) (port (open-input-pipe cmd)) (output (read-lines port)) (exit-status (status:exit-val (close-pipe port)))) (values output exit-status))) -(define-method (run% (c ) pwd env prog args) +(define-method (connection-run (c ) pwd env prog args) (let* ((cmd (build-command c pwd env prog args)) (channel (open-remote-input-pipe (get-session c) cmd)) (output (read-lines channel)) @@ -107,17 +106,6 @@ (close channel) (values output exit-status))) -(define* (connection-run c prog args #:key (env #f) (pwd #f)) - (run% c pwd env prog args)) - -(define* (connection-must c prog args #:key (env #f) (pwd #f) (error-msg #f)) - (let ((out rc (connection-run c prog args #:env env #:pwd pwd))) - (if (zero? rc) - out - (error (if error-msg - (format #f "~a: ~a" error-msg out) - (format #f "~a error: ~a" prog out)))))) - (define-method (connection-call-with-input-file (c ) (filename ) (proc )) (call-with-input-file filename proc)) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm index bc07882..1da0015 100644 --- a/modules/ordo/context.scm +++ b/modules/ordo/context.scm @@ -2,6 +2,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (ordo connection) #:export (make-context context? context-connection @@ -12,10 +14,12 @@ context-triggered? register-context-var! context-ref - bind-context-vars)) + bind-context-vars + run + must)) (define-record-type - (make-context connection vars scratch-dir) + (make-context connection vars) context? (connection context-connection) (scratch-dir context-scratch-dir set-context-scratch-dir!) @@ -45,3 +49,14 @@ (lambda (ctx) (let ((var-name (context-ref ctx (quote var-name))) ...) (proc ctx)))))) + +(define* (run ctx prog args #:key (env #f) (pwd #f)) + (connection-run (context-connection ctx) pwd env prog args)) + +(define* (must ctx prog args #:key (env #f) (pwd #f) (error-msg #f)) + (let ((out rc (run ctx prog args #:env env #:pwd pwd))) + (if (zero? rc) + out + (error (if error-msg + (format #f "~a: ~a" error-msg out) + (format #f "~a error: ~a" prog out)))))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index aa2036c..8d0450c 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -61,8 +61,8 @@ (call-with-connection (play-connection play) (lambda (c) - (let* ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) - (ctx (make-context c (play-vars play) tmp-dir))) + (let* ((ctx (make-context c (play-vars play)))) + (set-context-scratch-dir! ctx (first (must ctx "mktemp" '("--directory")))) (dynamic-wind (const #t) (lambda () @@ -72,4 +72,6 @@ (when (context-triggered? ctx name) (run-handler ctx handler)))) (play-handlers play))) - (lambda () (connection-must c "rm" `("-rf" ,tmp-dir)))))))) + (lambda () + (must ctx "rm" `("-rf" ,(context-scratch-dir ctx)))))))) + (format #t "COMPLETED PLAY ~a~%" (play-description play))) diff --git a/tryme.scm b/tryme.scm index 7428ac8..ac49dbf 100644 --- a/tryme.scm +++ b/tryme.scm @@ -36,19 +36,14 @@ (task "Create test file from string content" (bind-context-vars (base-dir) - (install-file (file-name-join* base-dir "foo") #:content "Hello, world!\n"))) - (task "Create test file from local source" - (bind-context-vars - (base-dir) - (install-file (file-name-join* base-dir "bar") #:local-src (file-name-join* base-dir "foo"))) - #:triggers '(fritz)) - (task "Create test file from remote source" - (bind-context-vars - (base-dir) - (install-file (file-name-join* base-dir "baz") #:remote-src (file-name-join* base-dir "bar"))) - #:triggers '(frobnicate))) - #:handlers `((frobnicate . ,(handler "Frobnicate" (const #t))) - (fritz . ,(handler "Fritz" (const #t))) - (frotz . ,(handler "Frotz" (const #t)))))) + (install-file (file-name-join* base-dir "foo") #:content "Hello, world!\n")) + #:register 'foo) + (task "Get file status" + (bind-context-vars (foo) (fs:stat foo)) + #:register 'stat-out + #:triggers '(display-stat))) + #:handlers `((display-stat . ,(handler "Display stat" + (bind-context-vars (foo stat-out) (lambda _ (pk foo stat-out)))))))) + (run-play test-play) From 715496b01c27d825cdaf8d2b662939c8721f62ac Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 8 Jan 2025 18:29:11 +0000 Subject: [PATCH 27/83] Remove uname blurb from test play --- tryme.scm | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/tryme.scm b/tryme.scm index ac49dbf..ca81cf1 100644 --- a/tryme.scm +++ b/tryme.scm @@ -7,20 +7,6 @@ (ordo task) (ordo handler)) -;; uname -a => Linux little-rascal 6.11.10-gnu #1 SMP PREEMPT_DYNAMIC 1 x86_64 GNU/Linux -;; kernel name: Linux -;; node name: little-rascal -;; kernel release: 6.11.10-gnu -;; kernel version: #1 -;; machine: SMP PREEMPT_DYNAMIC -;; processor: 1 -;; hardware platform: x86_64 -;; operating system: GNU/Linux -;; -;; Linux toolbox 6.12.6-200.fc41.x86_64 #1 SMP PREEMPT_DYNAMIC Thu Dec 19 21:06:34 UTC 2024 x86_64 x86_64 x86_64 GNU/Linux -;; uname --kernel-name --nodename --kernel-release --machine --operating-system -;; Linux little-rascal 6.11.10-gnu x86_64 GNU/Linux - (define test-play (play "Test play" #:connection (local-connection) From 0550ab5b60f5b92ed925ab60fbf9f743b4e6d746 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 10 Jan 2025 16:02:21 +0000 Subject: [PATCH 28/83] Update filesystem actions * Prefix all the exported actions with "action:" * Add new actions for remove, link * Make install-file and install-dir preserve the owner/group/mode of the original unless there's an explicit override * Remove use of context scratch-dir --- modules/ordo/action/filesystem.scm | 164 +++++++++++++++++++---------- 1 file changed, 106 insertions(+), 58 deletions(-) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 76b094e..12a940a 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -8,63 +8,14 @@ #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module (ordo connection) #:use-module (ordo context) - #:export (create-temporary-directory - install-directory - install-file - fs:stat)) + #:export (action:create-tmp-dir + action:install-dir + action:install-file + action:stat + action:remove + action:link)) -(define* (create-temporary-directory #:key tmpdir suffix template) - (lambda (ctx) - (must ctx "mktemp" (chain-when - '("--directory") - (tmpdir (append _ `("--tmpdir" tmpdir))) - (suffix (append _ `("--suffix" suffix))) - (template (append _ `(template))))))) - -(define* (install-directory path #:key owner group mode) - (lambda (ctx) - (must ctx "install" (chain-when - '("--directory") - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (#t (append _ `(,path))))))) - -;; Helper not intended for use outside of this module -(define (upload-tmp-file ctx) - (lambda (input-port) - (let ((tmp-path (first (must ctx "mktemp" `("-p" ,(context-scratch-dir ctx)))))) - (connection-call-with-output-file (context-connection ctx) tmp-path - (lambda (output-port) - (let loop ((data (get-bytevector-some input-port))) - (unless (eof-object? data) - (put-bytevector output-port data) - (loop (get-bytevector-some input-port)))) - (close-port output-port))) - tmp-path))) - -;; Because we might need sudo to install the remote file, we first -;; upload the source to a temporary file. -(define* (install-file path #:key owner group mode content local-src remote-src backup?) - (when (not (= 1 (length (filter identity (list content local-src remote-src))))) - (error "exactly one of #:content, #:local-src, or #:remote-src is required")) - (lambda (ctx) - (let ((remote-src (cond - (remote-src remote-src) - (local-src (call-with-input-file local-src (upload-tmp-file ctx))) - ((string? content) (call-with-input-string content (upload-tmp-file ctx))) - ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx))) - (else (error "unsupported type for #:content"))))) - (must ctx "install" (chain-when - '() - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (backup? (append _ '("--backup" "numbered"))) - (#t (append _ (list remote-src path))))) - path))) - -(define (fs:stat path) +(define (action:stat path) (define (parse-stat-result s) (match-let* (((file-type user group . rest) (string-split s #\:)) ((uid gid size mode atime mtime ctime) (map string->number rest))) @@ -81,6 +32,103 @@ (lambda (ctx) (let ((result rc (run ctx "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path)))) (cond - ((zero? rc) (parse-stat-result (first result))) - ((string-contains? (first result) "No such file or directory") #f) + ((zero? rc) (parse-stat-result (first result))) + ((string-contains (first result) "No such file or directory") #f) (else (error (format #f "stat ~a: ~a" path (first result)))))))) + +(define* (action:remove path #:key (recurse? #f) (force? #f) (verbose? #t)) + (lambda (ctx) + (must ctx "rm" (chain-when '() + (verbose? (append _ '("-v"))) + (recurse? (append _ '("-r"))) + (force? (append _ '("-f"))) + (#t (append _ `(,path))))))) + +(define* (action:link target link-name #:key (symbolic? #f) (force? #f) (backup? #f)) + "Create a link to @code{target} with the name @code{link-name}." + (must ctx "ln" (chain-when '() + (symbolic? (append _ '("--symbolic"))) + (force? (append _ '("--force"))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append `(,target ,link-name)))))) + +(define* (action:create-tmp-dir #:key tmpdir suffix template) + (lambda (ctx) + (match-let (((tmp-dir) (must ctx "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template))))))) + tmp-dir))) + +(define* (action:install-dir path #:key owner group mode) + (lambda (ctx) + ;; If owner/group/mode is unspecified and the destination directory already exists, + ;; preserve the current ownership and mode. + (unless (and owner group mode) + (let ((st ((action:stat path) ctx))) + (when st + (set! owner (or owner (assoc-ref st 'user))) + (set! group (or group (assoc-ref st 'group))) + (set! mode (or mode (assoc-ref st 'mode)))))) + (when (integer? mode) + (set! mode (number->string mode 8))) + (must ctx "install" (chain-when + '("--directory") + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (#t (append _ `(,path))))) + path)) + +(define (upload-tmp-file ctx tmp-file) + (lambda (input-port) + (connection-call-with-output-file (context-connection ctx) tmp-file + (lambda (output-port) + (let loop ((data (get-bytevector-some input-port))) + (unless (eof-object? data) + (put-bytevector output-port data) + (loop (get-bytevector-some input-port)))) + (close-port output-port))))) + +(define (install-remote-file ctx src dest owner group mode backup?) + ;; If owner/group/mode is unspecified and the destination file already exists, + ;; preserve the current ownership and mode. + (unless (and owner group mode) + (let ((st ((action:stat dest) ctx))) + (when st + (set! owner (or owner (assoc-ref st 'owner))) + (set! group (or group (assoc-ref st 'group))) + (set! mode (or mode (assoc-ref st 'mode)))))) + (when (integer? mode) + (set! mode (number->string mode 8))) + (must ctx "install" (chain-when + '() + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append _ (list src dest)))))) + +(define* (action:install-file path #:key owner group mode content local-src remote-src backup?) + (when (not (= 1 (length (filter identity (list content local-src remote-src))))) + (error "exactly one of #:content, #:local-src, or #:remote-src is required")) + (lambda (ctx) + (if remote-src + (install-remote-file ctx remote-src path owner group mode backup?) + ;; Because we might need sudo to install the remote file, we first + ;; upload the source to a temporary file, then call @code{install-remote-file} to + ;; install the temporary file to the target path. + (match-let (((tmp-file) (must ctx "mktemp" '()))) + (dynamic-wind + (const #t) + (lambda () + (cond + (local-src (call-with-input-file local-src (upload-tmp-file ctx tmp-file))) + ((string? content) (call-with-input-string content (upload-tmp-file ctx tmp-file))) + ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx tmp-file))) + (else (error "unsupported type for #:content"))) + (install-remote-file ctx tmp-file path owner group mode backup?)) + (lambda () + ((action:remove tmp-file #:force? #t) ctx))))) + path)) From 2e03da3e01ed75a398508518cace74a5e750fa96 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 10 Jan 2025 16:03:45 +0000 Subject: [PATCH 29/83] Get rid of scratch-dir from context Leave it to the actions to deal with their own temporary file clean-up. --- modules/ordo/context.scm | 3 --- modules/ordo/play.scm | 18 ++++++------------ 2 files changed, 6 insertions(+), 15 deletions(-) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm index 1da0015..06512b1 100644 --- a/modules/ordo/context.scm +++ b/modules/ordo/context.scm @@ -7,8 +7,6 @@ #:export (make-context context? context-connection - context-scratch-dir - set-context-scratch-dir! add-context-triggers! get-context-triggers context-triggered? @@ -22,7 +20,6 @@ (make-context connection vars) context? (connection context-connection) - (scratch-dir context-scratch-dir set-context-scratch-dir!) (vars context-vars set-context-vars!) (triggers context-triggers set-context-triggers!)) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index 8d0450c..c04be7a 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -62,16 +62,10 @@ (play-connection play) (lambda (c) (let* ((ctx (make-context c (play-vars play)))) - (set-context-scratch-dir! ctx (first (must ctx "mktemp" '("--directory")))) - (dynamic-wind - (const #t) - (lambda () - (for-each (cut run-task ctx <>) (play-tasks play)) - (for-each (match-lambda - ((name . handler) - (when (context-triggered? ctx name) - (run-handler ctx handler)))) - (play-handlers play))) - (lambda () - (must ctx "rm" `("-rf" ,(context-scratch-dir ctx)))))))) + (for-each (cut run-task ctx <>) (play-tasks play)) + (for-each (match-lambda + ((name . handler) + (when (context-triggered? ctx name) + (run-handler ctx handler)))) + (play-handlers play))))) (format #t "COMPLETED PLAY ~a~%" (play-description play))) From 145d01b17e3247eac2178198478b3e0047840787 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 10 Jan 2025 16:04:18 +0000 Subject: [PATCH 30/83] Add action: prefix to demo playbook --- tryme.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tryme.scm b/tryme.scm index ca81cf1..5223a7e 100644 --- a/tryme.scm +++ b/tryme.scm @@ -18,14 +18,14 @@ (task "Create test directory" (bind-context-vars (base-dir) - (install-directory base-dir))) + (action:install-dir base-dir))) (task "Create test file from string content" (bind-context-vars (base-dir) - (install-file (file-name-join* base-dir "foo") #:content "Hello, world!\n")) + (action:install-file (file-name-join* base-dir "foo") #:content "Hello, world!\n" #:mode #o600)) #:register 'foo) (task "Get file status" - (bind-context-vars (foo) (fs:stat foo)) + (bind-context-vars (foo) (action:stat foo)) #:register 'stat-out #:triggers '(display-stat))) #:handlers `((display-stat . ,(handler "Display stat" From 09e4f6d80678a4044e6f5de1e541ad6167c671a0 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 10 Jan 2025 16:53:26 +0000 Subject: [PATCH 31/83] Add apt actions --- modules/ordo/action/apt.scm | 51 +++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) create mode 100644 modules/ordo/action/apt.scm diff --git a/modules/ordo/action/apt.scm b/modules/ordo/action/apt.scm new file mode 100644 index 0000000..7cb7fd4 --- /dev/null +++ b/modules/ordo/action/apt.scm @@ -0,0 +1,51 @@ +(define-module (ordo action apt) + #:use-module (ordo context)) + +(define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive") + ("APT_LISTCHANGES_FRONTEND" . "none"))) + +(define (apt-get . args) + (lambda (ctx) + (must ctx "apt-get" (cons* "-q" "-y" args) #:env noninteractive-env))) + +(define-public (action:apt-update) + (apt-get "update")) + +(define-public (action:apt-upgrade) + (apt-get "upgrade")) + +(define-public (action:apt-dist-upgrade) + (apt-get "dist-upgrade")) + +(define-public (action:apt-install package-name) + (apt-get "install" package-name)) + +(define-public (action:apt-install-minimal package-name) + (apt-get "install" "--no-install-recommends" package-name)) + +(define-public (action:apt-reinstall package-name) + (apt-get "reinstall" package-name)) + +(define-public (action:apt-remove package-name) + (apt-get "remove" package-name)) + +(define-public (action:apt-purge package-name) + (apt-get "purge" package-name)) + +(define-public (action:apt-build-dep package-name) + (apt-get "build-dep" package-name)) + +(define-public (action:apt-clean) + (apt-get "clean")) + +(define-public (action:apt-autoclean) + (apt-get "autoclean")) + +(define-public (action:apt-distclean) + (apt-get "distclean")) + +(define-public (action:apt-autoremove) + (apt-get "autoremove")) + +(define-public (action:apt-autopurge) + (apt-get "autoperge")) From b19eaf10074004a829891eabc35e6fb14598cab9 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 10 Jan 2025 16:53:35 +0000 Subject: [PATCH 32/83] Add task conditions --- modules/ordo/condition.scm | 38 ++++++++++++++++++++++++++++++++++++++ modules/ordo/task.scm | 25 +++++++++++++++---------- 2 files changed, 53 insertions(+), 10 deletions(-) create mode 100644 modules/ordo/condition.scm diff --git a/modules/ordo/condition.scm b/modules/ordo/condition.scm new file mode 100644 index 0000000..caee868 --- /dev/null +++ b/modules/ordo/condition.scm @@ -0,0 +1,38 @@ +(define-module (ordo condition) + #:use-moudle (ordo context) + #:use-module (ordo action filesystem)) + +(define (cond:any preds) + (lambda (ctx) + (let loop ((preds preds)) + (if (null? preds) + #f + (let ((p (car preds))) + (if (p ctx) + #t + (loop (cdr preds)))))))) + +(define (cond:every preds) + (lambda (ctx) + (let loop ((preds preds)) + (if (null? preds) + #t + (let ((p (car preds))) + (if (p ctx) + (loop (cdr preds)) + #f)))))) + +(define (cond:command-available? cmd-name) + (lambda (ctx) + (let ((_ rc) (run "which" `(,cmd-name))) + (zero? rc)))) + +(define (cond:directory? path) + (lambda (ctx) + (let ((st ((action:stat path) ctx))) + (and st (string=? "directory" (assoc-ref st 'file-type)))))) + +(define (cond:regular-file? path) + (lambda (ctx) + (let ((st ((action:stat path) ctx))) + (and st (string=? "regular-file" (assoc-ref st 'file-type)))))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index a307d0a..fa3f694 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -7,28 +7,33 @@ #:export (task task? task-description + task-condition task-action task-register task-triggers run-task)) (define-record-type - (make-task description action register triggers) + (make-task description condition action register triggers) task? (description task-description) + (condition task-condition) (action task-action) (register task-register) (triggers task-triggers)) -(define* (task description action #:key (register #f) (triggers '())) - (make-task description action register triggers)) +(define* (task description action #:key (condition (const #t)) (register #f) (triggers '())) + (make-task description condition action register triggers)) (define (run-task ctx t) (match t - (($ description action register triggers) - (format #t "RUNNING TASK ~a~%" description) - (let ((result (action ctx))) - (when register - (register-context-var! ctx register result)) - (when triggers - (add-context-triggers! ctx triggers)))))) + (($ description condition action register triggers) + (if (not (condition ctx)) + (format #t "SKIPPING TASK ~a (precondition not met)~%" description) + (begin + (format #t "RUNNING TASK ~a~%" description) + (let ((result (action ctx))) + (when register + (register-context-var! ctx register result)) + (when triggers + (add-context-triggers! ctx triggers)))))))) From 875ce167e93f856cab8ed87e1b7e48164df56ce0 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 10 Jan 2025 17:22:44 +0000 Subject: [PATCH 33/83] Setup logging --- modules/ordo/action/filesystem.scm | 1 + modules/ordo/handler.scm | 3 ++- modules/ordo/logger.scm | 24 ++++++++++++++++++++++++ modules/ordo/play.scm | 9 +++++++-- modules/ordo/task.scm | 9 ++++++--- 5 files changed, 40 insertions(+), 6 deletions(-) create mode 100644 modules/ordo/logger.scm diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 12a940a..eaac534 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -1,6 +1,7 @@ (define-module (ordo action filesystem) #:use-module (ice-9 binary-ports) #:use-module (ice-9 match) + #:use-module (logging logger) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-26) ; cut diff --git a/modules/ordo/handler.scm b/modules/ordo/handler.scm index a7ddf41..ab7ec91 100644 --- a/modules/ordo/handler.scm +++ b/modules/ordo/handler.scm @@ -1,5 +1,6 @@ (define-module (ordo handler) #:use-module (ice-9 match) + #:use-module (logging logger) #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-9) ; records #:use-module (srfi srfi-26) ; cut @@ -21,5 +22,5 @@ (define (run-handler ctx h) (match h (($ description action) - (format #t "RUNNING HANDLER ~a~%" description) + (log-msg 'NOTICE "Running handler: " description) (action ctx)))) diff --git a/modules/ordo/logger.scm b/modules/ordo/logger.scm new file mode 100644 index 0000000..fd0c206 --- /dev/null +++ b/modules/ordo/logger.scm @@ -0,0 +1,24 @@ +(define-module (ordo logger) + #:use-module (oop goops) + #:use-module ((srfi srfi-1) #:select (take-while drop-while)) + #:use-module ((srfi srfi-26) #:select (cut)) + #:use-module (logging logger) + #:use-module (logging port-log) + #:export (setup-logging + shutdown-logging)) + +(define log-levels '(TRACE DEBUG INFO NOTICE WARN ERROR)) + +(define* (setup-logging #:key (level 'INFO)) + (let ((logger (make )) + (handler (make #:port (current-error-port)))) + (for-each (cut disable-log-level! handler <>) + (take-while (negate (cut equal? level <>)) log-levels)) + (add-handler! logger handler) + (set-default-logger! logger) + (open-log! logger))) + +(define (shutdown-logging) + (flush-log) ; since no args, it uses the default + (close-log!) ; ditto + (set-default-logger! #f)) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index c04be7a..87f1ae9 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -1,6 +1,7 @@ (define-module (ordo play) #:use-module (oop goops) #:use-module (ice-9 match) + #:use-module (logging logger) #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-9) ; records #:use-module (srfi srfi-26) ; cut @@ -8,6 +9,7 @@ #:use-module (ordo context) #:use-module (ordo task) #:use-module (ordo handler) + #:use-module (ordo logger) #:export (play run-play)) (define-record-type @@ -57,7 +59,9 @@ (make-play description connection (fold (match-lambda* (((k . v) accum) (alist-cons k v accum))) '() vars) tasks handlers)) (define (run-play play) - (format #t "RUNNING PLAY ~a~%" (play-description play)) + ;; TODO move logging setup and shutdown to a higher level when we implement playbook etc. + (setup-logging) + (log-msg 'NOTICE "Running play: " (play-description play)) (call-with-connection (play-connection play) (lambda (c) @@ -68,4 +72,5 @@ (when (context-triggered? ctx name) (run-handler ctx handler)))) (play-handlers play))))) - (format #t "COMPLETED PLAY ~a~%" (play-description play))) + (log-msg 'NOTICE "Completed play: " (play-description play)) + (shutdown-logging)) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index fa3f694..e1db8e0 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -1,5 +1,6 @@ (define-module (ordo task) #:use-module (ice-9 match) + #:use-module (logging logger) #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-9) ; records #:use-module (srfi srfi-26) ; cut @@ -29,11 +30,13 @@ (match t (($ description condition action register triggers) (if (not (condition ctx)) - (format #t "SKIPPING TASK ~a (precondition not met)~%" description) + (log-msg 'NOTICE "Skipping task: " description " (precondition not met)") (begin - (format #t "RUNNING TASK ~a~%" description) + (log-msg 'NOTICE "Running task: " description) (let ((result (action ctx))) (when register + (log-msg 'INFO "Registering result " register) (register-context-var! ctx register result)) - (when triggers + (when (and triggers (not (null? triggers))) + (log-msg 'INFO "Scheduling triggers " triggers) (add-context-triggers! ctx triggers)))))))) From dba8ca3153bd169269ffebcbdebd150dec828468 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 10 Jan 2025 17:31:11 +0000 Subject: [PATCH 34/83] Test (and bugfix) conditions --- modules/ordo/condition.scm | 15 ++++++++------- tryme.scm | 6 ++++-- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/modules/ordo/condition.scm b/modules/ordo/condition.scm index caee868..4834ab6 100644 --- a/modules/ordo/condition.scm +++ b/modules/ordo/condition.scm @@ -1,8 +1,9 @@ (define-module (ordo condition) - #:use-moudle (ordo context) + #:use-module (srfi srfi-71) + #:use-module (ordo context) #:use-module (ordo action filesystem)) -(define (cond:any preds) +(define-public (cond:any preds) (lambda (ctx) (let loop ((preds preds)) (if (null? preds) @@ -12,7 +13,7 @@ #t (loop (cdr preds)))))))) -(define (cond:every preds) +(define-public (cond:every preds) (lambda (ctx) (let loop ((preds preds)) (if (null? preds) @@ -22,17 +23,17 @@ (loop (cdr preds)) #f)))))) -(define (cond:command-available? cmd-name) +(define-public (cond:command-available? cmd-name) (lambda (ctx) - (let ((_ rc) (run "which" `(,cmd-name))) + (let ((_ rc (run "which" `(,cmd-name)))) (zero? rc)))) -(define (cond:directory? path) +(define-public (cond:directory? path) (lambda (ctx) (let ((st ((action:stat path) ctx))) (and st (string=? "directory" (assoc-ref st 'file-type)))))) -(define (cond:regular-file? path) +(define-public (cond:regular-file? path) (lambda (ctx) (let ((st ((action:stat path) ctx))) (and st (string=? "regular-file" (assoc-ref st 'file-type)))))) diff --git a/tryme.scm b/tryme.scm index 5223a7e..e8fe0a0 100644 --- a/tryme.scm +++ b/tryme.scm @@ -1,7 +1,8 @@ (use-modules (ice-9 filesystem) + (ordo condition) (ordo connection) - (ordo context ) + (ordo context) (ordo action filesystem) (ordo play) (ordo task) @@ -18,7 +19,8 @@ (task "Create test directory" (bind-context-vars (base-dir) - (action:install-dir base-dir))) + (action:install-dir base-dir)) + #:condition (bind-context-vars (base-dir) (negate (cond:directory? base-dir)))) (task "Create test file from string content" (bind-context-vars (base-dir) From 31bd78abb11ccc82ec2d02c82aa4364ceb035125 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 10 Jan 2025 17:41:11 +0000 Subject: [PATCH 35/83] Reformat to avoid long lines --- tryme.scm | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/tryme.scm b/tryme.scm index e8fe0a0..6ac494b 100644 --- a/tryme.scm +++ b/tryme.scm @@ -20,18 +20,25 @@ (bind-context-vars (base-dir) (action:install-dir base-dir)) - #:condition (bind-context-vars (base-dir) (negate (cond:directory? base-dir)))) + #:condition (bind-context-vars + (base-dir) + (negate (cond:directory? base-dir)))) (task "Create test file from string content" (bind-context-vars (base-dir) - (action:install-file (file-name-join* base-dir "foo") #:content "Hello, world!\n" #:mode #o600)) + (action:install-file (file-name-join* base-dir "foo") + #:content "Hello, world!\n" + #:mode #o600)) #:register 'foo) (task "Get file status" - (bind-context-vars (foo) (action:stat foo)) + (bind-context-vars + (foo) + (action:stat foo)) #:register 'stat-out #:triggers '(display-stat))) #:handlers `((display-stat . ,(handler "Display stat" - (bind-context-vars (foo stat-out) (lambda _ (pk foo stat-out)))))))) - + (bind-context-vars + (foo stat-out) + (lambda _ (pk foo stat-out)))))))) (run-play test-play) From a65415f846bb245076e3eb069684559a9b0a7541 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 11 Jan 2025 15:22:45 +0000 Subject: [PATCH 36/83] Experiment with interceptor chains --- modules/ordo/interceptor.scm | 207 +++++++++++++++++++++++++++++++++++ tryme-interceptors.scm | 55 ++++++++++ 2 files changed, 262 insertions(+) create mode 100644 modules/ordo/interceptor.scm create mode 100644 tryme-interceptors.scm diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm new file mode 100644 index 0000000..0e60674 --- /dev/null +++ b/modules/ordo/interceptor.scm @@ -0,0 +1,207 @@ +(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-69) ; hash tables + #:use-module (srfi srfi-71) ; extended let + #:use-module (ordo connection) + #:export (interceptor + init-context + context-error + set-context-error! + context-suppressed + terminate-when + execute + bind + unbind + run + must)) + +(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) + "Create an interceptor with optional enter, leave, and error functions." + (make-interceptor name enter leave error)) + +(define-record-type + (make-context connection 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 conn #:key (vars '())) + "Initialize a context with optional vars." + (make-context + ;; connection + conn + ;; vars + (alist->hash-table vars equal?) + ;; stack + '() + ;; queue + '() + ;; terminators + '() + ;; error + #f + ;; suppressed errors + '())) + +(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 'INFO "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 'INFO "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 'INFO "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 (context-error 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." + (unless (null? (context-queue 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 execute the leave phase + (begin + (set-context-queue! ctx (context-stack ctx)) + (set-context-stack! ctx '()) + (execute-leave 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." + (enqueue ctx interceptors) + (execute-enter ctx) + (execute-leave ctx)) + +(define-syntax bind + (syntax-rules () + ((bind ctx name value) + (hash-table-set! (context-vars ctx) (quote name) value)))) + +(define-syntax unbind + (syntax-rules () + ((unbind ctx name) + (hash-table-ref (context-vars ctx) (quote name))) + ((unbind ctx name default) + (hash-table-ref/default (context-vars ctx) (quote name) default)))) + +(define (keyword-arg kw args) + (cond + ((< (length args) 2) #f) + ((equal? (first args) kw) (second args)) + (else (keyword-arg kw (cddr args))))) + +(define (run ctx prog . args) + (let* ((args kwargs (break keyword? args)) + (pwd (keyword-arg #:pwd kwargs)) + (env (keyword-arg #:env kwargs))) + (connection-run (context-connection ctx) pwd env prog args))) + +(define (must ctx prog . args) + (let* ((args kwargs (break keyword? args)) + (pwd (keyword-arg #:pwd kwargs)) + (env (keyword-arg #:env kwargs)) + (error-msg (keyword-arg #:error-msg kwargs)) + (out rc (connection-run (context-connection ctx) pwd env prog args))) + (if (zero? rc) + out + (error (if error-msg + (format #f "~a: ~a" error-msg out) + (format #f "~a error: ~a" prog out)))))) diff --git a/tryme-interceptors.scm b/tryme-interceptors.scm new file mode 100644 index 0000000..00a8ded --- /dev/null +++ b/tryme-interceptors.scm @@ -0,0 +1,55 @@ +(use-modules + (ice-9 filesystem) + (logging logger) + (srfi srfi-9) + (ordo connection) + (ordo interceptor) + (ordo logger)) + +(define-record-type + (make-play name connection vars interceptors) + play? + (connection play-connection) + (vars play-vars) + (name play-name) + (interceptors play-interceptors)) + +(define* (play #:key name connection (interceptors '()) (vars '())) + (make-play name connection vars interceptors)) + +(define (run-play play) + (dynamic-wind + (lambda () + (log-msg 'NOTICE "Running play: " (play-name play)) + (init-connection! (play-connection play))) + (lambda () + (let ((ctx (init-context (play-connection play) #:vars (play-vars play)))) + (execute ctx (play-interceptors play)) + (if (context-error ctx) + (log-msg 'ERROR "Play " (play-name play) " terminated with error: " (context-error ctx)) + (log-msg 'NOTICE "Completed play: " (play-name play))))) + (lambda () + (close-connection! (play-connection play))))) + +(define test-play + (play + #:name "Test play" + #:connection (local-connection) + #:vars '((base-dir . "/home/ray/ordo-test")) + #:interceptors (list + (interceptor + "Handle errors" + #:error (lambda (ctx err) + (log-msg 'WARN "Handling error " err) + (set-context-error! ctx #f))) + (interceptor + "Create base directory" + #:enter (lambda (ctx) + (must ctx "mkdir" "-p" (unbind ctx base-dir)))) + (interceptor + "Create test file" + #:enter (lambda (ctx) + (must ctx "touch" (file-name-join* (unbind ctx base-dir) "test-file")))) + (interceptor + "Throw an error" + #:enter (lambda (ctx) (error "badness")))))) From 04a75984cbc865b89ab639670040ff3692803e99 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 11 Jan 2025 21:00:24 +0000 Subject: [PATCH 37/83] Refactor to use a core namespace with global vars --- modules/ordo.scm | 167 ++++++++++++++++++++++++++++++++++++ modules/ordo/connection.scm | 43 ++++++++-- tryme.scm | 58 ++++--------- 3 files changed, 222 insertions(+), 46 deletions(-) create mode 100644 modules/ordo.scm diff --git a/modules/ordo.scm b/modules/ordo.scm new file mode 100644 index 0000000..8a95faa --- /dev/null +++ b/modules/ordo.scm @@ -0,0 +1,167 @@ +(define-module (ordo) + #:use-module (ice-9 exceptions) + #:use-module (logging logger) + #:use-module (oop goops) + #:use-module (srfi srfi-1) ; list utils + #:use-module (srfi srfi-26) ; cut + #:use-module (srfi srfi-69) ; hash-tables + #:use-module (ordo connection) + #:export (task + act + play + playbook + $ + register-act-var + register-play-var + register-playbook-var + perform)) + +(define +filter-tags+ '()) + +(define (check-tags tags) + (or (null? +filter-tags+) + (not (null? (lset-intersection eqv? +filter-tags+ tags))))) + +(define +playbook-vars+ #f) + +(define +play-vars+ #f) + +(define +act-vars+ #f) + +(define (register-act-var var-name) + (lambda (v) + (log-msg 'DEBUG "Registering act variable " var-name) + (hash-table-set! +act-vars+ var-name v))) + +(define (register-play-var var-name) + (lambda (v) + (log-msg 'DEBUG "Registering play variable " var-name) + (hash-table-set! +play-vars+ var-name v))) + +(define (register-playbook-var var-name) + (lambda (v) + (log-msg 'DEBUG "Registering playbook variable " var-name) + (hash-table-set! +playbook-vars+ var-name v))) + +(define ($ var-name) + "Try to resolve var-name as an act variable, a play variable, or a playbook +variable (in that order). Raise an exception if the variable is not found." + (define not-found (cons 'not-found '())) + (define (lookup-var var-name vars) + (cond + ((null? vars) + (raise-exception (make-exception + (make-undefined-variable-error) + (make-exception-with-irritants var-name)))) + ((not (car vars)) (lookup-var var-name (cdr vars))) + (else (let ((v (hash-table-ref/default (car vars) var-name not-found))) + (if (eqv? v not-found) + (lookup-var var-name (cdr vars)) + v))))) + (lookup-var var-name (list +act-vars+ +play-vars+ +playbook-vars+))) + +(define-class () + (name #:init-keyword #:name #:getter task-name) + (tags #:init-keyword #:tags #:getter task-tags #:init-form '()) + (action #:init-keyword #:action #:getter task-action) + (condition #:init-keyword #:condition #:getter task-condition) + (register #:init-keyword #:register #:getter task-register) + (triggers #:init-keyword #:triggers #:getter task-triggers)) + +(define (task . args) (apply make args)) + +(define-method (check-condition (t ) (c )) + (if (slot-bound? t 'condition) + ((task-condition t) c) + #t)) + +(define-method (perform (t ) (c )) + (when (check-tags (task-tags t)) + (if (not (check-condition t c)) + (log-msg 'NOTICE "Skipping task " (task-name t) " (precondition not met)") + (begin + (log-msg 'NOTICE "Performing task " (task-name t)) + (let ((result ((task-action t) c))) + (when (slot-bound? t 'register) + ((task-register t) result)) + (when (slot-bound? t 'triggers) + (for-each (lambda (f) (f)) (task-triggers t)))))))) + +(define-class () + (name #:init-keyword #:name #:getter act-name) + (tags #:init-keyword #:tags #:getter act-tags #:init-form '()) + (vars #:init-keyword #:vars #:getter act-vars) + (condition #:init-keyword #:condition #:getter act-condition) + (tasks #:init-keyword #:tasks #:getter act-tasks) + (handlers #:init-keyword #:handlers #:getter act-handlers)) + +(define (act . args) (apply make args)) + +(define-method (check-condition (a ) (c )) + (if (slot-bound? a 'condition) + ((act-condition a) c) + #t)) + +(define-method (perform (a ) (c )) + (when (check-tags (act-tags a)) + (if (not (check-condition a c)) + (log-msg 'NOTICE "Skipping act " (act-name a) " (precondition not met") + (begin + (log-msg 'NOTICE "Performing act " (act-name a)) + (dynamic-wind + (lambda () + (when (slot-bound? a 'vars) + (set! +act-vars+ (alist->hash-table (act-vars a) equal?)))) + (lambda () + (for-each (cut perform <> c) (act-tasks a)) + ;; TODO: run any triggered handlers + ) + (lambda () + (set! +act-vars+ #f))))))) + +(define-class () + (name #:init-keyword #:name #:getter play-name) + (tags #:init-keyword #:tags #:getter play-tags #:init-form '()) + (vars #:init-keyword #:vars #:getter play-vars) + (connection #:init-keyword #:connection #:getter play-connection) + (acts #:init-keyword #:acts #:getter play-acts)) + +(define (play . args) (apply make args)) + +(define-method (perform (p )) + (when (check-tags (play-tags p)) + (log-msg 'NOTICE "Performing play " (play-name p)) + (dynamic-wind + (lambda () + (when (slot-bound? p 'vars) + (set! +play-vars+ (alist->hash-table (play-vars p) equal?))) + (init-connection! (play-connection p))) + (lambda () + (for-each (cut perform <> (play-connection p)) (play-acts p)) + ;; TODO: run any triggered handlers + ) + (lambda () + (set! +play-vars+ #f) + (close-connection! (play-connection p)))))) + +(define-class () + (name #:init-keyword #:name #:getter playbook-name) + (vars #:init-keyword #:vars #:getter playbook-vars) + (plays #:init-keyword #:plays #:getter playbook-plays)) + +(define (playbook . args) (apply make args)) + +(define-method (perform (pb ) (filter-tags )) + (log-msg 'NOTICE "Performing playbook " (playbook-name pb)) + (dynamic-wind + (lambda () + (set! +filter-tags+ filter-tags) + (when (slot-bound? pb 'vars) + (set! +playbook-vars+ (alist->hash-table (playbook-vars pb) equal?)))) + (lambda () + (for-each perform (playbook-plays pb))) + (lambda () + (set! +filter-tags+ '()) + (set! +playbook-vars+ #f)))) + +;; TODO: add validate methods for , , , and diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index afde8d6..b590395 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -19,7 +19,11 @@ connection-run connection-call-with-input-file connection-call-with-output-file - call-with-connection)) + call-with-connection + must + run + must1 + run1)) (define-class () (sudo #:getter sudo? #:init-keyword #:sudo)) @@ -74,12 +78,6 @@ (loop (read-line port) (cons line result)))) (loop (read-line port) '())) -(define (kw-arg kw kwargs) - (cond - ((null? (kwargs)) #f) - ((equal? (car kwargs) kw) (cadr kwargs)) - (else (kw-arg kw (cddr kwargs))))) - (define-method (build-command (c ) pwd env prog args) (let ((cmd (list (if (sudo? c) "sudo" "env")))) (chain-when cmd @@ -123,3 +121,34 @@ (lambda () (init-connection! c)) (lambda () (proc c)) (lambda () (close-connection! c)))) + +(define (keyword-arg kw args) + (cond + ((< (length args) 2) #f) + ((equal? (first args) kw) (second args)) + (else (keyword-arg kw (cddr args))))) + +(define (run conn prog . args) + (let* ((args kwargs (break keyword? args)) + (pwd (keyword-arg #:pwd kwargs)) + (env (keyword-arg #:env kwargs))) + (connection-run conn pwd env prog args))) + +(define (run1 . args) + (let ((out rc (apply run args))) + (values (first out) rc))) + +(define (must conn prog . args) + (let* ((args kwargs (break keyword? args)) + (pwd (keyword-arg #:pwd kwargs)) + (env (keyword-arg #:env kwargs)) + (error-msg (keyword-arg #:error-msg kwargs)) + (out rc (connection-run conn pwd env prog args))) + (if (zero? rc) + out + (error (if error-msg + (format #f "~a: ~a" error-msg out) + (format #f "~a error: ~a" prog out)))))) + +(define (must1 . args) + (first (apply must args))) diff --git a/tryme.scm b/tryme.scm index 6ac494b..8430a66 100644 --- a/tryme.scm +++ b/tryme.scm @@ -1,44 +1,24 @@ (use-modules (ice-9 filesystem) - (ordo condition) + (ordo) (ordo connection) - (ordo context) - (ordo action filesystem) - (ordo play) - (ordo task) - (ordo handler)) + (ordo logger)) -(define test-play - (play "Test play" - #:connection (local-connection) - #:vars '((base-dir . "/home/ray/ordo-test")) - #:tasks (list - (task "Override base dir" - (const "/home/ray/ordo-test-again") - #:register 'base-dir) - (task "Create test directory" - (bind-context-vars - (base-dir) - (action:install-dir base-dir)) - #:condition (bind-context-vars - (base-dir) - (negate (cond:directory? base-dir)))) - (task "Create test file from string content" - (bind-context-vars - (base-dir) - (action:install-file (file-name-join* base-dir "foo") - #:content "Hello, world!\n" - #:mode #o600)) - #:register 'foo) - (task "Get file status" - (bind-context-vars - (foo) - (action:stat foo)) - #:register 'stat-out - #:triggers '(display-stat))) - #:handlers `((display-stat . ,(handler "Display stat" - (bind-context-vars - (foo stat-out) - (lambda _ (pk foo stat-out)))))))) +(define test-playbook + (playbook + #:name "Test Playbook" + #:plays (list + (play + #:name "Test play" + #:connection (local-connection) + #:vars '((base-dir . "/home/ray/ordo-test")) + #:acts (list + (act #:name "Act I" + #:tasks (list + (task #:name "Create base directory" + #:action (lambda (c) (must c "mkdir" "-p" ($ 'base-dir)))) + (task #:name "Create test file" + #:action (lambda (c) (must c "touch" (file-name-join* ($ 'base-dir) "test-file"))))))))))) -(run-play test-play) +(setup-logging) +(perform test-playbook '()) From 35651090718fc9458375abd0598816725ce4c231 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 11 Jan 2025 21:21:48 +0000 Subject: [PATCH 38/83] Add trigger support --- modules/ordo.scm | 35 +++++++++++++++++++++++++---------- 1 file changed, 25 insertions(+), 10 deletions(-) diff --git a/modules/ordo.scm b/modules/ordo.scm index 8a95faa..f68a2ff 100644 --- a/modules/ordo.scm +++ b/modules/ordo.scm @@ -2,10 +2,10 @@ #:use-module (ice-9 exceptions) #:use-module (logging logger) #:use-module (oop goops) + #:use-module (ordo connection) #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-69) ; hash-tables - #:use-module (ordo connection) #:export (task act play @@ -22,9 +22,11 @@ (or (null? +filter-tags+) (not (null? (lset-intersection eqv? +filter-tags+ tags))))) -(define +playbook-vars+ #f) +(define +act-triggers+ #f) -(define +play-vars+ #f) +(define (add-act-triggers triggers) + (set! +act-triggers+ (apply lset-adjoin equal? (or +act-triggers+ '()) + triggers))) (define +act-vars+ #f) @@ -33,11 +35,15 @@ (log-msg 'DEBUG "Registering act variable " var-name) (hash-table-set! +act-vars+ var-name v))) +(define +play-vars+ #f) + (define (register-play-var var-name) (lambda (v) (log-msg 'DEBUG "Registering play variable " var-name) (hash-table-set! +play-vars+ var-name v))) +(define +playbook-vars+ #f) + (define (register-playbook-var var-name) (lambda (v) (log-msg 'DEBUG "Registering playbook variable " var-name) @@ -85,7 +91,13 @@ variable (in that order). Raise an exception if the variable is not found." (when (slot-bound? t 'register) ((task-register t) result)) (when (slot-bound? t 'triggers) - (for-each (lambda (f) (f)) (task-triggers t)))))))) + (add-act-triggers (task-triggers t)))))))) + +(define-class () + (name #:init-keyword #:name #:getter handler-name) + (action #:init-keyword #:action #:getter handler-action)) + +(define (handler . args) (apply make args)) (define-class () (name #:init-keyword #:name #:getter act-name) @@ -114,10 +126,15 @@ variable (in that order). Raise an exception if the variable is not found." (set! +act-vars+ (alist->hash-table (act-vars a) equal?)))) (lambda () (for-each (cut perform <> c) (act-tasks a)) - ;; TODO: run any triggered handlers - ) + (when (slot-bound? a 'handlers) + (for-each (lambda (h) + (when (member (handler-name h) +act-triggers+) + (log-msg 'INFO "Running handler " (handler-name h)) + ((handler-action h) c))) + (act-handlers a)))) (lambda () - (set! +act-vars+ #f))))))) + (set! +act-vars+ #f) + (set! +act-triggers+ #f))))))) (define-class () (name #:init-keyword #:name #:getter play-name) @@ -137,9 +154,7 @@ variable (in that order). Raise an exception if the variable is not found." (set! +play-vars+ (alist->hash-table (play-vars p) equal?))) (init-connection! (play-connection p))) (lambda () - (for-each (cut perform <> (play-connection p)) (play-acts p)) - ;; TODO: run any triggered handlers - ) + (for-each (cut perform <> (play-connection p)) (play-acts p))) (lambda () (set! +play-vars+ #f) (close-connection! (play-connection p)))))) From b0070af1fd1dd2d666243501526f8d899bca5ebb Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 12 Jan 2025 11:05:26 +0000 Subject: [PATCH 39/83] Fix typo in log message --- modules/ordo.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/ordo.scm b/modules/ordo.scm index f68a2ff..06b70ab 100644 --- a/modules/ordo.scm +++ b/modules/ordo.scm @@ -117,7 +117,7 @@ variable (in that order). Raise an exception if the variable is not found." (define-method (perform (a ) (c )) (when (check-tags (act-tags a)) (if (not (check-condition a c)) - (log-msg 'NOTICE "Skipping act " (act-name a) " (precondition not met") + (log-msg 'NOTICE "Skipping act " (act-name a) " (precondition not met)") (begin (log-msg 'NOTICE "Performing act " (act-name a)) (dynamic-wind From 70543ef7c5c9d40a75df97c5213eac32aa32c8db Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 12 Jan 2025 12:38:47 +0000 Subject: [PATCH 40/83] Checkpoint some refactoring --- modules/ordo/connection.scm | 48 +++++++++++++++-------------------- modules/ordo/util/flatten.scm | 10 ++++++++ tryme.scm | 19 ++++++++++++++ 3 files changed, 50 insertions(+), 27 deletions(-) create mode 100644 modules/ordo/util/flatten.scm diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index b590395..ad0e5ce 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -1,8 +1,11 @@ (define-module (ordo connection) #:use-module (oop goops) + #:use-module (ice-9 exceptions) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) - #:use-module (srfi srfi-1) ; list operations + #:use-module (logging logger) + #:use-module (srfi srfi-1) ; list operations + #:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module (ssh session) @@ -10,6 +13,7 @@ #:use-module (ssh auth) #:use-module (ssh popen) #:use-module (ssh sftp) + #:use-module (ordo util flatten) #:use-module (ordo util shell-quote) #:export ( local-connection @@ -20,10 +24,7 @@ connection-call-with-input-file connection-call-with-output-file call-with-connection - must - run - must1 - run1)) + run)) (define-class () (sudo #:getter sudo? #:init-keyword #:sudo)) @@ -122,33 +123,26 @@ (lambda () (proc c)) (lambda () (close-connection! c)))) -(define (keyword-arg kw args) +(define* (keyword-arg kw args #:optional (default #f)) (cond - ((< (length args) 2) #f) + ((< (length args) 2) default) ((equal? (first args) kw) (second args)) (else (keyword-arg kw (cddr args))))) (define (run conn prog . args) - (let* ((args kwargs (break keyword? args)) - (pwd (keyword-arg #:pwd kwargs)) - (env (keyword-arg #:env kwargs))) - (connection-run conn pwd env prog args))) - -(define (run1 . args) - (let ((out rc (apply run args))) - (values (first out) rc))) - -(define (must conn prog . args) - (let* ((args kwargs (break keyword? args)) + (let* ((args (flatten args)) + (args kwargs (break keyword? args)) + (args (remove unspecified? args)) (pwd (keyword-arg #:pwd kwargs)) (env (keyword-arg #:env kwargs)) - (error-msg (keyword-arg #:error-msg kwargs)) + (return (keyword-arg #:return kwargs identity)) + (check? (keyword-arg #:check? kwargs #t)) (out rc (connection-run conn pwd env prog args))) - (if (zero? rc) - out - (error (if error-msg - (format #f "~a: ~a" error-msg out) - (format #f "~a error: ~a" prog out)))))) - -(define (must1 . args) - (first (apply must args))) + (log-msg 'INFO "Command " prog " exited " rc) + (if check? + (if (zero? rc) + (return out) + (raise-exception (make-exception + (make-external-error) + (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog))))) + (values (return out) rc)))) diff --git a/modules/ordo/util/flatten.scm b/modules/ordo/util/flatten.scm new file mode 100644 index 0000000..a37c788 --- /dev/null +++ b/modules/ordo/util/flatten.scm @@ -0,0 +1,10 @@ +(define-module (ordo util flatten) + #:export (flatten)) + +(define (flatten lst) + (cond + ((null? lst) '()) + ((list? (car lst)) + (append (flatten (car lst)) (flatten (cdr lst)))) + (else + (cons (car lst) (flatten (cdr lst)))))) diff --git a/tryme.scm b/tryme.scm index 8430a66..8fc584a 100644 --- a/tryme.scm +++ b/tryme.scm @@ -1,9 +1,28 @@ (use-modules (ice-9 filesystem) + (logging logger) + (srfi srfi-26) (ordo) (ordo connection) (ordo logger)) +(define* (install-aws-cli conn #:key (url "https://awscli.amazonaws.com/awscli-exe-linux-x86_64.zip") update? install-dir bin-dir) + (let ((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 () + (for-each (cut log-msg 'INFO <>) + (run conn "echo" "rm" "-rf" tmp-dir #:check? #t)))))) + (define test-playbook (playbook #:name "Test Playbook" From 5376ce9f197af7231635cfb0669071238cfe6757 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 12 Jan 2025 15:28:29 +0000 Subject: [PATCH 41/83] Switch back to records, not goops --- modules/ordo.scm | 202 ++++++++++++++++-------------------- modules/ordo/connection.scm | 21 ++-- tryme.scm | 34 +++--- 3 files changed, 117 insertions(+), 140 deletions(-) diff --git a/modules/ordo.scm b/modules/ordo.scm index 06b70ab..3813bf1 100644 --- a/modules/ordo.scm +++ b/modules/ordo.scm @@ -1,20 +1,34 @@ (define-module (ordo) #:use-module (ice-9 exceptions) #:use-module (logging logger) - #:use-module (oop goops) #:use-module (ordo connection) #: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 #:export (task - act + task-name + task-tags + task-action + task-condition + task-register + task-triggers + run-task play + play-name + play-vars + play-tasks + play-connection + play-handlers + run-play playbook + playbook-name + playbook-vars + playbook-plays + run-playbook $ - register-act-var register-play-var - register-playbook-var - perform)) + register-playbook-var)) (define +filter-tags+ '()) @@ -22,19 +36,6 @@ (or (null? +filter-tags+) (not (null? (lset-intersection eqv? +filter-tags+ tags))))) -(define +act-triggers+ #f) - -(define (add-act-triggers triggers) - (set! +act-triggers+ (apply lset-adjoin equal? (or +act-triggers+ '()) - triggers))) - -(define +act-vars+ #f) - -(define (register-act-var var-name) - (lambda (v) - (log-msg 'DEBUG "Registering act variable " var-name) - (hash-table-set! +act-vars+ var-name v))) - (define +play-vars+ #f) (define (register-play-var var-name) @@ -50,7 +51,7 @@ (hash-table-set! +playbook-vars+ var-name v))) (define ($ var-name) - "Try to resolve var-name as an act variable, a play variable, or a playbook + "Try to resolve var-name as a play variable or a playbook variable (in that order). Raise an exception if the variable is not found." (define not-found (cons 'not-found '())) (define (lookup-var var-name vars) @@ -64,119 +65,98 @@ variable (in that order). Raise an exception if the variable is not found." (if (eqv? v not-found) (lookup-var var-name (cdr vars)) v))))) - (lookup-var var-name (list +act-vars+ +play-vars+ +playbook-vars+))) + (lookup-var var-name (list +play-vars+ +playbook-vars+))) -(define-class () - (name #:init-keyword #:name #:getter task-name) - (tags #:init-keyword #:tags #:getter task-tags #:init-form '()) - (action #:init-keyword #:action #:getter task-action) - (condition #:init-keyword #:condition #:getter task-condition) - (register #:init-keyword #:register #:getter task-register) - (triggers #:init-keyword #:triggers #:getter task-triggers)) +(define +triggers+ #f) -(define (task . args) (apply make args)) +(define (add-triggers triggers) + (set! +triggers+ (apply lset-adjoin equal? (or +triggers+ '()) + triggers))) -(define-method (check-condition (t ) (c )) - (if (slot-bound? t 'condition) - ((task-condition t) c) - #t)) +(define-record-type + (make-task name tags action condition register triggers) + task? + (name task-name) + (tags task-tags) + (action task-action) + (condition task-condition) + (register task-register) + (triggers task-triggers)) -(define-method (perform (t ) (c )) +(define* (task name action #:key (tags '()) (condition (const #t)) (register (const #f)) (triggers '())) + (make-task name tags action condition register triggers)) + +(define (run-task t c) (when (check-tags (task-tags t)) - (if (not (check-condition t c)) + (if (not ((task-condition t) c)) (log-msg 'NOTICE "Skipping task " (task-name t) " (precondition not met)") (begin - (log-msg 'NOTICE "Performing task " (task-name t)) + (log-msg 'NOTICE "Running task " (task-name t)) (let ((result ((task-action t) c))) - (when (slot-bound? t 'register) - ((task-register t) result)) - (when (slot-bound? t 'triggers) - (add-act-triggers (task-triggers t)))))))) + ((task-register t) result) + (add-triggers (task-triggers t))))))) -(define-class () - (name #:init-keyword #:name #:getter handler-name) - (action #:init-keyword #:action #:getter handler-action)) +(define-record-type + (make-handler name action) + handler? + (name handler-name) + (action handler-action)) -(define (handler . args) (apply make args)) +(define (handler name action) + (make-handler name action)) -(define-class () - (name #:init-keyword #:name #:getter act-name) - (tags #:init-keyword #:tags #:getter act-tags #:init-form '()) - (vars #:init-keyword #:vars #:getter act-vars) - (condition #:init-keyword #:condition #:getter act-condition) - (tasks #:init-keyword #:tasks #:getter act-tasks) - (handlers #:init-keyword #:handlers #:getter act-handlers)) +(define-record-type + (make-play name connection vars tasks handlers) + play? + (name play-name) + (connection play-connection) + (vars play-vars) + (tasks play-tasks) + (handlers play-handlers)) -(define (act . args) (apply make args)) +(define* (play name #:key connection (vars '()) . more) + (let ((tasks (filter task? more)) + (handlers (filter handler? more))) + (make-play name connection vars tasks handlers))) -(define-method (check-condition (a ) (c )) - (if (slot-bound? a 'condition) - ((act-condition a) c) - #t)) +(define (run-play p) + (log-msg 'NOTICE "Running play " (play-name p)) + (dynamic-wind + (lambda () + (set! +play-vars+ (alist->hash-table (play-vars p) equal?)) + (init-connection! (play-connection p))) + (lambda () + (for-each (cut run-task <> (play-connection p)) (play-tasks p)) + (for-each (lambda (h) + (when (member (handler-name h) +triggers+) + (log-msg 'INFO "Running handler " (handler-name h)) + ((handler-action h) (play-connection p)))) + (play-handlers p))) + (lambda () + (set! +play-vars+ #f) + (set! +triggers+ #f) + (close-connection! (play-connection p))))) -(define-method (perform (a ) (c )) - (when (check-tags (act-tags a)) - (if (not (check-condition a c)) - (log-msg 'NOTICE "Skipping act " (act-name a) " (precondition not met)") - (begin - (log-msg 'NOTICE "Performing act " (act-name a)) - (dynamic-wind - (lambda () - (when (slot-bound? a 'vars) - (set! +act-vars+ (alist->hash-table (act-vars a) equal?)))) - (lambda () - (for-each (cut perform <> c) (act-tasks a)) - (when (slot-bound? a 'handlers) - (for-each (lambda (h) - (when (member (handler-name h) +act-triggers+) - (log-msg 'INFO "Running handler " (handler-name h)) - ((handler-action h) c))) - (act-handlers a)))) - (lambda () - (set! +act-vars+ #f) - (set! +act-triggers+ #f))))))) +(define-record-type + (make-playbook name vars plays) + playbook? + (name playbook-name) + (vars playbook-vars) + (plays playbook-plays)) -(define-class () - (name #:init-keyword #:name #:getter play-name) - (tags #:init-keyword #:tags #:getter play-tags #:init-form '()) - (vars #:init-keyword #:vars #:getter play-vars) - (connection #:init-keyword #:connection #:getter play-connection) - (acts #:init-keyword #:acts #:getter play-acts)) +(define* (playbook name #:key (vars '()) . plays) + (make-playbook name vars plays)) -(define (play . args) (apply make args)) - -(define-method (perform (p )) - (when (check-tags (play-tags p)) - (log-msg 'NOTICE "Performing play " (play-name p)) - (dynamic-wind - (lambda () - (when (slot-bound? p 'vars) - (set! +play-vars+ (alist->hash-table (play-vars p) equal?))) - (init-connection! (play-connection p))) - (lambda () - (for-each (cut perform <> (play-connection p)) (play-acts p))) - (lambda () - (set! +play-vars+ #f) - (close-connection! (play-connection p)))))) - -(define-class () - (name #:init-keyword #:name #:getter playbook-name) - (vars #:init-keyword #:vars #:getter playbook-vars) - (plays #:init-keyword #:plays #:getter playbook-plays)) - -(define (playbook . args) (apply make args)) - -(define-method (perform (pb ) (filter-tags )) - (log-msg 'NOTICE "Performing playbook " (playbook-name pb)) +(define* (run-playbook pb #:optional (filter-tags '())) + (log-msg 'NOTICE "Running playbook " (playbook-name pb)) (dynamic-wind (lambda () (set! +filter-tags+ filter-tags) - (when (slot-bound? pb 'vars) - (set! +playbook-vars+ (alist->hash-table (playbook-vars pb) equal?)))) + (set! +playbook-vars+ (alist->hash-table (playbook-vars pb) equal?))) (lambda () - (for-each perform (playbook-plays pb))) + (for-each run-play (playbook-plays pb))) (lambda () (set! +filter-tags+ '()) (set! +playbook-vars+ #f)))) -;; TODO: add validate methods for , , , and +;; TODO: add validate methods for , , and diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index ad0e5ce..e17ad7c 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -80,15 +80,16 @@ (loop (read-line port) '())) (define-method (build-command (c ) pwd env prog args) - (let ((cmd (list (if (sudo? c) "sudo" "env")))) - (chain-when cmd - (pwd (append _ (list "--chdir" pwd))) - (env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env))) - (#t (append _ - (list prog) - (map string-shell-quote args) - (list "2>&1"))) - (#t (string-join _ " "))))) + (let ((cmd (chain-when (list (if (sudo? c) "sudo" "env")) + (pwd (append _ (list "--chdir" pwd))) + (env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env))) + (#t (append _ + (list prog) + (map string-shell-quote args) + (list "2>&1"))) + (#t (string-join _ " "))))) + (log-msg 'INFO "Running command: " cmd) + cmd)) (define-method (connection-run (c ) pwd env prog args) (let* ((cmd (build-command c pwd env prog args)) @@ -127,7 +128,7 @@ (cond ((< (length args) 2) default) ((equal? (first args) kw) (second args)) - (else (keyword-arg kw (cddr args))))) + (else (keyword-arg kw (cddr args) default)))) (define (run conn prog . args) (let* ((args (flatten args)) diff --git a/tryme.scm b/tryme.scm index 8fc584a..d866f04 100644 --- a/tryme.scm +++ b/tryme.scm @@ -1,7 +1,5 @@ (use-modules (ice-9 filesystem) - (logging logger) - (srfi srfi-26) (ordo) (ordo connection) (ordo logger)) @@ -20,24 +18,22 @@ (when update? "-u") #:check? #t))) (lambda () - (for-each (cut log-msg 'INFO <>) - (run conn "echo" "rm" "-rf" tmp-dir #:check? #t)))))) + (run conn "rm" "-rf" tmp-dir #:check? #t))))) (define test-playbook - (playbook - #:name "Test Playbook" - #:plays (list - (play - #:name "Test play" - #:connection (local-connection) - #:vars '((base-dir . "/home/ray/ordo-test")) - #:acts (list - (act #:name "Act I" - #:tasks (list - (task #:name "Create base directory" - #:action (lambda (c) (must c "mkdir" "-p" ($ 'base-dir)))) - (task #:name "Create test file" - #:action (lambda (c) (must c "touch" (file-name-join* ($ 'base-dir) "test-file"))))))))))) + (playbook "Test Playbook" + (play "Test play" + #:connection (local-connection) + (task "Get home directory" + (lambda (c) (run c "sh" "-c" "[ -n \"$HOME\" ] && echo $HOME" #:check? #t #:return car)) + #:register (register-play-var 'home-dir) + #:tags '(#:always)) + (task "Install AWS CLI" + (lambda (c) + (install-aws-cli c + #:update? #t + #:install-dir (file-name-join* ($ 'home-dir) ".local" "aws-cli") + #:bin-dir (file-name-join* ($ 'home-dir) ".local" "bin"))))))) (setup-logging) -(perform test-playbook '()) +(run-playbook test-playbook) From 7f507c8e6d4b1bb0e1284e21d89a0e882621c7c3 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 13 Jan 2025 20:15:41 +0000 Subject: [PATCH 42/83] Add support for facts. --- modules/ordo.scm | 17 +++++++++++++---- modules/ordo/facts.scm | 18 ++++++++++++++++++ modules/ordo/facts/user.scm | 31 +++++++++++++++++++++++++++++++ tryme.scm | 8 ++------ 4 files changed, 64 insertions(+), 10 deletions(-) create mode 100644 modules/ordo/facts.scm create mode 100644 modules/ordo/facts/user.scm diff --git a/modules/ordo.scm b/modules/ordo.scm index 3813bf1..3a35d84 100644 --- a/modules/ordo.scm +++ b/modules/ordo.scm @@ -2,6 +2,7 @@ #:use-module (ice-9 exceptions) #:use-module (logging logger) #:use-module (ordo connection) + #:use-module (ordo facts) #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-9) ; records #:use-module (srfi srfi-26) ; cut @@ -27,6 +28,7 @@ playbook-plays run-playbook $ + $$ register-play-var register-playbook-var)) @@ -67,6 +69,10 @@ variable (in that order). Raise an exception if the variable is not found." v))))) (lookup-var var-name (list +play-vars+ +playbook-vars+))) +(define ($$ . keys) + "Look up nested keys in gathered facts." + (apply get-fact (hash-table-ref +play-vars+ #:ordo-facts) keys)) + (define +triggers+ #f) (define (add-triggers triggers) @@ -106,18 +112,19 @@ variable (in that order). Raise an exception if the variable is not found." (make-handler name action)) (define-record-type - (make-play name connection vars tasks handlers) + (make-play name connection vars gather-facts tasks handlers) play? (name play-name) (connection play-connection) (vars play-vars) (tasks play-tasks) - (handlers play-handlers)) + (handlers play-handlers) + (gather-facts play-gather-facts)) -(define* (play name #:key connection (vars '()) . more) +(define* (play name #:key connection (vars '()) (gather-facts #t) . more) (let ((tasks (filter task? more)) (handlers (filter handler? more))) - (make-play name connection vars tasks handlers))) + (make-play name connection vars gather-facts tasks handlers))) (define (run-play p) (log-msg 'NOTICE "Running play " (play-name p)) @@ -126,6 +133,8 @@ variable (in that order). Raise an exception if the variable is not found." (set! +play-vars+ (alist->hash-table (play-vars p) equal?)) (init-connection! (play-connection p))) (lambda () + (when (play-gather-facts p) + (hash-table-set! +play-vars+ #:ordo-facts (gather-facts (play-connection p)))) (for-each (cut run-task <> (play-connection p)) (play-tasks p)) (for-each (lambda (h) (when (member (handler-name h) +triggers+) diff --git a/modules/ordo/facts.scm b/modules/ordo/facts.scm new file mode 100644 index 0000000..6138c59 --- /dev/null +++ b/modules/ordo/facts.scm @@ -0,0 +1,18 @@ +(define-module (ordo facts) + #:use-module (ordo facts user) + #:export (gather-facts + get-fact)) + +(define (get-fact facts . keys) + (cond + ((null? keys) facts) + ((list? facts) (let ((facts (assoc-ref facts (car keys)))) + (apply get-fact facts (cdr keys)))) + (else #f))) + +(define (gather-facts conn) + (let* ((id (fact:id conn)) + (user-name (get-fact id #:user #:name)) + (pwent (fact:pwent conn user-name))) + `((#:id . ,id) + (#:pwent . ,pwent)))) diff --git a/modules/ordo/facts/user.scm b/modules/ordo/facts/user.scm new file mode 100644 index 0000000..fb4fa72 --- /dev/null +++ b/modules/ordo/facts/user.scm @@ -0,0 +1,31 @@ +(define-module (ordo facts user) + #:use-module (rx irregex) + #:use-module (srfi srfi-1) ; list utils + #:use-module (srfi srfi-2) ; and-let* + #: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 . ,(first data)) + (#:group . ,(second data)) + (#: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/tryme.scm b/tryme.scm index d866f04..75d622a 100644 --- a/tryme.scm +++ b/tryme.scm @@ -24,16 +24,12 @@ (playbook "Test Playbook" (play "Test play" #:connection (local-connection) - (task "Get home directory" - (lambda (c) (run c "sh" "-c" "[ -n \"$HOME\" ] && echo $HOME" #:check? #t #:return car)) - #:register (register-play-var 'home-dir) - #:tags '(#:always)) (task "Install AWS CLI" (lambda (c) (install-aws-cli c #:update? #t - #:install-dir (file-name-join* ($ 'home-dir) ".local" "aws-cli") - #:bin-dir (file-name-join* ($ 'home-dir) ".local" "bin"))))))) + #:install-dir (file-name-join* ($$ #:pwent #:home-dir) ".local" "aws-cli") + #:bin-dir (file-name-join* ($$ #:pwent #:home-dir) ".local" "bin"))))))) (setup-logging) (run-playbook test-playbook) From c9db388914af84f91172fd634a25696a45a5186f Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 17 Jan 2025 10:06:03 +0000 Subject: [PATCH 43/83] Start to rework sudo handling --- modules/ordo/connection.scm | 199 ++++++++++++++++++++++-------------- 1 file changed, 124 insertions(+), 75 deletions(-) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index e17ad7c..b6a5b0c 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -18,60 +18,14 @@ #:export ( local-connection ssh-connection - init-connection! - close-connection! + setup + teardown connection-run connection-call-with-input-file connection-call-with-output-file call-with-connection run)) -(define-class () - (sudo #:getter sudo? #:init-keyword #:sudo)) - -(define-class ()) - -(define* (local-connection #:key (sudo? #f)) - (make #:sudo sudo?)) - -(define-class () - (user #:getter get-user #:init-keyword #:user) - (host #:getter get-host #:init-keyword #:host) - (session #:getter get-session #:setter set-session!) - (sftp-session #:getter get-sftp-session #:setter set-sftp-session!)) - -(define* (ssh-connection user host #:key (sudo? #f)) - (make #:user user #:host host #:sudo sudo?)) - -(define-method (init-connection! (c )) #f) - -(define-method (close-connection! (c )) #f) - -(define-method (init-connection! (c )) - (unless (slot-bound? c 'session) - (set-session! c (make-session #:user (get-user c) #:host (get-host c)))) - (let ((s (get-session c))) - (unless (connected? s) - (connect! s) - (let ((server-auth (authenticate-server s))) - (unless (equal? 'ok server-auth) - (error (format #f "authenticate-server: ~a" server-auth)))) - (let ((user-auth (userauth-public-key/auto! s))) - (unless (equal? 'success user-auth) - (error (format #f "userauth-public-key: ~a" user-auth)))))) - #t) - -(define-method (sftp-session (c )) - (unless (slot-bound? c 'sftp-session) - (set-sftp-session! c (make-sftp-session (get-session c)))) - (get-sftp-session c)) - -(define-method (close-connection! (c )) - (when (slot-bound? c 'session) - (let ((s (get-session c))) - (when (connected? s) - (disconnect! s))))) - (define (read-lines port) (define (loop line result) (if (eof-object? line) @@ -79,6 +33,126 @@ (loop (read-line port) (cons line result)))) (loop (read-line port) '())) + +(define-class ()) + +(define-class ()) + +(define-method (setup (c )) #f) + +(define-method (teardown (c )) #f) + +(define (local-connection) + (make )) + +(define-method (connection-run (c ) (command ) + (let* ((port (open-input-pipe command)) + (output (read-lines port)) + (exit-status (status:exit-val (close-pipe port)))) + (values output exit-status)))) + +(define-method (connection-call-with-input-file (c ) (filename ) (proc )) + (call-with-input-file filename proc)) + +(define-method (connection-call-with-output-file (c ) (filename ) (proc )) + (call-with-output-file filename proc)) + +(define-class () + (user #:getter ssh-user #:init-keyword #:user) + (host #:getter ssh-host #:init-keyword #:host) + (password #:getter ssh-password #:init-keyword #:password) + (identity #:getter ssh-identity #:init-keyword #:identity) + (authenticate-server? #:getter ssh-authenticate-server? #:init-keyword authenticate-server?) + (session #:getter ssh-session #:setter set-ssh-session!) + (sftp-session #:getter sftp-session #:setter set-sftp-session!)) + +(define* (ssh-connection user host #:key (authenticate-server #t) password identity) + (make #:user user #:host host #:password password #:identity identity #:authenticate-server? authenticate-server)) + +(define-method (setup (c )) + (unless (slot-bound? c 'session) + (set-session! c (make-session #:user (ssh-user c) #:host (ssh-host c))) + (when (ssh-identity c) + (session-set! (ssh-session c) 'identity (ssh-identity c)))) + (let ((s (get-session c))) + (unless (connected? s) + (connect! s) + (when (authenticate-server? s) + (let ((server-auth (authenticate-server s))) + (unless (equal? 'ok server-auth) + (error (format #f "authenticate-server: ~a" server-auth))))) + (let ((user-auth (if (ssh-password c) + (userauth-password s (ssh-password c)) + (userauth-public-key/auto! s)))) + (unless (equal? 'success user-auth) + (error (format #f "userauth: ~a" user-auth))))))) + +(define-method (connection-run (c ) (command )) + (let* ((channel (open-remote-input-pipe (get-session c) command)) + (output (read-lines channel)) + (exit-status (channel-get-exit-status channel))) + (close channel) + (values output exit-status))) + +(define-method (sftp-session (c )) + (unless (slot-bound? c 'sftp-session) + (set-sftp-session! c (make-sftp-session (get-session c)))) + (get-sftp-session c)) + +(define-method (connection-call-with-input-file (c ) (filename ) (proc )) + (call-with-remote-input-file (sftp-session c) filename proc)) + +(define-method (connection-call-with-output-file (c ) (filename ) (proc )) + (call-with-remote-output-file (sftp-session c) filename proc)) + +(define-method (teardown (c )) + (when (slot-bound? c 'session) + (let ((s (get-session c))) + (when (connected? s) + (disconnect! s))))) + + +(define-class () + (parent-connection #:getter get-connection #:init-keyword #:connection) + (become-user #:getter get-become-user #:init-keyword #:become-user) + (become-password #:getter get-become-password #:init-keyworcd #:become-password) + (password-tmp-file #:getter get-password-tmp-file #:setter set-password-tmp-file!)) + +(define-method (setup (c )) + (setup (parent-connection c)) + (when (become-password c) + (let ((tmp-file (first (connection-run (parent-connection c) "mktemp")))) + (connection-call-with-output-file! (parent-connection c) tmp-file (cut write-line (become-password c) <>)) + (set-password-tmp-file! c tmp-file)))) + +(define-method (sudo-command (c )) + (cond + ((and (become-user c) (become-password c))) + (format #f "cat ~a - | sudo -k -S -H -u ~a" (shell-quote (get-password-tmp-file c)) (shell-quote (get-become-user c))) + + ((become-password c) + (format #f "cat ~a - | sudo -k -S -H" (shell-quote (get-password-tmp-file c)))) + + ((become-user c) + (format #f "sudo -k -n -H -u ~a" (shell-quote (get-become-user c)))) + + (else "sudo -k -n -H"))) + +(define-method (teardown (c )) + (when (slot-bound? c 'password-tmp-file) + (connection-run (parent-connection c) (format #f "rm -rf ~a" (shell-quote (get-password-tmp-file c))))) + (teardown (parent-connection c))) + +(define-method (connection-run (c ) (command )) + (let ((command (string-append (sudo-command c) " -- " command))) + (connection-run (parent-connection c) command))) + +(define-method (connection-call-with-input-file (c ) (filename ) (proc )) + (connection-call-with-input-file (parent-connection c) filename proc)) + +(define-method (connection-call-with-output-file (c ) (filename ) (proc )) + (connection-call-with-output-file (parent-connection c) filename proc)) + (define-method (build-command (c ) pwd env prog args) (let ((cmd (chain-when (list (if (sudo? c) "sudo" "env")) (pwd (append _ (list "--chdir" pwd))) @@ -91,38 +165,13 @@ (log-msg 'INFO "Running command: " cmd) cmd)) -(define-method (connection-run (c ) pwd env prog args) - (let* ((cmd (build-command c pwd env prog args)) - (port (open-input-pipe cmd)) - (output (read-lines port)) - (exit-status (status:exit-val (close-pipe port)))) - (values output exit-status))) -(define-method (connection-run (c ) pwd env prog args) - (let* ((cmd (build-command c pwd env prog args)) - (channel (open-remote-input-pipe (get-session c) cmd)) - (output (read-lines channel)) - (exit-status (channel-get-exit-status channel))) - (close channel) - (values output exit-status))) - -(define-method (connection-call-with-input-file (c ) (filename ) (proc )) - (call-with-input-file filename proc)) - -(define-method (connection-call-with-input-file (c ) (filename ) (proc )) - (call-with-remote-input-file (sftp-session c) filename proc)) - -(define-method (connection-call-with-output-file (c ) (filename ) (proc )) - (call-with-output-file filename proc)) - -(define-method (connection-call-with-output-file (c ) (filename ) (proc )) - (call-with-remote-output-file (sftp-session c) filename proc)) (define (call-with-connection c proc) (dynamic-wind - (lambda () (init-connection! c)) + (lambda () (setup c)) (lambda () (proc c)) - (lambda () (close-connection! c)))) + (lambda () (teardown c)))) (define* (keyword-arg kw args #:optional (default #f)) (cond From d16df7616f17ca6094ab9c23b8d3844dec6c2fc5 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 19 Jan 2025 12:18:20 +0000 Subject: [PATCH 44/83] Factor out connection types into different files --- modules/ordo/connection.scm | 204 +++++------------------------ modules/ordo/connection/base.scm | 23 ++++ modules/ordo/connection/local.scm | 20 +++ modules/ordo/connection/ssh.scm | 74 +++++++++++ modules/ordo/connection/sudo.scm | 60 +++++++++ modules/ordo/util/keyword-args.scm | 27 ++++ modules/ordo/util/read-lines.scm | 11 ++ 7 files changed, 251 insertions(+), 168 deletions(-) create mode 100644 modules/ordo/connection/base.scm create mode 100644 modules/ordo/connection/local.scm create mode 100644 modules/ordo/connection/ssh.scm create mode 100644 modules/ordo/connection/sudo.scm create mode 100644 modules/ordo/util/keyword-args.scm create mode 100644 modules/ordo/util/read-lines.scm diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index b6a5b0c..8dd40ce 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -1,194 +1,62 @@ (define-module (ordo connection) #:use-module (oop goops) #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) #:use-module (logging logger) #:use-module (srfi srfi-1) ; list operations - #:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-71) ; extended let - #:use-module ((srfi srfi-197) #:select (chain-when)) - #:use-module (ssh session) - #: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 local) + #:use-module (ordo connection ssh) + #:use-module (ordo connection sudo) #:use-module (ordo util flatten) #:use-module (ordo util shell-quote) - #:export ( - local-connection - ssh-connection - setup - teardown - connection-run - connection-call-with-input-file - connection-call-with-output-file + #:use-module (ordo util keyword-args) + #:export (connection call-with-connection run)) -(define (read-lines port) - (define (loop line result) - (if (eof-object? line) - (reverse result) - (loop (read-line port) (cons line result)))) - (loop (read-line port) '())) - - -(define-class ()) - -(define-class ()) - -(define-method (setup (c )) #f) - -(define-method (teardown (c )) #f) - -(define (local-connection) - (make )) - -(define-method (connection-run (c ) (command ) - (let* ((port (open-input-pipe command)) - (output (read-lines port)) - (exit-status (status:exit-val (close-pipe port)))) - (values output exit-status)))) - -(define-method (connection-call-with-input-file (c ) (filename ) (proc )) - (call-with-input-file filename proc)) - -(define-method (connection-call-with-output-file (c ) (filename ) (proc )) - (call-with-output-file filename proc)) - -(define-class () - (user #:getter ssh-user #:init-keyword #:user) - (host #:getter ssh-host #:init-keyword #:host) - (password #:getter ssh-password #:init-keyword #:password) - (identity #:getter ssh-identity #:init-keyword #:identity) - (authenticate-server? #:getter ssh-authenticate-server? #:init-keyword authenticate-server?) - (session #:getter ssh-session #:setter set-ssh-session!) - (sftp-session #:getter sftp-session #:setter set-sftp-session!)) - -(define* (ssh-connection user host #:key (authenticate-server #t) password identity) - (make #:user user #:host host #:password password #:identity identity #:authenticate-server? authenticate-server)) - -(define-method (setup (c )) - (unless (slot-bound? c 'session) - (set-session! c (make-session #:user (ssh-user c) #:host (ssh-host c))) - (when (ssh-identity c) - (session-set! (ssh-session c) 'identity (ssh-identity c)))) - (let ((s (get-session c))) - (unless (connected? s) - (connect! s) - (when (authenticate-server? s) - (let ((server-auth (authenticate-server s))) - (unless (equal? 'ok server-auth) - (error (format #f "authenticate-server: ~a" server-auth))))) - (let ((user-auth (if (ssh-password c) - (userauth-password s (ssh-password c)) - (userauth-public-key/auto! s)))) - (unless (equal? 'success user-auth) - (error (format #f "userauth: ~a" user-auth))))))) - -(define-method (connection-run (c ) (command )) - (let* ((channel (open-remote-input-pipe (get-session c) command)) - (output (read-lines channel)) - (exit-status (channel-get-exit-status channel))) - (close channel) - (values output exit-status))) - -(define-method (sftp-session (c )) - (unless (slot-bound? c 'sftp-session) - (set-sftp-session! c (make-sftp-session (get-session c)))) - (get-sftp-session c)) - -(define-method (connection-call-with-input-file (c ) (filename ) (proc )) - (call-with-remote-input-file (sftp-session c) filename proc)) - -(define-method (connection-call-with-output-file (c ) (filename ) (proc )) - (call-with-remote-output-file (sftp-session c) filename proc)) - -(define-method (teardown (c )) - (when (slot-bound? c 'session) - (let ((s (get-session c))) - (when (connected? s) - (disconnect! s))))) - - -(define-class () - (parent-connection #:getter get-connection #:init-keyword #:connection) - (become-user #:getter get-become-user #:init-keyword #:become-user) - (become-password #:getter get-become-password #:init-keyworcd #:become-password) - (password-tmp-file #:getter get-password-tmp-file #:setter set-password-tmp-file!)) - -(define-method (setup (c )) - (setup (parent-connection c)) - (when (become-password c) - (let ((tmp-file (first (connection-run (parent-connection c) "mktemp")))) - (connection-call-with-output-file! (parent-connection c) tmp-file (cut write-line (become-password c) <>)) - (set-password-tmp-file! c tmp-file)))) - -(define-method (sudo-command (c )) - (cond - ((and (become-user c) (become-password c))) - (format #f "cat ~a - | sudo -k -S -H -u ~a" (shell-quote (get-password-tmp-file c)) (shell-quote (get-become-user c))) - - ((become-password c) - (format #f "cat ~a - | sudo -k -S -H" (shell-quote (get-password-tmp-file c)))) - - ((become-user c) - (format #f "sudo -k -n -H -u ~a" (shell-quote (get-become-user c)))) - - (else "sudo -k -n -H"))) - -(define-method (teardown (c )) - (when (slot-bound? c 'password-tmp-file) - (connection-run (parent-connection c) (format #f "rm -rf ~a" (shell-quote (get-password-tmp-file c))))) - (teardown (parent-connection c))) - -(define-method (connection-run (c ) (command )) - (let ((command (string-append (sudo-command c) " -- " command))) - (connection-run (parent-connection c) command))) - -(define-method (connection-call-with-input-file (c ) (filename ) (proc )) - (connection-call-with-input-file (parent-connection c) filename proc)) - -(define-method (connection-call-with-output-file (c ) (filename ) (proc )) - (connection-call-with-output-file (parent-connection c) filename proc)) - -(define-method (build-command (c ) pwd env prog args) - (let ((cmd (chain-when (list (if (sudo? c) "sudo" "env")) - (pwd (append _ (list "--chdir" pwd))) - (env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env))) - (#t (append _ - (list prog) - (map string-shell-quote args) - (list "2>&1"))) - (#t (string-join _ " "))))) - (log-msg 'INFO "Running command: " cmd) - cmd)) - - +(define (connection type . kwargs) + (validate-keyword-args kwargs) + (let* ((c (case type + ((#:local) (make )) + ((#:ssh) (apply make + (select-keyword-args kwargs '(#:user #:host #:password #:identity #:authenticate-server?)))))) + (c (if (keyword-arg kwargs #:sudo?) + (apply make #:connection c (select-keyword-args kwargs '(#:become-user #:become-password))) + c))) + (conn:validate c) + c)) (define (call-with-connection c proc) (dynamic-wind - (lambda () (setup c)) + (lambda () (conn:setup c)) (lambda () (proc c)) - (lambda () (teardown c)))) + (lambda () (conn:teardown c)))) -(define* (keyword-arg kw args #:optional (default #f)) - (cond - ((< (length args) 2) default) - ((equal? (first args) kw) (second args)) - (else (keyword-arg kw (cddr args) default)))) +(define (build-command prog args pwd env) + (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 + (map string-shell-quote args) + "2>&1"))))) + (string-join xs " "))) (define (run conn prog . args) (let* ((args (flatten args)) (args kwargs (break keyword? args)) (args (remove unspecified? args)) - (pwd (keyword-arg #:pwd kwargs)) - (env (keyword-arg #:env kwargs)) - (return (keyword-arg #:return kwargs identity)) - (check? (keyword-arg #:check? kwargs #t)) - (out rc (connection-run conn pwd env prog args))) - (log-msg 'INFO "Command " prog " exited " rc) + (pwd (keyword-arg kwargs #:pwd)) + (env (keyword-arg kwargs #:env)) + (return (keyword-arg kwargs #:return identity)) + (check? (keyword-arg kwargs #:check?)) + (command (build-command prog args pwd env)) + (out rc (conn:run conn command))) + (log-msg 'INFO "Command " command " exited " rc) (if check? (if (zero? rc) (return out) diff --git a/modules/ordo/connection/base.scm b/modules/ordo/connection/base.scm new file mode 100644 index 0000000..3e67972 --- /dev/null +++ b/modules/ordo/connection/base.scm @@ -0,0 +1,23 @@ +(define-module (ordo connection base) + #:use-module (oop goops) + #:export ( + conn:validate + conn:setup + conn:teardown + conn:run + conn:call-with-input-file + conn:call-with-output-file)) + +(define-class ()) + +(define-method (conn:validate (c )) #t) + +(define-method (conn:setup (c )) #t) + +(define-method (conn:teardown (c )) #t) + +(define-generic conn:run) + +(define-generic conn:call-with-input-file) + +(define-generic conn:call-with-output-file) diff --git a/modules/ordo/connection/local.scm b/modules/ordo/connection/local.scm new file mode 100644 index 0000000..24c99d9 --- /dev/null +++ b/modules/ordo/connection/local.scm @@ -0,0 +1,20 @@ +(define-module (ordo connection local) + #:use-module (oop goops) + #:use-module (ice-9 popen) + #:use-module (ordo connection base) + #:use-module (ordo util read-lines) + #:export ()) + +(define-class ()) + +(define-method (conn:run (c ) (command )) + (let* ((port (open-input-pipe command)) + (output (read-lines port)) + (exit-status (status:exit-val (close-pipe port)))) + (values output exit-status))) + +(define-method (conn:call-with-input-file (c ) (filename ) (proc )) + (call-with-input-file filename proc)) + +(define-method (conn:call-with-output-file (c ) (filename ) (proc )) + (call-with-output-file filename proc)) diff --git a/modules/ordo/connection/ssh.scm b/modules/ordo/connection/ssh.scm new file mode 100644 index 0000000..2b0015c --- /dev/null +++ b/modules/ordo/connection/ssh.scm @@ -0,0 +1,74 @@ +(define-module (ordo connection ssh) + #:use-module (oop goops) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 popen) + #:use-module (ssh session) + #:use-module (ssh channel) + #:use-module (ssh auth) + #:use-module (ssh popen) + #:use-module (ssh sftp) + #:use-module (ordo connection base) + #:use-module (ordo util read-lines) + #:export ()) + +(define-class () + (user #:getter user #:init-keyword #:user) + (host #:getter host #:init-keyword #:host) + (password #:getter password #:init-keyword #:password #:init-val #f) + (identity #:getter identity #:init-keyword #:identity #:init-val #f) + (authenticate-server? #:getter authenticate-server? #:init-keyword #:authenticate-server? #:init-val #t) + (session #:accessor session) + (sftp-session #:accessor sftp-session)) + +(define-method (conn:validate (c )) + (unless (slot-bound? c 'user) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message "#:user is required")))) + (unless (slot-bound? c 'host) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message "#:host is required"))))) + +(define-method (conn:setup (c )) + (unless (slot-bound? c 'session) + (set! (session c) (make-session #:user (user c) #:host (host c))) + (when (identity c) (session-set! (session c) 'identity (identity c)))) + (let ((s (session c))) + (unless (connected? s) + (connect! s) + (when (authenticate-server? s) + (let ((server-auth (authenticate-server s))) + (unless (equal? 'ok server-auth) + (error (format #f "authenticate-server: ~a" server-auth))))) + (let ((user-auth (if (password c) + (userauth-password! s (password c)) + (userauth-public-key/auto! s)))) + (unless (equal? 'success user-auth) + (error (format #f "userauth: ~a" user-auth))))))) + +(define-method (conn:run (c ) (command )) + (let* ((channel (open-remote-input-pipe (session c) command)) + (output (read-lines channel)) + (exit-status (channel-get-exit-status channel))) + (close channel) + (values output exit-status))) + +(define-method (sftp-session (c )) + (unless (slot-bound? c 'sftp-session) + (set! (sftp-session c) (make-sftp-session (session c)))) + (sftp-session c)) + +(define-method (conn:call-with-input-file (c ) (filename ) (proc )) + (call-with-remote-input-file (sftp-session c) filename proc)) + +(define-method (conn:call-with-output-file (c ) (filename ) (proc )) + (call-with-remote-output-file (sftp-session c) filename proc)) + +(define-method (conn:teardown (c )) + (when (slot-bound? c 'session) + (let ((s (session c))) + (when (connected? s) + (disconnect! s))))) diff --git a/modules/ordo/connection/sudo.scm b/modules/ordo/connection/sudo.scm new file mode 100644 index 0000000..95d47b2 --- /dev/null +++ b/modules/ordo/connection/sudo.scm @@ -0,0 +1,60 @@ +(define-module (ordo connection sudo) + #:use-module (oop goops) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (ordo connection base) + #:use-module (ordo util shell-quote) + #:export ()) + +(define-class () + (connection #:getter connection #:init-keyword #:connection) + (become-user #:getter become-user #:init-keyword #:become-user #:init-form #f) + (become-password #:getter become-password #:init-keyword #:become-password #:init-form #f) + (password-tmp-file #:accessor password-tmp-file)) + +(define-method (conn:validate (c )) + (conn:validate (connection c))) + +(define-method (conn:setup (c )) + (conn:setup (connection c)) + (when (become-password c) + (let ((out rc (conn:run (connection c) "mktemp"))) + (unless (zero? rc) + (raise-exception (make-exception + (make-external-error) + (make-exception-with-message (format #f "Failed to create temporary directory: ~a" (car out)))))) + (let ((tmp-file (car out))) + (conn:call-with-output-file (connection c) tmp-file (cut write-line (become-password c) <>)) + (set! (password-tmp-file c) tmp-file))))) + +(define-method (sudo-command (c )) + (cond + ((and (become-user c) (become-password c)) + (format #f "cat ~a - | sudo -k -S -H -u ~a" (string-shell-quote (password-tmp-file c)) (string-shell-quote (become-user c)))) + + ((become-password c) + (format #f "cat ~a - | sudo -k -S -H" (string-shell-quote (password-tmp-file c)))) + + ((become-user c) + (format #f "sudo -k -n -H -u ~a" (string-shell-quote (become-user c)))) + + (else "sudo -k -n -H"))) + +(define-method (conn:teardown (c )) + (when (slot-bound? c 'password-tmp-file) + (conn:run (connection c) (format #f "rm -f ~a" (string-shell-quote (password-tmp-file c))))) + (conn:teardown (connection c))) + +(define-method (conn:run (c ) (command )) + (let ((command (string-append (sudo-command c) " -- " command))) + (conn:run (connection c) command))) + +;; There is no special sudo handling for file I/O. This means the caller needs to +;; ensure that they have read/write access to the target file. +(define-method (conn:call-with-input-file (c ) (filename ) (proc )) + (conn:call-with-input-file (connection c) filename proc)) + +(define-method (conn:call-with-output-file (c ) (filename ) (proc )) + (conn:call-with-output-file (connection c) filename proc)) diff --git a/modules/ordo/util/keyword-args.scm b/modules/ordo/util/keyword-args.scm new file mode 100644 index 0000000..76441c1 --- /dev/null +++ b/modules/ordo/util/keyword-args.scm @@ -0,0 +1,27 @@ +(define-module (ordo util keyword-args) + #:use-module (ice-9 exceptions) + #:export (keyword-arg + select-keyword-args + validate-keyword-args)) + +(define* (keyword-arg args kw #:optional (default #f)) + (cond + ((< (length args) 2) default) + ((equal? (car args) kw) (cadr args)) + (else (keyword-arg (cddr args) kw default)))) + +(define (select-keyword-args kwargs wanted) + (let loop ((kwargs kwargs) (accum '())) + (cond + ((null? kwargs) + (reverse accum)) + ((member (car kwargs) wanted) + (loop (cddr kwargs) (cons* (car kwargs) (cadr kwargs) accum))) + (else (loop (cddr kwargs) accum))))) + +(define (validate-keyword-args kwargs) + (unless (even? (length kwargs)) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message "keyword args should have an even number of elements"))))) diff --git a/modules/ordo/util/read-lines.scm b/modules/ordo/util/read-lines.scm new file mode 100644 index 0000000..def581d --- /dev/null +++ b/modules/ordo/util/read-lines.scm @@ -0,0 +1,11 @@ +(define-module (ordo util read-lines) + #:use-module (ice-9 rdelim) + #:export (read-lines)) + +(define (read-lines port) + "Read lines from port until eof is encountered. Return list of all lines read." + (define (loop line result) + (if (eof-object? line) + (reverse result) + (loop (read-line port) (cons line result)))) + (loop (read-line port) '())) From 54b6fd0377be9f604ab56960df3f6e3d9cec3d25 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 19 Jan 2025 19:21:35 +0000 Subject: [PATCH 45/83] Refactor, implement inventory, add examples --- tryme.scm => examples/install-aws-cli.scm | 26 ++- examples/inventory.scm | 14 ++ modules/ordo.scm | 187 +++------------------- modules/ordo/connection.scm | 64 ++++---- modules/ordo/connection/base.scm | 3 - modules/ordo/connection/ssh.scm | 12 -- modules/ordo/context.scm | 59 ------- modules/ordo/facts.scm | 22 +-- modules/ordo/facts/user.scm | 9 +- modules/ordo/handler.scm | 22 ++- modules/ordo/interceptor.scm | 22 +-- modules/ordo/inventory.scm | 54 +++++++ modules/ordo/play.scm | 117 +++++++------- modules/ordo/playbook.scm | 31 ++++ modules/ordo/task.scm | 55 ++++--- modules/ordo/vars.scm | 104 ++++++++++++ tryme-interceptors.scm | 55 ------- 17 files changed, 373 insertions(+), 483 deletions(-) rename tryme.scm => examples/install-aws-cli.scm (55%) create mode 100644 examples/inventory.scm delete mode 100644 modules/ordo/context.scm create mode 100644 modules/ordo/inventory.scm create mode 100644 modules/ordo/playbook.scm create mode 100644 modules/ordo/vars.scm delete mode 100644 tryme-interceptors.scm diff --git a/tryme.scm b/examples/install-aws-cli.scm similarity index 55% rename from tryme.scm rename to examples/install-aws-cli.scm index 75d622a..3844110 100644 --- a/tryme.scm +++ b/examples/install-aws-cli.scm @@ -1,8 +1,6 @@ (use-modules (ice-9 filesystem) - (ordo) - (ordo connection) - (ordo logger)) + (ordo)) (define* (install-aws-cli conn #:key (url "https://awscli.amazonaws.com/awscli-exe-linux-x86_64.zip") update? install-dir bin-dir) (let ((tmp-dir (run conn "mktemp" "-d" #:return car #:check? #t))) @@ -20,16 +18,12 @@ (lambda () (run conn "rm" "-rf" tmp-dir #:check? #t))))) -(define test-playbook - (playbook "Test Playbook" - (play "Test play" - #:connection (local-connection) - (task "Install AWS CLI" - (lambda (c) - (install-aws-cli c - #:update? #t - #:install-dir (file-name-join* ($$ #:pwent #:home-dir) ".local" "aws-cli") - #:bin-dir (file-name-join* ($$ #:pwent #:home-dir) ".local" "bin"))))))) - -(setup-logging) -(run-playbook test-playbook) +(playbook "Test Playbook" + (play "Test play" + #:host "localhost" + (task "Install AWS CLI" + (lambda (c) + (install-aws-cli c + #:update? #t + #:install-dir (file-name-join* ($ #:fact.home-dir) ".local" "aws-cli") + #:bin-dir (file-name-join* ($ #:fact.home-dir) ".local" "bin")))))) diff --git a/examples/inventory.scm b/examples/inventory.scm new file mode 100644 index 0000000..00bee3e --- /dev/null +++ b/examples/inventory.scm @@ -0,0 +1,14 @@ +(use-modules (ordo inventory) + (ordo connection)) + +(add-host! "little-rascal" + (local-connection) + #:linux #:guix) + +(add-host! "screw-loose" + (ssh-connection "core" "screw-loose") + #:linux #:coreos) + +(add-host! "limiting-factor" + (ssh-connection "core" "limiting-factor") + #:linux #:coreos) diff --git a/modules/ordo.scm b/modules/ordo.scm index 3a35d84..efd874f 100644 --- a/modules/ordo.scm +++ b/modules/ordo.scm @@ -1,171 +1,22 @@ (define-module (ordo) - #:use-module (ice-9 exceptions) - #:use-module (logging logger) + #:declarative? #f + #: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 facts) - #: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 - #:export (task - task-name - task-tags - task-action - task-condition - task-register - task-triggers - run-task - play - play-name - play-vars - play-tasks - play-connection - play-handlers - run-play - playbook - playbook-name - playbook-vars - playbook-plays - run-playbook - $ - $$ - register-play-var - register-playbook-var)) + #:use-module (ordo inventory) + #:use-module (ordo vars) + #:use-module (ordo logger) + #:export (main) + #:re-export (add-host! local-connection ssh-connection run playbook play task handler $)) -(define +filter-tags+ '()) - -(define (check-tags tags) - (or (null? +filter-tags+) - (not (null? (lset-intersection eqv? +filter-tags+ tags))))) - -(define +play-vars+ #f) - -(define (register-play-var var-name) - (lambda (v) - (log-msg 'DEBUG "Registering play variable " var-name) - (hash-table-set! +play-vars+ var-name v))) - -(define +playbook-vars+ #f) - -(define (register-playbook-var var-name) - (lambda (v) - (log-msg 'DEBUG "Registering playbook variable " var-name) - (hash-table-set! +playbook-vars+ var-name v))) - -(define ($ var-name) - "Try to resolve var-name as a play variable or a playbook -variable (in that order). Raise an exception if the variable is not found." - (define not-found (cons 'not-found '())) - (define (lookup-var var-name vars) - (cond - ((null? vars) - (raise-exception (make-exception - (make-undefined-variable-error) - (make-exception-with-irritants var-name)))) - ((not (car vars)) (lookup-var var-name (cdr vars))) - (else (let ((v (hash-table-ref/default (car vars) var-name not-found))) - (if (eqv? v not-found) - (lookup-var var-name (cdr vars)) - v))))) - (lookup-var var-name (list +play-vars+ +playbook-vars+))) - -(define ($$ . keys) - "Look up nested keys in gathered facts." - (apply get-fact (hash-table-ref +play-vars+ #:ordo-facts) keys)) - -(define +triggers+ #f) - -(define (add-triggers triggers) - (set! +triggers+ (apply lset-adjoin equal? (or +triggers+ '()) - triggers))) - -(define-record-type - (make-task name tags action condition register triggers) - task? - (name task-name) - (tags task-tags) - (action task-action) - (condition task-condition) - (register task-register) - (triggers task-triggers)) - -(define* (task name action #:key (tags '()) (condition (const #t)) (register (const #f)) (triggers '())) - (make-task name tags action condition register triggers)) - -(define (run-task t c) - (when (check-tags (task-tags t)) - (if (not ((task-condition t) c)) - (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) c))) - ((task-register t) result) - (add-triggers (task-triggers t))))))) - -(define-record-type - (make-handler name action) - handler? - (name handler-name) - (action handler-action)) - -(define (handler name action) - (make-handler name action)) - -(define-record-type - (make-play name connection vars gather-facts tasks handlers) - play? - (name play-name) - (connection play-connection) - (vars play-vars) - (tasks play-tasks) - (handlers play-handlers) - (gather-facts play-gather-facts)) - -(define* (play name #:key connection (vars '()) (gather-facts #t) . more) - (let ((tasks (filter task? more)) - (handlers (filter handler? more))) - (make-play name connection vars gather-facts tasks handlers))) - -(define (run-play p) - (log-msg 'NOTICE "Running play " (play-name p)) - (dynamic-wind - (lambda () - (set! +play-vars+ (alist->hash-table (play-vars p) equal?)) - (init-connection! (play-connection p))) - (lambda () - (when (play-gather-facts p) - (hash-table-set! +play-vars+ #:ordo-facts (gather-facts (play-connection p)))) - (for-each (cut run-task <> (play-connection p)) (play-tasks p)) - (for-each (lambda (h) - (when (member (handler-name h) +triggers+) - (log-msg 'INFO "Running handler " (handler-name h)) - ((handler-action h) (play-connection p)))) - (play-handlers p))) - (lambda () - (set! +play-vars+ #f) - (set! +triggers+ #f) - (close-connection! (play-connection p))))) - -(define-record-type - (make-playbook name vars plays) - playbook? - (name playbook-name) - (vars playbook-vars) - (plays playbook-plays)) - -(define* (playbook name #:key (vars '()) . plays) - (make-playbook name vars plays)) - -(define* (run-playbook pb #:optional (filter-tags '())) - (log-msg 'NOTICE "Running playbook " (playbook-name pb)) - (dynamic-wind - (lambda () - (set! +filter-tags+ filter-tags) - (set! +playbook-vars+ (alist->hash-table (playbook-vars pb) equal?))) - (lambda () - (for-each run-play (playbook-plays pb))) - (lambda () - (set! +filter-tags+ '()) - (set! +playbook-vars+ #f)))) - -;; TODO: add validate methods for , , and +(define (main args) + (match-let (((_ inventory-path playbook-path) args)) + (setup-logging #:level 'DEBUG) + (init-command-line-vars! '()) + (load inventory-path) + (let ((playbook (load playbook-path))) + (run-playbook playbook))) + (quit)) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 8dd40ce..4e57bda 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -2,8 +2,6 @@ #:use-module (oop goops) #:use-module (ice-9 exceptions) #:use-module (ice-9 match) - #:use-module (ice-9 popen) - #:use-module (ice-9 rdelim) #:use-module (logging logger) #:use-module (srfi srfi-1) ; list operations #:use-module (srfi srfi-71) ; extended let @@ -14,36 +12,39 @@ #:use-module (ordo util flatten) #:use-module (ordo util shell-quote) #:use-module (ordo util keyword-args) - #:export (connection + #:export (connection? + local-connection + ssh-connection call-with-connection run)) -(define (connection type . kwargs) - (validate-keyword-args kwargs) - (let* ((c (case type - ((#:local) (make )) - ((#:ssh) (apply make - (select-keyword-args kwargs '(#:user #:host #:password #:identity #:authenticate-server?)))))) - (c (if (keyword-arg kwargs #:sudo?) - (apply make #:connection c (select-keyword-args kwargs '(#:become-user #:become-password))) - c))) - (conn:validate c) - c)) +(define (connection? c) + (is-a? c )) -(define (call-with-connection c proc) - (dynamic-wind - (lambda () (conn:setup c)) - (lambda () (proc c)) - (lambda () (conn:teardown c)))) +(define (local-connection) + (make )) -(define (build-command prog args pwd env) +(define* (ssh-connection user host #:key (password #f) (identity #f) (authenticate-server? #t)) + (make #:user user #:host host #:password password + #:identity identity #:authenticate-server? authenticate-server?)) + +(define* (call-with-connection c proc #:key (sudo? #f) (sudo-user #f) (sudo-password #f)) + (let ((c (if sudo? + (make #:connection c #:become-user sudo-user #:become-password sudo-password) + c))) + (dynamic-wind + (lambda () (conn:setup c)) + (lambda () (proc c)) + (lambda () (conn:teardown c))))) + +(define (build-command prog args pwd env redirect-err?) (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 (map string-shell-quote args) - "2>&1"))))) + (when redirect-err? "2>&1")))))) (string-join xs " "))) (define (run conn prog . args) @@ -54,13 +55,14 @@ (env (keyword-arg kwargs #:env)) (return (keyword-arg kwargs #:return identity)) (check? (keyword-arg kwargs #:check?)) - (command (build-command prog args pwd env)) - (out rc (conn:run conn command))) - (log-msg 'INFO "Command " command " exited " 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)))) + (command (build-command prog args pwd env #t))) + (log-msg 'INFO "Running command: " command) + (let ((out rc (conn:run conn command))) + (log-msg 'INFO "Command exit code: " rc) + (if check? + (if (zero? rc) + (return out) + (raise-exception (make-exception + (make-external-error) + (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog))))) + (values (return out) rc))))) diff --git a/modules/ordo/connection/base.scm b/modules/ordo/connection/base.scm index 3e67972..9a3b17c 100644 --- a/modules/ordo/connection/base.scm +++ b/modules/ordo/connection/base.scm @@ -1,7 +1,6 @@ (define-module (ordo connection base) #:use-module (oop goops) #:export ( - conn:validate conn:setup conn:teardown conn:run @@ -10,8 +9,6 @@ (define-class ()) -(define-method (conn:validate (c )) #t) - (define-method (conn:setup (c )) #t) (define-method (conn:teardown (c )) #t) diff --git a/modules/ordo/connection/ssh.scm b/modules/ordo/connection/ssh.scm index 2b0015c..7b6a065 100644 --- a/modules/ordo/connection/ssh.scm +++ b/modules/ordo/connection/ssh.scm @@ -20,18 +20,6 @@ (session #:accessor session) (sftp-session #:accessor sftp-session)) -(define-method (conn:validate (c )) - (unless (slot-bound? c 'user) - (raise-exception - (make-exception - (make-programming-error) - (make-exception-with-message "#:user is required")))) - (unless (slot-bound? c 'host) - (raise-exception - (make-exception - (make-programming-error) - (make-exception-with-message "#:host is required"))))) - (define-method (conn:setup (c )) (unless (slot-bound? c 'session) (set! (session c) (make-session #:user (user c) #:host (host c))) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm deleted file mode 100644 index 06512b1..0000000 --- a/modules/ordo/context.scm +++ /dev/null @@ -1,59 +0,0 @@ -(define-module (ordo context) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-71) - #:use-module (ordo connection) - #:export (make-context - context? - context-connection - add-context-triggers! - get-context-triggers - context-triggered? - register-context-var! - context-ref - bind-context-vars - run - must)) - -(define-record-type - (make-context connection vars) - context? - (connection context-connection) - (vars context-vars set-context-vars!) - (triggers context-triggers set-context-triggers!)) - -(define (context-ref ctx var-name) - (let ((kv (assoc var-name (context-vars ctx)))) - (if kv - (cdr kv) - (error (format #f "failed to resolve context reference: ~a" var-name))))) - -(define (add-context-triggers! ctx triggers) - (when triggers - (set-context-triggers! ctx - (apply lset-adjoin equal? (or (context-triggers ctx) '()) triggers)))) - -(define (context-triggered? ctx trigger) - (find (lambda (t) (equal? t trigger)) (context-triggers ctx))) - -(define (register-context-var! ctx var-name val) - (set-context-vars! ctx (assoc-set! (context-vars ctx) var-name val))) - -(define-syntax bind-context-vars - (syntax-rules () - ((bind-context-vars (var-name ...) proc) - (lambda (ctx) - (let ((var-name (context-ref ctx (quote var-name))) ...) - (proc ctx)))))) - -(define* (run ctx prog args #:key (env #f) (pwd #f)) - (connection-run (context-connection ctx) pwd env prog args)) - -(define* (must ctx prog args #:key (env #f) (pwd #f) (error-msg #f)) - (let ((out rc (run ctx prog args #:env env #:pwd pwd))) - (if (zero? rc) - out - (error (if error-msg - (format #f "~a: ~a" error-msg out) - (format #f "~a error: ~a" prog out)))))) diff --git a/modules/ordo/facts.scm b/modules/ordo/facts.scm index 6138c59..d3d3e6b 100644 --- a/modules/ordo/facts.scm +++ b/modules/ordo/facts.scm @@ -1,18 +1,18 @@ (define-module (ordo facts) + #:use-module ((srfi srfi-88) #:select (string->keyword)) + #:use-module (ordo vars) #:use-module (ordo facts user) - #:export (gather-facts - get-fact)) + #:export (gather-facts)) -(define (get-fact facts . keys) - (cond - ((null? keys) facts) - ((list? facts) (let ((facts (assoc-ref facts (car keys)))) - (apply get-fact facts (cdr keys)))) - (else #f))) +(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 conn) (let* ((id (fact:id conn)) - (user-name (get-fact id #:user #:name)) + (user-name (assoc-ref id #:user-name)) (pwent (fact:pwent conn user-name))) - `((#:id . ,id) - (#:pwent . ,pwent)))) + (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 index fb4fa72..80ce865 100644 --- a/modules/ordo/facts/user.scm +++ b/modules/ordo/facts/user.scm @@ -1,7 +1,6 @@ (define-module (ordo facts user) #:use-module (rx irregex) - #:use-module (srfi srfi-1) ; list utils - #:use-module (srfi srfi-2) ; and-let* + #:use-module (srfi srfi-1) #:use-module (ordo connection) #:export (fact:id fact:pwent)) @@ -14,8 +13,10 @@ accum)) '() s)))) - `((#:user . ,(first data)) - (#:group . ,(second data)) + `((#: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) diff --git a/modules/ordo/handler.scm b/modules/ordo/handler.scm index ab7ec91..127555e 100644 --- a/modules/ordo/handler.scm +++ b/modules/ordo/handler.scm @@ -1,26 +1,24 @@ (define-module (ordo handler) #:use-module (ice-9 match) - #: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 (ordo context) + #:use-module (logging logger) #:export (handler handler? - handler-description + handler-name handler-action run-handler)) (define-record-type - (make-handler description action) + (make-handler name action) handler? - (description handler-description) + (name handler-name) (action handler-action)) -(define handler make-handler) +(define (handler name action) + (make-handler name action)) -(define (run-handler ctx h) +(define (run-handler c h) (match h - (($ description action) - (log-msg 'NOTICE "Running handler: " description) - (action ctx)))) + (($ name action) + (log-msg 'NOTICE "Running handler: " name) + (action c)))) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm index 0e60674..772aaf5 100644 --- a/modules/ordo/interceptor.scm +++ b/modules/ordo/interceptor.scm @@ -14,9 +14,7 @@ terminate-when execute bind - unbind - run - must)) + unbind)) (define-record-type (make-interceptor name enter leave error) @@ -187,21 +185,3 @@ ((< (length args) 2) #f) ((equal? (first args) kw) (second args)) (else (keyword-arg kw (cddr args))))) - -(define (run ctx prog . args) - (let* ((args kwargs (break keyword? args)) - (pwd (keyword-arg #:pwd kwargs)) - (env (keyword-arg #:env kwargs))) - (connection-run (context-connection ctx) pwd env prog args))) - -(define (must ctx prog . args) - (let* ((args kwargs (break keyword? args)) - (pwd (keyword-arg #:pwd kwargs)) - (env (keyword-arg #:env kwargs)) - (error-msg (keyword-arg #:error-msg kwargs)) - (out rc (connection-run (context-connection ctx) pwd env prog args))) - (if (zero? rc) - out - (error (if error-msg - (format #f "~a: ~a" error-msg out) - (format #f "~a error: ~a" prog out)))))) diff --git a/modules/ordo/inventory.scm b/modules/ordo/inventory.scm new file mode 100644 index 0000000..a433fa2 --- /dev/null +++ b/modules/ordo/inventory.scm @@ -0,0 +1,54 @@ +(define-module (ordo inventory) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-69) + #:use-module (logging logger) + #:use-module (ordo connection) + #:export (make-host + host? + host-name + host-connection + host-tags + add-host! + resolve-hosts)) + +(define *hosts* (make-hash-table equal?)) + +(define-record-type + (make-host name connection tags) + host? + (name host-name) + (connection host-connection) + (tags host-tags)) + +(define (add-host! name connection . tags) + (log-msg 'DEBUG "Adding host to inventory: " name) + (hash-table-set! *hosts* name (make-host name connection tags))) + +(define (tagged-all? wanted-tags) + (lambda (h) + (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) + +(define (tagged-any? wanted-tags) + (lambda (h) + (not (null? (lset-intersection equal? (host-tags h) wanted-tags))))) + +(define resolve-hosts + (match-lambda + ("localhost" (list (or (hash-table-ref/default *hosts* "localhost" #f) + (make-host "localhost" (local-connection) '())))) + ((? string? name) (list (hash-table-ref *hosts* name))) + ('all (hash-table-values *hosts*)) + (('every-tag tag . tags) (filter (tagged-all? (cons tag tags)) (hash-table-values *hosts*))) + (('any-tag tag . tags) (filter (tagged-any? (cons tag tags)) (hash-table-values *hosts*))))) + +#! +(define (setup-test-data) + (add-host! "little-rascal" (ssh-connection "ray" "little-rascal") #:linux #:guix) + (add-host! "linux-1" (ssh-connection "root" "linux-1") #:linux) + (add-host! "linux-2" (ssh-connection "root" "linux-2") #:linux) + (add-host! "debian-1" (ssh-connection "root" "debian-1") #:linux #:debian) + (add-host! "debian-2" (ssh-connection "root" "debian-2") #:linux #:debian) + (add-host! "debian-3" (ssh-connection "root" "debian-3") #:linux #:debian #:eu-west-1)) +!# diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index 87f1ae9..adf857c 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -1,76 +1,67 @@ (define-module (ordo play) - #:use-module (oop goops) - #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) #: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 (ordo connection) - #:use-module (ordo context) #:use-module (ordo task) #:use-module (ordo handler) - #:use-module (ordo logger) - #:export (play run-play)) + #:use-module (ordo vars) + #:use-module (ordo inventory) + #:use-module (ordo facts) + #:export (play + play? + play-host + play-sudo? + play-sudo-user + play-sudo-password + play-vars + play-tasks + play-handlers + play-gather-facts + run-play)) (define-record-type - (make-play description connection vars tasks handlers) + (make-play name host sudo? sudo-user sudo-password vars gather-facts tasks handlers) play? - (connection play-connection) + (name play-name) + (host play-host) + (sudo? play-sudo?) + (sudo-user play-sudo-user) + (sudo-password play-sudo-password) (vars play-vars) - (description play-description) (tasks play-tasks) - (handlers play-handlers)) + (handlers play-handlers) + (gather-facts play-gather-facts)) -(define (validate-connection connection) - (unless (and connection (is-a? connection )) - (error (format #f "invalid connection: ~a" connection)))) +(define* (play name #:key host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (gather-facts #t) . more) + (let ((tasks (filter task? more)) + (handlers (filter handler? more))) + (make-play name host sudo? sudo-user sudo-password vars gather-facts tasks handlers))) -(define (validate-tasks tasks) - (unless (and tasks (not (null? tasks)) (every task? tasks)) - (error (format #f "invalid tasks: ~a" tasks)))) +(define (run-play p) + (log-msg 'NOTICE "Running play: " (play-name p)) + (for-each (lambda (h) (run-host-play p h)) + (resolve-hosts (play-host p)))) -(define (validate-handlers handlers) - (unless (every (lambda (h) (and (pair? h) (handler? (cdr h)))) handlers) - (error (format #f "invalid handlers: ~a" handlers)))) - -(define (validate-vars vars) - (unless (every pair? vars) - (error (format #f "invalid vars: ~a" vars)))) - -(define (validate-triggers tasks handlers) - (for-each (lambda (task) - (for-each (lambda (trigger) - (unless (assoc-ref handlers trigger) - (error (format #f "task \"~a\" references an undefined trigger: ~a" - (task-description task) - trigger)))) - (task-triggers task))) - tasks)) - -(define* (play description #:key connection tasks (vars '()) (handlers '())) - (validate-connection connection) - (validate-tasks tasks) - (validate-handlers handlers) - (validate-triggers tasks handlers) - (validate-vars vars) - ;; Reconstruct the vars here because, when a quoted list is passed in the - ;; play, it can result in an error (expected mutable pair) from assoc-set! - ;; from register-context-var!. - (make-play description connection (fold (match-lambda* (((k . v) accum) (alist-cons k v accum))) '() vars) tasks handlers)) - -(define (run-play play) - ;; TODO move logging setup and shutdown to a higher level when we implement playbook etc. - (setup-logging) - (log-msg 'NOTICE "Running play: " (play-description play)) - (call-with-connection - (play-connection play) - (lambda (c) - (let* ((ctx (make-context c (play-vars play)))) - (for-each (cut run-task ctx <>) (play-tasks play)) - (for-each (match-lambda - ((name . handler) - (when (context-triggered? ctx name) - (run-handler ctx handler)))) - (play-handlers play))))) - (log-msg 'NOTICE "Completed play: " (play-description play)) - (shutdown-logging)) +(define (run-host-play p h) + (log-msg 'NOTICE "Running play: " (play-name p) " on host: " (host-name h)) + (dynamic-wind + (lambda () + (init-play-vars! (play-vars p))) + (lambda () + (call-with-connection + (host-connection h) + (lambda (c) + (when (play-gather-facts p) + (gather-facts c)) + (for-each (cut run-task <> c) + (play-tasks p)) + (for-each (cut run-handler <> c) + (filter (compose play-triggered? handler-name) + (play-handlers p)))) + #:sudo? (play-sudo? p) + #:sudo-user (play-sudo-user p) + #:sudo-password (play-sudo-password p))) + (lambda () + (reset-play-vars!) + (reset-play-triggers!)))) diff --git a/modules/ordo/playbook.scm b/modules/ordo/playbook.scm new file mode 100644 index 0000000..376510e --- /dev/null +++ b/modules/ordo/playbook.scm @@ -0,0 +1,31 @@ +(define-module (ordo playbook) + #:use-module (srfi srfi-9) + #:use-module (logging logger) + #:use-module (ordo play) + #:use-module (ordo vars) + #:export (playbook + playbook? + playbook-name + playbook-vars + playbook-plays + run-playbook)) + +(define-record-type + (make-playbook name vars plays) + playbook? + (name playbook-name) + (vars playbook-vars) + (plays playbook-plays)) + +(define* (playbook name #:key (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!)))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index e1db8e0..feee5ab 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -1,42 +1,41 @@ (define-module (ordo task) - #:use-module (ice-9 match) + #:use-module (srfi srfi-9) #: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 (ordo context) + #:use-module (ordo vars) #:export (task task? - task-description - task-condition + task-name + task-tags task-action - task-register + task-condition + task-register-play-var + task-register-playbook-var task-triggers run-task)) (define-record-type - (make-task description condition action register triggers) + (make-task name tags action condition register-play-var register-playbook-var triggers) task? - (description task-description) - (condition task-condition) + (name task-name) + (tags task-tags) (action task-action) - (register task-register) + (condition task-condition) + (register-play-var task-register-play-var) + (register-playbook-var task-register-playbook-var) (triggers task-triggers)) -(define* (task description action #:key (condition (const #t)) (register #f) (triggers '())) - (make-task description condition action register triggers)) +(define* (task name action #:key (tags '()) (condition (const #t)) (register-play-var #f) (register-playbook-var #f) (triggers '())) + (make-task name tags action condition register-play-var register-playbook-var triggers)) -(define (run-task ctx t) - (match t - (($ description condition action register triggers) - (if (not (condition ctx)) - (log-msg 'NOTICE "Skipping task: " description " (precondition not met)") - (begin - (log-msg 'NOTICE "Running task: " description) - (let ((result (action ctx))) - (when register - (log-msg 'INFO "Registering result " register) - (register-context-var! ctx register result)) - (when (and triggers (not (null? triggers))) - (log-msg 'INFO "Scheduling triggers " triggers) - (add-context-triggers! ctx triggers)))))))) +(define (run-task t c) + (when (check-filter-tags (task-tags t)) + (if (not ((task-condition t) c)) + (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) c))) + (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))))))) diff --git a/modules/ordo/vars.scm b/modules/ordo/vars.scm new file mode 100644 index 0000000..bef2af4 --- /dev/null +++ b/modules/ordo/vars.scm @@ -0,0 +1,104 @@ +(define-module (ordo vars) + #:use-module (ice-9 exceptions) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-69) + #:export (init-playbook-vars! + get-playbook-var + set-playbook-var! + reset-playbook-vars! + init-play-vars! + get-play-var + set-play-var! + reset-play-vars! + init-command-line-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)) + +(define not-found (cons 'not-found '())) + +(define (not-found? x) (eq? x not-found)) + +(define *playbook-vars* #f) + +(define (init-playbook-vars! alist) + (set! *playbook-vars* (alist->hash-table alist equal?))) + +(define (get-playbook-var var-name) + (hash-table-ref/default *playbook-vars* var-name not-found)) + +(define (set-playbook-var! var-name val) + (hash-table-set! *playbook-vars* var-name val)) + +(define (reset-playbook-vars!) + (set! *playbook-vars* #f)) + +(define *play-vars* #f) + +(define (init-play-vars! alist) + (set! *play-vars* (alist->hash-table alist equal?))) + +(define (get-play-var var-name) + (hash-table-ref/default *play-vars* var-name not-found)) + +(define (set-play-var! var-name val) + (hash-table-set! *play-vars* var-name val)) + +(define (reset-play-vars!) + (set! *play-vars* #f)) + +(define *command-line-vars* #f) + +(define (init-command-line-vars! alist) + (set! *command-line-vars* (alist->hash-table alist equal?))) + +(define (get-command-line-var var-name) + (hash-table-ref/default *command-line-vars* var-name not-found)) + +(define (set-command-line-var var-name val) + (hash-table-set! *command-line-vars* 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 *play-triggers* '()) + +(define (reset-play-triggers!) + (set! *play-triggers* '())) + +(define (add-play-triggers! triggers) + (set! *play-triggers* (apply lset-adjoin equal? (or *play-triggers* '()) + triggers))) + +(define (play-triggered? trigger) + (member trigger *play-triggers*)) + +(define *filter-tags* '()) + +(define (set-filter-tag! tag) + (set! *filter-tags* (lset-adjoin equal? *filter-tags* tag))) + +(define (reset-filter-tags!) + (set! *filter-tags* '())) + +(define (check-filter-tags tags) + (or (null? *filter-tags*) + (not (null? (lset-intersection eqv? *filter-tags* tags))))) diff --git a/tryme-interceptors.scm b/tryme-interceptors.scm deleted file mode 100644 index 00a8ded..0000000 --- a/tryme-interceptors.scm +++ /dev/null @@ -1,55 +0,0 @@ -(use-modules - (ice-9 filesystem) - (logging logger) - (srfi srfi-9) - (ordo connection) - (ordo interceptor) - (ordo logger)) - -(define-record-type - (make-play name connection vars interceptors) - play? - (connection play-connection) - (vars play-vars) - (name play-name) - (interceptors play-interceptors)) - -(define* (play #:key name connection (interceptors '()) (vars '())) - (make-play name connection vars interceptors)) - -(define (run-play play) - (dynamic-wind - (lambda () - (log-msg 'NOTICE "Running play: " (play-name play)) - (init-connection! (play-connection play))) - (lambda () - (let ((ctx (init-context (play-connection play) #:vars (play-vars play)))) - (execute ctx (play-interceptors play)) - (if (context-error ctx) - (log-msg 'ERROR "Play " (play-name play) " terminated with error: " (context-error ctx)) - (log-msg 'NOTICE "Completed play: " (play-name play))))) - (lambda () - (close-connection! (play-connection play))))) - -(define test-play - (play - #:name "Test play" - #:connection (local-connection) - #:vars '((base-dir . "/home/ray/ordo-test")) - #:interceptors (list - (interceptor - "Handle errors" - #:error (lambda (ctx err) - (log-msg 'WARN "Handling error " err) - (set-context-error! ctx #f))) - (interceptor - "Create base directory" - #:enter (lambda (ctx) - (must ctx "mkdir" "-p" (unbind ctx base-dir)))) - (interceptor - "Create test file" - #:enter (lambda (ctx) - (must ctx "touch" (file-name-join* (unbind ctx base-dir) "test-file")))) - (interceptor - "Throw an error" - #:enter (lambda (ctx) (error "badness")))))) From 1535baa68bd2dd19526f60e3d0172175de4ac7da Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 19 Jan 2025 19:56:02 +0000 Subject: [PATCH 46/83] Factor out CLI into its own module --- examples/inventory.scm | 3 +-- modules/ordo.scm | 11 ----------- modules/ordo/cli.scm | 16 ++++++++++++++++ 3 files changed, 17 insertions(+), 13 deletions(-) create mode 100644 modules/ordo/cli.scm diff --git a/examples/inventory.scm b/examples/inventory.scm index 00bee3e..01c0a25 100644 --- a/examples/inventory.scm +++ b/examples/inventory.scm @@ -1,5 +1,4 @@ -(use-modules (ordo inventory) - (ordo connection)) +(use-modules (ordo)) (add-host! "little-rascal" (local-connection) diff --git a/modules/ordo.scm b/modules/ordo.scm index efd874f..b978821 100644 --- a/modules/ordo.scm +++ b/modules/ordo.scm @@ -1,5 +1,4 @@ (define-module (ordo) - #:declarative? #f #:use-module (ice-9 match) #:use-module (ordo playbook) #:use-module (ordo play) @@ -9,14 +8,4 @@ #:use-module (ordo inventory) #:use-module (ordo vars) #:use-module (ordo logger) - #:export (main) #:re-export (add-host! local-connection ssh-connection run playbook play task handler $)) - -(define (main args) - (match-let (((_ inventory-path playbook-path) args)) - (setup-logging #:level 'DEBUG) - (init-command-line-vars! '()) - (load inventory-path) - (let ((playbook (load playbook-path))) - (run-playbook playbook))) - (quit)) diff --git a/modules/ordo/cli.scm b/modules/ordo/cli.scm new file mode 100644 index 0000000..3d4497c --- /dev/null +++ b/modules/ordo/cli.scm @@ -0,0 +1,16 @@ +(define-module (ordo cli) + #:use-module (ice-9 match) + #:use-module (ordo logger) + #:use-module (ordo vars) + #:use-module (ordo playbook) + #:declarative? #f + #:export (main)) + +(define (main args) + (match-let (((_ inventory-path playbook-path) args)) + (setup-logging #:level 'DEBUG) + (init-command-line-vars! '()) + (load inventory-path) + ;; (let ((playbook (load playbook-path))) + ;; (run-playbook playbook)) + (quit))) From 7f5ec3ac2955f0bc38dae1962bcf10a74c358bc5 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 20 Jan 2025 10:42:15 +0000 Subject: [PATCH 47/83] Use context instead of global vars --- examples/install-aws-cli.scm | 10 +-- modules/ordo.scm | 5 +- modules/ordo/cli.scm | 8 +- modules/ordo/connection.scm | 2 +- modules/ordo/context.scm | 152 +++++++++++++++++++++++++++++++++++ modules/ordo/facts.scm | 7 +- modules/ordo/handler.scm | 5 +- modules/ordo/host.scm | 39 +++++++++ modules/ordo/inventory.scm | 54 ------------- modules/ordo/play.scm | 52 ++++++------ modules/ordo/playbook.scm | 2 +- modules/ordo/task.scm | 8 +- modules/ordo/vars.scm | 104 ------------------------ 13 files changed, 243 insertions(+), 205 deletions(-) create mode 100644 modules/ordo/context.scm create mode 100644 modules/ordo/host.scm delete mode 100644 modules/ordo/inventory.scm delete mode 100644 modules/ordo/vars.scm diff --git a/examples/install-aws-cli.scm b/examples/install-aws-cli.scm index 3844110..1e1f273 100644 --- a/examples/install-aws-cli.scm +++ b/examples/install-aws-cli.scm @@ -2,8 +2,9 @@ (ice-9 filesystem) (ordo)) -(define* (install-aws-cli conn #:key (url "https://awscli.amazonaws.com/awscli-exe-linux-x86_64.zip") update? install-dir bin-dir) - (let ((tmp-dir (run conn "mktemp" "-d" #:return car #:check? #t))) +(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 () @@ -22,8 +23,7 @@ (play "Test play" #:host "localhost" (task "Install AWS CLI" - (lambda (c) - (install-aws-cli c - #:update? #t + (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")))))) diff --git a/modules/ordo.scm b/modules/ordo.scm index b978821..7c3741f 100644 --- a/modules/ordo.scm +++ b/modules/ordo.scm @@ -5,7 +5,6 @@ #:use-module (ordo task) #:use-module (ordo handler) #:use-module (ordo connection) - #:use-module (ordo inventory) - #:use-module (ordo vars) + #:use-module (ordo context) #:use-module (ordo logger) - #:re-export (add-host! local-connection ssh-connection run playbook play task handler $)) + #:re-export (add-host! local-connection ssh-connection current-connection run playbook play task handler $)) diff --git a/modules/ordo/cli.scm b/modules/ordo/cli.scm index 3d4497c..519e3f1 100644 --- a/modules/ordo/cli.scm +++ b/modules/ordo/cli.scm @@ -1,7 +1,7 @@ (define-module (ordo cli) #:use-module (ice-9 match) #:use-module (ordo logger) - #:use-module (ordo vars) + #:use-module (ordo context) #:use-module (ordo playbook) #:declarative? #f #:export (main)) @@ -9,8 +9,8 @@ (define (main args) (match-let (((_ inventory-path playbook-path) args)) (setup-logging #:level 'DEBUG) - (init-command-line-vars! '()) + (init-context!) (load inventory-path) - ;; (let ((playbook (load playbook-path))) - ;; (run-playbook playbook)) + (let ((playbook (load playbook-path))) + (run-playbook playbook)) (quit))) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 4e57bda..f5b4c60 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -28,7 +28,7 @@ (make #:user user #:host host #:password password #:identity identity #:authenticate-server? authenticate-server?)) -(define* (call-with-connection c proc #:key (sudo? #f) (sudo-user #f) (sudo-password #f)) +(define* (call-with-connection c sudo? sudo-user sudo-password proc) (let ((c (if sudo? (make #:connection c #:become-user sudo-user #:become-password sudo-password) c))) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm new file mode 100644 index 0000000..2b4dcda --- /dev/null +++ b/modules/ordo/context.scm @@ -0,0 +1,152 @@ +(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 index d3d3e6b..9462e7f 100644 --- a/modules/ordo/facts.scm +++ b/modules/ordo/facts.scm @@ -1,6 +1,6 @@ (define-module (ordo facts) #:use-module ((srfi srfi-88) #:select (string->keyword)) - #:use-module (ordo vars) + #:use-module (ordo context) #:use-module (ordo facts user) #:export (gather-facts)) @@ -10,8 +10,9 @@ (assoc-ref src (string->keyword k)))) keys)) -(define (gather-facts conn) - (let* ((id (fact:id conn)) +(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")) diff --git a/modules/ordo/handler.scm b/modules/ordo/handler.scm index 127555e..0a6ebba 100644 --- a/modules/ordo/handler.scm +++ b/modules/ordo/handler.scm @@ -2,6 +2,7 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-9) ; records #:use-module (logging logger) + #:use-module (ordo context) #:export (handler handler? handler-name @@ -17,8 +18,8 @@ (define (handler name action) (make-handler name action)) -(define (run-handler c h) +(define (run-handler h) (match h (($ name action) (log-msg 'NOTICE "Running handler: " name) - (action c)))) + (action (current-connection))))) diff --git a/modules/ordo/host.scm b/modules/ordo/host.scm new file mode 100644 index 0000000..fa19045 --- /dev/null +++ b/modules/ordo/host.scm @@ -0,0 +1,39 @@ +(define-module (ordo host) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (ordo connection) + #:export (make-host + host? + host-name + host-connection + host-tags + resolve-hosts)) + +(define-record-type + (make-host name connection tags) + host? + (name host-name) + (connection host-connection) + (tags host-tags)) + +(define (tagged-all? wanted-tags) + (lambda (h) + (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) + +(define (tagged-any? wanted-tags) + (lambda (h) + (not (null? (lset-intersection equal? (host-tags h) wanted-tags))))) + +(define (named? hostname) + (lambda (h) + (string=? (host-name h) hostname))) + +(define (resolve-hosts inventory) + (match-lambda + ("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)))) diff --git a/modules/ordo/inventory.scm b/modules/ordo/inventory.scm deleted file mode 100644 index a433fa2..0000000 --- a/modules/ordo/inventory.scm +++ /dev/null @@ -1,54 +0,0 @@ -(define-module (ordo inventory) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-69) - #:use-module (logging logger) - #:use-module (ordo connection) - #:export (make-host - host? - host-name - host-connection - host-tags - add-host! - resolve-hosts)) - -(define *hosts* (make-hash-table equal?)) - -(define-record-type - (make-host name connection tags) - host? - (name host-name) - (connection host-connection) - (tags host-tags)) - -(define (add-host! name connection . tags) - (log-msg 'DEBUG "Adding host to inventory: " name) - (hash-table-set! *hosts* name (make-host name connection tags))) - -(define (tagged-all? wanted-tags) - (lambda (h) - (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) - -(define (tagged-any? wanted-tags) - (lambda (h) - (not (null? (lset-intersection equal? (host-tags h) wanted-tags))))) - -(define resolve-hosts - (match-lambda - ("localhost" (list (or (hash-table-ref/default *hosts* "localhost" #f) - (make-host "localhost" (local-connection) '())))) - ((? string? name) (list (hash-table-ref *hosts* name))) - ('all (hash-table-values *hosts*)) - (('every-tag tag . tags) (filter (tagged-all? (cons tag tags)) (hash-table-values *hosts*))) - (('any-tag tag . tags) (filter (tagged-any? (cons tag tags)) (hash-table-values *hosts*))))) - -#! -(define (setup-test-data) - (add-host! "little-rascal" (ssh-connection "ray" "little-rascal") #:linux #:guix) - (add-host! "linux-1" (ssh-connection "root" "linux-1") #:linux) - (add-host! "linux-2" (ssh-connection "root" "linux-2") #:linux) - (add-host! "debian-1" (ssh-connection "root" "debian-1") #:linux #:debian) - (add-host! "debian-2" (ssh-connection "root" "debian-2") #:linux #:debian) - (add-host! "debian-3" (ssh-connection "root" "debian-3") #:linux #:debian #:eu-west-1)) -!# diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index adf857c..8586425 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -3,10 +3,11 @@ #: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 vars) - #:use-module (ordo inventory) + #:use-module (ordo context) + #:use-module (ordo host) #:use-module (ordo facts) #:export (play play? @@ -40,28 +41,31 @@ (define (run-play p) (log-msg 'NOTICE "Running play: " (play-name p)) - (for-each (lambda (h) (run-host-play p h)) - (resolve-hosts (play-host p)))) + (let ((hosts ((resolve-hosts (current-inventory)) (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)))) (define (run-host-play p h) (log-msg 'NOTICE "Running play: " (play-name p) " on host: " (host-name h)) - (dynamic-wind - (lambda () - (init-play-vars! (play-vars p))) - (lambda () - (call-with-connection - (host-connection h) - (lambda (c) - (when (play-gather-facts p) - (gather-facts c)) - (for-each (cut run-task <> c) - (play-tasks p)) - (for-each (cut run-handler <> c) - (filter (compose play-triggered? handler-name) - (play-handlers p)))) - #:sudo? (play-sudo? p) - #:sudo-user (play-sudo-user p) - #:sudo-password (play-sudo-password p))) - (lambda () - (reset-play-vars!) - (reset-play-triggers!)))) + (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!)))))) diff --git a/modules/ordo/playbook.scm b/modules/ordo/playbook.scm index 376510e..b8a1169 100644 --- a/modules/ordo/playbook.scm +++ b/modules/ordo/playbook.scm @@ -2,7 +2,7 @@ #:use-module (srfi srfi-9) #:use-module (logging logger) #:use-module (ordo play) - #:use-module (ordo vars) + #:use-module (ordo context) #:export (playbook playbook? playbook-name diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index feee5ab..8104b16 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -1,7 +1,7 @@ (define-module (ordo task) #:use-module (srfi srfi-9) #:use-module (logging logger) - #:use-module (ordo vars) + #:use-module (ordo context) #:export (task task? task-name @@ -27,13 +27,13 @@ (define* (task name action #:key (tags '()) (condition (const #t)) (register-play-var #f) (register-playbook-var #f) (triggers '())) (make-task name tags action condition register-play-var register-playbook-var triggers)) -(define (run-task t c) +(define (run-task t) (when (check-filter-tags (task-tags t)) - (if (not ((task-condition t) c)) + (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) c))) + (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) diff --git a/modules/ordo/vars.scm b/modules/ordo/vars.scm deleted file mode 100644 index bef2af4..0000000 --- a/modules/ordo/vars.scm +++ /dev/null @@ -1,104 +0,0 @@ -(define-module (ordo vars) - #:use-module (ice-9 exceptions) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-69) - #:export (init-playbook-vars! - get-playbook-var - set-playbook-var! - reset-playbook-vars! - init-play-vars! - get-play-var - set-play-var! - reset-play-vars! - init-command-line-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)) - -(define not-found (cons 'not-found '())) - -(define (not-found? x) (eq? x not-found)) - -(define *playbook-vars* #f) - -(define (init-playbook-vars! alist) - (set! *playbook-vars* (alist->hash-table alist equal?))) - -(define (get-playbook-var var-name) - (hash-table-ref/default *playbook-vars* var-name not-found)) - -(define (set-playbook-var! var-name val) - (hash-table-set! *playbook-vars* var-name val)) - -(define (reset-playbook-vars!) - (set! *playbook-vars* #f)) - -(define *play-vars* #f) - -(define (init-play-vars! alist) - (set! *play-vars* (alist->hash-table alist equal?))) - -(define (get-play-var var-name) - (hash-table-ref/default *play-vars* var-name not-found)) - -(define (set-play-var! var-name val) - (hash-table-set! *play-vars* var-name val)) - -(define (reset-play-vars!) - (set! *play-vars* #f)) - -(define *command-line-vars* #f) - -(define (init-command-line-vars! alist) - (set! *command-line-vars* (alist->hash-table alist equal?))) - -(define (get-command-line-var var-name) - (hash-table-ref/default *command-line-vars* var-name not-found)) - -(define (set-command-line-var var-name val) - (hash-table-set! *command-line-vars* 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 *play-triggers* '()) - -(define (reset-play-triggers!) - (set! *play-triggers* '())) - -(define (add-play-triggers! triggers) - (set! *play-triggers* (apply lset-adjoin equal? (or *play-triggers* '()) - triggers))) - -(define (play-triggered? trigger) - (member trigger *play-triggers*)) - -(define *filter-tags* '()) - -(define (set-filter-tag! tag) - (set! *filter-tags* (lset-adjoin equal? *filter-tags* tag))) - -(define (reset-filter-tags!) - (set! *filter-tags* '())) - -(define (check-filter-tags tags) - (or (null? *filter-tags*) - (not (null? (lset-intersection eqv? *filter-tags* tags))))) From 1843544e49b7ee1f258ae158e5a3ca6b3cd3158b Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Tue, 21 Jan 2025 20:56:49 +0000 Subject: [PATCH 48/83] Add a macro to make task definitions more succinct --- examples/install-aws-cli.scm | 11 +++++------ modules/ordo/task.scm | 9 ++++++++- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/examples/install-aws-cli.scm b/examples/install-aws-cli.scm index 1e1f273..15ea839 100644 --- a/examples/install-aws-cli.scm +++ b/examples/install-aws-cli.scm @@ -17,13 +17,12 @@ (when update? "-u") #:check? #t))) (lambda () - (run conn "rm" "-rf" tmp-dir #:check? #t))))) + (run conn "rm" "-rf" tmp-dir))))) (playbook "Test Playbook" (play "Test play" #:host "localhost" - (task "Install AWS CLI" - (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")))))) + (task + (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"))))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index 8104b16..0b62d8d 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -24,9 +24,16 @@ (register-playbook-var task-register-playbook-var) (triggers task-triggers)) -(define* (task name action #:key (tags '()) (condition (const #t)) (register-play-var #f) (register-playbook-var #f) (triggers '())) +(define* (%task name action #:key (tags '()) (condition (const #t)) (register-play-var #f) (register-playbook-var #f) (triggers '())) (make-task name tags action condition register-play-var register-playbook-var triggers)) +(define-syntax task + (syntax-rules () + ((task (f args ...) kwargs ...) + (%task (symbol->string 'f) (lambda () (f args ...) kwargs ...))) + ((task name (f args ...) kwargs ...) + (%task name (lambda () (f args ...)) kwargs ...)))) + (define (run-task t) (when (check-filter-tags (task-tags t)) (if (not ((task-condition t))) From 47b63da25ef7e692558c7f6801cbfb912162cec0 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Tue, 21 Jan 2025 20:57:17 +0000 Subject: [PATCH 49/83] Rework actions for new context implementation --- modules/ordo/action/apt.scm | 6 +- modules/ordo/action/filesystem.scm | 155 +++++++++++++++-------------- 2 files changed, 84 insertions(+), 77 deletions(-) diff --git a/modules/ordo/action/apt.scm b/modules/ordo/action/apt.scm index 7cb7fd4..fc05ef7 100644 --- a/modules/ordo/action/apt.scm +++ b/modules/ordo/action/apt.scm @@ -1,12 +1,12 @@ (define-module (ordo action apt) - #:use-module (ordo context)) + #:use-module (ordo)) (define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive") ("APT_LISTCHANGES_FRONTEND" . "none"))) (define (apt-get . args) - (lambda (ctx) - (must ctx "apt-get" (cons* "-q" "-y" args) #:env noninteractive-env))) + (lambda () + (run (current-connection) "apt-get" (cons* "-q" "-y" args) #:env noninteractive-env))) (define-public (action:apt-update) (apt-get "update")) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index eaac534..f433940 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -7,8 +7,7 @@ #:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) - #:use-module (ordo connection) - #:use-module (ordo context) + #:use-module (ordo) #:export (action:create-tmp-dir action:install-dir action:install-file @@ -30,61 +29,68 @@ (atime . ,atime) (mtime . ,mtime) (ctime . ,ctime)))) - (lambda (ctx) - (let ((result rc (run ctx "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path)))) - (cond - ((zero? rc) (parse-stat-result (first result))) - ((string-contains (first result) "No such file or directory") #f) - (else (error (format #f "stat ~a: ~a" path (first result)))))))) + (let ((result rc (run (current-connection) "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path)))) + (cond + ((zero? rc) (parse-stat-result (first result))) + ((string-contains (first result) "No such file or directory") #f) + (else (error (format #f "stat ~a: ~a" path (first result))))))) (define* (action:remove path #:key (recurse? #f) (force? #f) (verbose? #t)) - (lambda (ctx) - (must ctx "rm" (chain-when '() - (verbose? (append _ '("-v"))) - (recurse? (append _ '("-r"))) - (force? (append _ '("-f"))) - (#t (append _ `(,path))))))) + (run (current-connection) + "rm" (chain-when '() + (verbose? (append _ '("-v"))) + (recurse? (append _ '("-r"))) + (force? (append _ '("-f"))) + (#t (append _ `(,path)))) + #:check? #t)) (define* (action:link target link-name #:key (symbolic? #f) (force? #f) (backup? #f)) "Create a link to @code{target} with the name @code{link-name}." - (must ctx "ln" (chain-when '() - (symbolic? (append _ '("--symbolic"))) - (force? (append _ '("--force"))) - (backup? (append _ '("--backup" "numbered"))) - (#t (append `(,target ,link-name)))))) + (run (current-connection) + "ln" (chain-when '() + (symbolic? (append _ '("--symbolic"))) + (force? (append _ '("--force"))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append `(,target ,link-name)))) + #:check? #t)) (define* (action:create-tmp-dir #:key tmpdir suffix template) - (lambda (ctx) - (match-let (((tmp-dir) (must ctx "mktemp" (chain-when - '("--directory") - (tmpdir (append _ `("--tmpdir" tmpdir))) - (suffix (append _ `("--suffix" suffix))) - (template (append _ `(template))))))) - tmp-dir))) + (match-let (((tmp-dir) (run (current-connection) + "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template)))) + #:check? #t))) + tmp-dir)) (define* (action:install-dir path #:key owner group mode) - (lambda (ctx) - ;; If owner/group/mode is unspecified and the destination directory already exists, - ;; preserve the current ownership and mode. - (unless (and owner group mode) - (let ((st ((action:stat path) ctx))) - (when st - (set! owner (or owner (assoc-ref st 'user))) - (set! group (or group (assoc-ref st 'group))) - (set! mode (or mode (assoc-ref st 'mode)))))) - (when (integer? mode) - (set! mode (number->string mode 8))) - (must ctx "install" (chain-when - '("--directory") - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (#t (append _ `(,path))))) - path)) + ;; If owner/group/mode is unspecified and the destination directory already exists, + ;; preserve the current ownership and mode. + ;; TODO: this does not make much sense: if the object exists but is not a directory + ;; then the install will fail. If the object exists an *is* a directory, then we + ;; should just chmod/chown it. + (unless (and owner group mode) + (let ((st (action:stat path))) + (when st + (set! owner (or owner (assoc-ref st 'user))) + (set! group (or group (assoc-ref st 'group))) + (set! mode (or mode (assoc-ref st 'mode)))))) + (when (integer? mode) + (set! mode (number->string mode 8))) + (run (current-connection) + "install" (chain-when + '("--directory") + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (#t (append _ `(,path)))) + #:check? #t) + path) -(define (upload-tmp-file ctx tmp-file) +(define (upload-tmp-file tmp-file) (lambda (input-port) - (connection-call-with-output-file (context-connection ctx) tmp-file + (connection-call-with-output-file (current-connection) tmp-file (lambda (output-port) (let loop ((data (get-bytevector-some input-port))) (unless (eof-object? data) @@ -92,44 +98,45 @@ (loop (get-bytevector-some input-port)))) (close-port output-port))))) -(define (install-remote-file ctx src dest owner group mode backup?) +(define (install-remote-file src dest owner group mode backup?) ;; If owner/group/mode is unspecified and the destination file already exists, ;; preserve the current ownership and mode. (unless (and owner group mode) - (let ((st ((action:stat dest) ctx))) + (let ((st (action:stat dest))) (when st (set! owner (or owner (assoc-ref st 'owner))) (set! group (or group (assoc-ref st 'group))) (set! mode (or mode (assoc-ref st 'mode)))))) (when (integer? mode) (set! mode (number->string mode 8))) - (must ctx "install" (chain-when - '() - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (backup? (append _ '("--backup" "numbered"))) - (#t (append _ (list src dest)))))) + (run (current-connection) + "install" (chain-when + '() + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append _ (list src dest)))) + #:check? #t)) (define* (action:install-file path #:key owner group mode content local-src remote-src backup?) (when (not (= 1 (length (filter identity (list content local-src remote-src))))) (error "exactly one of #:content, #:local-src, or #:remote-src is required")) - (lambda (ctx) - (if remote-src - (install-remote-file ctx remote-src path owner group mode backup?) - ;; Because we might need sudo to install the remote file, we first - ;; upload the source to a temporary file, then call @code{install-remote-file} to - ;; install the temporary file to the target path. - (match-let (((tmp-file) (must ctx "mktemp" '()))) - (dynamic-wind - (const #t) - (lambda () - (cond - (local-src (call-with-input-file local-src (upload-tmp-file ctx tmp-file))) - ((string? content) (call-with-input-string content (upload-tmp-file ctx tmp-file))) - ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx tmp-file))) - (else (error "unsupported type for #:content"))) - (install-remote-file ctx tmp-file path owner group mode backup?)) - (lambda () - ((action:remove tmp-file #:force? #t) ctx))))) - path)) + (if remote-src + (install-remote-file remote-src path owner group mode backup?) + ;; Because we might need sudo to install the remote file, we first + ;; upload the source to a temporary file, then call @code{install-remote-file} to + ;; install the temporary file to the target path. + (let ((tmp-file (run (current-connection) "mktemp" #:check? #t #:result car))) + (dynamic-wind + (const #t) + (lambda () + (cond + (local-src (call-with-input-file local-src (upload-tmp-file tmp-file))) + ((string? content) (call-with-input-string content (upload-tmp-file tmp-file))) + ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file tmp-file))) + (else (error "unsupported type for #:content"))) + (install-remote-file tmp-file path owner group mode backup?)) + (lambda () + (action:remove tmp-file #:force? #t))))) + path) From c126639016c84eca7a194f2a7d46f02c5d1e9f99 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Tue, 21 Jan 2025 21:06:23 +0000 Subject: [PATCH 50/83] Import just what we need, rename fs functions --- modules/ordo/action/apt.scm | 3 ++- modules/ordo/action/filesystem.scm | 42 ++++++++++++------------------ 2 files changed, 18 insertions(+), 27 deletions(-) diff --git a/modules/ordo/action/apt.scm b/modules/ordo/action/apt.scm index fc05ef7..60a2648 100644 --- a/modules/ordo/action/apt.scm +++ b/modules/ordo/action/apt.scm @@ -1,5 +1,6 @@ (define-module (ordo action apt) - #:use-module (ordo)) + #:use-module ((ordo connection) #:select (run)) + #:use-module ((ordo context) #:select (current-connection))) (define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive") ("APT_LISTCHANGES_FRONTEND" . "none"))) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index f433940..5d4cfa5 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -7,15 +7,16 @@ #:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) - #:use-module (ordo) - #:export (action:create-tmp-dir - action:install-dir - action:install-file - action:stat - action:remove - action:link)) + #:use-module ((ordo connection) #:select (run)) + #:use-module ((ordo context) #:select (current-connection)) + #:export (fs:create-tmp-dir + fs:install-dir + fs:install-file + fs:stat + fs:remove + fs:link)) -(define (action:stat path) +(define (fs:stat path) (define (parse-stat-result s) (match-let* (((file-type user group . rest) (string-split s #\:)) ((uid gid size mode atime mtime ctime) (map string->number rest))) @@ -35,7 +36,7 @@ ((string-contains (first result) "No such file or directory") #f) (else (error (format #f "stat ~a: ~a" path (first result))))))) -(define* (action:remove path #:key (recurse? #f) (force? #f) (verbose? #t)) +(define* (fs:remove path #:key (recurse? #f) (force? #f) (verbose? #t)) (run (current-connection) "rm" (chain-when '() (verbose? (append _ '("-v"))) @@ -44,7 +45,7 @@ (#t (append _ `(,path)))) #:check? #t)) -(define* (action:link target link-name #:key (symbolic? #f) (force? #f) (backup? #f)) +(define* (fs:link target link-name #:key (symbolic? #f) (force? #f) (backup? #f)) "Create a link to @code{target} with the name @code{link-name}." (run (current-connection) "ln" (chain-when '() @@ -54,7 +55,7 @@ (#t (append `(,target ,link-name)))) #:check? #t)) -(define* (action:create-tmp-dir #:key tmpdir suffix template) +(define* (fs:create-tmp-dir #:key tmpdir suffix template) (match-let (((tmp-dir) (run (current-connection) "mktemp" (chain-when '("--directory") @@ -64,18 +65,7 @@ #:check? #t))) tmp-dir)) -(define* (action:install-dir path #:key owner group mode) - ;; If owner/group/mode is unspecified and the destination directory already exists, - ;; preserve the current ownership and mode. - ;; TODO: this does not make much sense: if the object exists but is not a directory - ;; then the install will fail. If the object exists an *is* a directory, then we - ;; should just chmod/chown it. - (unless (and owner group mode) - (let ((st (action:stat path))) - (when st - (set! owner (or owner (assoc-ref st 'user))) - (set! group (or group (assoc-ref st 'group))) - (set! mode (or mode (assoc-ref st 'mode)))))) +(define* (fs:install-dir path #:key owner group mode) (when (integer? mode) (set! mode (number->string mode 8))) (run (current-connection) @@ -102,7 +92,7 @@ ;; If owner/group/mode is unspecified and the destination file already exists, ;; preserve the current ownership and mode. (unless (and owner group mode) - (let ((st (action:stat dest))) + (let ((st (fs:stat dest))) (when st (set! owner (or owner (assoc-ref st 'owner))) (set! group (or group (assoc-ref st 'group))) @@ -119,7 +109,7 @@ (#t (append _ (list src dest)))) #:check? #t)) -(define* (action:install-file path #:key owner group mode content local-src remote-src backup?) +(define* (fs:install-file path #:key owner group mode content local-src remote-src backup?) (when (not (= 1 (length (filter identity (list content local-src remote-src))))) (error "exactly one of #:content, #:local-src, or #:remote-src is required")) (if remote-src @@ -138,5 +128,5 @@ (else (error "unsupported type for #:content"))) (install-remote-file tmp-file path owner group mode backup?)) (lambda () - (action:remove tmp-file #:force? #t))))) + (fs:remove tmp-file #:force? #t))))) path) From de18c1d771ae7bc7d2d600c37f1f473c55f712eb Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 22 Jan 2025 09:49:59 +0000 Subject: [PATCH 51/83] Make actions take conn argument ...rather than using (current-connection). Rework apt module with a helper macro. --- modules/ordo/action/apt.scm | 56 ++++++++------------ modules/ordo/action/filesystem.scm | 85 ++++++++++++++---------------- 2 files changed, 63 insertions(+), 78 deletions(-) diff --git a/modules/ordo/action/apt.scm b/modules/ordo/action/apt.scm index 60a2648..6a19462 100644 --- a/modules/ordo/action/apt.scm +++ b/modules/ordo/action/apt.scm @@ -1,52 +1,42 @@ (define-module (ordo action apt) - #:use-module ((ordo connection) #:select (run)) - #:use-module ((ordo context) #:select (current-connection))) + #:use-module ((ordo connection) #:select (run))) (define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive") ("APT_LISTCHANGES_FRONTEND" . "none"))) -(define (apt-get . args) - (lambda () - (run (current-connection) "apt-get" (cons* "-q" "-y" args) #:env noninteractive-env))) +(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-public (action:apt-update) - (apt-get "update")) +(define-apt-operation apt:update "update") -(define-public (action:apt-upgrade) - (apt-get "upgrade")) +(define-apt-operation apt:upgrade "upgrade") -(define-public (action:apt-dist-upgrade) - (apt-get "dist-upgrade")) +(define-apt-operation apt:dist-upgrade "dist-upgrade") -(define-public (action:apt-install package-name) - (apt-get "install" package-name)) +(define-apt-operation (apt:install package-name) "install") -(define-public (action:apt-install-minimal package-name) - (apt-get "install" "--no-install-recommends" package-name)) +(define-apt-operation (apt:install-minimal package-name) "install" "--no-install-recommends") -(define-public (action:apt-reinstall package-name) - (apt-get "reinstall" package-name)) +(define-apt-operation (apt:reinstall package-name) "reinstall") -(define-public (action:apt-remove package-name) - (apt-get "remove" package-name)) +(define-apt-operation (apt:remove package-name) "remove") -(define-public (action:apt-purge package-name) - (apt-get "purge" package-name)) +(define-apt-operation (apt:purge package-name) "purge") -(define-public (action:apt-build-dep package-name) - (apt-get "build-dep" package-name)) +(define-apt-operation (apt:build-dep package-name) "build-dep") -(define-public (action:apt-clean) - (apt-get "clean")) +(define-apt-operation apt:clean "clean") -(define-public (action:apt-autoclean) - (apt-get "autoclean")) +(define-apt-operation apt:autoclean "autoclean") -(define-public (action:apt-distclean) - (apt-get "distclean")) +(define-apt-operation apt:distclean "distclean") -(define-public (action:apt-autoremove) - (apt-get "autoremove")) +(define-apt-operation apt:autoremove "autoremove") -(define-public (action:apt-autopurge) - (apt-get "autoperge")) +(define-apt-operation apt:autopurge "autopurge") diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 5d4cfa5..5989e65 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -8,7 +8,6 @@ #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module ((ordo connection) #:select (run)) - #:use-module ((ordo context) #:select (current-connection)) #:export (fs:create-tmp-dir fs:install-dir fs:install-file @@ -16,7 +15,7 @@ fs:remove fs:link)) -(define (fs:stat path) +(define (fs:stat conn path) (define (parse-stat-result s) (match-let* (((file-type user group . rest) (string-split s #\:)) ((uid gid size mode atime mtime ctime) (map string->number rest))) @@ -30,57 +29,53 @@ (atime . ,atime) (mtime . ,mtime) (ctime . ,ctime)))) - (let ((result rc (run (current-connection) "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path)))) + (let ((result rc (run conn "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path)))) (cond ((zero? rc) (parse-stat-result (first result))) ((string-contains (first result) "No such file or directory") #f) (else (error (format #f "stat ~a: ~a" path (first result))))))) -(define* (fs:remove path #:key (recurse? #f) (force? #f) (verbose? #t)) - (run (current-connection) - "rm" (chain-when '() - (verbose? (append _ '("-v"))) - (recurse? (append _ '("-r"))) - (force? (append _ '("-f"))) - (#t (append _ `(,path)))) +(define* (fs:remove conn path #:key (recurse? #f) (force? #f) (verbose? #t)) + (run conn "rm" (chain-when '() + (verbose? (append _ '("-v"))) + (recurse? (append _ '("-r"))) + (force? (append _ '("-f"))) + (#t (append _ `(,path)))) #:check? #t)) -(define* (fs:link target link-name #:key (symbolic? #f) (force? #f) (backup? #f)) +(define* (fs:link conn target link-name #:key (symbolic? #f) (force? #f) (backup? #f)) "Create a link to @code{target} with the name @code{link-name}." - (run (current-connection) - "ln" (chain-when '() - (symbolic? (append _ '("--symbolic"))) - (force? (append _ '("--force"))) - (backup? (append _ '("--backup" "numbered"))) - (#t (append `(,target ,link-name)))) + (run conn "ln" (chain-when '() + (symbolic? (append _ '("--symbolic"))) + (force? (append _ '("--force"))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append `(,target ,link-name)))) #:check? #t)) -(define* (fs:create-tmp-dir #:key tmpdir suffix template) - (match-let (((tmp-dir) (run (current-connection) - "mktemp" (chain-when - '("--directory") - (tmpdir (append _ `("--tmpdir" tmpdir))) - (suffix (append _ `("--suffix" suffix))) - (template (append _ `(template)))) +(define* (fs:create-tmp-dir conn #:key tmpdir suffix template) + (match-let (((tmp-dir) (run conn "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template)))) #:check? #t))) tmp-dir)) -(define* (fs:install-dir path #:key owner group mode) +(define* (fs:install-dir conn path #:key owner group mode) (when (integer? mode) (set! mode (number->string mode 8))) - (run (current-connection) - "install" (chain-when - '("--directory") - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (#t (append _ `(,path)))) + (run conn "install" (chain-when + '("--directory") + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (#t (append _ `(,path)))) #:check? #t) path) -(define (upload-tmp-file tmp-file) +(define (upload-tmp-file conn tmp-file) (lambda (input-port) - (connection-call-with-output-file (current-connection) tmp-file + (connection-call-with-output-file conn tmp-file (lambda (output-port) (let loop ((data (get-bytevector-some input-port))) (unless (eof-object? data) @@ -88,18 +83,18 @@ (loop (get-bytevector-some input-port)))) (close-port output-port))))) -(define (install-remote-file src dest owner group mode backup?) +(define (install-remote-file conn src dest owner group mode backup?) ;; If owner/group/mode is unspecified and the destination file already exists, ;; preserve the current ownership and mode. (unless (and owner group mode) - (let ((st (fs:stat dest))) + (let ((st (fs:stat conn dest))) (when st (set! owner (or owner (assoc-ref st 'owner))) (set! group (or group (assoc-ref st 'group))) (set! mode (or mode (assoc-ref st 'mode)))))) (when (integer? mode) (set! mode (number->string mode 8))) - (run (current-connection) + (run conn "install" (chain-when '() (owner (append _ `("--owner" ,owner))) @@ -109,24 +104,24 @@ (#t (append _ (list src dest)))) #:check? #t)) -(define* (fs:install-file path #:key owner group mode content local-src remote-src backup?) +(define* (fs:install-file conn path #:key owner group mode content local-src remote-src backup?) (when (not (= 1 (length (filter identity (list content local-src remote-src))))) (error "exactly one of #:content, #:local-src, or #:remote-src is required")) (if remote-src - (install-remote-file remote-src path owner group mode backup?) + (install-remote-file conn remote-src path owner group mode backup?) ;; Because we might need sudo to install the remote file, we first ;; upload the source to a temporary file, then call @code{install-remote-file} to ;; install the temporary file to the target path. - (let ((tmp-file (run (current-connection) "mktemp" #:check? #t #:result car))) + (let ((tmp-file (run conn "mktemp" #:check? #t #:result car))) (dynamic-wind (const #t) (lambda () (cond - (local-src (call-with-input-file local-src (upload-tmp-file tmp-file))) - ((string? content) (call-with-input-string content (upload-tmp-file tmp-file))) - ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file tmp-file))) + (local-src (call-with-input-file local-src (upload-tmp-file conn tmp-file))) + ((string? content) (call-with-input-string content (upload-tmp-file conn tmp-file))) + ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn tmp-file))) (else (error "unsupported type for #:content"))) - (install-remote-file tmp-file path owner group mode backup?)) + (install-remote-file conn tmp-file path owner group mode backup?)) (lambda () - (fs:remove tmp-file #:force? #t))))) + (fs:remove conn tmp-file #:force? #t))))) path) From f49be4af29116e02d95f126a1a300320b47f62e0 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 22 Jan 2025 22:00:13 +0000 Subject: [PATCH 52/83] Bugfixes and interceptor chain example. --- examples/interceptor.scm | 66 ++++++++++++++++++++++++++++++ modules/ordo/action/filesystem.scm | 31 +++++++------- modules/ordo/connection.scm | 3 +- modules/ordo/interceptor.scm | 42 ++++++++----------- 4 files changed, 102 insertions(+), 40 deletions(-) create mode 100644 examples/interceptor.scm diff --git a/examples/interceptor.scm b/examples/interceptor.scm new file mode 100644 index 0000000..ebb8689 --- /dev/null +++ b/examples/interceptor.scm @@ -0,0 +1,66 @@ +(use-modules + (ice-9 filesystem) + (oop goops) + (logging logger) + (srfi srfi-26) + (ordo logger) + (ordo interceptor) + (ordo connection) + (ordo connection sudo) + (ordo action filesystem)) + +(define* (i:connection c #:key sudo? sudo-user sudo-password) + "Interceptor to manage the current connection." + (interceptor + "manage-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 (lambda (ctx) + (and=> (context-connection ctx) conn:teardown) + (set-context-connection! ctx #f)))) + +(define (i:handle-errors) + "Interceptor to log (and clear) the context error. This will allow any + earlier #:leave handlers in the chain to run normally." + (interceptor + "handle-errors" + #:error (lambda (ctx) + (and=> (context-error ctx) (cut log-msg 'ERROR <>)) + (set-context-error! ctx #f)))) + +(define (i:tmp-dir) + "Interceptor to manage a temporary directory." + (interceptor + "tmp-dir" + #:enter (lambda (ctx) + (var-set! ctx 'tmp-dir (fs:create-tmp-dir (context-connection ctx)))) + #:leave (lambda (ctx) + (and=> (var-ref ctx 'tmp-dir #f) + (cut fs:remove (context-connection ctx) <> #:recurse? #t)) + (var-delete! ctx 'tmp-dir)))) + +(define chain + (list (i:connection (local-connection)) + (i:tmp-dir) + (i:handle-errors) + (interceptor + "hello-world" + #:enter (lambda (ctx) + (var-set! ctx 'hello + (fs:install-file (context-connection ctx) + (file-name-join* (var-ref ctx 'tmp-dir) + "hello.txt") + #:content "Hello, world!\n")))) + (interceptor + "get-file-status" + #:enter (lambda (ctx) + (let ((st (fs:stat (context-connection ctx) (var-ref ctx 'hello)))) + (log-msg 'INFO "stat result: " st)))))) + +(setup-logging #:level 'DEBUG) +(execute (init-context) chain) +(shutdown-logging) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 5989e65..2a56409 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -8,6 +8,7 @@ #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module ((ordo connection) #:select (run)) + #:use-module (ordo connection base) #:export (fs:create-tmp-dir fs:install-dir fs:install-file @@ -53,13 +54,13 @@ #:check? #t)) (define* (fs:create-tmp-dir conn #:key tmpdir suffix template) - (match-let (((tmp-dir) (run conn "mktemp" (chain-when - '("--directory") - (tmpdir (append _ `("--tmpdir" tmpdir))) - (suffix (append _ `("--suffix" suffix))) - (template (append _ `(template)))) - #:check? #t))) - tmp-dir)) + (run conn "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template)))) + #:check? #t + #:return car)) (define* (fs:install-dir conn path #:key owner group mode) (when (integer? mode) @@ -75,13 +76,13 @@ (define (upload-tmp-file conn tmp-file) (lambda (input-port) - (connection-call-with-output-file conn tmp-file - (lambda (output-port) - (let loop ((data (get-bytevector-some input-port))) - (unless (eof-object? data) - (put-bytevector output-port data) - (loop (get-bytevector-some input-port)))) - (close-port output-port))))) + (conn:call-with-output-file conn tmp-file + (lambda (output-port) + (let loop ((data (get-bytevector-some input-port))) + (unless (eof-object? data) + (put-bytevector output-port data) + (loop (get-bytevector-some input-port)))) + (close-port output-port))))) (define (install-remote-file conn src dest owner group mode backup?) ;; If owner/group/mode is unspecified and the destination file already exists, @@ -112,7 +113,7 @@ ;; Because we might need sudo to install the remote file, we first ;; upload the source to a temporary file, then call @code{install-remote-file} to ;; install the temporary file to the target path. - (let ((tmp-file (run conn "mktemp" #:check? #t #:result car))) + (let ((tmp-file (run conn "mktemp" #:check? #t #:return car))) (dynamic-wind (const #t) (lambda () diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index f5b4c60..d5e3223 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -16,7 +16,8 @@ local-connection ssh-connection call-with-connection - run)) + run) + #:re-export (conn:setup conn:teardown)) (define (connection? c) (is-a? c )) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm index 772aaf5..2a1eda0 100644 --- a/modules/ordo/interceptor.scm +++ b/modules/ordo/interceptor.scm @@ -8,13 +8,16 @@ #:use-module (ordo connection) #:export (interceptor init-context + context-connection + set-context-connection! context-error set-context-error! context-suppressed terminate-when execute - bind - unbind)) + var-set! + var-ref + var-delete!)) (define-record-type (make-interceptor name enter leave error) @@ -39,8 +42,8 @@ (error context-error set-context-error!) (suppressed context-suppressed set-context-suppressed!)) -(define* (init-context conn #:key (vars '())) - "Initialize a context with optional vars." +(define* (init-context #:key conn (vars '())) + "Initialize a context with optional connection and vars." (make-context ;; connection conn @@ -119,7 +122,7 @@ (set-context-suppressed! ctx (cons (make-interceptor-error (interceptor-name t) #:error e) (context-suppressed ctx)))) - (lambda () (handler ctx (context-error ctx))) + (lambda () (handler ctx)) #:unwind? #t)))) (define (execute-leave ctx) @@ -148,11 +151,10 @@ (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 execute the leave phase + ;; 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 '()) - (execute-leave ctx)) + (set-context-stack! ctx '())) ;; Otherwise, check for early termination or carry on down the chain (begin (check-terminators ctx) @@ -166,22 +168,14 @@ "Execute all the interceptors on the given context." (enqueue ctx interceptors) (execute-enter ctx) - (execute-leave ctx)) + (execute-leave ctx) + (and=> (context-error ctx) raise-exception)) -(define-syntax bind - (syntax-rules () - ((bind ctx name value) - (hash-table-set! (context-vars ctx) (quote name) value)))) +(define (var-set! ctx name value) + (hash-table-set! (context-vars ctx) name value)) -(define-syntax unbind - (syntax-rules () - ((unbind ctx name) - (hash-table-ref (context-vars ctx) (quote name))) - ((unbind ctx name default) - (hash-table-ref/default (context-vars ctx) (quote name) default)))) +(define* (var-ref ctx name #:optional default) + (hash-table-ref/default (context-vars ctx) name default)) -(define (keyword-arg kw args) - (cond - ((< (length args) 2) #f) - ((equal? (first args) kw) (second args)) - (else (keyword-arg kw (cddr args))))) +(define (var-delete! ctx name) + (hash-table-delete! (context-vars ctx) name)) From 63b9ad67539214048725bb6b66d43e3cbef32b2a Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Thu, 23 Jan 2025 17:08:06 +0000 Subject: [PATCH 53/83] Bugfix interceptor and add example --- examples/interceptor.scm | 71 +++++------------ modules/ordo/connection.scm | 21 ++++- modules/ordo/interceptor.scm | 114 ++++++++++++++++----------- modules/ordo/interceptor/debug.scm | 16 ++++ modules/ordo/interceptor/errors.scm | 14 ++++ modules/ordo/interceptor/tmp-dir.scm | 20 +++++ 6 files changed, 155 insertions(+), 101 deletions(-) create mode 100644 modules/ordo/interceptor/debug.scm create mode 100644 modules/ordo/interceptor/errors.scm create mode 100644 modules/ordo/interceptor/tmp-dir.scm diff --git a/examples/interceptor.scm b/examples/interceptor.scm index ebb8689..cedff3f 100644 --- a/examples/interceptor.scm +++ b/examples/interceptor.scm @@ -1,66 +1,31 @@ (use-modules (ice-9 filesystem) - (oop goops) (logging logger) - (srfi srfi-26) - (ordo logger) - (ordo interceptor) (ordo connection) - (ordo connection sudo) - (ordo action filesystem)) - -(define* (i:connection c #:key sudo? sudo-user sudo-password) - "Interceptor to manage the current connection." - (interceptor - "manage-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 (lambda (ctx) - (and=> (context-connection ctx) conn:teardown) - (set-context-connection! ctx #f)))) - -(define (i:handle-errors) - "Interceptor to log (and clear) the context error. This will allow any - earlier #:leave handlers in the chain to run normally." - (interceptor - "handle-errors" - #:error (lambda (ctx) - (and=> (context-error ctx) (cut log-msg 'ERROR <>)) - (set-context-error! ctx #f)))) - -(define (i:tmp-dir) - "Interceptor to manage a temporary directory." - (interceptor - "tmp-dir" - #:enter (lambda (ctx) - (var-set! ctx 'tmp-dir (fs:create-tmp-dir (context-connection ctx)))) - #:leave (lambda (ctx) - (and=> (var-ref ctx 'tmp-dir #f) - (cut fs:remove (context-connection ctx) <> #:recurse? #t)) - (var-delete! ctx 'tmp-dir)))) + (ordo interceptor) + (ordo interceptor tmp-dir) + (ordo interceptor debug) + (ordo action filesystem) + (ordo logger)) (define chain - (list (i:connection (local-connection)) - (i:tmp-dir) - (i:handle-errors) + (list (connection-interceptor (local-connection)) + (tmp-dir-interceptor #:tmp-dir) (interceptor - "hello-world" + "install hello" #:enter (lambda (ctx) - (var-set! ctx 'hello - (fs:install-file (context-connection ctx) - (file-name-join* (var-ref ctx 'tmp-dir) - "hello.txt") - #:content "Hello, world!\n")))) + (fs:install-file (context-connection ctx) + (file-name-join* (var-ref ctx #:tmp-dir) "hello.txt") + #:content "Hello, world!\n")) + #:register #:hello) (interceptor - "get-file-status" + "stat hello" #:enter (lambda (ctx) - (let ((st (fs:stat (context-connection ctx) (var-ref ctx 'hello)))) - (log-msg 'INFO "stat result: " st)))))) + (fs:stat (context-connection ctx) (var-ref ctx #:hello))) + #:register #:hello-stat) + (debug-vars-interceptor #:hello #:hello-stat) + (debug-vars-interceptor))) -(setup-logging #:level 'DEBUG) +(setup-logging #:level 'INFO) (execute (init-context) chain) (shutdown-logging) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index d5e3223..2e4c9b7 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -9,15 +9,16 @@ #:use-module (ordo connection local) #:use-module (ordo connection ssh) #:use-module (ordo connection sudo) + #:use-module (ordo interceptor) #:use-module (ordo util flatten) #:use-module (ordo util shell-quote) #:use-module (ordo util keyword-args) - #:export (connection? + #:export (connection-interceptor + connection? local-connection ssh-connection call-with-connection - run) - #:re-export (conn:setup conn:teardown)) + run)) (define (connection? c) (is-a? c )) @@ -67,3 +68,17 @@ (make-external-error) (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog))))) (values (return out) rc))))) + +(define* (connection-interceptor c #:key sudo? sudo-user sudo-password) + "Interceptor to manage the current connection." + (interceptor + "manage-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 (lambda (ctx) + (and=> (context-connection ctx) conn:teardown) + (set-context-connection! ctx #f)))) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm index 2a1eda0..d899769 100644 --- a/modules/ordo/interceptor.scm +++ b/modules/ordo/interceptor.scm @@ -3,9 +3,9 @@ #: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 (ordo connection) #:export (interceptor init-context context-connection @@ -13,23 +13,20 @@ context-error set-context-error! context-suppressed - terminate-when - execute - var-set! + context-vars + set-context-vars! var-ref - var-delete!)) + var-set! + var-delete! + terminate-when + execute)) -(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) - "Create an interceptor with optional enter, leave, and error functions." - (make-interceptor name enter leave error)) +(define (check-var-name name) + (unless (keyword? name) + (raise-exception (make-exception + (make-assertion-failure) + (make-exception-with-message "Variable name should be a keyword") + (make-exception-with-irritants name))))) (define-record-type (make-context connection vars stack queue terminators error suppressed) @@ -44,6 +41,7 @@ (define* (init-context #:key conn (vars '())) "Initialize a context with optional connection and vars." + (for-each check-var-name (map car vars)) (make-context ;; connection conn @@ -60,6 +58,34 @@ ;; 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-record-type + (make-interceptor name enter leave error register) + interceptor? + (name interceptor-name) + (enter interceptor-enter) + (leave interceptor-leave) + (error interceptor-error) + (register interceptor-register)) + +(define* (interceptor name #:key enter leave error register) + "Create an interceptor with optional enter, leave, and error functions." + (make-interceptor name enter leave error register)) + (define-exception-type &interceptor-error &error make-interceptor-error interceptor-error? @@ -91,19 +117,21 @@ "Run the interceptor's #:enter function." (let ((handler (interceptor-enter t))) (when handler - (log-msg 'INFO "Running #:enter function for " (interceptor-name t)) + (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)) + (lambda () + (let ((result (handler ctx))) + (and=> (interceptor-register t) (cut var-set! ctx <> result)))) #:unwind? #t)))) (define (try-leave ctx t) "Run the interceptor's #:leave function." (let ((handler (interceptor-leave t))) (when handler - (log-msg 'INFO "Running #:leave function for " (interceptor-name t)) + (log-msg 'NOTICE "Running #:leave function for " (interceptor-name t)) (with-exception-handler (lambda (e) (set-context-error! ctx @@ -115,7 +143,7 @@ "Run the interceptor's #:error function." (let ((handler (interceptor-error t))) (when handler - (log-msg 'INFO "Running #:error function for " (interceptor-name t)) + (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) @@ -143,22 +171,24 @@ (define (execute-enter ctx) "Run all the #:enter functions in the queue." - (unless (null? (context-queue 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)))))) + (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." @@ -166,16 +196,10 @@ (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)) - -(define (var-set! ctx name value) - (hash-table-set! (context-vars ctx) name value)) - -(define* (var-ref ctx name #:optional default) - (hash-table-ref/default (context-vars ctx) name default)) - -(define (var-delete! ctx name) - (hash-table-delete! (context-vars ctx) name)) diff --git a/modules/ordo/interceptor/debug.scm b/modules/ordo/interceptor/debug.scm new file mode 100644 index 0000000..ca4707a --- /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-interceptor)) + +(define (debug-vars-interceptor . 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/errors.scm b/modules/ordo/interceptor/errors.scm new file mode 100644 index 0000000..7dbf012 --- /dev/null +++ b/modules/ordo/interceptor/errors.scm @@ -0,0 +1,14 @@ +(define-module (ordo interceptor errors) + #:use-module (logging logger) + #:use-module (srfi srfi-26) + #:use-module (ordo interceptor) + #:export (errors-interceptor)) + +(define (errors-interceptor) + "Interceptor to log (and clear) the context error. This will allow any + earlier #:leave handlers in the chain to run normally." + (interceptor + "handle-errors" + #:error (lambda (ctx) + (and=> (context-error ctx) (cut log-msg 'ERROR <>)) + (set-context-error! ctx #f)))) diff --git a/modules/ordo/interceptor/tmp-dir.scm b/modules/ordo/interceptor/tmp-dir.scm new file mode 100644 index 0000000..f1d0acd --- /dev/null +++ b/modules/ordo/interceptor/tmp-dir.scm @@ -0,0 +1,20 @@ +(define-module (ordo interceptor tmp-dir) + #:use-module (ice-9 format) + #:use-module (ordo connection) + #:use-module (ordo interceptor) + #:export (tmp-dir-interceptor)) + +(define (tmp-dir-interceptor var-name) + (define (create-tmp-dir ctx) + (run (context-connection ctx) "mktemp" "--directory" #:check? #t #:return car)) + (define (cleanup-tmp-dir ctx) + (and=> (var-ref ctx var-name #f) + (lambda (dir-name) + (run (context-connection ctx) "rm" "-rf" dir-name))) + (var-delete! ctx var-name)) + (interceptor + (format #f "manage-tmp-dir ~a" var-name) + #:enter create-tmp-dir + #:register var-name + #:leave cleanup-tmp-dir + #:error cleanup-tmp-dir)) From e22e6181427f52936752fd2f73ab2fdfe6554084 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Thu, 23 Jan 2025 17:12:56 +0000 Subject: [PATCH 54/83] Remove interceptors from the main branch --- examples/interceptor.scm | 66 ------------- modules/ordo/interceptor.scm | 181 ----------------------------------- 2 files changed, 247 deletions(-) delete mode 100644 examples/interceptor.scm delete mode 100644 modules/ordo/interceptor.scm diff --git a/examples/interceptor.scm b/examples/interceptor.scm deleted file mode 100644 index ebb8689..0000000 --- a/examples/interceptor.scm +++ /dev/null @@ -1,66 +0,0 @@ -(use-modules - (ice-9 filesystem) - (oop goops) - (logging logger) - (srfi srfi-26) - (ordo logger) - (ordo interceptor) - (ordo connection) - (ordo connection sudo) - (ordo action filesystem)) - -(define* (i:connection c #:key sudo? sudo-user sudo-password) - "Interceptor to manage the current connection." - (interceptor - "manage-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 (lambda (ctx) - (and=> (context-connection ctx) conn:teardown) - (set-context-connection! ctx #f)))) - -(define (i:handle-errors) - "Interceptor to log (and clear) the context error. This will allow any - earlier #:leave handlers in the chain to run normally." - (interceptor - "handle-errors" - #:error (lambda (ctx) - (and=> (context-error ctx) (cut log-msg 'ERROR <>)) - (set-context-error! ctx #f)))) - -(define (i:tmp-dir) - "Interceptor to manage a temporary directory." - (interceptor - "tmp-dir" - #:enter (lambda (ctx) - (var-set! ctx 'tmp-dir (fs:create-tmp-dir (context-connection ctx)))) - #:leave (lambda (ctx) - (and=> (var-ref ctx 'tmp-dir #f) - (cut fs:remove (context-connection ctx) <> #:recurse? #t)) - (var-delete! ctx 'tmp-dir)))) - -(define chain - (list (i:connection (local-connection)) - (i:tmp-dir) - (i:handle-errors) - (interceptor - "hello-world" - #:enter (lambda (ctx) - (var-set! ctx 'hello - (fs:install-file (context-connection ctx) - (file-name-join* (var-ref ctx 'tmp-dir) - "hello.txt") - #:content "Hello, world!\n")))) - (interceptor - "get-file-status" - #:enter (lambda (ctx) - (let ((st (fs:stat (context-connection ctx) (var-ref ctx 'hello)))) - (log-msg 'INFO "stat result: " st)))))) - -(setup-logging #:level 'DEBUG) -(execute (init-context) chain) -(shutdown-logging) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm deleted file mode 100644 index 2a1eda0..0000000 --- a/modules/ordo/interceptor.scm +++ /dev/null @@ -1,181 +0,0 @@ -(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-69) ; hash tables - #:use-module (srfi srfi-71) ; extended let - #:use-module (ordo connection) - #:export (interceptor - init-context - context-connection - set-context-connection! - context-error - set-context-error! - context-suppressed - terminate-when - execute - var-set! - var-ref - var-delete!)) - -(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) - "Create an interceptor with optional enter, leave, and error functions." - (make-interceptor name enter leave error)) - -(define-record-type - (make-context connection 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 conn (vars '())) - "Initialize a context with optional connection and vars." - (make-context - ;; connection - conn - ;; vars - (alist->hash-table vars equal?) - ;; stack - '() - ;; queue - '() - ;; terminators - '() - ;; error - #f - ;; suppressed errors - '())) - -(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 'INFO "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 'INFO "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 'INFO "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." - (unless (null? (context-queue 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." - (enqueue ctx interceptors) - (execute-enter ctx) - (execute-leave ctx) - (and=> (context-error ctx) raise-exception)) - -(define (var-set! ctx name value) - (hash-table-set! (context-vars ctx) name value)) - -(define* (var-ref ctx name #:optional default) - (hash-table-ref/default (context-vars ctx) name default)) - -(define (var-delete! ctx name) - (hash-table-delete! (context-vars ctx) name)) From 8a1e1b244fb3ed0c9136f3c83863ce4ab3282c8b Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Thu, 23 Jan 2025 18:19:54 +0000 Subject: [PATCH 55/83] Some simplifications --- examples/basic.scm | 34 ++++++++++++++++++++++++++++++ examples/install-aws-cli.scm | 19 +++++++++++------ modules/ordo/action/filesystem.scm | 16 ++++++++------ modules/ordo/cli.scm | 4 ++++ modules/ordo/connection.scm | 1 + modules/ordo/play.scm | 7 +++--- modules/ordo/playbook.scm | 3 ++- modules/ordo/task.scm | 21 +++++++++++------- 8 files changed, 78 insertions(+), 27 deletions(-) create mode 100644 examples/basic.scm diff --git a/examples/basic.scm b/examples/basic.scm new file mode 100644 index 0000000..597d1ad --- /dev/null +++ b/examples/basic.scm @@ -0,0 +1,34 @@ +(use-modules + (ice-9 filesystem) + (ice-9 pretty-print) + (logging logger) + (ordo) + (ordo action filesystem)) + +(playbook + #:name "Basic filesystem operations" + #:plays (list + (play + #:name "Temporary files on localhost" + #:host "localhost" + #:tasks (list + (task #:name "Create temporary directory" + #:action (lambda () (fs:create-tmp-dir (current-connection))) + #:register-play-var #:tmp-dir) + + (task #:name "Create hello.txt" + #:action (lambda () (fs:install-file (current-connection) + (file-name-join* ($ #:tmp-dir) "hello.txt") + #:content "Hello, world!")) + #:register-play-var #:hello) + + (task #:name "Stat hello.txt" + #:action (lambda () (fs:stat (current-connection) ($ #:hello))) + #:register-play-var #:hello-stat) + + (task #:name "Debug variables" + #:action (lambda () + (pretty-print (list #:hello ($ #:hello) #:hello-stat ($ #:hello-stat))))) + + (task #:name "Clean up tmp dir" + #:action (lambda () (fs:remove (current-connection) ($ #:tmp-dir) #:recurse? #t #:verbose? #t))))))) diff --git a/examples/install-aws-cli.scm b/examples/install-aws-cli.scm index 15ea839..0ee79aa 100644 --- a/examples/install-aws-cli.scm +++ b/examples/install-aws-cli.scm @@ -19,10 +19,15 @@ (lambda () (run conn "rm" "-rf" tmp-dir))))) -(playbook "Test Playbook" - (play "Test play" - #:host "localhost" - (task - (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"))))) +(playbook + #:name "Test Playbook" + #:plays (list + (play + #:name "Test play" + #: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")))))))) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 2a56409..7bd0bf4 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -36,13 +36,15 @@ ((string-contains (first result) "No such file or directory") #f) (else (error (format #f "stat ~a: ~a" path (first result))))))) -(define* (fs:remove conn path #:key (recurse? #f) (force? #f) (verbose? #t)) - (run conn "rm" (chain-when '() - (verbose? (append _ '("-v"))) - (recurse? (append _ '("-r"))) - (force? (append _ '("-f"))) - (#t (append _ `(,path)))) - #:check? #t)) +(define* (fs:remove conn path #:key (recurse? #f) (force? #f) (verbose? #f)) + (let ((out (run conn "rm" (chain-when '() + (verbose? (append _ '("-v"))) + (recurse? (append _ '("-r"))) + (force? (append _ '("-f"))) + (#t (append _ `(,path)))) + #:check? #t))) + (when verbose? + (for-each (cut log-msg 'INFO <>) out)))) (define* (fs:link conn target link-name #:key (symbolic? #f) (force? #f) (backup? #f)) "Create a link to @code{target} with the name @code{link-name}." diff --git a/modules/ordo/cli.scm b/modules/ordo/cli.scm index 519e3f1..8312ccb 100644 --- a/modules/ordo/cli.scm +++ b/modules/ordo/cli.scm @@ -1,5 +1,6 @@ (define-module (ordo cli) #:use-module (ice-9 match) + #:use-module (logging logger) #:use-module (ordo logger) #:use-module (ordo context) #:use-module (ordo playbook) @@ -9,8 +10,11 @@ (define (main args) (match-let (((_ inventory-path playbook-path) args)) (setup-logging #:level 'DEBUG) + (log-msg 'DEBUG "Initializing context") (init-context!) (load inventory-path) + (log-msg 'DEBUG "Loaded inventory: " inventory-path) (let ((playbook (load playbook-path))) + (log-msg 'DEBUG "Loaded playbook: " playbook-path) (run-playbook playbook)) (quit))) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index d5e3223..817f797 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -4,6 +4,7 @@ #:use-module (ice-9 match) #:use-module (logging logger) #:use-module (srfi srfi-1) ; list operations + #:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-71) ; extended let #:use-module (ordo connection base) #:use-module (ordo connection local) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index 8586425..7c1f3a4 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -34,10 +34,9 @@ (handlers play-handlers) (gather-facts play-gather-facts)) -(define* (play name #:key host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (gather-facts #t) . more) - (let ((tasks (filter task? more)) - (handlers (filter handler? more))) - (make-play name host sudo? sudo-user sudo-password vars gather-facts tasks handlers))) +;; 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 (run-play p) (log-msg 'NOTICE "Running play: " (play-name p)) diff --git a/modules/ordo/playbook.scm b/modules/ordo/playbook.scm index b8a1169..a9df40d 100644 --- a/modules/ordo/playbook.scm +++ b/modules/ordo/playbook.scm @@ -17,7 +17,8 @@ (vars playbook-vars) (plays playbook-plays)) -(define* (playbook name #:key (vars '()) . plays) +;; TODO: argument validation +(define* (playbook #:key name (vars '()) plays) (make-playbook name vars plays)) (define (run-playbook pb) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index 0b62d8d..460f40f 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -1,4 +1,5 @@ (define-module (ordo task) + #:use-module (ice-9 exceptions) #:use-module (srfi srfi-9) #:use-module (logging logger) #:use-module (ordo context) @@ -24,15 +25,19 @@ (register-playbook-var task-register-playbook-var) (triggers task-triggers)) -(define* (%task name action #:key (tags '()) (condition (const #t)) (register-play-var #f) (register-playbook-var #f) (triggers '())) - (make-task name tags action condition register-play-var register-playbook-var triggers)) - -(define-syntax task +(define-syntax assert (syntax-rules () - ((task (f args ...) kwargs ...) - (%task (symbol->string 'f) (lambda () (f args ...) kwargs ...))) - ((task name (f args ...) kwargs ...) - (%task name (lambda () (f args ...)) kwargs ...)))) + ((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)) From 740126366495815b6f173bc15ba298ab802bf1d3 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Thu, 23 Jan 2025 18:29:47 +0000 Subject: [PATCH 56/83] Expand file names before loading --- modules/ordo/cli.scm | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/modules/ordo/cli.scm b/modules/ordo/cli.scm index 8312ccb..64241e6 100644 --- a/modules/ordo/cli.scm +++ b/modules/ordo/cli.scm @@ -1,4 +1,5 @@ (define-module (ordo cli) + #:use-module (ice-9 filesystem) #:use-module (ice-9 match) #:use-module (logging logger) #:use-module (ordo logger) @@ -9,12 +10,14 @@ (define (main args) (match-let (((_ inventory-path playbook-path) args)) - (setup-logging #:level 'DEBUG) - (log-msg 'DEBUG "Initializing context") - (init-context!) - (load inventory-path) - (log-msg 'DEBUG "Loaded inventory: " inventory-path) - (let ((playbook (load playbook-path))) - (log-msg 'DEBUG "Loaded playbook: " playbook-path) - (run-playbook playbook)) - (quit))) + (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!) + (load inventory-path) + (log-msg 'DEBUG "Loaded inventory: " inventory-path) + (let ((playbook (load playbook-path))) + (log-msg 'DEBUG "Loaded playbook: " playbook-path) + (run-playbook playbook)) + (quit)))) From 06c2679c648c163abba718d9d15e2d1342e3ddcf Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Thu, 23 Jan 2025 18:29:56 +0000 Subject: [PATCH 57/83] Helper script for invoking CLI --- bin/ordo.sh | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100755 bin/ordo.sh diff --git a/bin/ordo.sh b/bin/ordo.sh new file mode 100755 index 0000000..f2c6e2a --- /dev/null +++ b/bin/ordo.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +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)' -- "$@" From 0f6744ad30b995485f42602af73be18f6fc973d3 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 25 Jan 2025 14:41:37 +0000 Subject: [PATCH 58/83] Improvements to interceptors --- examples/interceptor.scm | 36 ++--- modules/ordo/action/quadlet.scm | 41 ++++++ modules/ordo/context.scm | 152 -------------------- modules/ordo/facts.scm | 19 --- modules/ordo/facts/user.scm | 32 ----- modules/ordo/handler.scm | 25 ---- modules/ordo/interceptor.scm | 52 ++++--- modules/ordo/interceptor/create-tmp-dir.scm | 19 +++ modules/ordo/interceptor/debug.scm | 4 +- modules/ordo/interceptor/errors.scm | 14 -- modules/ordo/interceptor/install-file.scm | 28 ++++ modules/ordo/interceptor/stat-file.scm | 17 +++ modules/ordo/interceptor/tmp-dir.scm | 20 --- modules/ordo/interceptor/user-info.scm | 43 ++++++ modules/ordo/task.scm | 48 ------- 15 files changed, 203 insertions(+), 347 deletions(-) create mode 100644 modules/ordo/action/quadlet.scm delete mode 100644 modules/ordo/context.scm delete mode 100644 modules/ordo/facts.scm delete mode 100644 modules/ordo/facts/user.scm delete mode 100644 modules/ordo/handler.scm create mode 100644 modules/ordo/interceptor/create-tmp-dir.scm delete mode 100644 modules/ordo/interceptor/errors.scm create mode 100644 modules/ordo/interceptor/install-file.scm create mode 100644 modules/ordo/interceptor/stat-file.scm delete mode 100644 modules/ordo/interceptor/tmp-dir.scm create mode 100644 modules/ordo/interceptor/user-info.scm delete mode 100644 modules/ordo/task.scm diff --git a/examples/interceptor.scm b/examples/interceptor.scm index cedff3f..b0d1631 100644 --- a/examples/interceptor.scm +++ b/examples/interceptor.scm @@ -1,30 +1,32 @@ (use-modules (ice-9 filesystem) + (srfi srfi-2) + (srfi srfi-71) (logging logger) (ordo connection) (ordo interceptor) - (ordo interceptor tmp-dir) + (ordo interceptor install-file) + (ordo interceptor create-tmp-dir) + (ordo interceptor stat-file) + (ordo interceptor user-info) (ordo interceptor debug) - (ordo action filesystem) (ordo logger)) (define chain (list (connection-interceptor (local-connection)) - (tmp-dir-interceptor #:tmp-dir) - (interceptor - "install hello" - #:enter (lambda (ctx) - (fs:install-file (context-connection ctx) - (file-name-join* (var-ref ctx #:tmp-dir) "hello.txt") - #:content "Hello, world!\n")) - #:register #:hello) - (interceptor - "stat hello" - #:enter (lambda (ctx) - (fs:stat (context-connection ctx) (var-ref ctx #:hello))) - #:register #:hello-stat) - (debug-vars-interceptor #:hello #:hello-stat) - (debug-vars-interceptor))) + (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 "Hello, world!\n" + #:register 'hello) + (stat-file + "stat-hello" + #:path (let-vars (hello) hello) + #:register 'hello-stat) + (debug-vars 'hello 'hello-stat))) (setup-logging #:level 'INFO) (execute (init-context) chain) 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/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 index d899769..8e9036d 100644 --- a/modules/ordo/interceptor.scm +++ b/modules/ordo/interceptor.scm @@ -1,11 +1,12 @@ (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-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 @@ -18,14 +19,16 @@ var-ref var-set! var-delete! + let-vars + expand-vars terminate-when execute)) (define (check-var-name name) - (unless (keyword? name) + (unless (symbol? name) (raise-exception (make-exception (make-assertion-failure) - (make-exception-with-message "Variable name should be a keyword") + (make-exception-with-message "Variable name should be a symbol") (make-exception-with-irritants name))))) (define-record-type @@ -73,18 +76,34 @@ (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 expand-vars + (syntax-rules () + ((expand-vars ctx v ...) + (values (if (and (procedure? v) (procedure-property v 'delayed-var-ref?)) + (v ctx) + v) + ...)))) + (define-record-type - (make-interceptor name enter leave error register) + (make-interceptor name enter leave error) interceptor? (name interceptor-name) (enter interceptor-enter) (leave interceptor-leave) - (error interceptor-error) - (register interceptor-register)) + (error interceptor-error)) -(define* (interceptor name #:key enter leave error register) - "Create an interceptor with optional enter, leave, and error functions." - (make-interceptor name enter leave error register)) +(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 @@ -120,11 +139,8 @@ (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 () - (let ((result (handler ctx))) - (and=> (interceptor-register t) (cut var-set! ctx <> result)))) + (set-context-error! ctx (make-interceptor-error (interceptor-name t) #:enter e))) + (lambda () (handler ctx)) #:unwind? #t)))) (define (try-leave ctx t) 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 index ca4707a..025f9b8 100644 --- a/modules/ordo/interceptor/debug.scm +++ b/modules/ordo/interceptor/debug.scm @@ -3,9 +3,9 @@ #:use-module ((srfi srfi-1) #:select (concatenate)) #:use-module ((srfi srfi-69) #:select (hash-table-keys)) #:use-module (ordo interceptor) - #:export (debug-vars-interceptor)) + #:export (debug-vars)) -(define (debug-vars-interceptor . var-names) +(define (debug-vars . var-names) (interceptor "debug-vars" #:enter (lambda (ctx) diff --git a/modules/ordo/interceptor/errors.scm b/modules/ordo/interceptor/errors.scm deleted file mode 100644 index 7dbf012..0000000 --- a/modules/ordo/interceptor/errors.scm +++ /dev/null @@ -1,14 +0,0 @@ -(define-module (ordo interceptor errors) - #:use-module (logging logger) - #:use-module (srfi srfi-26) - #:use-module (ordo interceptor) - #:export (errors-interceptor)) - -(define (errors-interceptor) - "Interceptor to log (and clear) the context error. This will allow any - earlier #:leave handlers in the chain to run normally." - (interceptor - "handle-errors" - #:error (lambda (ctx) - (and=> (context-error ctx) (cut log-msg 'ERROR <>)) - (set-context-error! ctx #f)))) 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/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/tmp-dir.scm b/modules/ordo/interceptor/tmp-dir.scm deleted file mode 100644 index f1d0acd..0000000 --- a/modules/ordo/interceptor/tmp-dir.scm +++ /dev/null @@ -1,20 +0,0 @@ -(define-module (ordo interceptor tmp-dir) - #:use-module (ice-9 format) - #:use-module (ordo connection) - #:use-module (ordo interceptor) - #:export (tmp-dir-interceptor)) - -(define (tmp-dir-interceptor var-name) - (define (create-tmp-dir ctx) - (run (context-connection ctx) "mktemp" "--directory" #:check? #t #:return car)) - (define (cleanup-tmp-dir ctx) - (and=> (var-ref ctx var-name #f) - (lambda (dir-name) - (run (context-connection ctx) "rm" "-rf" dir-name))) - (var-delete! ctx var-name)) - (interceptor - (format #f "manage-tmp-dir ~a" var-name) - #:enter create-tmp-dir - #:register var-name - #:leave cleanup-tmp-dir - #:error cleanup-tmp-dir)) diff --git a/modules/ordo/interceptor/user-info.scm b/modules/ordo/interceptor/user-info.scm new file mode 100644 index 0000000..987d1b8 --- /dev/null +++ b/modules/ordo/interceptor/user-info.scm @@ -0,0 +1,43 @@ +(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) + #: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" (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/task.scm b/modules/ordo/task.scm deleted file mode 100644 index 0b62d8d..0000000 --- a/modules/ordo/task.scm +++ /dev/null @@ -1,48 +0,0 @@ -(define-module (ordo task) - #: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* (%task name action #:key (tags '()) (condition (const #t)) (register-play-var #f) (register-playbook-var #f) (triggers '())) - (make-task name tags action condition register-play-var register-playbook-var triggers)) - -(define-syntax task - (syntax-rules () - ((task (f args ...) kwargs ...) - (%task (symbol->string 'f) (lambda () (f args ...) kwargs ...))) - ((task name (f args ...) kwargs ...) - (%task name (lambda () (f args ...)) kwargs ...)))) - -(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))))))) From d79dbaddedfe42b1b1c30c74c8249eff9c8dfaf1 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 25 Jan 2025 15:46:12 +0000 Subject: [PATCH 59/83] Update modules to work with interceptors --- bin/ordo.sh | 5 ++ bin/play.scm | 43 ---------------- examples/interceptor.scm | 48 +++++++++--------- examples/inventory.scm | 3 +- modules/ordo.scm | 10 ---- modules/ordo/cli.scm | 18 ++++--- modules/ordo/condition.scm | 9 ++-- modules/ordo/connection.scm | 21 ++------ modules/ordo/interceptor.scm | 8 ++- modules/ordo/interceptor/connection.scm | 22 +++++++++ modules/ordo/interceptor/user-info.scm | 3 +- modules/ordo/{host.scm => inventory.scm} | 23 ++++++--- modules/ordo/play.scm | 62 ++++++++---------------- modules/ordo/playbook.scm | 13 ++--- 14 files changed, 115 insertions(+), 173 deletions(-) create mode 100755 bin/ordo.sh delete mode 100755 bin/play.scm delete mode 100644 modules/ordo.scm create mode 100644 modules/ordo/interceptor/connection.scm rename modules/ordo/{host.scm => inventory.scm} (65%) diff --git a/bin/ordo.sh b/bin/ordo.sh new file mode 100755 index 0000000..9ecc787 --- /dev/null +++ b/bin/ordo.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +MODULES_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )/../modules" &> /dev/null && pwd ) + +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/interceptor.scm b/examples/interceptor.scm index b0d1631..d01ec6f 100644 --- a/examples/interceptor.scm +++ b/examples/interceptor.scm @@ -1,33 +1,31 @@ (use-modules (ice-9 filesystem) - (srfi srfi-2) - (srfi srfi-71) - (logging logger) - (ordo connection) + (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 debug) - (ordo logger)) + (ordo interceptor debug)) -(define chain - (list (connection-interceptor (local-connection)) - (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 "Hello, world!\n" - #:register 'hello) - (stat-file - "stat-hello" - #:path (let-vars (hello) hello) - #:register 'hello-stat) - (debug-vars 'hello 'hello-stat))) - -(setup-logging #:level 'INFO) -(execute (init-context) chain) -(shutdown-logging) +(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 (let-vars (file-content) file-content) + #:register 'hello) + (stat-file + "stat-hello" + #:path (let-vars (hello) hello) + #:register 'hello-stat) + (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/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/cli.scm b/modules/ordo/cli.scm index 519e3f1..0038916 100644 --- a/modules/ordo/cli.scm +++ b/modules/ordo/cli.scm @@ -1,16 +1,20 @@ (define-module (ordo cli) + #:use-module (ice-9 filesystem) #: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)) (define (main args) (match-let (((_ inventory-path playbook-path) args)) - (setup-logging #:level 'DEBUG) - (init-context!) - (load inventory-path) - (let ((playbook (load playbook-path))) - (run-playbook playbook)) - (quit))) + (let ((inventory-path (expand-file-name inventory-path)) + (playbook-path (expand-file-name playbook-path))) + (setup-logging #:level 'INFO) + (load inventory-path) + (log-msg 'DEBUG "Loaded inventory: " inventory-path) + (let ((playbook (load playbook-path))) + (log-msg 'DEBUG "Loaded playbook: " playbook-path) + (run-playbook playbook)) + (quit)))) 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 2e4c9b7..d5e3223 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -9,16 +9,15 @@ #:use-module (ordo connection local) #:use-module (ordo connection ssh) #:use-module (ordo connection sudo) - #:use-module (ordo interceptor) #:use-module (ordo util flatten) #:use-module (ordo util shell-quote) #:use-module (ordo util keyword-args) - #:export (connection-interceptor - connection? + #:export (connection? local-connection ssh-connection call-with-connection - run)) + run) + #:re-export (conn:setup conn:teardown)) (define (connection? c) (is-a? c )) @@ -68,17 +67,3 @@ (make-external-error) (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog))))) (values (return out) rc))))) - -(define* (connection-interceptor c #:key sudo? sudo-user sudo-password) - "Interceptor to manage the current connection." - (interceptor - "manage-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 (lambda (ctx) - (and=> (context-connection ctx) conn:teardown) - (set-context-connection! ctx #f)))) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm index 8e9036d..af3a4ec 100644 --- a/modules/ordo/interceptor.scm +++ b/modules/ordo/interceptor.scm @@ -32,7 +32,7 @@ (make-exception-with-irritants name))))) (define-record-type - (make-context connection vars stack queue terminators error suppressed) + (make-context vars stack queue terminators error suppressed) context? (connection context-connection set-context-connection!) (vars context-vars set-context-vars!) @@ -42,14 +42,12 @@ (error context-error set-context-error!) (suppressed context-suppressed set-context-suppressed!)) -(define* (init-context #:key conn (vars '())) +(define* (init-context #:key (vars '())) "Initialize a context with optional connection and vars." (for-each check-var-name (map car vars)) (make-context - ;; connection - conn ;; vars - (alist->hash-table vars equal?) + (alist->hash-table vars eqv?) ;; stack '() ;; queue 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/user-info.scm b/modules/ordo/interceptor/user-info.scm index 987d1b8..291e5c7 100644 --- a/modules/ordo/interceptor/user-info.scm +++ b/modules/ordo/interceptor/user-info.scm @@ -4,6 +4,7 @@ #: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) @@ -33,7 +34,7 @@ (let* ((conn (context-connection ctx)) (id (run conn "id" #:check? #t #:return (compose parse-id car))) - (pwent (run conn "getent" "passwd" (assoc-ref id #:user-name) + (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)) diff --git a/modules/ordo/host.scm b/modules/ordo/inventory.scm similarity index 65% rename from modules/ordo/host.scm rename to modules/ordo/inventory.scm index fa19045..37294f2 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,6 +20,10 @@ (connection host-connection) (tags host-tags)) +(define (add-host! name connection . tags) + (set! *inventory* (cons (make-host name connection tags) + *inventory*))) + (define (tagged-all? wanted-tags) (lambda (h) (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) @@ -29,11 +36,11 @@ (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*) + (('every-tag tag . tags) (filter (tagged-all? (cons tag tags)) *inventory*)) + (('any-tag tag . tags) (filter (tagged-any? (cons tag tags)) *inventory*)))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index 8586425..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,42 +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)) -(define* (play name #:key host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (gather-facts #t) . more) - (let ((tasks (filter task? more)) - (handlers (filter handler? more))) - (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 b8a1169..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,15 +17,10 @@ (vars playbook-vars) (plays playbook-plays)) -(define* (playbook name #:key (vars '()) . plays) +(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))) From 7cf4e5a4dfc9626b914e70dcc52d98a9dda05b77 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 25 Jan 2025 18:05:52 +0000 Subject: [PATCH 60/83] Implement install-aws-cli as an interceptor chain --- examples/install-aws-cli.scm | 84 ++++++++++++++----- modules/ordo/interceptor/require-commands.scm | 28 +++++++ 2 files changed, 89 insertions(+), 23 deletions(-) create mode 100644 modules/ordo/interceptor/require-commands.scm diff --git a/examples/install-aws-cli.scm b/examples/install-aws-cli.scm index 15ea839..58df289 100644 --- a/examples/install-aws-cli.scm +++ b/examples/install-aws-cli.scm @@ -1,28 +1,66 @@ (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 util flatten)) + +;; TODO: this should be in (ordo interceptor download) and it needs arg validation +(define* (download name #:key url target-dir 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))))) + +;; TODO: this should be in (ordo interceptor unzip) and it needs arg validation +(define* (unzip name #:key file-name 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))))) + +;; TODO: this should be in (ordo interceptor command) +;; Maybe it could expose more of the run functionality? +(define (command name prog . args) + (interceptor + name + #:enter (lambda (ctx) + (run (context-connection ctx) + (expand-vars ctx prog) + (map (lambda (a) (expand-vars ctx a)) (flatten args)) + #:check? #t)))) (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 (let-vars (aws-cli-tmp) aws-cli-tmp) #:register 'aws-cli-zipfile) + (unzip "extract-aws-cli" #:file-name (let-vars (aws-cli-zipfile) aws-cli-zipfile) #:target-dir (let-vars (aws-cli-tmp) aws-cli-tmp)) + (command "run-aws-cli-installer" + (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")))) -(playbook "Test Playbook" - (play "Test play" - #:host "localhost" - (task - (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"))))) +(playbook + #:name "Test Playbook" + #:plays (list + (play + #:name "Install AWS CLI" + #:host "localhost" + #: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/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)))) From dd885ce55928f3666747ab65d2064cde35a2632a Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 26 Jan 2025 14:02:19 +0000 Subject: [PATCH 61/83] Tidy up the AWS CLI interceptor example. --- examples/install-aws-cli.scm | 53 +++++++-------------------- examples/interceptor.scm | 7 +++- modules/ordo/interceptor.scm | 15 ++++++-- modules/ordo/interceptor/command.scm | 22 +++++++++++ modules/ordo/interceptor/download.scm | 22 +++++++++++ modules/ordo/interceptor/unzip.scm | 16 ++++++++ 6 files changed, 90 insertions(+), 45 deletions(-) create mode 100644 modules/ordo/interceptor/command.scm create mode 100644 modules/ordo/interceptor/download.scm create mode 100644 modules/ordo/interceptor/unzip.scm diff --git a/examples/install-aws-cli.scm b/examples/install-aws-cli.scm index 58df289..8ced506 100644 --- a/examples/install-aws-cli.scm +++ b/examples/install-aws-cli.scm @@ -8,50 +8,25 @@ (ordo interceptor create-tmp-dir) (ordo interceptor require-commands) (ordo interceptor user-info) - (ordo util flatten)) - -;; TODO: this should be in (ordo interceptor download) and it needs arg validation -(define* (download name #:key url target-dir 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))))) - -;; TODO: this should be in (ordo interceptor unzip) and it needs arg validation -(define* (unzip name #:key file-name 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))))) - -;; TODO: this should be in (ordo interceptor command) -;; Maybe it could expose more of the run functionality? -(define (command name prog . args) - (interceptor - name - #:enter (lambda (ctx) - (run (context-connection ctx) - (expand-vars ctx prog) - (map (lambda (a) (expand-vars ctx a)) (flatten args)) - #:check? #t)))) + (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) (list (require-commands "wget" "unzip") (create-tmp-dir #:register 'aws-cli-tmp) - (download "download-aws-cli" #:url url #:target-dir (let-vars (aws-cli-tmp) aws-cli-tmp) #:register 'aws-cli-zipfile) - (unzip "extract-aws-cli" #:file-name (let-vars (aws-cli-zipfile) aws-cli-zipfile) #:target-dir (let-vars (aws-cli-tmp) 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" - (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")))) + (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" diff --git a/examples/interceptor.scm b/examples/interceptor.scm index d01ec6f..92018a2 100644 --- a/examples/interceptor.scm +++ b/examples/interceptor.scm @@ -7,6 +7,7 @@ (ordo interceptor create-tmp-dir) (ordo interceptor stat-file) (ordo interceptor user-info) + (ordo interceptor command) (ordo interceptor debug)) (playbook @@ -22,10 +23,12 @@ (install-file "install-hello" #:path (let-vars (tmp-dir) (file-name-join* tmp-dir "hello.txt")) - #:content (let-vars (file-content) file-content) + #:content (var file-content) #:register 'hello) (stat-file "stat-hello" - #:path (let-vars (hello) 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/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm index af3a4ec..18cbdd6 100644 --- a/modules/ordo/interceptor.scm +++ b/modules/ordo/interceptor.scm @@ -20,7 +20,9 @@ var-set! var-delete! let-vars + var expand-vars + delayed-var-ref? terminate-when execute)) @@ -83,13 +85,18 @@ 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 (and (procedure? v) (procedure-property v 'delayed-var-ref?)) - (v ctx) - v) - ...)))) + (values (if (delayed-var-ref? v) (v ctx) v) ...)))) (define-record-type (make-interceptor name enter leave error) 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/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/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))))) From 1784234385b3823e5f171f1375700e5e4040063a Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 26 Jan 2025 14:30:04 +0000 Subject: [PATCH 62/83] Implement apt interceptors --- examples/ubuntu.scm | 17 +++++++++++ modules/ordo/action/apt.scm | 42 --------------------------- modules/ordo/connection.scm | 5 ++-- modules/ordo/interceptor/apt.scm | 49 ++++++++++++++++++++++++++++++++ modules/ordo/inventory.scm | 7 +++-- 5 files changed, 72 insertions(+), 48 deletions(-) create mode 100644 examples/ubuntu.scm delete mode 100644 modules/ordo/action/apt.scm create mode 100644 modules/ordo/interceptor/apt.scm diff --git a/examples/ubuntu.scm b/examples/ubuntu.scm new file mode 100644 index 0000000..eb6ede4 --- /dev/null +++ b/examples/ubuntu.scm @@ -0,0 +1,17 @@ +(use-modules + (ordo playbook) + (ordo play) + (ordo interceptor) + (ordo interceptor apt)) + +(playbook + #:name "APT operations" + #:plays (list + (play + #:name "Test APT operations" + ;;#:host '(tagged #:ubuntu) + #:host "localhost" + #:interceptors (list + (apt:update) + (apt:dist-upgrade) + (map apt:install (list "curl" "ca-certificates")))))) 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/connection.scm b/modules/ordo/connection.scm index d5e3223..0c75ac9 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -49,9 +49,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/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/inventory.scm b/modules/ordo/inventory.scm index 37294f2..47924ea 100644 --- a/modules/ordo/inventory.scm +++ b/modules/ordo/inventory.scm @@ -24,7 +24,7 @@ (set! *inventory* (cons (make-host name connection tags) *inventory*))) -(define (tagged-all? wanted-tags) +(define (tagged-every? wanted-tags) (lambda (h) (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) @@ -42,5 +42,6 @@ (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*)))) + (('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*)))) From 9b2afb81cc7f61de263d789700f0fc7ee4546155 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 26 Jan 2025 14:39:25 +0000 Subject: [PATCH 63/83] Host specifier for debian/ubuntu --- examples/ubuntu.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/examples/ubuntu.scm b/examples/ubuntu.scm index eb6ede4..e993b2c 100644 --- a/examples/ubuntu.scm +++ b/examples/ubuntu.scm @@ -1,7 +1,6 @@ (use-modules (ordo playbook) (ordo play) - (ordo interceptor) (ordo interceptor apt)) (playbook @@ -9,8 +8,7 @@ #:plays (list (play #:name "Test APT operations" - ;;#:host '(tagged #:ubuntu) - #:host "localhost" + #:host '(tagged/any #:ubuntu #:debian) #:interceptors (list (apt:update) (apt:dist-upgrade) From 9faaeab2b0b40fb3deef14a23d404ce3b092e965 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 26 Jan 2025 14:49:07 +0000 Subject: [PATCH 64/83] Merge branch wip/interceptors into main --- bin/ordo.sh | 1 - bin/play.scm | 43 ---- examples/install-aws-cli.scm | 54 +++-- examples/interceptor.scm | 34 +++ examples/inventory.scm | 3 +- examples/ubuntu.scm | 15 ++ modules/ordo.scm | 10 - modules/ordo/action/apt.scm | 42 ---- modules/ordo/action/quadlet.scm | 41 ++++ modules/ordo/cli.scm | 5 +- modules/ordo/condition.scm | 9 +- modules/ordo/connection.scm | 5 +- modules/ordo/context.scm | 152 ------------ modules/ordo/facts.scm | 19 -- modules/ordo/facts/user.scm | 32 --- modules/ordo/handler.scm | 25 -- modules/ordo/interceptor.scm | 226 ++++++++++++++++++ modules/ordo/interceptor/apt.scm | 49 ++++ modules/ordo/interceptor/command.scm | 22 ++ modules/ordo/interceptor/connection.scm | 22 ++ modules/ordo/interceptor/create-tmp-dir.scm | 19 ++ modules/ordo/interceptor/debug.scm | 16 ++ modules/ordo/interceptor/download.scm | 22 ++ modules/ordo/interceptor/install-file.scm | 28 +++ modules/ordo/interceptor/require-commands.scm | 28 +++ modules/ordo/interceptor/stat-file.scm | 17 ++ modules/ordo/interceptor/unzip.scm | 16 ++ modules/ordo/interceptor/user-info.scm | 44 ++++ modules/ordo/{host.scm => inventory.scm} | 26 +- modules/ordo/play.scm | 61 ++--- modules/ordo/playbook.scm | 12 +- modules/ordo/task.scm | 53 ---- 32 files changed, 680 insertions(+), 471 deletions(-) delete mode 100755 bin/play.scm create mode 100644 examples/interceptor.scm create mode 100644 examples/ubuntu.scm delete mode 100644 modules/ordo.scm delete mode 100644 modules/ordo/action/apt.scm create mode 100644 modules/ordo/action/quadlet.scm delete mode 100644 modules/ordo/context.scm delete mode 100644 modules/ordo/facts.scm delete mode 100644 modules/ordo/facts/user.scm delete mode 100644 modules/ordo/handler.scm create mode 100644 modules/ordo/interceptor.scm create mode 100644 modules/ordo/interceptor/apt.scm create mode 100644 modules/ordo/interceptor/command.scm create mode 100644 modules/ordo/interceptor/connection.scm create mode 100644 modules/ordo/interceptor/create-tmp-dir.scm create mode 100644 modules/ordo/interceptor/debug.scm create mode 100644 modules/ordo/interceptor/download.scm create mode 100644 modules/ordo/interceptor/install-file.scm create mode 100644 modules/ordo/interceptor/require-commands.scm create mode 100644 modules/ordo/interceptor/stat-file.scm create mode 100644 modules/ordo/interceptor/unzip.scm create mode 100644 modules/ordo/interceptor/user-info.scm rename modules/ordo/{host.scm => inventory.scm} (50%) delete mode 100644 modules/ordo/task.scm 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))))))) From 96ee23d7779197cc5e70dc811b9877e9d8d25401 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 26 Jan 2025 16:07:31 +0000 Subject: [PATCH 65/83] Delete basic example (it was for the non-interceptor implementation) --- examples/basic.scm | 34 ---------------------------------- 1 file changed, 34 deletions(-) delete mode 100644 examples/basic.scm diff --git a/examples/basic.scm b/examples/basic.scm deleted file mode 100644 index 597d1ad..0000000 --- a/examples/basic.scm +++ /dev/null @@ -1,34 +0,0 @@ -(use-modules - (ice-9 filesystem) - (ice-9 pretty-print) - (logging logger) - (ordo) - (ordo action filesystem)) - -(playbook - #:name "Basic filesystem operations" - #:plays (list - (play - #:name "Temporary files on localhost" - #:host "localhost" - #:tasks (list - (task #:name "Create temporary directory" - #:action (lambda () (fs:create-tmp-dir (current-connection))) - #:register-play-var #:tmp-dir) - - (task #:name "Create hello.txt" - #:action (lambda () (fs:install-file (current-connection) - (file-name-join* ($ #:tmp-dir) "hello.txt") - #:content "Hello, world!")) - #:register-play-var #:hello) - - (task #:name "Stat hello.txt" - #:action (lambda () (fs:stat (current-connection) ($ #:hello))) - #:register-play-var #:hello-stat) - - (task #:name "Debug variables" - #:action (lambda () - (pretty-print (list #:hello ($ #:hello) #:hello-stat ($ #:hello-stat))))) - - (task #:name "Clean up tmp dir" - #:action (lambda () (fs:remove (current-connection) ($ #:tmp-dir) #:recurse? #t #:verbose? #t))))))) From 0419c90c9b4441618c0457646fd9723a44224eb3 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 26 Jan 2025 18:36:38 +0000 Subject: [PATCH 66/83] Add some helper functions to interact with pass --- modules/ordo/password-store.scm | 65 +++++++++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) create mode 100644 modules/ordo/password-store.scm diff --git a/modules/ordo/password-store.scm b/modules/ordo/password-store.scm new file mode 100644 index 0000000..fefbab2 --- /dev/null +++ b/modules/ordo/password-store.scm @@ -0,0 +1,65 @@ +(define-module (ordo password-store) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 format) + #:use-module (ice-9 popen) + #:use-module ((srfi srfi-1) #:select (last)) + #:use-module ((srfi srfi-9) #:select (define-record-type)) + #:use-module (ordo util read-lines) + #:use-module (ordo util shell-quote) + #:export (make-password-store + get-password + generate-password)) + +(define-exception-type &password-store-error &external-error + make-password-store-error + password-store-error? + (message password-store-error-message) + (cause password-store-error-cause)) + +(define-record-type + (make-password-store dir) + password-store? + (dir password-store-dir)) + +(define (pass-command store . args) + (let ((base-cmd (if (password-store-dir store) + (format #f "env PASSWORD_STORE_DIR=~a pass" (string-shell-quote (password-store-dir store))) + "pass"))) + (string-append base-cmd + " " + (string-join (map string-shell-quote args) " ") + " 2>&1"))) + +(define (get-password store path) + (let* ((command (pass-command store "show" path)) + (port (open-input-pipe command)) + (data (read-lines port)) + (status (close-pipe port))) + (unless (zero? (status:exit-val status)) + (raise-exception (make-password-store-error (format #f "Error getting password ~a" path) data))) + (car data))) + +(define (password-exists? store path) + (and (false-if-exception (get-password store path)) #t)) + +(define* (generate-password store path #:key (overwrite? #f) (password-length 25)) + ;; WARNING: there is a race condition here between checking the password + ;; exists and calling pass generate to create it. We have to pass the + ;; -f option to generate in case we hit this race condition, when pass will prompt + ;; for confirmation to overwrite an existing file. With the -f option, we will + ;; go ahead and overwrite it, which seems the lesser of two evils. + (unless (or overwrite? (not (password-exists? store path))) + (raise-exception (make-password-store-error (format #f "Error generating password ~a" path) + "Password already exists"))) + (let* ((command (pass-command store "generate" "-f" path (number->string password-length))) + (port (open-input-pipe command)) + (data (read-lines port)) + (status (close-pipe port))) + (unless (zero? (status:exit-val status)) + (raise-exception (make-password-store-error (format #f "Error generating password for ~a" path) data))) + (let ((password (last data))) + ;; Pass wraps the generated password in an escape sequence to change the + ;; displayed colour: we strip this from the result. + (define prefix-len (string-length "\x1b[1m\x1b[93m")) + (define suffix-len (string-length "\x1b[0m")) + (substring password prefix-len (- (string-length password) suffix-len))))) From 8426126b3017585dbeb17c1d6b519a26b7d53714 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Thu, 29 May 2025 15:31:32 +0100 Subject: [PATCH 67/83] Skeleton CLI using guile-config --- .gitignore | 66 ++++++++++++++++++++++++++++++++++++++++ README.md | 27 +++++++++++++++++ guix.scm | 79 ++++++++++++++++++++++++++++++++++++++++++++++++ ordo.scm | 42 +++++++++++++++++++++++++ ordo/cli/run.scm | 48 +++++++++++++++++++++++++++++ 5 files changed, 262 insertions(+) create mode 100644 .gitignore create mode 100644 README.md create mode 100644 guix.scm create mode 100755 ordo.scm create mode 100644 ordo/cli/run.scm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e16f7ad --- /dev/null +++ b/.gitignore @@ -0,0 +1,66 @@ +*.eps +*.go +*.log +*.pdf +*.png +*.tar.xz +*.tar.gz +*.tmp +*~ +.#* +\#*\# +,* +/ABOUT-NLS +/INSTALL +/aclocal.m4 +/autom4te.cache +/build-aux/ar-lib +/build-aux/compile +/build-aux/config.guess +/build-aux/config.rpath +/build-aux/config.sub +/build-aux/depcomp +/build-aux/install-sh +/build-aux/mdate-sh +/build-aux/missing +/build-aux/test-driver +/build-aux/texinfo.tex +/config.status +/configure +/doc/*.1 +/doc/.dirstamp +/doc/contributing.*.texi +/doc/*.aux +/doc/*.cp +/doc/*.cps +/doc/*.fn +/doc/*.fns +/doc/*.html +/doc/*.info +/doc/*.info-[0-9] +/doc/*.ky +/doc/*.pg +/doc/*.toc +/doc/*.t2p +/doc/*.tp +/doc/*.vr +/doc/*.vrs +/doc/stamp-vti +/doc/version.texi +/doc/version-*.texi +/m4/* +/pre-inst-env +/test-env +/test-tmp +/tests/*.trs +GPATH +GRTAGS +GTAGS +Makefile +Makefile.in +config.cache +stamp-h[0-9] +tmp +/.version +/doc/stamp-[0-9] +/.config/ diff --git a/README.md b/README.md new file mode 100644 index 0000000..ce944c7 --- /dev/null +++ b/README.md @@ -0,0 +1,27 @@ +# Ordo + +Ordo ab chao: from chaos, comes order. + +## Installing Dependencies + +On a Guix system, you can simply run: + +``` bash +guix package -m manifest.scm +``` + +If Guix is not available where you plan to run ordo, but you have access to a +system running Guix, you can create a tarball containing all the dependencies: + +``` bash +guix pack -RR -m manifest.scm +``` + +Copy the tarball to your system and unpack it (somewhere). + +Find the name of the profile in the tarball and use that to configure paths etc. + +``` bash +export GUIX_PROFILE=$(realpath gnu/store/*-profile) +source "${GUIX_PROFILE}/etc/profile" +``` diff --git a/guix.scm b/guix.scm new file mode 100644 index 0000000..fe59576 --- /dev/null +++ b/guix.scm @@ -0,0 +1,79 @@ +(use-modules + (gnu packages) + (gnu packages bash) + (gnu packages golang-crypto) + (gnu packages guile) + (gnu packages guile-xyz) + (gnu packages ssh) + (gnu packages version-control) + (guix build-system guile) + (guix download) + (guix gexp) + ((guix licenses) #:prefix license:) + (guix packages) + (srfi srfi-1)) + +(package + (name "guile-ordo") + (version "0.1.0") + (source + (local-file + (dirname (current-filename)) + #:recursive? #t + #:select? (lambda (file stat) + (not (any (lambda (my-string) + (string-contains file my-string)) + (list ".git" ".dir-locals.el" "guix.scm")))))) + (build-system guile-build-system) + (arguments + (list + #:phases #~(modify-phases %standard-phases + (add-after 'build 'link-and-wrap-executable + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((bin (string-append #$output "/bin")) ; bin directory for PATH. + (site-version (target-guile-effective-version)) + (scm (lambda (p) (string-append p "/share/guile/site/" site-version))) + (go (lambda (p) (string-append p "/lib/guile/" site-version "/site-ccache"))) + (runtime-deps (cons #$output (map (lambda (p) (assoc-ref inputs p)) (list "guile-config" + "guile-dsv" + "guile-filesystem" + "guile-ini" + "guile-irregex" + "guile-libyaml" + "guile-json" + "guile-lib" + "guile-semver" + "guile-srfi-145" + "guile-srfi-158" + "guile-srfi-197" + "guile-srfi-235" + "guile-ssh"))))) + (mkdir-p bin) + (let ((source-script (string-append #$output + "/share/guile/site/" site-version "/" + "ordo.scm")) + (target-command (string-append bin "/ordo"))) + (symlink source-script target-command) + (wrap-program target-command + #:sh (which "bash") + `("GUILE_LOAD_PATH" prefix ,(map scm runtime-deps)) + `("GUILE_LOAD_COMPILED_PATH" prefix ,(map go runtime-deps)))))))))) + (inputs (list guile-3.0 bash-minimal git git-lfs age)) + (propagated-inputs (list guile-config + guile-dsv + guile-filesystem + guile-ini + guile-irregex + guile-libyaml + guile-json-4 + guile-lib + guile-semver + guile-srfi-145 + guile-srfi-158 + guile-srfi-197 + guile-srfi-235 + guile-ssh)) + (synopsis "Ordo configuration management") + (description "") + (home-page "") + (license license:gpl3+)) diff --git a/ordo.scm b/ordo.scm new file mode 100755 index 0000000..38a1697 --- /dev/null +++ b/ordo.scm @@ -0,0 +1,42 @@ +#!/usr/bin/guile \ +--no-auto-compile -e main -s +!# + +(use-modules (config) + (config api) + (config parser sexp) + (ice-9 format) + (ice-9 match) + ((ordo cli run) #:prefix run:) + (srfi srfi-1)) + +(define config + (configuration + (name 'ordo) + (synopsis "From chaos, comes order") + (description "Ordo configuration management.") + (keywords + (list + (setting + (name 'log-level) + (handler string->symbol) + (test symbol?) + (default 'NOTICE) + (example "DEBUG|INFO|NOTICE|WARN|ERROR") + (synopsis "Log level")))) + (parser sexp-parser) + (directory (in-cwd ".config/" #t)) + (version "0.1.0") + (author "Ray Miller") + (license gpl3+) + (copyright (list 2025)) + (subcommands + (list + run:config)))) + +(define (main cmd-line) + (let ((options (getopt-config-auto cmd-line config))) + (match (full-command options) + (("ordo" "run") + (run:handler options)) + (_ (emit-help options))))) diff --git a/ordo/cli/run.scm b/ordo/cli/run.scm new file mode 100644 index 0000000..4098047 --- /dev/null +++ b/ordo/cli/run.scm @@ -0,0 +1,48 @@ +(define-module (ordo cli run) + #:use-module (config) + #:use-module (config api) + #:use-module (srfi srfi-1) + #:export (config handler)) + +(define (valid-tags? x) + (or (null? x) + (and (list? x) (every keyword? x)))) + +(define (parse-tags x) + (map (compose symbol->keyword string->symbol) + (if (list? x) x (list x)))) + +(define config + (configuration + (name 'run) + (wanted '((keywords . (log-level)) directory)) + (keywords + (list + (setting + (name 'inventory) + (default "inventory.scm") + (example "examples/inventory.scm") + (handler identity) + (test file-exists?) + (synopsis "Inventory file")) + (switch + (name 'tag) + (default (list)) + (test valid-tags?) + (handler parse-tags) + (merge-strategy cons) + (synopsis "Limit operations to specified tag(s)")))) + (arguments + (list + (argument + (name 'playbook) + (handler identity) + (test file-exists?)))) + (synopsis "Run a playbook"))) + +(define (handler options) + (format #t "run:handler log-level=~a inventory=~a tags=~a playbook=~a~%" + (option-ref options 'log-level) + (option-ref options 'inventory) + (option-ref options 'tag) + (option-ref options '(playbook)))) From 38115b8a573779fdc775b57a2395a8e94fdce197 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Thu, 29 May 2025 16:57:26 +0100 Subject: [PATCH 68/83] Implement logger --- ordo.scm | 18 +++++++++++------ ordo/cli/run.scm | 10 +++++----- ordo/inventory.scm | 48 ++++++++++++++++++++++++++++++++++++++++++++++ ordo/logger.scm | 29 ++++++++++++++++++++++++++++ 4 files changed, 94 insertions(+), 11 deletions(-) create mode 100644 ordo/inventory.scm create mode 100644 ordo/logger.scm diff --git a/ordo.scm b/ordo.scm index 38a1697..ddc878a 100755 --- a/ordo.scm +++ b/ordo.scm @@ -8,7 +8,7 @@ (ice-9 format) (ice-9 match) ((ordo cli run) #:prefix run:) - (srfi srfi-1)) + (ordo logger)) (define config (configuration @@ -20,7 +20,7 @@ (setting (name 'log-level) (handler string->symbol) - (test symbol?) + (test valid-log-level?) (default 'NOTICE) (example "DEBUG|INFO|NOTICE|WARN|ERROR") (synopsis "Log level")))) @@ -36,7 +36,13 @@ (define (main cmd-line) (let ((options (getopt-config-auto cmd-line config))) - (match (full-command options) - (("ordo" "run") - (run:handler options)) - (_ (emit-help options))))) + (dynamic-wind + (lambda () + (setup-logging! #:level (option-ref options 'log-level))) + (lambda () + (match (full-command options) + (("ordo" "run") + (run:handler options)) + (_ (emit-help options)))) + (lambda () + (shutdown-logging!))))) diff --git a/ordo/cli/run.scm b/ordo/cli/run.scm index 4098047..efbc8cc 100644 --- a/ordo/cli/run.scm +++ b/ordo/cli/run.scm @@ -1,6 +1,7 @@ (define-module (ordo cli run) #:use-module (config) #:use-module (config api) + #:use-module (ordo logger) #:use-module (srfi srfi-1) #:export (config handler)) @@ -41,8 +42,7 @@ (synopsis "Run a playbook"))) (define (handler options) - (format #t "run:handler log-level=~a inventory=~a tags=~a playbook=~a~%" - (option-ref options 'log-level) - (option-ref options 'inventory) - (option-ref options 'tag) - (option-ref options '(playbook)))) + (let ((inventory (option-ref options 'inventory)) + (playbook (option-ref options '(playbook)))) + (log-msg 'INFO "Running playbook " playbook " with inventory " inventory) + )) diff --git a/ordo/inventory.scm b/ordo/inventory.scm new file mode 100644 index 0000000..c89f5ec --- /dev/null +++ b/ordo/inventory.scm @@ -0,0 +1,48 @@ +(define-module (ordo inventory) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + ;; #:use-module ((ordo connection) #:select (local-connection)) TODO: implement connections + #: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? + (name host-name) + (connection host-connection) + (tags host-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)))) + +(define (tagged-any? wanted-tags) + (lambda (h) + (not (null? (lset-intersection equal? (host-tags h) wanted-tags))))) + +(define (named? hostname) + (lambda (h) + (string=? (host-name h) hostname))) + +(define resolve-hosts + (match-lambda + ("localhost" (list (or (find (named? "localhost") *inventory*) + ;;(make-host "localhost" (local-connection) '()) ;; TODO: needs connections + ))) + ((? 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/ordo/logger.scm b/ordo/logger.scm new file mode 100644 index 0000000..a4b6927 --- /dev/null +++ b/ordo/logger.scm @@ -0,0 +1,29 @@ +(define-module (ordo logger) + #:use-module (oop goops) + #:use-module ((srfi srfi-1) #:select (take-while member)) + #:use-module ((srfi srfi-26) #:select (cut)) + #:use-module (logging logger) + #:use-module (logging port-log) + #:export (setup-logging! + shutdown-logging! + valid-log-level?) + #:re-export (log-msg)) + +(define log-levels '(DEBUG INFO NOTICE WARN ERROR)) + +(define (valid-log-level? level) + (member level log-levels eq?)) + +(define* (setup-logging! #:key (level 'INFO)) + (let ((logger (make )) + (handler (make #:port (current-error-port)))) + (for-each (cut disable-log-level! handler <>) + (take-while (negate (cut equal? level <>)) log-levels)) + (add-handler! logger handler) + (set-default-logger! logger) + (open-log! logger))) + +(define (shutdown-logging!) + (flush-log) ; since no args, it uses the default + (close-log!) ; ditto + (set-default-logger! #f)) From f6ef09f91db6d72404936940f061bd4b5766595d Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 31 May 2025 16:50:06 +0100 Subject: [PATCH 69/83] Get rudimentary connections working again --- ordo/connection.scm | 59 +++++++++++++++++++++++++++++++++++ ordo/connection/base.scm | 40 ++++++++++++++++++++++++ ordo/connection/local.scm | 21 +++++++++++++ ordo/connection/ssh.scm | 63 ++++++++++++++++++++++++++++++++++++++ ordo/connection/sudo.scm | 49 +++++++++++++++++++++++++++++ ordo/util/flatten.scm | 10 ++++++ ordo/util/keyword-args.scm | 27 ++++++++++++++++ ordo/util/read-lines.scm | 11 +++++++ ordo/util/shell-quote.scm | 57 ++++++++++++++++++++++++++++++++++ 9 files changed, 337 insertions(+) create mode 100644 ordo/connection.scm create mode 100644 ordo/connection/base.scm create mode 100644 ordo/connection/local.scm create mode 100644 ordo/connection/ssh.scm create mode 100644 ordo/connection/sudo.scm create mode 100644 ordo/util/flatten.scm create mode 100644 ordo/util/keyword-args.scm create mode 100644 ordo/util/read-lines.scm create mode 100644 ordo/util/shell-quote.scm diff --git a/ordo/connection.scm b/ordo/connection.scm new file mode 100644 index 0000000..c871fe9 --- /dev/null +++ b/ordo/connection.scm @@ -0,0 +1,59 @@ +(define-module (ordo connection) + #:use-module (ice-9 exceptions) + #:use-module (oop goops) + #:use-module (ordo connection base) + #:use-module (ordo connection local) + #:use-module (ordo connection ssh) + #:use-module (ordo connection sudo) + #:use-module (ordo logger) + #:use-module (ordo util flatten) + #:use-module (ordo util keyword-args) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) + #:export (connection? + local-connection + ssh-connection + call-with-connection + run) + #:re-export (remote-exec with-remote-input-file with-remote-output-file)) + +(define (connection? c) + (is-a? c )) + +(define (local-connection) + (make )) + +(define* (ssh-connection user host #:key (password #f) (identity #f) (authenticate-server? #t)) + (make #:user user #:host host #:password password + #:identity identity #:authenticate-server? authenticate-server?)) + +(define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password) + (when (and sudo? (not (is-a? conn ))) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message (format #f "connection ~a does not support sudo" conn))))) + (set! (become? conn) sudo?) + (set! (become-user conn) sudo-user) + (set! (become-password conn) sudo-password) + (dynamic-wind + (lambda () (setup conn)) + (lambda () (proc conn)) + (lambda () (teardown conn)))) + +(define (run conn prog . args) + (let* ((args options (break keyword? args)) + (args (remove unspecified? (flatten args))) + (return (keyword-arg options #:return identity)) + (check? (keyword-arg options #:check?)) + (command (build-command conn prog args options))) + (log-msg 'INFO "Running command: " command) + (let ((out rc (remote-exec conn command))) + (log-msg 'INFO "Command exit code: " rc) + (if check? + (if (zero? rc) + (return out) + (raise-exception (make-exception + (make-external-error) + (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog))))) + (values (return out) rc))))) diff --git a/ordo/connection/base.scm b/ordo/connection/base.scm new file mode 100644 index 0000000..daedcca --- /dev/null +++ b/ordo/connection/base.scm @@ -0,0 +1,40 @@ +(define-module (ordo connection base) + #:use-module (ice-9 match) + #: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 ( + setup + teardown + build-command + remote-exec + with-remote-input-file + with-remote-output-file)) + +(define-generic setup) +(define-generic teardown) +(define-generic build-command) +(define-generic remote-exec) +(define-generic with-remote-input-file) +(define-generic with-remote-output-file) + +(define-class ()) + +(define-method (setup (c )) #t) + +(define-method (teardown (c )) #t) + +(define-method (build-command (c ) (prog-name ) (prog-args ) (options )) + (let* ((pwd (keyword-arg options #:pwd)) + (env (keyword-arg options #:env)) + (redirect-err? (keyword-arg options #:redirect-err?)) + (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) + (when redirect-err? "2>&1")))))) + (string-join xs " "))) diff --git a/ordo/connection/local.scm b/ordo/connection/local.scm new file mode 100644 index 0000000..7eb9eb7 --- /dev/null +++ b/ordo/connection/local.scm @@ -0,0 +1,21 @@ +(define-module (ordo connection local) + #:use-module (ice-9 popen) + #:use-module (oop goops) + #:use-module (ordo connection base) + #:use-module (ordo connection sudo) + #:use-module (ordo util read-lines) + #:export ()) + +(define-class ()) + +(define-method (remote-exec (c ) (command )) + (let* ((port (open-input-pipe command)) + (output (read-lines port)) + (exit-status (status:exit-val (close-pipe port)))) + (values output exit-status))) + +(define-method (with-remote-input-file (c ) (filename ) (proc )) + (call-with-input-file filename proc)) + +(define-method (with-remote-output-file (c ) (filename ) (proc )) + (call-with-output-file filename proc)) diff --git a/ordo/connection/ssh.scm b/ordo/connection/ssh.scm new file mode 100644 index 0000000..c71f2d4 --- /dev/null +++ b/ordo/connection/ssh.scm @@ -0,0 +1,63 @@ +(define-module (ordo connection ssh) + #:use-module (oop goops) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 popen) + #:use-module (ssh session) + #: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) + #:export ()) + +(define-class () + (user #:getter ssh-connection-user #:init-keyword #:user) + (host #:getter ssh-connection-host #:init-keyword #:host) + (password #:getter ssh-connection-password #:init-keyword #:password #:init-val #f) + (identity #:getter ssh-connection-identity #:init-keyword #:identity #:init-val #f) + (authenticate-server? #:getter ssh-connection-authenticate-server? #:init-keyword #:authenticate-server? #:init-val #t) + (session) + (sftp-session)) + +(define-method (setup (c )) + (unless (slot-bound? c 'session) + (slot-set! c 'session (make-session #:user (ssh-connection-user c) #:host (ssh-connection-host c))) + (when (ssh-connection-identity c) (session-set! (slot-ref c 'session) 'identity (ssh-connection-identity c)))) + (let ((s (slot-ref c 'session))) + (unless (connected? s) + (connect! s) + (when (ssh-connection-authenticate-server? s) + (let ((server-auth (authenticate-server s))) + (unless (equal? 'ok server-auth) + (error (format #f "authenticate-server: ~a" server-auth))))) + (let ((user-auth (if (ssh-connection-password c) + (userauth-password! s (ssh-connection-password c)) + (userauth-public-key/auto! s)))) + (unless (equal? 'success user-auth) + (error (format #f "userauth: ~a" user-auth))))))) + +(define-method (remote-exec (c ) (command )) + (let* ((channel (open-remote-input-pipe (slot-ref c 'session) command)) + (output (read-lines channel)) + (exit-status (channel-get-exit-status channel))) + (close channel) + (values output exit-status))) + +(define-method (sftp-session (c )) + (unless (slot-bound? c 'sftp-session) + (slot-set! c 'sftp-session (make-sftp-session (session c)))) + (slot-ref c 'sftp-session)) + +(define-method (with-remote-input-file (c ) (filename ) (proc )) + (call-with-remote-input-file (sftp-session c) filename proc)) + +(define-method (with-remote-output-file (c ) (filename ) (proc )) + (call-with-remote-output-file (sftp-session c) filename proc)) + +(define-method (teardown (c )) + (when (slot-bound? c 'session) + (let ((s (slot-ref c session))) + (when (connected? s) + (disconnect! s))))) diff --git a/ordo/connection/sudo.scm b/ordo/connection/sudo.scm new file mode 100644 index 0000000..ccb3732 --- /dev/null +++ b/ordo/connection/sudo.scm @@ -0,0 +1,49 @@ +(define-module (ordo connection sudo) + #:use-module (oop goops) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (ordo connection base) + #:use-module (ordo util shell-quote) + #:export ( + become? + become-user + become-password)) + +(define-class () + (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)) + +(define-method (setup (conn )) + (when (become-password conn) + (let ((out rc (exec conn "mktemp"))) + (unless (zero? rc) + (raise-exception (make-exception + (make-external-error) + (make-exception-with-message (format #f "Failed to create temporary directory: ~a" (car out)))))) + (let ((tmp-file (car out))) + (call-with-output-file conn tmp-file (cut write-line (become-password conn) <>)) + (set! (password-tmp-file conn) tmp-file))))) + +(define-method (build-command (conn ) (prog-name ) (prog-args ) (options )) + (cond + ((not (become? conn)) + (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))) + + ((become-password conn) + (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))) + + (else (format #f "sudo -k -n -H -- ~a" (next-method))))) + +(define-method (teardown (conn )) + (when (slot-bound? conn 'password-tmp-file) + (exec conn (format #f "rm -f ~a" (string-shell-quote (password-tmp-file conn)))))) diff --git a/ordo/util/flatten.scm b/ordo/util/flatten.scm new file mode 100644 index 0000000..a37c788 --- /dev/null +++ b/ordo/util/flatten.scm @@ -0,0 +1,10 @@ +(define-module (ordo util flatten) + #:export (flatten)) + +(define (flatten lst) + (cond + ((null? lst) '()) + ((list? (car lst)) + (append (flatten (car lst)) (flatten (cdr lst)))) + (else + (cons (car lst) (flatten (cdr lst)))))) diff --git a/ordo/util/keyword-args.scm b/ordo/util/keyword-args.scm new file mode 100644 index 0000000..76441c1 --- /dev/null +++ b/ordo/util/keyword-args.scm @@ -0,0 +1,27 @@ +(define-module (ordo util keyword-args) + #:use-module (ice-9 exceptions) + #:export (keyword-arg + select-keyword-args + validate-keyword-args)) + +(define* (keyword-arg args kw #:optional (default #f)) + (cond + ((< (length args) 2) default) + ((equal? (car args) kw) (cadr args)) + (else (keyword-arg (cddr args) kw default)))) + +(define (select-keyword-args kwargs wanted) + (let loop ((kwargs kwargs) (accum '())) + (cond + ((null? kwargs) + (reverse accum)) + ((member (car kwargs) wanted) + (loop (cddr kwargs) (cons* (car kwargs) (cadr kwargs) accum))) + (else (loop (cddr kwargs) accum))))) + +(define (validate-keyword-args kwargs) + (unless (even? (length kwargs)) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message "keyword args should have an even number of elements"))))) diff --git a/ordo/util/read-lines.scm b/ordo/util/read-lines.scm new file mode 100644 index 0000000..def581d --- /dev/null +++ b/ordo/util/read-lines.scm @@ -0,0 +1,11 @@ +(define-module (ordo util read-lines) + #:use-module (ice-9 rdelim) + #:export (read-lines)) + +(define (read-lines port) + "Read lines from port until eof is encountered. Return list of all lines read." + (define (loop line result) + (if (eof-object? line) + (reverse result) + (loop (read-line port) (cons line result)))) + (loop (read-line port) '())) diff --git a/ordo/util/shell-quote.scm b/ordo/util/shell-quote.scm new file mode 100644 index 0000000..5de60fa --- /dev/null +++ b/ordo/util/shell-quote.scm @@ -0,0 +1,57 @@ +;; This file is part of Ordo. +;; +;; Shell quoting implementation is based on Perl's String::ShellQuote +;; Copyright (c) 1997 Roderick Schertler. +;; +;; Guile implementation Copyright (c) 2025 Ray Miller. +;; +;; Ordo 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, either version 3 of the License, or (at your option) +;; any later version. +;; +;; Ordo 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 +;; Ordo. If not, see . + +(define-module (ordo util shell-quote) + #:use-module (rx irregex) + #:use-module ((srfi srfi-197) #:select (chain)) + #:export (string-shell-quote)) + +(define unsafe-characters (irregex '(~ (or alphanumeric ("!%+,\\-./:=@^"))))) + +(define (needs-escape? s) + (irregex-search unsafe-characters s)) + +(define (squash-quotes m) + (let ((n (/ (- (irregex-match-end-index m) + (irregex-match-start-index m)) + 4))) + (list->string (append + '(#\' #\") + (make-list n #\') + '(#\" #\'))))) + +(define (escape s) + (chain s + ;; ' -> '\'' + (irregex-replace/all (irregex "'") _ "'\\''") + ;; make multiple ' in a row look simpler + ;; '\'''\'''\'' -> '"'''"' + (irregex-replace/all (irregex '(>= 2 "'\\''")) _ squash-quotes) + ;; wrap in single quotes + (string-append "'" _ "'") + ;; kill leading/trailing pair of single quotes + (irregex-replace (irregex '(seq bos "''")) _ "") + (irregex-replace (irregex '(seq "''" eos)) _ ""))) + +(define (string-shell-quote s) + "Quote strings for passing through the shell" + (cond + ((zero? (string-length s)) "''") + ((needs-escape? s) (escape s)) + (else s))) From 3685369de57bddd242e28fd3cc3603704ebd156d Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 31 May 2025 16:53:00 +0100 Subject: [PATCH 70/83] Fix inventory --- ordo/inventory.scm | 30 +++++++++++++----------------- 1 file changed, 13 insertions(+), 17 deletions(-) diff --git a/ordo/inventory.scm b/ordo/inventory.scm index c89f5ec..11123e4 100644 --- a/ordo/inventory.scm +++ b/ordo/inventory.scm @@ -2,8 +2,8 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) - ;; #:use-module ((ordo connection) #:select (local-connection)) TODO: implement connections - #:export (make-host + #:use-module ((ordo connection) #:select (local-connection)) + #:export (host host? host-name host-connection @@ -11,8 +11,6 @@ add-host! resolve-hosts)) -(define *inventory* '()) - (define-record-type (make-host name connection tags) host? @@ -20,9 +18,8 @@ (connection host-connection) (tags host-tags)) -(define (add-host! name connection . tags) - (set! *inventory* (cons (make-host name connection tags) - *inventory*))) +(define (host name connection . tags) + (make-host name connection tags)) (define (tagged-every? wanted-tags) (lambda (h) @@ -36,13 +33,12 @@ (lambda (h) (string=? (host-name h) hostname))) -(define resolve-hosts - (match-lambda - ("localhost" (list (or (find (named? "localhost") *inventory*) - ;;(make-host "localhost" (local-connection) '()) ;; TODO: needs connections - ))) - ((? 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*)))) +(define (resolve-hosts inventory expr) + (match expr + ("localhost" (list (or (find (named? "localhost") inventory) + (make-host "localhost" (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)))) From 38f08e8ce4508b80fbbecc522716e7fe40c1aa9d Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 1 Jun 2025 15:50:12 +0100 Subject: [PATCH 71/83] Basic playbook functionality --- examples/inventory.scm | 19 ++++++++++++++ examples/playbook.scm | 8 ++++++ ordo/cli/run.scm | 17 +++++++------ ordo/connection.scm | 28 +++++++++++---------- ordo/context.scm | 49 ++++++++++++++++++++++++++++++++++++ ordo/inventory.scm | 47 ++++++++++++++++++++++++---------- ordo/play.scm | 57 ++++++++++++++++++++++++++++++++++++++++++ ordo/playbook.scm | 45 +++++++++++++++++++++++++++++++++ 8 files changed, 237 insertions(+), 33 deletions(-) create mode 100644 examples/inventory.scm create mode 100644 examples/playbook.scm create mode 100644 ordo/context.scm create mode 100644 ordo/play.scm create mode 100644 ordo/playbook.scm diff --git a/examples/inventory.scm b/examples/inventory.scm new file mode 100644 index 0000000..7d5b9a9 --- /dev/null +++ b/examples/inventory.scm @@ -0,0 +1,19 @@ +(use-modules (ordo connection) + (ordo inventory)) + +(list + (host #:name "localhost" + #:connection (local-connection) + #:tags '(#:linux #:guix)) + + (host #:name "limiting-factor" + #:connection (ssh-connection "limiting-factor" #:user "core") + #:tags '(#:linux #:coreos)) + + (host #:name "screw-loose" + #:connection (ssh-connection "screw-loose" #:user "core") + #:tags '(#:linux #:coreos)) + + (host #:name "control-surface" + #:connection (ssh-connection "control-surface") + #:tags '(#:linux #:debian))) diff --git a/examples/playbook.scm b/examples/playbook.scm new file mode 100644 index 0000000..64836f5 --- /dev/null +++ b/examples/playbook.scm @@ -0,0 +1,8 @@ +(use-modules (ordo playbook)) + +(playbook + #:name "Example playbook" + #:vars '((foo . 1) (bar . "baz")) + #:plays (list + (play #:name "Example play" + #:host "localhost"))) diff --git a/ordo/cli/run.scm b/ordo/cli/run.scm index efbc8cc..98f31bf 100644 --- a/ordo/cli/run.scm +++ b/ordo/cli/run.scm @@ -1,8 +1,12 @@ (define-module (ordo cli run) #:use-module (config) #:use-module (config api) + #:use-module (ice-9 filesystem) + #: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)) (define (valid-tags? x) @@ -21,9 +25,9 @@ (list (setting (name 'inventory) - (default "inventory.scm") + (default "/dev/null") (example "examples/inventory.scm") - (handler identity) + (handler (cut expand-file-name <> #f #t)) (test file-exists?) (synopsis "Inventory file")) (switch @@ -37,12 +41,11 @@ (list (argument (name 'playbook) - (handler identity) + (handler (cut expand-file-name <> #f #t)) (test file-exists?)))) (synopsis "Run a playbook"))) (define (handler options) - (let ((inventory (option-ref options 'inventory)) - (playbook (option-ref options '(playbook)))) - (log-msg 'INFO "Running playbook " playbook " with inventory " inventory) - )) + (let ((inventory (load-inventory (option-ref options 'inventory))) + (playbook (load-playbook (option-ref options '(playbook))))) + (run-playbook playbook inventory))) diff --git a/ordo/connection.scm b/ordo/connection.scm index c871fe9..2cda66f 100644 --- a/ordo/connection.scm +++ b/ordo/connection.scm @@ -23,23 +23,25 @@ (define (local-connection) (make )) -(define* (ssh-connection user host #:key (password #f) (identity #f) (authenticate-server? #t)) +(define* (ssh-connection host #:key (user (getlogin)) (password #f) (identity #f) (authenticate-server? #t)) (make #:user user #:host host #:password password #:identity identity #:authenticate-server? authenticate-server?)) (define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password) - (when (and sudo? (not (is-a? conn ))) - (raise-exception - (make-exception - (make-programming-error) - (make-exception-with-message (format #f "connection ~a does not support sudo" conn))))) - (set! (become? conn) sudo?) - (set! (become-user conn) sudo-user) - (set! (become-password conn) sudo-password) - (dynamic-wind - (lambda () (setup conn)) - (lambda () (proc conn)) - (lambda () (teardown conn)))) + (let ((conn (deep-clone conn))) + (when sudo? + (unless (is-a? conn ) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message (format #f "connection ~a does not support sudo" conn))))) + (set! (become? conn) sudo?) + (set! (become-user conn) sudo-user) + (set! (become-password conn) sudo-password)) + (dynamic-wind + (lambda () (setup conn)) + (lambda () (proc conn)) + (lambda () (teardown conn))))) (define (run conn prog . args) (let* ((args options (break keyword? args)) diff --git a/ordo/context.scm b/ordo/context.scm new file mode 100644 index 0000000..a10ff0a --- /dev/null +++ b/ordo/context.scm @@ -0,0 +1,49 @@ +(define-module (ordo context) + #:use-module (srfi srfi-69)) + +;; +;; Inventory +;; +(define-public *inventory* (make-parameter #f)) + +;; +;; Playbook vars +;; +(define-public *playbook-vars* (make-parameter #f)) + +(define-public (playbook-var-ref key) + (hash-table-ref (*playbook-vars*) key)) + +(define-public (playbook-var-ref/default key default) + (hash-table-ref/default (*playbook-vars*) key default)) + +(define-public (playbook-var-set! key value) + (hash-table-set! (*playbook-vars*) key value)) + +;; +;; Play vars +;; +(define-public *play-vars* (make-parameter #f)) + +(define-public (play-var-ref key) + (hash-table-ref (*play-vars*) key)) + +(define-public (play-var-ref/default key default) + (hash-table-ref/default (*play-vars*) key default)) + +(define-public (play-var-set! key value) + (hash-table-set! (*play-vars*) key value)) + +;; +;; Host vars +;; +(define-public *host-vars* (make-parameter #f)) + +(define-public (host-var-ref key) + (hash-table-ref (*host-vars*) key)) + +(define-public (host-var-ref/default key default) + (hash-table-ref/default (*host-vars*) key default)) + +(define-public (host-var-set! key value) + (hash-table-set! (*host-vars*) key value)) diff --git a/ordo/inventory.scm b/ordo/inventory.scm index 11123e4..946f8be 100644 --- a/ordo/inventory.scm +++ b/ordo/inventory.scm @@ -1,25 +1,37 @@ (define-module (ordo inventory) + #:use-module (ice-9 eval-string) #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) + #:use-module (ice-9 textual-ports) + #:use-module (oop goops) #:use-module ((ordo connection) #:select (local-connection)) + #:use-module (ordo logger) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-69) #:export (host host? host-name host-connection host-tags - add-host! - resolve-hosts)) + host-vars + resolve-hosts + load-inventory)) -(define-record-type - (make-host name connection tags) - host? - (name host-name) - (connection host-connection) - (tags host-tags)) +(define-class () + (name #:init-keyword #:name #:getter host-name) + (connection #:init-keyword #:connection #:getter host-connection) + (tags #:init-keyword #:tags #:getter host-tags #:init-form (list)) + (vars #:init-keyword #:vars #:getter host-vars #:init-form (list))) -(define (host name connection . tags) - (make-host name connection tags)) +(define-method (initialize (object ) initargs) + (next-method) + (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars))) + object) + +(define (host . args) + (apply make args)) + +(define (host? x) + (is-a? x )) (define (tagged-every? wanted-tags) (lambda (h) @@ -36,9 +48,18 @@ (define (resolve-hosts inventory expr) (match expr ("localhost" (list (or (find (named? "localhost") inventory) - (make-host "localhost" (local-connection) '())))) + (make #:name "localhost" #:connection (local-connection))))) ((? string? hostname) (filter (named? hostname) inventory)) ('all inventory) (('tagged tag) (filter (tagged-every? (list tag)) inventory)) (('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) inventory)) (('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) inventory)))) + +(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)) diff --git a/ordo/play.scm b/ordo/play.scm new file mode 100644 index 0000000..8d4ce80 --- /dev/null +++ b/ordo/play.scm @@ -0,0 +1,57 @@ +(define-module (ordo play) + #:use-module (oop goops) + #:use-module (ordo connection) + #:use-module (ordo context) + #:use-module (ordo inventory) + #:use-module (ordo logger) + #:use-module (ordo util flatten) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-69) + #:export (play + play? + play-host + play-sudo? + play-sudo-user + play-sudo-password + play-vars + play-actions + play-handlers + run-play)) + +(define-class () + (name #:init-keyword #:name #:getter play-name) + (host #:init-keyword #:host #:getter play-host) + (sudo? #:init-keyword #:sudo? #:getter play-sudo? #:init-value #f) + (sudo-user #:init-keyword #:sudo-user #:getter play-sudo-user #:init-value #f) + (sudo-password #:init-keyword #:sudo-password #:getter play-sudo-password #:init-value #f) + (vars #:init-keyword #:vars #:getter play-vars #:init-form (list)) + (actions #:init-keyword #:actions #:getter play-actions #:init-form (list)) + (handlers #:init-keyword #:handlers #:getter play-handlers #:init-form (list))) + +(define-method (initialize (object ) initargs) + (next-method) + (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars))) + object) + +(define (play . args) + (apply make args)) + +(define (run-play p) + (log-msg 'NOTICE "Running play: " (play-name p)) + (parameterize ((*play-vars* (play-vars p))) + (let ((hosts (resolve-hosts (*inventory*) (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))))) + +(define (run-host-play p h) + (log-msg 'NOTICE "Running play: " (play-name p) " on host: " (host-name h)) + (parameterize ((*host-vars* (host-vars h))) + (call-with-connection + (host-connection h) + (lambda (conn) + #f + ) + #:sudo? (play-sudo? p) + #:sudo-user (play-sudo-user p) + #:sudo-password (play-sudo-password p)))) diff --git a/ordo/playbook.scm b/ordo/playbook.scm new file mode 100644 index 0000000..e980585 --- /dev/null +++ b/ordo/playbook.scm @@ -0,0 +1,45 @@ +(define-module (ordo playbook) + #:use-module (ice-9 eval-string) + #:use-module (ice-9 textual-ports) + #:use-module (oop goops) + #:use-module (ordo context) + #:use-module (ordo logger) + #:use-module (ordo play) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-69) + #:export ( + playbook + playbook? + playbook-name + playbook-vars + playbook-plays + load-playbook + run-playbook) + #:re-export (play)) + +(define-class () + (name #:init-keyword #:name #:getter playbook-name) + (vars #:init-keyword #:vars #:getter playbook-vars) + (plays #:init-keyword #:plays #:getter playbook-plays)) + +(define-method (initialize (object ) initargs) + (next-method) + (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars))) + object) + +(define (playbook . args) + (apply make args)) + +(define (playbook? p) + (is-a? p )) + +(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-vars* (playbook-vars pb))) + (for-each run-play (playbook-plays pb)))) From b81433c75e2642bbed051c3a108ba5479c91ad58 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 1 Jun 2025 15:56:32 +0100 Subject: [PATCH 72/83] Remove unnecessary return --- ordo/inventory.scm | 3 +-- ordo/play.scm | 3 +-- ordo/playbook.scm | 3 +-- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/ordo/inventory.scm b/ordo/inventory.scm index 946f8be..468ff30 100644 --- a/ordo/inventory.scm +++ b/ordo/inventory.scm @@ -24,8 +24,7 @@ (define-method (initialize (object ) initargs) (next-method) - (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars))) - object) + (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars)))) (define (host . args) (apply make args)) diff --git a/ordo/play.scm b/ordo/play.scm index 8d4ce80..61c32c5 100644 --- a/ordo/play.scm +++ b/ordo/play.scm @@ -30,8 +30,7 @@ (define-method (initialize (object ) initargs) (next-method) - (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars))) - object) + (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars)))) (define (play . args) (apply make args)) diff --git a/ordo/playbook.scm b/ordo/playbook.scm index e980585..cdae7bb 100644 --- a/ordo/playbook.scm +++ b/ordo/playbook.scm @@ -24,8 +24,7 @@ (define-method (initialize (object ) initargs) (next-method) - (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars))) - object) + (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars)))) (define (playbook . args) (apply make args)) From 00c5c91b11d2f9114023fa93bddd63f396bc4af7 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 1 Jun 2025 16:13:05 +0100 Subject: [PATCH 73/83] Add GPL headers --- ordo/cli/run.scm | 17 +++++++++++++++++ ordo/connection.scm | 17 +++++++++++++++++ ordo/connection/base.scm | 17 +++++++++++++++++ ordo/connection/local.scm | 17 +++++++++++++++++ ordo/connection/ssh.scm | 17 +++++++++++++++++ ordo/connection/sudo.scm | 23 ++++++++++++++++++++--- ordo/context.scm | 17 +++++++++++++++++ ordo/inventory.scm | 17 +++++++++++++++++ ordo/logger.scm | 17 +++++++++++++++++ ordo/play.scm | 17 +++++++++++++++++ ordo/playbook.scm | 17 +++++++++++++++++ ordo/util/flatten.scm | 17 +++++++++++++++++ ordo/util/keyword-args.scm | 17 +++++++++++++++++ ordo/util/read-lines.scm | 17 +++++++++++++++++ ordo/util/shell-quote.scm | 38 ++++++++++++++++++++------------------ 15 files changed, 261 insertions(+), 21 deletions(-) diff --git a/ordo/cli/run.scm b/ordo/cli/run.scm index 98f31bf..1b46d6b 100644 --- a/ordo/cli/run.scm +++ b/ordo/cli/run.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo cli run) #:use-module (config) #:use-module (config api) diff --git a/ordo/connection.scm b/ordo/connection.scm index 2cda66f..8046bcf 100644 --- a/ordo/connection.scm +++ b/ordo/connection.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo connection) #:use-module (ice-9 exceptions) #:use-module (oop goops) diff --git a/ordo/connection/base.scm b/ordo/connection/base.scm index daedcca..6803f20 100644 --- a/ordo/connection/base.scm +++ b/ordo/connection/base.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo connection base) #:use-module (ice-9 match) #:use-module (oop goops) diff --git a/ordo/connection/local.scm b/ordo/connection/local.scm index 7eb9eb7..c4d39ae 100644 --- a/ordo/connection/local.scm +++ b/ordo/connection/local.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo connection local) #:use-module (ice-9 popen) #:use-module (oop goops) diff --git a/ordo/connection/ssh.scm b/ordo/connection/ssh.scm index c71f2d4..2b2d2e6 100644 --- a/ordo/connection/ssh.scm +++ b/ordo/connection/ssh.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo connection ssh) #:use-module (oop goops) #:use-module (ice-9 exceptions) diff --git a/ordo/connection/sudo.scm b/ordo/connection/sudo.scm index ccb3732..8271c22 100644 --- a/ordo/connection/sudo.scm +++ b/ordo/connection/sudo.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo connection sudo) #:use-module (oop goops) #:use-module (ice-9 exceptions) @@ -19,13 +36,13 @@ (define-method (setup (conn )) (when (become-password conn) - (let ((out rc (exec conn "mktemp"))) + (let ((out rc (remote-exec conn "mktemp"))) (unless (zero? rc) (raise-exception (make-exception (make-external-error) (make-exception-with-message (format #f "Failed to create temporary directory: ~a" (car out)))))) (let ((tmp-file (car out))) - (call-with-output-file conn tmp-file (cut write-line (become-password conn) <>)) + (with-remote-output-file conn tmp-file (cut write-line (become-password conn) <>)) (set! (password-tmp-file conn) tmp-file))))) (define-method (build-command (conn ) (prog-name ) (prog-args ) (options )) @@ -46,4 +63,4 @@ (define-method (teardown (conn )) (when (slot-bound? conn 'password-tmp-file) - (exec conn (format #f "rm -f ~a" (string-shell-quote (password-tmp-file conn)))))) + (remote-exec conn (format #f "rm -f ~a" (string-shell-quote (password-tmp-file conn)))))) diff --git a/ordo/context.scm b/ordo/context.scm index a10ff0a..ff150a0 100644 --- a/ordo/context.scm +++ b/ordo/context.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo context) #:use-module (srfi srfi-69)) diff --git a/ordo/inventory.scm b/ordo/inventory.scm index 468ff30..669ed8e 100644 --- a/ordo/inventory.scm +++ b/ordo/inventory.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo inventory) #:use-module (ice-9 eval-string) #:use-module (ice-9 match) diff --git a/ordo/logger.scm b/ordo/logger.scm index a4b6927..b2aed69 100644 --- a/ordo/logger.scm +++ b/ordo/logger.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo logger) #:use-module (oop goops) #:use-module ((srfi srfi-1) #:select (take-while member)) diff --git a/ordo/play.scm b/ordo/play.scm index 61c32c5..ba08ee2 100644 --- a/ordo/play.scm +++ b/ordo/play.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo play) #:use-module (oop goops) #:use-module (ordo connection) diff --git a/ordo/playbook.scm b/ordo/playbook.scm index cdae7bb..44df6a7 100644 --- a/ordo/playbook.scm +++ b/ordo/playbook.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo playbook) #:use-module (ice-9 eval-string) #:use-module (ice-9 textual-ports) diff --git a/ordo/util/flatten.scm b/ordo/util/flatten.scm index a37c788..944c070 100644 --- a/ordo/util/flatten.scm +++ b/ordo/util/flatten.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo util flatten) #:export (flatten)) diff --git a/ordo/util/keyword-args.scm b/ordo/util/keyword-args.scm index 76441c1..e194140 100644 --- a/ordo/util/keyword-args.scm +++ b/ordo/util/keyword-args.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo util keyword-args) #:use-module (ice-9 exceptions) #:export (keyword-arg diff --git a/ordo/util/read-lines.scm b/ordo/util/read-lines.scm index def581d..1979ec3 100644 --- a/ordo/util/read-lines.scm +++ b/ordo/util/read-lines.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo util read-lines) #:use-module (ice-9 rdelim) #:export (read-lines)) diff --git a/ordo/util/shell-quote.scm b/ordo/util/shell-quote.scm index 5de60fa..dcfbcf4 100644 --- a/ordo/util/shell-quote.scm +++ b/ordo/util/shell-quote.scm @@ -1,21 +1,23 @@ -;; This file is part of Ordo. -;; -;; Shell quoting implementation is based on Perl's String::ShellQuote -;; Copyright (c) 1997 Roderick Schertler. -;; -;; Guile implementation Copyright (c) 2025 Ray Miller. -;; -;; Ordo 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, either version 3 of the License, or (at your option) -;; any later version. -;; -;; Ordo 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 -;; Ordo. If not, see . +#| +This file is part of Ordo. + +Shell quoting implementation is based on Perl's String::ShellQuote +Copyright (c) 1997 Roderick Schertler. + +Guile implementation 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, either version 3 of the License, or (at your option) +any later version. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +A PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# (define-module (ordo util shell-quote) #:use-module (rx irregex) From 49571984c27b85656bfeea3d346a4d35f6cb8590 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 7 Jun 2025 16:25:31 +0100 Subject: [PATCH 74/83] Basic functionality for play and playbook --- examples/inventory.scm | 10 +++-- examples/playbook.scm | 11 +++++- ordo/connection.scm | 6 ++- ordo/context.scm | 18 +++++++++ ordo/inventory.scm | 29 ++++++-------- ordo/play.scm | 89 +++++++++++++++++++++++++++++++----------- ordo/playbook.scm | 28 ++++++------- 7 files changed, 131 insertions(+), 60 deletions(-) diff --git a/examples/inventory.scm b/examples/inventory.scm index 7d5b9a9..30a2a78 100644 --- a/examples/inventory.scm +++ b/examples/inventory.scm @@ -2,7 +2,7 @@ (ordo inventory)) (list - (host #:name "localhost" + (host #:name "little-rascal" #:connection (local-connection) #:tags '(#:linux #:guix)) @@ -15,5 +15,9 @@ #:tags '(#:linux #:coreos)) (host #:name "control-surface" - #:connection (ssh-connection "control-surface") - #:tags '(#:linux #:debian))) + #:connection (ssh-connection "control-surface" #:user "ray") + #:tags '(#:linux #:debian)) + + (host #:name "cargo-cult" + #:connection (ssh-connection "cargo-cult" #:user "ray") + #:tags '(#:linux #:synology))) diff --git a/examples/playbook.scm b/examples/playbook.scm index 64836f5..631b2a6 100644 --- a/examples/playbook.scm +++ b/examples/playbook.scm @@ -5,4 +5,13 @@ #:vars '((foo . 1) (bar . "baz")) #:plays (list (play #:name "Example play" - #:host "localhost"))) + #:host "localhost" + #:tasks (list + (task #:name "First task" + #:action (const #t)) + (task #:name "Second task" + #:action (lambda (conn) + (trigger-handler! 'foo)))) + #:handlers (list + (handler #:name 'foo + #:action (const #f)))))) diff --git a/ordo/connection.scm b/ordo/connection.scm index 8046bcf..f9b2886 100644 --- a/ordo/connection.scm +++ b/ordo/connection.scm @@ -40,9 +40,11 @@ this program. If not, see . (define (local-connection) (make )) -(define* (ssh-connection host #:key (user (getlogin)) (password #f) (identity #f) (authenticate-server? #t)) +(define* (ssh-connection host #:key (user (getlogin)) (password #f) (identity #f) (authenticate-server? #t) + (sudo? #f) (sudo-user #f) (sudo-password #f)) (make #:user user #:host host #:password password - #:identity identity #:authenticate-server? authenticate-server?)) + #:identity identity #:authenticate-server? authenticate-server? + #:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password)) (define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password) (let ((conn (deep-clone conn))) diff --git a/ordo/context.scm b/ordo/context.scm index ff150a0..4a0157b 100644 --- a/ordo/context.scm +++ b/ordo/context.scm @@ -16,6 +16,9 @@ this program. If not, see . |# (define-module (ordo context) + #:use-module (ice-9 exceptions) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-69)) ;; @@ -64,3 +67,18 @@ this program. If not, see . (define-public (host-var-set! key value) (hash-table-set! (*host-vars*) key value)) + +;; +;; Play handlers +;; +(define-public *play-handlers* (make-parameter #f)) +(define-public *play-triggers* (make-parameter #f)) + +(define-public (trigger-handler! handler-name) + (let ((ix (list-index (cut equal? handler-name <>) (*play-handlers*)))) + (if ix + (bitvector-set-bit! (*play-triggers*) ix) + (raise-exception + (make-exception + (make-programming-error) + (make-exception-with-message (format #f "no such handler: ~a" handler-name))))))) diff --git a/ordo/inventory.scm b/ordo/inventory.scm index 669ed8e..354e8e4 100644 --- a/ordo/inventory.scm +++ b/ordo/inventory.scm @@ -23,6 +23,7 @@ this program. If not, see . #:use-module ((ordo connection) #:select (local-connection)) #:use-module (ordo logger) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-69) #:export (host host? @@ -33,21 +34,16 @@ this program. If not, see . resolve-hosts load-inventory)) -(define-class () - (name #:init-keyword #:name #:getter host-name) - (connection #:init-keyword #:connection #:getter host-connection) - (tags #:init-keyword #:tags #:getter host-tags #:init-form (list)) - (vars #:init-keyword #:vars #:getter host-vars #:init-form (list))) +(define-record-type + (make-host name connection tags vars) + host? + (name host-name) + (connection host-connection) + (tags host-tags) + (vars host-vars)) -(define-method (initialize (object ) initargs) - (next-method) - (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars)))) - -(define (host . args) - (apply make args)) - -(define (host? x) - (is-a? x )) +(define* (host #:key name connection (tags '()) (vars '())) + (make-host name connection tags (alist->hash-table vars))) (define (tagged-every? wanted-tags) (lambda (h) @@ -64,12 +60,13 @@ this program. If not, see . (define (resolve-hosts inventory expr) (match expr ("localhost" (list (or (find (named? "localhost") inventory) - (make #:name "localhost" #:connection (local-connection))))) + (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)))) + (('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) diff --git a/ordo/play.scm b/ordo/play.scm index ba08ee2..8ef756a 100644 --- a/ordo/play.scm +++ b/ordo/play.scm @@ -16,12 +16,12 @@ this program. If not, see . |# (define-module (ordo play) - #:use-module (oop goops) #:use-module (ordo connection) #:use-module (ordo context) #:use-module (ordo inventory) #:use-module (ordo logger) #:use-module (ordo util flatten) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-69) #:export (play @@ -31,43 +31,86 @@ this program. If not, see . play-sudo-user play-sudo-password play-vars - play-actions + play-tasks play-handlers - run-play)) + run-play + task + task? + task-name + task-pre-condition + task-action + run-task + handler + handler? + handler-name + handler-action)) -(define-class () - (name #:init-keyword #:name #:getter play-name) - (host #:init-keyword #:host #:getter play-host) - (sudo? #:init-keyword #:sudo? #:getter play-sudo? #:init-value #f) - (sudo-user #:init-keyword #:sudo-user #:getter play-sudo-user #:init-value #f) - (sudo-password #:init-keyword #:sudo-password #:getter play-sudo-password #:init-value #f) - (vars #:init-keyword #:vars #:getter play-vars #:init-form (list)) - (actions #:init-keyword #:actions #:getter play-actions #:init-form (list)) - (handlers #:init-keyword #:handlers #:getter play-handlers #:init-form (list))) +(define-record-type + (make-play name host sudo? sudo-user sudo-password vars tasks handlers) + play? + (name play-name) + (host play-host) + (sudo? play-sudo?) + (sudo-user play-sudo-user) + (sudo-password play-sudo-password) + (vars play-vars) + (tasks play-tasks) + (handlers play-handlers)) -(define-method (initialize (object ) initargs) - (next-method) - (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars)))) +(define* (play #:key name host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (tasks '()) (handlers '())) + (make-play name host sudo? sudo-user sudo-password (alist->hash-table vars) tasks handlers)) -(define (play . args) - (apply make args)) +(define-record-type + (make-task name action pre-condition) + task? + (name task-name) + (pre-condition task-pre-condition) + (action task-action)) + +(define* (task #:key name action (pre-condition (const #t))) + (make-task name action pre-condition)) + +(define (run-task t conn) + (if ((task-pre-condition t) conn) + (begin + (log-msg 'NOTICE "Running task " (task-name t)) + ((task-action t) conn)) + (log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met"))) + +(define-record-type + (make-handler name action) + handler? + (name handler-name) + (action handler-action)) + +(define* (handler #:key name action) + (make-handler name action)) + +(define (run-handler h conn) + (log-msg 'NOTICE "Running handler: " (handler-name h)) + ((handler-action h) conn)) (define (run-play p) (log-msg 'NOTICE "Running play: " (play-name p)) - (parameterize ((*play-vars* (play-vars p))) + (parameterize ((*play-handlers* (map handler-name (play-handlers p))) + (*play-vars* (play-vars p))) (let ((hosts (resolve-hosts (*inventory*) (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 (cut run-host-play p <>) hosts))))) (define (run-host-play p h) - (log-msg 'NOTICE "Running play: " (play-name p) " on host: " (host-name h)) - (parameterize ((*host-vars* (host-vars h))) + (log-msg 'NOTICE "Running play on host: " (host-name h)) + (parameterize ((*host-vars* (host-vars h)) + (*play-triggers* (make-bitvector (length (play-handlers p)) #f))) (call-with-connection (host-connection h) (lambda (conn) - #f - ) + (for-each (cut run-task <> conn) (play-tasks p)) + (for-each (lambda (h i) + (when (bitvector-bit-set? (*play-triggers*) i) + (run-handler h conn))) + (play-handlers p) (iota (length (play-handlers p))))) #:sudo? (play-sudo? p) #:sudo-user (play-sudo-user p) #:sudo-password (play-sudo-password p)))) diff --git a/ordo/playbook.scm b/ordo/playbook.scm index 44df6a7..122ab6e 100644 --- a/ordo/playbook.scm +++ b/ordo/playbook.scm @@ -18,10 +18,10 @@ this program. If not, see . (define-module (ordo playbook) #:use-module (ice-9 eval-string) #:use-module (ice-9 textual-ports) - #:use-module (oop goops) #:use-module (ordo context) #:use-module (ordo logger) #:use-module (ordo play) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-69) #:export ( @@ -32,22 +32,20 @@ this program. If not, see . playbook-plays load-playbook run-playbook) - #:re-export (play)) + #:re-export (play + task + handler + trigger-handler!)) -(define-class () - (name #:init-keyword #:name #:getter playbook-name) - (vars #:init-keyword #:vars #:getter playbook-vars) - (plays #:init-keyword #:plays #:getter playbook-plays)) +(define-record-type + (make-playbook name vars plays) + playbook? + (name playbook-name) + (vars playbook-vars) + (plays playbook-plays)) -(define-method (initialize (object ) initargs) - (next-method) - (slot-set! object 'vars (alist->hash-table (slot-ref object 'vars)))) - -(define (playbook . args) - (apply make args)) - -(define (playbook? p) - (is-a? p )) +(define* (playbook #:key name (vars '()) (plays '())) + (make-playbook name (alist->hash-table vars) plays)) (define (load-playbook filename) (log-msg 'INFO "Loading playbook " filename) From c69a9e200730819805463f7ad77b726dac0a2408 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 21 Jun 2025 15:55:28 +0100 Subject: [PATCH 75/83] Factor out task and handler into their own modules --- ordo/handler.scm | 22 ++++++++++++++++++++++ ordo/play.scm | 45 ++++----------------------------------------- ordo/task.scm | 26 ++++++++++++++++++++++++++ 3 files changed, 52 insertions(+), 41 deletions(-) create mode 100644 ordo/handler.scm create mode 100644 ordo/task.scm diff --git a/ordo/handler.scm b/ordo/handler.scm new file mode 100644 index 0000000..a6202db --- /dev/null +++ b/ordo/handler.scm @@ -0,0 +1,22 @@ +(define-module (ordo handler) + #:use-module (srfi srfi-9) + #:use-module (ordo logger) + #:export (make-handler + handler? + handler-name + handler-action + handler + run-handler)) + +(define-record-type + (make-handler name action) + handler? + (name handler-name) + (action handler-action)) + +(define* (handler #:key name action) + (make-handler name action)) + +(define (run-handler h conn) + (log-msg 'NOTICE "Running handler: " (handler-name h)) + ((handler-action h) conn)) diff --git a/ordo/play.scm b/ordo/play.scm index 8ef756a..95532f6 100644 --- a/ordo/play.scm +++ b/ordo/play.scm @@ -18,8 +18,10 @@ this program. If not, see . (define-module (ordo play) #:use-module (ordo connection) #:use-module (ordo context) + #:use-module (ordo handler) #:use-module (ordo inventory) #:use-module (ordo logger) + #:use-module (ordo task) #:use-module (ordo util flatten) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) @@ -33,17 +35,7 @@ this program. If not, see . play-vars play-tasks play-handlers - run-play - task - task? - task-name - task-pre-condition - task-action - run-task - handler - handler? - handler-name - handler-action)) + run-play)) (define-record-type (make-play name host sudo? sudo-user sudo-password vars tasks handlers) @@ -60,36 +52,6 @@ this program. If not, see . (define* (play #:key name host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (tasks '()) (handlers '())) (make-play name host sudo? sudo-user sudo-password (alist->hash-table vars) tasks handlers)) -(define-record-type - (make-task name action pre-condition) - task? - (name task-name) - (pre-condition task-pre-condition) - (action task-action)) - -(define* (task #:key name action (pre-condition (const #t))) - (make-task name action pre-condition)) - -(define (run-task t conn) - (if ((task-pre-condition t) conn) - (begin - (log-msg 'NOTICE "Running task " (task-name t)) - ((task-action t) conn)) - (log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met"))) - -(define-record-type - (make-handler name action) - handler? - (name handler-name) - (action handler-action)) - -(define* (handler #:key name action) - (make-handler name action)) - -(define (run-handler h conn) - (log-msg 'NOTICE "Running handler: " (handler-name h)) - ((handler-action h) conn)) - (define (run-play p) (log-msg 'NOTICE "Running play: " (play-name p)) (parameterize ((*play-handlers* (map handler-name (play-handlers p))) @@ -102,6 +64,7 @@ this program. If not, see . (define (run-host-play p h) (log-msg 'NOTICE "Running play on host: " (host-name h)) (parameterize ((*host-vars* (host-vars h)) + (*play-handlers* (play-handlers p)) (*play-triggers* (make-bitvector (length (play-handlers p)) #f))) (call-with-connection (host-connection h) diff --git a/ordo/task.scm b/ordo/task.scm new file mode 100644 index 0000000..8ccce13 --- /dev/null +++ b/ordo/task.scm @@ -0,0 +1,26 @@ +(define-module (ordo task) + #:use-module (ordo logger) + #:use-module (srfi srfi-9) + #:export (task + task? + task-name + task-pre-condition + task-action + run-task)) + +(define-record-type + (make-task name action pre-condition) + task? + (name task-name) + (pre-condition task-pre-condition) + (action task-action)) + +(define* (task #:key name action (pre-condition (const #t))) + (make-task name action pre-condition)) + +(define (run-task t conn) + (if ((task-pre-condition t) conn) + (begin + (log-msg 'NOTICE "Running task " (task-name t)) + ((task-action t) conn)) + (log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met"))) From 27d71df8b90779fbd02912646c328e2540b564a0 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 21 Jun 2025 15:56:35 +0100 Subject: [PATCH 76/83] GPL headers for new files --- ordo/handler.scm | 17 +++++++++++++++++ ordo/task.scm | 17 +++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/ordo/handler.scm b/ordo/handler.scm index a6202db..883f734 100644 --- a/ordo/handler.scm +++ b/ordo/handler.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo handler) #:use-module (srfi srfi-9) #:use-module (ordo logger) diff --git a/ordo/task.scm b/ordo/task.scm index 8ccce13..9399317 100644 --- a/ordo/task.scm +++ b/ordo/task.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo task) #:use-module (ordo logger) #:use-module (srfi srfi-9) From 407613152b3040ffaef95daaba5d07db9f8d1280 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 22 Jun 2025 11:26:31 +0100 Subject: [PATCH 77/83] Missing use-modules --- ordo/playbook.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ordo/playbook.scm b/ordo/playbook.scm index 122ab6e..b9b3b4e 100644 --- a/ordo/playbook.scm +++ b/ordo/playbook.scm @@ -19,8 +19,10 @@ this program. If not, see . #: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 (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-69) From 54564ec19f61a3d5cc48013d10901d48569555d5 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 22 Jun 2025 18:31:36 +0100 Subject: [PATCH 78/83] Some actions, and fleshing out playbook/tasks --- examples/forgejo.scm | 62 +++++++++++++++++ ordo/action/filesystem.scm | 138 +++++++++++++++++++++++++++++++++++++ ordo/action/quadlet.scm | 53 ++++++++++++++ ordo/connection.scm | 4 +- ordo/connection/base.scm | 2 +- ordo/context.scm | 70 ++----------------- ordo/core.scm | 69 +++++++++++++++++++ ordo/play.scm | 43 ++++++++---- ordo/playbook.scm | 22 +++--- ordo/util/keyword-args.scm | 27 +------- 10 files changed, 372 insertions(+), 118 deletions(-) create mode 100644 examples/forgejo.scm create mode 100644 ordo/action/filesystem.scm create mode 100644 ordo/action/quadlet.scm create mode 100644 ordo/core.scm diff --git a/examples/forgejo.scm b/examples/forgejo.scm new file mode 100644 index 0000000..2f3dff5 --- /dev/null +++ b/examples/forgejo.scm @@ -0,0 +1,62 @@ +(use-modules + ((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"))) + (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") + (#:quadlet-options . ((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"))))) + +(playbook "Install Forgejo on limiting-factor" + ;; #:vars '((forgejo-version . "11.0.2")) + (play + #:host "limiting-factor" + #:become? #t + (install-forgejo #:version "11"))) diff --git a/ordo/action/filesystem.scm b/ordo/action/filesystem.scm new file mode 100644 index 0000000..009363d --- /dev/null +++ b/ordo/action/filesystem.scm @@ -0,0 +1,138 @@ +(define-module (ordo action filesystem) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (logging logger) + #:use-module (rnrs bytevectors) + #: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) + #:export (create-tmp-dir + install-dir + install-file + file-info + delete + link)) + +(define* (file-info conn #:key path (atime? #t) (ctime? #t)) + (define (parse-stat-result s) + (match-let* (((file-type user group . rest) (string-split s #\:)) + ((uid gid size mode atime mtime ctime) (map string->number rest))) + `((file-type . ,file-type) + (user . ,user) + (group . ,group) + (uid . ,uid) + (gid . ,gid) + (size . ,size) + (mode . ,mode) + ,@(if atime? (list (cons 'atime atime)) '()) + (mtime . ,mtime) + ,@(if ctime? (list (cons 'ctime ctime)) '())))) + (let ((result rc (remote-cmd conn "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path)))) + (cond + ((zero? rc) (parse-stat-result (first result))) + ((string-contains (first result) "No such file or directory") #f) + (else (error (format #f "stat ~a: ~a" path (first result))))))) + +(define-syntax changed-if-stat-changed + (syntax-rules () + ((changed-if-stat-changed conn path expr ...) + (let ((st-before (file-info conn #:path path #:atime? #f #:ctime? #f))) + expr ... + (let ((st-after (file-info conn #:path path #:atime? #f #:ctime? #f))) + (not (equal? st-before st-after))))))) + +(define* (delete conn #:key path (recurse? #f)) + (changed-if-stat-changed + conn path + (remote-cmd conn "rm" "-f" + (when recurse? "-r") + path + #:check? #t))) + +(define* (link conn #:key target link-name (symbolic? #f) (force? #t) (backup? #f)) + "Create a link to @code{target} with the name @code{link-name}." + (changed-if-stat-changed + conn link-name + (remote-cmd conn "ln" + (when symbolic? "--symbolic") + (when force? "--force") + (when backup? "--backup=numbered") + target + link-name + #:check? #t))) + +(define* (create-tmp-dir conn #:key tmpdir suffix template) + (remote-cmd conn "mktemp" "--directory" + (when tmpdir '("--tmpdir" tmpdir)) + (when suffix '("--suffix" suffix)) + (when template template) + #:check? #t + #:return car)) + +(define* (install-dir conn #:key path owner group mode) + (when (integer? mode) + (set! mode (number->string mode 8))) + (changed-if-stat-changed + conn path + (remote-cmd conn "install" "--directory" + (when owner `("--owner" ,owner)) + (when group `("--group" ,group)) + (when mode `("--mode" ,mode)) + path + #:check? #t))) + +(define (upload-tmp-file conn tmp-file) + (lambda (input-port) + (with-remote-output-file conn tmp-file + (lambda (output-port) + (let loop ((data (get-bytevector-some input-port))) + (unless (eof-object? data) + (put-bytevector output-port data) + (loop (get-bytevector-some input-port)))) + (close-port output-port))))) + +(define (install-remote-file conn src dest owner group mode backup?) + ;; If owner/group/mode is unspecified and the destination file already exists, + ;; preserve the current ownership and mode. + (unless (and owner group mode) + (let ((st (file-info conn #:path dest))) + (when st + (set! owner (or owner (assoc-ref st 'owner))) + (set! group (or group (assoc-ref st 'group))) + (set! mode (or mode (assoc-ref st 'mode)))))) + (when (integer? mode) + (set! mode (number->string mode 8))) + (remote-cmd conn "install" + "--compare" + (when owner `("--owner" ,owner)) + (when group `("--group" ,group)) + (when mode `("--mode" ,mode)) + (when backup? "--backup=numbered") + src + dest + #:check? #t)) + +(define* (install-file conn #:key path owner group (mode #o644) content local-src remote-src backup?) + (when (not (= 1 (length (filter identity (list content local-src remote-src))))) + (error "exactly one of #:content, #:local-src, or #:remote-src is required")) + (changed-if-stat-changed + conn path + (if remote-src + (install-remote-file conn remote-src path owner group mode backup?) + ;; Because we might need sudo to install the remote file, we first + ;; upload the source to a temporary file, then call @code{install-remote-file} to + ;; install the temporary file to the target path. + (let ((tmp-file (remote-cmd conn "mktemp" #:check? #t #:return car))) + (dynamic-wind + (const #t) + (lambda () + (cond + (local-src (call-with-input-file local-src (upload-tmp-file conn tmp-file))) + ((string? content) (call-with-input-string content (upload-tmp-file conn tmp-file))) + ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn tmp-file))) + (else (error "unsupported type for #:content"))) + (install-remote-file conn tmp-file path owner group mode backup?)) + (lambda () + (remote-cmd conn "rm" "-f" tmp-file))))))) diff --git a/ordo/action/quadlet.scm b/ordo/action/quadlet.scm new file mode 100644 index 0000000..b1f79e7 --- /dev/null +++ b/ordo/action/quadlet.scm @@ -0,0 +1,53 @@ +(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) #:prefix fs:) + #:use-module ((srfi srfi-1) #:select (remove)) + #:export (create-network + create-pod + create-container + create-volume + create-image + create-build)) + +(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 service-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) + ,@(if (null? service-options) '() (list (cons "Service" service-options))) + ,@(if (null? install-options) '() (list (cons "Install" 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 + #:key name description + (quadlet-options '()) + (unit-options '()) + (service-options '()) + (install-options default-install-options)) + (fs:install-file conn + #:path (file-name-join* quadlet-dir (string-append name suffix)) + #:content (build-quadlet quadlet-type name description quadlet-options unit-options service-options install-options)))))) + +(define-quadlet-type create-network "Network" ".network" default-install-options) + +(define-quadlet-type create-pod "Pod" ".pod" default-install-options) + +(define-quadlet-type create-container "Container" ".container" default-install-options) + +(define-quadlet-type create-volume "Volume" ".volume" '()) + +(define-quadlet-type create-build "Build" ".build" '()) + +(define-quadlet-type create-image "Image" ".image" '()) diff --git a/ordo/connection.scm b/ordo/connection.scm index f9b2886..4c31470 100644 --- a/ordo/connection.scm +++ b/ordo/connection.scm @@ -31,7 +31,7 @@ this program. If not, see . local-connection ssh-connection call-with-connection - run) + remote-cmd) #:re-export (remote-exec with-remote-input-file with-remote-output-file)) (define (connection? c) @@ -62,7 +62,7 @@ this program. If not, see . (lambda () (proc conn)) (lambda () (teardown conn))))) -(define (run conn prog . args) +(define (remote-cmd conn prog . args) (let* ((args options (break keyword? args)) (args (remove unspecified? (flatten args))) (return (keyword-arg options #:return identity)) diff --git a/ordo/connection/base.scm b/ordo/connection/base.scm index 6803f20..d853fdb 100644 --- a/ordo/connection/base.scm +++ b/ordo/connection/base.scm @@ -46,7 +46,7 @@ this program. If not, see . (define-method (build-command (c ) (prog-name ) (prog-args ) (options )) (let* ((pwd (keyword-arg options #:pwd)) (env (keyword-arg options #:env)) - (redirect-err? (keyword-arg options #:redirect-err?)) + (redirect-err? (keyword-arg options #:redirect-err? #t)) (xs (remove unspecified? (flatten (list "env" (when pwd (list "--chdir" (string-shell-quote pwd))) diff --git a/ordo/context.scm b/ordo/context.scm index 4a0157b..94c6290 100644 --- a/ordo/context.scm +++ b/ordo/context.scm @@ -15,70 +15,10 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . |# -(define-module (ordo context) - #:use-module (ice-9 exceptions) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-69)) +(define-module (ordo context)) -;; -;; Inventory -;; (define-public *inventory* (make-parameter #f)) - -;; -;; Playbook vars -;; -(define-public *playbook-vars* (make-parameter #f)) - -(define-public (playbook-var-ref key) - (hash-table-ref (*playbook-vars*) key)) - -(define-public (playbook-var-ref/default key default) - (hash-table-ref/default (*playbook-vars*) key default)) - -(define-public (playbook-var-set! key value) - (hash-table-set! (*playbook-vars*) key value)) - -;; -;; Play vars -;; -(define-public *play-vars* (make-parameter #f)) - -(define-public (play-var-ref key) - (hash-table-ref (*play-vars*) key)) - -(define-public (play-var-ref/default key default) - (hash-table-ref/default (*play-vars*) key default)) - -(define-public (play-var-set! key value) - (hash-table-set! (*play-vars*) key value)) - -;; -;; Host vars -;; -(define-public *host-vars* (make-parameter #f)) - -(define-public (host-var-ref key) - (hash-table-ref (*host-vars*) key)) - -(define-public (host-var-ref/default key default) - (hash-table-ref/default (*host-vars*) key default)) - -(define-public (host-var-set! key value) - (hash-table-set! (*host-vars*) key value)) - -;; -;; Play handlers -;; -(define-public *play-handlers* (make-parameter #f)) -(define-public *play-triggers* (make-parameter #f)) - -(define-public (trigger-handler! handler-name) - (let ((ix (list-index (cut equal? handler-name <>) (*play-handlers*)))) - (if ix - (bitvector-set-bit! (*play-triggers*) ix) - (raise-exception - (make-exception - (make-programming-error) - (make-exception-with-message (format #f "no such handler: ~a" handler-name))))))) +(define-public *playbook* (make-parameter #f)) +(define-public *play* (make-parameter #f)) +(define-public *host* (make-parameter #f)) +(define-public *triggered-handlers* (make-parameter #f)) diff --git a/ordo/core.scm b/ordo/core.scm new file mode 100644 index 0000000..d12c7c1 --- /dev/null +++ b/ordo/core.scm @@ -0,0 +1,69 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# +(define-module (ordo core) + #:use-module (ordo connection) + #:use-module (ordo context) + #:use-module (ordo handler) + #:use-module (ordo inventory) + #:use-module (ordo logger) + #:use-module (ordo playbook) + #:use-module (ordo play) + #:use-module (ordo task) + #:use-module ((srfi srfi-26) #:select (cut))) + +(define (run-playbook ctx pb) + (log-msg 'NOTICE "Running playbook: " (playbook-name pb)) + (set-ctx-playbook! ctx pb) + (for-each (cut run-play ctx <>) (playbook-plays pb))) + +(define (run-play ctx p) + (log-msg 'NOTICE "Running play: " (play-name p)) + (set-ctx-play! ctx p) + (let ((hosts (resolve-hosts (ctx-inventory ctx) (play-host p)))) + (if (null? hosts) + (log-msg 'WARN "No hosts matched: " (play-host p)) + (for-each (cut run-host-play ctx p <>) hosts)))) + +(define (run-host-play ctx p h) + (log-msg 'NOTICE "Running play on host: " (host-name h)) + (set-ctx-host! ctx h) + (call-with-connection + (host-connection h) + (lambda (conn) + (dynamic-wind + (lambda () + (set-ctx-connection! ctx conn)) + (lambda () + (for-each (cut run-task ctx <>) (play-tasks p)) + (for-each (cut run-handler ctx <>) (play-handlers p))) + (lambda () + (set-ctx-connection! ctx #f)))) + #:sudo? (play-sudo? p) + #:sudo-user (play-sudo-user p) + #:sudo-password (play-sudo-password p))) + +(define (run-task ctx t) + (if ((task-pre-condition t) ctx) + (begin + (log-msg 'NOTICE "Running task " (task-name t)) + ((task-action t) ctx)) + (log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met"))) + +(define (run-handler ctx h) + (when (member (ctx-triggers ctx) (handler-name h)) + (log-msg 'NOTICE "Running handler: " (handler-name h)) + ((handler-action h) ctx))) diff --git a/ordo/play.scm b/ordo/play.scm index 95532f6..326d5c6 100644 --- a/ordo/play.scm +++ b/ordo/play.scm @@ -23,9 +23,12 @@ this program. If not, see . #:use-module (ordo logger) #:use-module (ordo task) #:use-module (ordo util flatten) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-69) + #: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 @@ -35,7 +38,8 @@ this program. If not, see . play-vars play-tasks play-handlers - run-play)) + run-play + trigger-handler!)) (define-record-type (make-play name host sudo? sudo-user sudo-password vars tasks handlers) @@ -49,13 +53,21 @@ this program. If not, see . (tasks play-tasks) (handlers play-handlers)) -(define* (play #:key name host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (tasks '()) (handlers '())) - (make-play name host sudo? sudo-user sudo-password (alist->hash-table vars) tasks 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-handlers* (map handler-name (play-handlers p))) - (*play-vars* (play-vars p))) + (parameterize ((*play* p)) (let ((hosts (resolve-hosts (*inventory*) (play-host p)))) (if (null? hosts) (log-msg 'WARN "No hosts matched: " (play-host p)) @@ -63,17 +75,18 @@ this program. If not, see . (define (run-host-play p h) (log-msg 'NOTICE "Running play on host: " (host-name h)) - (parameterize ((*host-vars* (host-vars h)) - (*play-handlers* (play-handlers p)) - (*play-triggers* (make-bitvector (length (play-handlers p)) #f))) + (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 (lambda (h i) - (when (bitvector-bit-set? (*play-triggers*) i) - (run-handler h conn))) - (play-handlers p) (iota (length (play-handlers p))))) + (for-each (cut run-handler <> conn) + (filter (compose (cut hash-table-ref/default *triggered-handlers* <> #f) handler-name) + (play-handlers p)))) #:sudo? (play-sudo? p) #:sudo-user (play-sudo-user p) #:sudo-password (play-sudo-password p)))) + +(define (trigger-handler! handler-name) + (hash-table-set! *triggered-handlers* handler-name #t)) diff --git a/ordo/playbook.scm b/ordo/playbook.scm index b9b3b4e..b22fc3c 100644 --- a/ordo/playbook.scm +++ b/ordo/playbook.scm @@ -23,9 +23,12 @@ this program. If not, see . #:use-module (ordo logger) #:use-module (ordo play) #:use-module (ordo task) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-69) + #: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? @@ -33,11 +36,7 @@ this program. If not, see . playbook-vars playbook-plays load-playbook - run-playbook) - #:re-export (play - task - handler - trigger-handler!)) + run-playbook)) (define-record-type (make-playbook name vars plays) @@ -46,8 +45,9 @@ this program. If not, see . (vars playbook-vars) (plays playbook-plays)) -(define* (playbook #:key name (vars '()) (plays '())) - (make-playbook name (alist->hash-table vars) 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) @@ -57,5 +57,5 @@ this program. If not, see . (define (run-playbook pb inventory) (log-msg 'NOTICE "Running playbook: " (playbook-name pb)) (parameterize ((*inventory* inventory) - (*playbook-vars* (playbook-vars pb))) + (*playbook* pb)) (for-each run-play (playbook-plays pb)))) diff --git a/ordo/util/keyword-args.scm b/ordo/util/keyword-args.scm index e194140..95de5eb 100644 --- a/ordo/util/keyword-args.scm +++ b/ordo/util/keyword-args.scm @@ -16,29 +16,8 @@ this program. If not, see . |# (define-module (ordo util keyword-args) - #:use-module (ice-9 exceptions) - #:export (keyword-arg - select-keyword-args - validate-keyword-args)) + #:use-module ((srfi srfi-1) #:select (member)) + #:export (keyword-arg)) (define* (keyword-arg args kw #:optional (default #f)) - (cond - ((< (length args) 2) default) - ((equal? (car args) kw) (cadr args)) - (else (keyword-arg (cddr args) kw default)))) - -(define (select-keyword-args kwargs wanted) - (let loop ((kwargs kwargs) (accum '())) - (cond - ((null? kwargs) - (reverse accum)) - ((member (car kwargs) wanted) - (loop (cddr kwargs) (cons* (car kwargs) (cadr kwargs) accum))) - (else (loop (cddr kwargs) accum))))) - -(define (validate-keyword-args kwargs) - (unless (even? (length kwargs)) - (raise-exception - (make-exception - (make-programming-error) - (make-exception-with-message "keyword args should have an even number of elements"))))) + (or (and=> (member kw args) cadr) default)) From 8a41f8f558bbba73e4a59c72c71039c48ecfac92 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 23 Jun 2025 09:49:50 +0100 Subject: [PATCH 79/83] Updates to quadlet generation * Define quadlets directly, without use of a macro * Allow override of the quadlet install directory --- ordo/action/quadlet.scm | 47 +++++++++++++++++++++++------------------ 1 file changed, 26 insertions(+), 21 deletions(-) diff --git a/ordo/action/quadlet.scm b/ordo/action/quadlet.scm index b1f79e7..c4b65c2 100644 --- a/ordo/action/quadlet.scm +++ b/ordo/action/quadlet.scm @@ -12,14 +12,14 @@ create-image create-build)) -(define quadlet-dir "/etc/containers/systemd") +(define system-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 service-options install-options) +(define (quadlet quadlet-type name description unit-options quadlet-options service-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) @@ -27,27 +27,32 @@ ,@(if (null? install-options) '() (list (cons "Install" 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 - #:key name description - (quadlet-options '()) - (unit-options '()) - (service-options '()) - (install-options default-install-options)) - (fs:install-file conn - #:path (file-name-join* quadlet-dir (string-append name suffix)) - #:content (build-quadlet quadlet-type name description quadlet-options unit-options service-options install-options)))))) +(define* (create-network conn #:key name description network (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir)) + (fs:install-file conn + #:path (file-name-join* quadlet-dir (string-append name ".network")) + #:content (quadlet "Network" name description unit network service install))) -(define-quadlet-type create-network "Network" ".network" default-install-options) +(define* (create-pod conn #:key name description pod (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir)) + (fs:install-file conn + #:path (file-name-join* quadlet-dir (string-append name ".pod")) + #:content (quadlet "Pod" name description unit pod service install))) -(define-quadlet-type create-pod "Pod" ".pod" default-install-options) +(define* (create-container conn #:key name description container (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir)) + (fs:install-file conn + #:path (file-name-join* quadlet-dir (string-append name ".container")) + #:content (quadlet "Container" name description unit container service install))) -(define-quadlet-type create-container "Container" ".container" default-install-options) +(define* (create-volume conn #:key name description volume (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir)) + (fs:install-file conn + #:path (file-name-join* quadlet-dir (string-append name ".volume")) + #:content (quadlet "Volume" name description unit volume service install))) -(define-quadlet-type create-volume "Volume" ".volume" '()) +(define* (create-build conn #:key name description build (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir)) + (fs:install-file conn + #:path (file-name-join* quadlet-dir (string-append name ".build")) + #:content (quadlet "Build" name description unit build service install))) -(define-quadlet-type create-build "Build" ".build" '()) - -(define-quadlet-type create-image "Image" ".image" '()) +(define* (create-image conn #:key name description image (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir)) + (fs:install-file conn + #:path (file-name-join* quadlet-dir (string-append name ".image")) + #:content (quadlet "Image" name description unit image service install))) From 9c3373dea94e40280328fbff7a481f16494b2a99 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 23 Jun 2025 09:51:00 +0100 Subject: [PATCH 80/83] Rename functions to disambiguate --- ordo/action/filesystem.scm | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/ordo/action/filesystem.scm b/ordo/action/filesystem.scm index 009363d..87e421b 100644 --- a/ordo/action/filesystem.scm +++ b/ordo/action/filesystem.scm @@ -12,8 +12,8 @@ install-dir install-file file-info - delete - link)) + remove-file + create-link)) (define* (file-info conn #:key path (atime? #t) (ctime? #t)) (define (parse-stat-result s) @@ -43,15 +43,13 @@ (let ((st-after (file-info conn #:path path #:atime? #f #:ctime? #f))) (not (equal? st-before st-after))))))) -(define* (delete conn #:key path (recurse? #f)) +(define* (remove-file conn #:key path (recurse? #f)) (changed-if-stat-changed conn path - (remote-cmd conn "rm" "-f" - (when recurse? "-r") - path + (remote-cmd conn "rm" "-f" (when recurse? "-r") path #:check? #t))) -(define* (link conn #:key target link-name (symbolic? #f) (force? #t) (backup? #f)) +(define* (create-link conn #:key target link-name (symbolic? #f) (force? #t) (backup? #f)) "Create a link to @code{target} with the name @code{link-name}." (changed-if-stat-changed conn link-name From ce4de34d5a870b8f0f3a9c594944f80c20a49a29 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 23 Jun 2025 10:09:03 +0100 Subject: [PATCH 81/83] Add copyright headers --- ordo/action/filesystem.scm | 17 +++++++++++++++++ ordo/action/quadlet.scm | 17 +++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/ordo/action/filesystem.scm b/ordo/action/filesystem.scm index 87e421b..bb87ae3 100644 --- a/ordo/action/filesystem.scm +++ b/ordo/action/filesystem.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo action filesystem) #:use-module (ice-9 binary-ports) #:use-module (ice-9 match) diff --git a/ordo/action/quadlet.scm b/ordo/action/quadlet.scm index c4b65c2..883baf0 100644 --- a/ordo/action/quadlet.scm +++ b/ordo/action/quadlet.scm @@ -1,3 +1,20 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + (define-module (ordo action quadlet) #:use-module (ice-9 filesystem) #:use-module (ini) From bcf0b56911448bf1f8142076a2d174ce2f6a3d18 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 23 Jun 2025 10:09:14 +0100 Subject: [PATCH 82/83] Implement sytemctl actions --- ordo/action/systemcl.scm | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 ordo/action/systemcl.scm diff --git a/ordo/action/systemcl.scm b/ordo/action/systemcl.scm new file mode 100644 index 0000000..14da223 --- /dev/null +++ b/ordo/action/systemcl.scm @@ -0,0 +1,40 @@ +#| +This file is part of Ordo. + +Copyright (C) 2025 Ray Miller + +This program is free software: you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free Software +Foundation, version 3. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with +this program. If not, see . +|# + +(define-module (ordo action systemctl) + #:use-module (ordo connection) + #:export (daemon-reload stop start restart reload)) + +(define (daemon-reload conn #:key user?) + (remote-cmd conn "systemctl" (when user? "--user") "daemon-reload" #:check? #t) + #t) + +(define (stop conn #:key unit user?) + (remote-cmd conn "systemctl" (when user? "--user") "stop" unit #:check? #t) + #t) + +(define (start conn #:key unit user?) + (remote-cmd conn "systemctl" (when user? "--user") "start" unit #:check? #t) + #t) + +(define (reload conn #:key unit user?) + (remote-cmd conn "systemctl" (when user? "--user") "reload" unit #:check? #t) + #t) + +(define (restart conn #:key unit user?) + (remote-cmd conn "systemctl" (when user? "--user") "restart" unit #:check? #t) + #t) From 1158efbaa439ad61fa78ab2f7fc66262f5b6f81a Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Mon, 23 Jun 2025 10:12:03 +0100 Subject: [PATCH 83/83] Bugfix systemctl, update example --- examples/forgejo.scm | 44 ++++++++++----------- ordo/action/{systemcl.scm => systemctl.scm} | 10 ++--- 2 files changed, 26 insertions(+), 28 deletions(-) rename ordo/action/{systemcl.scm => systemctl.scm} (85%) diff --git a/examples/forgejo.scm b/examples/forgejo.scm index 2f3dff5..bada9dd 100644 --- a/examples/forgejo.scm +++ b/examples/forgejo.scm @@ -7,46 +7,44 @@ (list (task "Install configuration directory" #:action fs:install-dir - #:args '((#:path . "/etc/forgejo")) + #:args '(#:path "/etc/forgejo") #:trigger '("Restart pod")) (task "Install timezone configuration" #:action fs:install-file - #:args '((#:path . "/etc/forgejo/timezone") - (#:local-src . "files/timezone")) + #: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"))) + #: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")) + #:args '(#:name "forgejo" #:description "Forgejo data volume") #:trigger '("Reload systemd" "Restart pod")) (task "Create pod quadlet" #:action quadlet:create-pod - #:args '((#:name . "forgejo") - (#:quadlet-options . ((PodName . "forge") - (Volume . "forgejo.volume:U,Z") - (PodmanArgs . "--userns auto")))) + #: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)))) + #: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")))) + #: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) diff --git a/ordo/action/systemcl.scm b/ordo/action/systemctl.scm similarity index 85% rename from ordo/action/systemcl.scm rename to ordo/action/systemctl.scm index 14da223..d8b5eeb 100644 --- a/ordo/action/systemcl.scm +++ b/ordo/action/systemctl.scm @@ -19,22 +19,22 @@ this program. If not, see . #:use-module (ordo connection) #:export (daemon-reload stop start restart reload)) -(define (daemon-reload conn #:key user?) +(define* (daemon-reload conn #:key user?) (remote-cmd conn "systemctl" (when user? "--user") "daemon-reload" #:check? #t) #t) -(define (stop conn #:key unit user?) +(define* (stop conn #:key unit user?) (remote-cmd conn "systemctl" (when user? "--user") "stop" unit #:check? #t) #t) -(define (start conn #:key unit user?) +(define* (start conn #:key unit user?) (remote-cmd conn "systemctl" (when user? "--user") "start" unit #:check? #t) #t) -(define (reload conn #:key unit user?) +(define* (reload conn #:key unit user?) (remote-cmd conn "systemctl" (when user? "--user") "reload" unit #:check? #t) #t) -(define (restart conn #:key unit user?) +(define* (restart conn #:key unit user?) (remote-cmd conn "systemctl" (when user? "--user") "restart" unit #:check? #t) #t)