From 3e1b3e3f374c784f673c75018a31af1beff2d9ac Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 14 Jul 2024 17:11:24 +0100 Subject: [PATCH 01/26] 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/26] 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/26] 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/26] 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/26] 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/26] 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/26] 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/26] 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 c9c9429fc4ab2933f6b52530ae4fb2fe47d0096b Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 3 Jan 2025 20:07:02 +0000 Subject: [PATCH 09/26] Add podman connection (incomplete) --- modules/ordo/connection.scm | 38 +++++++++++++++++++++++++++++++++++-- 1 file changed, 36 insertions(+), 2 deletions(-) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index c4b48ae..4deddb2 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -15,6 +15,7 @@ #:use-module (srfi srfi-197) ;; chain #:export (local-connection ssh-connection + ;;podman-connection init! close! run @@ -41,9 +42,16 @@ (define* (ssh-connection user host #:key (sudo? #f)) (make #:user user #:host host #:sudo? sudo?)) -(define-method (init! (c )) #t) +;; (define-class () +;; (container-name #:getter get-container-name #:init-keyword #:container) +;; (user #:getter get-user #:init-keyword #:user #:init-value #f)) -(define-method (close! (c )) #t) +;; (define* (podman-connection #:key (sudo? #f)) +;; (make #:sudo? sudo?)) + +(define-method (init! c) #t) + +(define-method (close! c) #t) (define-method (init! (c )) (unless (slot-bound? c 'session) @@ -88,6 +96,23 @@ (close channel) (values output exit-status))) +;; (define-method (build-podman-exec (c pwd env prog args) +;; (chain-when '() +;; ((sudo? c) (append _ "sudo")) +;; (#t (append _ '("podman" "exec"))) +;; ((get-user c) (append (list "-u" (get-user c)))) +;; (pwd (append _ '( "-w" pwd))) +;; (env (append _ (concatenate (map (lambda (x) (list "-e" (format #f "~a=~a" (car x) (cdr x)))) env)))) +;; (#t (append (list container-name))) +;; (#t (append _ (cons prog args)))))) + +;; (define-method (%run (c ) pwd env prog args) +;; (let* ((cmd (build-podman-exec c pwd env prog args))) +;; (port (apply open-pipe* OPEN_READ cmd)) +;; (output (read-lines port)) +;; (exit-status (status:exit-val (close-pipe port)))) +;; (values output exit-status)) + (define (find-kw-arg kw kwargs) (let loop ((kwargs kwargs)) (cond @@ -131,6 +156,15 @@ (error (format #f "error reading text file ~a@~a:~a" (get-user c) (get-host c) path))) output)) +;; (define-method (read-file (c ) (path ) (reader )) +;; (let* ((cmd (build-podman-exec c #f #f "cat" (list path))) +;; (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 file ~a:~a" (get-container-name c) path))) +;; output)) + (define (read-text-file c path) (read-file c path get-string-all)) From 8426126b3017585dbeb17c1d6b519a26b7d53714 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Thu, 29 May 2025 15:31:32 +0100 Subject: [PATCH 10/26] 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 11/26] 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 12/26] 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 13/26] 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 14/26] 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 15/26] 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 16/26] 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 17/26] 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 18/26] 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 19/26] 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 20/26] 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 21/26] 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 22/26] 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 23/26] 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 24/26] 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 25/26] 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 26/26] 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)