From 63b9ad67539214048725bb6b66d43e3cbef32b2a Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Thu, 23 Jan 2025 17:08:06 +0000 Subject: [PATCH 1/7] Bugfix interceptor and add example --- examples/interceptor.scm | 71 +++++------------ modules/ordo/connection.scm | 21 ++++- modules/ordo/interceptor.scm | 114 ++++++++++++++++----------- modules/ordo/interceptor/debug.scm | 16 ++++ modules/ordo/interceptor/errors.scm | 14 ++++ modules/ordo/interceptor/tmp-dir.scm | 20 +++++ 6 files changed, 155 insertions(+), 101 deletions(-) create mode 100644 modules/ordo/interceptor/debug.scm create mode 100644 modules/ordo/interceptor/errors.scm create mode 100644 modules/ordo/interceptor/tmp-dir.scm diff --git a/examples/interceptor.scm b/examples/interceptor.scm index ebb8689..cedff3f 100644 --- a/examples/interceptor.scm +++ b/examples/interceptor.scm @@ -1,66 +1,31 @@ (use-modules (ice-9 filesystem) - (oop goops) (logging logger) - (srfi srfi-26) - (ordo logger) - (ordo interceptor) (ordo connection) - (ordo connection sudo) - (ordo action filesystem)) - -(define* (i:connection c #:key sudo? sudo-user sudo-password) - "Interceptor to manage the current connection." - (interceptor - "manage-connection" - #:enter (lambda (ctx) - (let ((c (if sudo? - (make #:connection c #:become-user sudo-user #:become-password sudo-password) - c))) - (conn:setup c) - (set-context-connection! ctx c))) - #:leave (lambda (ctx) - (and=> (context-connection ctx) conn:teardown) - (set-context-connection! ctx #f)))) - -(define (i:handle-errors) - "Interceptor to log (and clear) the context error. This will allow any - earlier #:leave handlers in the chain to run normally." - (interceptor - "handle-errors" - #:error (lambda (ctx) - (and=> (context-error ctx) (cut log-msg 'ERROR <>)) - (set-context-error! ctx #f)))) - -(define (i:tmp-dir) - "Interceptor to manage a temporary directory." - (interceptor - "tmp-dir" - #:enter (lambda (ctx) - (var-set! ctx 'tmp-dir (fs:create-tmp-dir (context-connection ctx)))) - #:leave (lambda (ctx) - (and=> (var-ref ctx 'tmp-dir #f) - (cut fs:remove (context-connection ctx) <> #:recurse? #t)) - (var-delete! ctx 'tmp-dir)))) + (ordo interceptor) + (ordo interceptor tmp-dir) + (ordo interceptor debug) + (ordo action filesystem) + (ordo logger)) (define chain - (list (i:connection (local-connection)) - (i:tmp-dir) - (i:handle-errors) + (list (connection-interceptor (local-connection)) + (tmp-dir-interceptor #:tmp-dir) (interceptor - "hello-world" + "install hello" #:enter (lambda (ctx) - (var-set! ctx 'hello - (fs:install-file (context-connection ctx) - (file-name-join* (var-ref ctx 'tmp-dir) - "hello.txt") - #:content "Hello, world!\n")))) + (fs:install-file (context-connection ctx) + (file-name-join* (var-ref ctx #:tmp-dir) "hello.txt") + #:content "Hello, world!\n")) + #:register #:hello) (interceptor - "get-file-status" + "stat hello" #:enter (lambda (ctx) - (let ((st (fs:stat (context-connection ctx) (var-ref ctx 'hello)))) - (log-msg 'INFO "stat result: " st)))))) + (fs:stat (context-connection ctx) (var-ref ctx #:hello))) + #:register #:hello-stat) + (debug-vars-interceptor #:hello #:hello-stat) + (debug-vars-interceptor))) -(setup-logging #:level 'DEBUG) +(setup-logging #:level 'INFO) (execute (init-context) chain) (shutdown-logging) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index d5e3223..2e4c9b7 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -9,15 +9,16 @@ #:use-module (ordo connection local) #:use-module (ordo connection ssh) #:use-module (ordo connection sudo) + #:use-module (ordo interceptor) #:use-module (ordo util flatten) #:use-module (ordo util shell-quote) #:use-module (ordo util keyword-args) - #:export (connection? + #:export (connection-interceptor + connection? local-connection ssh-connection call-with-connection - run) - #:re-export (conn:setup conn:teardown)) + run)) (define (connection? c) (is-a? c )) @@ -67,3 +68,17 @@ (make-external-error) (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog))))) (values (return out) rc))))) + +(define* (connection-interceptor c #:key sudo? sudo-user sudo-password) + "Interceptor to manage the current connection." + (interceptor + "manage-connection" + #:enter (lambda (ctx) + (let ((c (if sudo? + (make #:connection c #:become-user sudo-user #:become-password sudo-password) + c))) + (conn:setup c) + (set-context-connection! ctx c))) + #:leave (lambda (ctx) + (and=> (context-connection ctx) conn:teardown) + (set-context-connection! ctx #f)))) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm index 2a1eda0..d899769 100644 --- a/modules/ordo/interceptor.scm +++ b/modules/ordo/interceptor.scm @@ -3,9 +3,9 @@ #:use-module (logging logger) #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-9) ; records + #:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-69) ; hash tables #:use-module (srfi srfi-71) ; extended let - #:use-module (ordo connection) #:export (interceptor init-context context-connection @@ -13,23 +13,20 @@ context-error set-context-error! context-suppressed - terminate-when - execute - var-set! + context-vars + set-context-vars! var-ref - var-delete!)) + var-set! + var-delete! + terminate-when + execute)) -(define-record-type - (make-interceptor name enter leave error) - interceptor? - (name interceptor-name) - (enter interceptor-enter) - (leave interceptor-leave) - (error interceptor-error)) - -(define* (interceptor name #:key enter leave error) - "Create an interceptor with optional enter, leave, and error functions." - (make-interceptor name enter leave error)) +(define (check-var-name name) + (unless (keyword? name) + (raise-exception (make-exception + (make-assertion-failure) + (make-exception-with-message "Variable name should be a keyword") + (make-exception-with-irritants name))))) (define-record-type (make-context connection vars stack queue terminators error suppressed) @@ -44,6 +41,7 @@ (define* (init-context #:key conn (vars '())) "Initialize a context with optional connection and vars." + (for-each check-var-name (map car vars)) (make-context ;; connection conn @@ -60,6 +58,34 @@ ;; suppressed errors '())) +(define (var-set! ctx name value) + (check-var-name name) + (log-msg 'DEBUG "Setting variable " name " to " value) + (hash-table-set! (context-vars ctx) name value)) + +(define* (var-ref ctx name #:optional default) + (check-var-name name) + (log-msg 'DEBUG "Getting variable " name " with default " default) + (hash-table-ref/default (context-vars ctx) name default)) + +(define (var-delete! ctx name) + (check-var-name name) + (log-msg 'DEBUG "Deleting variable " name) + (hash-table-delete! (context-vars ctx) name)) + +(define-record-type + (make-interceptor name enter leave error register) + interceptor? + (name interceptor-name) + (enter interceptor-enter) + (leave interceptor-leave) + (error interceptor-error) + (register interceptor-register)) + +(define* (interceptor name #:key enter leave error register) + "Create an interceptor with optional enter, leave, and error functions." + (make-interceptor name enter leave error register)) + (define-exception-type &interceptor-error &error make-interceptor-error interceptor-error? @@ -91,19 +117,21 @@ "Run the interceptor's #:enter function." (let ((handler (interceptor-enter t))) (when handler - (log-msg 'INFO "Running #:enter function for " (interceptor-name t)) + (log-msg 'NOTICE "Running #:enter function for " (interceptor-name t)) (with-exception-handler (lambda (e) (set-context-error! ctx (make-interceptor-error (interceptor-name t) #:enter e))) - (lambda () (handler ctx)) + (lambda () + (let ((result (handler ctx))) + (and=> (interceptor-register t) (cut var-set! ctx <> result)))) #:unwind? #t)))) (define (try-leave ctx t) "Run the interceptor's #:leave function." (let ((handler (interceptor-leave t))) (when handler - (log-msg 'INFO "Running #:leave function for " (interceptor-name t)) + (log-msg 'NOTICE "Running #:leave function for " (interceptor-name t)) (with-exception-handler (lambda (e) (set-context-error! ctx @@ -115,7 +143,7 @@ "Run the interceptor's #:error function." (let ((handler (interceptor-error t))) (when handler - (log-msg 'INFO "Running #:error function for " (interceptor-name t)) + (log-msg 'NOTICE "Running #:error function for " (interceptor-name t)) (with-exception-handler (lambda (e) (log-msg 'WARN "error handler for interceptor '" (interceptor-name t) "' threw error: " e) @@ -143,22 +171,24 @@ (define (execute-enter ctx) "Run all the #:enter functions in the queue." - (unless (null? (context-queue ctx)) - (let ((t (car (context-queue ctx)))) - ;; Run the enter handler for the interceptor - (try-enter ctx t) - ;; Remove the current interceptor from the queue and add it to the stack - (set-context-stack! ctx (cons t (context-stack ctx))) - (set-context-queue! ctx (cdr (context-queue ctx))) - (if (context-error ctx) - ;; If an error was caught, abort the enter phase and set up to run the leave phase - (begin - (set-context-queue! ctx (context-stack ctx)) - (set-context-stack! ctx '())) - ;; Otherwise, check for early termination or carry on down the chain - (begin - (check-terminators ctx) - (execute-enter ctx)))))) + (if (null? (context-queue ctx)) + ;; Prepare to leave + (set-context-queue! ctx (context-stack ctx)) + (let ((t (car (context-queue ctx)))) + ;; Run the enter handler for the interceptor + (try-enter ctx t) + ;; Remove the current interceptor from the queue and add it to the stack + (set-context-stack! ctx (cons t (context-stack ctx))) + (set-context-queue! ctx (cdr (context-queue ctx))) + (if (context-error ctx) + ;; If an error was caught, abort the enter phase and set up to run the leave phase + (begin + (set-context-queue! ctx (context-stack ctx)) + (set-context-stack! ctx '())) + ;; Otherwise, check for early termination or carry on down the chain + (begin + (check-terminators ctx) + (execute-enter ctx)))))) (define (terminate-when ctx pred) "Add a predicate for a termination condition to exit the #:enter chain early." @@ -166,16 +196,10 @@ (define (execute ctx interceptors) "Execute all the interceptors on the given context." + (log-msg 'DEBUG "Enqueuing interceptors: " (map interceptor-name interceptors)) (enqueue ctx interceptors) + (log-msg 'DEBUG "Starting #:enter chain: " (map interceptor-name (context-queue ctx))) (execute-enter ctx) + (log-msg 'DEBUG "Starting #:leave chain: " (map interceptor-name (context-queue ctx))) (execute-leave ctx) (and=> (context-error ctx) raise-exception)) - -(define (var-set! ctx name value) - (hash-table-set! (context-vars ctx) name value)) - -(define* (var-ref ctx name #:optional default) - (hash-table-ref/default (context-vars ctx) name default)) - -(define (var-delete! ctx name) - (hash-table-delete! (context-vars ctx) name)) diff --git a/modules/ordo/interceptor/debug.scm b/modules/ordo/interceptor/debug.scm new file mode 100644 index 0000000..ca4707a --- /dev/null +++ b/modules/ordo/interceptor/debug.scm @@ -0,0 +1,16 @@ +(define-module (ordo interceptor debug) + #:use-module (ice-9 pretty-print) + #:use-module ((srfi srfi-1) #:select (concatenate)) + #:use-module ((srfi srfi-69) #:select (hash-table-keys)) + #:use-module (ordo interceptor) + #:export (debug-vars-interceptor)) + +(define (debug-vars-interceptor . var-names) + (interceptor + "debug-vars" + #:enter (lambda (ctx) + (let ((var-names (if (null? var-names) + (hash-table-keys (context-vars ctx)) + var-names))) + (pretty-print (map (lambda (v) (list v (var-ref ctx v 'not-found))) + var-names)))))) diff --git a/modules/ordo/interceptor/errors.scm b/modules/ordo/interceptor/errors.scm new file mode 100644 index 0000000..7dbf012 --- /dev/null +++ b/modules/ordo/interceptor/errors.scm @@ -0,0 +1,14 @@ +(define-module (ordo interceptor errors) + #:use-module (logging logger) + #:use-module (srfi srfi-26) + #:use-module (ordo interceptor) + #:export (errors-interceptor)) + +(define (errors-interceptor) + "Interceptor to log (and clear) the context error. This will allow any + earlier #:leave handlers in the chain to run normally." + (interceptor + "handle-errors" + #:error (lambda (ctx) + (and=> (context-error ctx) (cut log-msg 'ERROR <>)) + (set-context-error! ctx #f)))) diff --git a/modules/ordo/interceptor/tmp-dir.scm b/modules/ordo/interceptor/tmp-dir.scm new file mode 100644 index 0000000..f1d0acd --- /dev/null +++ b/modules/ordo/interceptor/tmp-dir.scm @@ -0,0 +1,20 @@ +(define-module (ordo interceptor tmp-dir) + #:use-module (ice-9 format) + #:use-module (ordo connection) + #:use-module (ordo interceptor) + #:export (tmp-dir-interceptor)) + +(define (tmp-dir-interceptor var-name) + (define (create-tmp-dir ctx) + (run (context-connection ctx) "mktemp" "--directory" #:check? #t #:return car)) + (define (cleanup-tmp-dir ctx) + (and=> (var-ref ctx var-name #f) + (lambda (dir-name) + (run (context-connection ctx) "rm" "-rf" dir-name))) + (var-delete! ctx var-name)) + (interceptor + (format #f "manage-tmp-dir ~a" var-name) + #:enter create-tmp-dir + #:register var-name + #:leave cleanup-tmp-dir + #:error cleanup-tmp-dir)) From 0f6744ad30b995485f42602af73be18f6fc973d3 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 25 Jan 2025 14:41:37 +0000 Subject: [PATCH 2/7] Improvements to interceptors --- examples/interceptor.scm | 36 ++--- modules/ordo/action/quadlet.scm | 41 ++++++ modules/ordo/context.scm | 152 -------------------- modules/ordo/facts.scm | 19 --- modules/ordo/facts/user.scm | 32 ----- modules/ordo/handler.scm | 25 ---- modules/ordo/interceptor.scm | 52 ++++--- modules/ordo/interceptor/create-tmp-dir.scm | 19 +++ modules/ordo/interceptor/debug.scm | 4 +- modules/ordo/interceptor/errors.scm | 14 -- modules/ordo/interceptor/install-file.scm | 28 ++++ modules/ordo/interceptor/stat-file.scm | 17 +++ modules/ordo/interceptor/tmp-dir.scm | 20 --- modules/ordo/interceptor/user-info.scm | 43 ++++++ modules/ordo/task.scm | 48 ------- 15 files changed, 203 insertions(+), 347 deletions(-) create mode 100644 modules/ordo/action/quadlet.scm delete mode 100644 modules/ordo/context.scm delete mode 100644 modules/ordo/facts.scm delete mode 100644 modules/ordo/facts/user.scm delete mode 100644 modules/ordo/handler.scm create mode 100644 modules/ordo/interceptor/create-tmp-dir.scm delete mode 100644 modules/ordo/interceptor/errors.scm create mode 100644 modules/ordo/interceptor/install-file.scm create mode 100644 modules/ordo/interceptor/stat-file.scm delete mode 100644 modules/ordo/interceptor/tmp-dir.scm create mode 100644 modules/ordo/interceptor/user-info.scm delete mode 100644 modules/ordo/task.scm diff --git a/examples/interceptor.scm b/examples/interceptor.scm index cedff3f..b0d1631 100644 --- a/examples/interceptor.scm +++ b/examples/interceptor.scm @@ -1,30 +1,32 @@ (use-modules (ice-9 filesystem) + (srfi srfi-2) + (srfi srfi-71) (logging logger) (ordo connection) (ordo interceptor) - (ordo interceptor tmp-dir) + (ordo interceptor install-file) + (ordo interceptor create-tmp-dir) + (ordo interceptor stat-file) + (ordo interceptor user-info) (ordo interceptor debug) - (ordo action filesystem) (ordo logger)) (define chain (list (connection-interceptor (local-connection)) - (tmp-dir-interceptor #:tmp-dir) - (interceptor - "install hello" - #:enter (lambda (ctx) - (fs:install-file (context-connection ctx) - (file-name-join* (var-ref ctx #:tmp-dir) "hello.txt") - #:content "Hello, world!\n")) - #:register #:hello) - (interceptor - "stat hello" - #:enter (lambda (ctx) - (fs:stat (context-connection ctx) (var-ref ctx #:hello))) - #:register #:hello-stat) - (debug-vars-interceptor #:hello #:hello-stat) - (debug-vars-interceptor))) + (create-tmp-dir #:register 'tmp-dir) + (user-info) + (debug-vars 'user-info) + (install-file + "install-hello" + #:path (let-vars (tmp-dir) (file-name-join* tmp-dir "hello.txt")) + #:content "Hello, world!\n" + #:register 'hello) + (stat-file + "stat-hello" + #:path (let-vars (hello) hello) + #:register 'hello-stat) + (debug-vars 'hello 'hello-stat))) (setup-logging #:level 'INFO) (execute (init-context) chain) diff --git a/modules/ordo/action/quadlet.scm b/modules/ordo/action/quadlet.scm new file mode 100644 index 0000000..e1d3f2e --- /dev/null +++ b/modules/ordo/action/quadlet.scm @@ -0,0 +1,41 @@ +(define-module (ordo action quadlet) + #:use-module (ice-9 filesystem) + #:use-module (ini) + #:use-module (logging logger) + #:use-module (ordo connection) + #:use-module (ordo action filesystem) + #:export (create-network-quadlet)) + +(define quadlet-dir "/etc/containers/systemd") + +(define default-install-options '(("WantedBy" . "multi-user.target default.target"))) + +(define (scm->ini-string data) + (with-output-to-string (lambda () (scm->ini data)))) + +(define (build-quadlet quadlet-type name description unit-options quadlet-options install-options) + (let* ((description (or description (string-append "Podman " (string-downcase quadlet-type) " " name))) + (data `(("Unit" ("Description" . ,description) ,@unit-options) + (,(string-titlecase quadlet-type) ,@quadlet-options) + ("Install" ,@(or install-options default-install-options))))) + (scm->ini-string data))) + +(define-syntax define-quadlet-type + (syntax-rules () + ((define-quadlet-type function-name quadlet-type suffix default-install-options) + (define* (function-name conn name #:key description (quadlet-options '()) (unit-options '()) (install-options default-install-options)) + (fs:install-file conn + (file-name-join* quadlet-dir (string-append name suffix)) + #:content (build-quadlet quadlet-type name description quadlet-options unit-options install-options)))))) + +(define-quadlet-type create-network-quadlet "Network" ".network" default-install-options) + +(define-quadlet-type create-pod-quadlet "Pod" ".pod" default-install-options) + +(define-quadlet-type create-container-quadlet "Container" ".container" default-install-options) + +(define-quadlet-type create-volume-quadlet "Volume" ".volume" '()) + +(define-quadlet-type create-build-quadlet "Build" ".build" '()) + +(define-quadlet-type create-image-quadlet "Image" ".image" '()) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm deleted file mode 100644 index 2b4dcda..0000000 --- a/modules/ordo/context.scm +++ /dev/null @@ -1,152 +0,0 @@ -(define-module (ordo context) - #:use-module (ice-9 exceptions) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-69) - #:use-module (logging logger) - #:use-module (ordo host) - #:export (init-context! - set-current-connection! - current-connection - current-host - set-current-host! - init-playbook-vars! - get-playbook-var - set-playbook-var! - reset-playbook-vars! - init-play-vars! - get-play-var - set-play-var! - reset-play-vars! - get-command-line-var - set-command-line-var! - $ - reset-play-triggers! - add-play-triggers! - play-triggered? - set-filter-tag! - reset-filter-tags! - check-filter-tags - add-host! - current-inventory)) - -(define *current-context* #f) - -(define-record-type - (make-context) - context? - (connection connection set-connection!) - (hostname hostname set-hostname!) - (command-line-vars command-line-vars set-command-line-vars!) - (play-vars play-vars set-play-vars!) - (play-triggers play-triggers set-play-triggers!) - (playbook-vars playbook-vars set-playbook-vars!) - (filter-tags filter-tags set-filter-tags!) - (inventory inventory set-inventory!)) - -(define (init-context!) - (set! *current-context* (make-context))) - -(define not-found (cons 'not-found '())) - -(define (not-found? x) (eq? x not-found)) - -(define (set-current-connection! conn) - (set-connection! *current-context* conn)) - -(define (current-connection) - (connection *current-context*)) - -(define (set-current-host! hostname) - (set-hostname! *current-context* hostname)) - -(define (current-host) - (hostname *current-context*)) - -(define (init-playbook-vars! alist) - (set-playbook-vars! *current-context* (alist->hash-table alist eqv?))) - -(define (get-playbook-var var-name) - (if (playbook-vars *current-context*) - (hash-table-ref/default (playbook-vars *current-context*) var-name not-found) - not-found)) - -(define (set-playbook-var! var-name val) - (unless (playbook-vars *current-context*) - (set-playbook-vars! *current-context* (make-hash-table eqv?))) - (hash-table-set! (playbook-vars *current-context*) var-name val)) - -(define (reset-playbook-vars!) - (set-playbook-vars! *current-context* #f)) - -(define (init-play-vars! alist) - (set-play-vars! *current-context* (alist->hash-table alist eqv?))) - -(define (get-play-var var-name) - (if (play-vars *current-context*) - (hash-table-ref/default (play-vars *current-context*) var-name not-found) - not-found)) - -(define (set-play-var! var-name val) - (unless (play-vars *current-context*) - (set-play-vars! *current-context* (make-hash-table equal?))) - (hash-table-set! (play-vars *current-context*) var-name val)) - -(define (reset-play-vars!) - (set-play-vars! *current-context* #f)) - -(define (get-command-line-var var-name) - (if (command-line-vars *current-context*) - (hash-table-ref/default (command-line-vars *current-context*) var-name not-found) - not-found)) - -(define (set-command-line-var! var-name val) - (unless (command-line-vars *current-context*) - (set-command-line-vars! *current-context* (make-hash-table eqv?))) - (hash-table-set! (command-line-vars *current-context*) var-name val)) - -(define ($ var-name) - "Try to resolve var-name as a command-line variable, a play variable or a -playbook variable (in that order). Raise an exception if the variable is not -found." - (define (lookup-var procs) - (if (null? procs) - (raise-exception (make-exception - (make-undefined-variable-error) - (make-exception-with-irritants var-name))) - (let ((v ((car procs) var-name))) - (if (not-found? v) - (lookup-var (cdr procs)) - v)))) - (lookup-var (list get-command-line-var get-play-var get-playbook-var))) - -(define (reset-play-triggers!) - (set-play-triggers! *current-context* #f)) - -(define (add-play-triggers! triggers) - (set-play-triggers! *current-context* - (apply lset-adjoin equal? (or (play-triggers *current-context*) '()) - triggers))) - -(define (play-triggered? trigger) - (and=> (play-triggers *current-context*) (cut member trigger <>))) - -(define (set-filter-tag! tag) - (set-filter-tags! *current-context* - (lset-adjoin equal? (or (filter-tags *current-context*) '()) tag))) - -(define (reset-filter-tags!) - (set-filter-tags! *current-context* #f)) - -(define (check-filter-tags tags) - (or (not (filter-tags *current-context*)) - (not (null? (lset-intersection eqv? (filter-tags *current-context*) tags))))) - -(define (current-inventory) - (or (inventory *current-context*) '())) - -(define (add-host! hostname connection . tags) - (log-msg 'DEBUG "Adding host to inventory: " hostname) - (set-inventory! *current-context* (cons (make-host hostname connection tags) - (or (inventory *current-context*) '())))) diff --git a/modules/ordo/facts.scm b/modules/ordo/facts.scm deleted file mode 100644 index 9462e7f..0000000 --- a/modules/ordo/facts.scm +++ /dev/null @@ -1,19 +0,0 @@ -(define-module (ordo facts) - #:use-module ((srfi srfi-88) #:select (string->keyword)) - #:use-module (ordo context) - #:use-module (ordo facts user) - #:export (gather-facts)) - -(define (set-facts! src keys) - (for-each (lambda (k) - (set-play-var! (string->keyword (string-append "fact." k)) - (assoc-ref src (string->keyword k)))) - keys)) - -(define (gather-facts) - (let* ((conn (current-connection)) - (id (fact:id conn)) - (user-name (assoc-ref id #:user-name)) - (pwent (fact:pwent conn user-name))) - (set-facts! id '("user-name" "user-id" "group-name" "group-id" "groups")) - (set-facts! pwent '("gecos" "home-dir" "shell")))) diff --git a/modules/ordo/facts/user.scm b/modules/ordo/facts/user.scm deleted file mode 100644 index 80ce865..0000000 --- a/modules/ordo/facts/user.scm +++ /dev/null @@ -1,32 +0,0 @@ -(define-module (ordo facts user) - #:use-module (rx irregex) - #:use-module (srfi srfi-1) - #:use-module (ordo connection) - #:export (fact:id - fact:pwent)) - -(define (parse-id-output s) - (let ((data (reverse (irregex-fold (irregex '(seq (=> id integer) "(" (=> name (+ alphanumeric)) ")")) - (lambda (_ m accum) - (cons `((#:id . ,(string->number (irregex-match-substring m 'id))) - (#:name . ,(irregex-match-substring m 'name))) - accum)) - '() - s)))) - `((#:user-id . ,(assoc-ref (first data) #:id)) - (#:user-name . ,(assoc-ref (first data) #:name)) - (#:group-id . ,(assoc-ref (second data) #:id)) - (#:group-name . ,(assoc-ref (second data) #:name)) - (#:groups . ,(drop data 2))))) - -(define (fact:id conn) - (run conn "id" #:check? #t #:return (compose parse-id-output car))) - -(define (parse-passwd-entry s) - (map cons - '(#:user-name #:password #:user-id #:group-id #:gecos #:home-dir #:shell) - (string-split s #\:))) - -(define (fact:pwent conn user-name) - (run conn "getent" "passwd" user-name - #:check? #t #:return (compose parse-passwd-entry car))) diff --git a/modules/ordo/handler.scm b/modules/ordo/handler.scm deleted file mode 100644 index 0a6ebba..0000000 --- a/modules/ordo/handler.scm +++ /dev/null @@ -1,25 +0,0 @@ -(define-module (ordo handler) - #:use-module (ice-9 match) - #:use-module (srfi srfi-9) ; records - #:use-module (logging logger) - #:use-module (ordo context) - #:export (handler - handler? - handler-name - handler-action - run-handler)) - -(define-record-type - (make-handler name action) - handler? - (name handler-name) - (action handler-action)) - -(define (handler name action) - (make-handler name action)) - -(define (run-handler h) - (match h - (($ name action) - (log-msg 'NOTICE "Running handler: " name) - (action (current-connection))))) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm index d899769..8e9036d 100644 --- a/modules/ordo/interceptor.scm +++ b/modules/ordo/interceptor.scm @@ -1,11 +1,12 @@ (define-module (ordo interceptor) #:use-module (ice-9 exceptions) #:use-module (logging logger) - #:use-module (srfi srfi-1) ; list utils - #:use-module (srfi srfi-9) ; records - #:use-module (srfi srfi-26) ; cut - #:use-module (srfi srfi-69) ; hash tables - #:use-module (srfi srfi-71) ; extended let + #:use-module (srfi srfi-1) ; list utils + #:use-module (srfi srfi-9) ; records + #:use-module (srfi srfi-26) ; cut + #:use-module (srfi srfi-69) ; hash tables + #:use-module (srfi srfi-71) ; extended let + #:use-module (srfi srfi-145) ; assume #:export (interceptor init-context context-connection @@ -18,14 +19,16 @@ var-ref var-set! var-delete! + let-vars + expand-vars terminate-when execute)) (define (check-var-name name) - (unless (keyword? name) + (unless (symbol? name) (raise-exception (make-exception (make-assertion-failure) - (make-exception-with-message "Variable name should be a keyword") + (make-exception-with-message "Variable name should be a symbol") (make-exception-with-irritants name))))) (define-record-type @@ -73,18 +76,34 @@ (log-msg 'DEBUG "Deleting variable " name) (hash-table-delete! (context-vars ctx) name)) +(define-syntax let-vars + (syntax-rules () + ((let-vars (var-name ...) expr exprs ...) + (lambda (ctx) + #((delayed-var-ref? . #t)) + (let ((var-name (hash-table-ref (context-vars ctx) 'var-name)) ...) + expr + exprs ...))))) + +(define-syntax expand-vars + (syntax-rules () + ((expand-vars ctx v ...) + (values (if (and (procedure? v) (procedure-property v 'delayed-var-ref?)) + (v ctx) + v) + ...)))) + (define-record-type - (make-interceptor name enter leave error register) + (make-interceptor name enter leave error) interceptor? (name interceptor-name) (enter interceptor-enter) (leave interceptor-leave) - (error interceptor-error) - (register interceptor-register)) + (error interceptor-error)) -(define* (interceptor name #:key enter leave error register) - "Create an interceptor with optional enter, leave, and error functions." - (make-interceptor name enter leave error register)) +(define* (interceptor name #:key enter leave error) + (assume (string? name) "interceptor name should be a string" name) + (make-interceptor name enter leave error)) (define-exception-type &interceptor-error &error make-interceptor-error @@ -120,11 +139,8 @@ (log-msg 'NOTICE "Running #:enter function for " (interceptor-name t)) (with-exception-handler (lambda (e) - (set-context-error! ctx - (make-interceptor-error (interceptor-name t) #:enter e))) - (lambda () - (let ((result (handler ctx))) - (and=> (interceptor-register t) (cut var-set! ctx <> result)))) + (set-context-error! ctx (make-interceptor-error (interceptor-name t) #:enter e))) + (lambda () (handler ctx)) #:unwind? #t)))) (define (try-leave ctx t) diff --git a/modules/ordo/interceptor/create-tmp-dir.scm b/modules/ordo/interceptor/create-tmp-dir.scm new file mode 100644 index 0000000..b35cf49 --- /dev/null +++ b/modules/ordo/interceptor/create-tmp-dir.scm @@ -0,0 +1,19 @@ +(define-module (ordo interceptor create-tmp-dir) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo action filesystem) + #:export (create-tmp-dir)) + +(define* (create-tmp-dir #:key (register 'tmp-dir)) + (assume (symbol? register) "register should be a symbol" register) + (define (cleanup ctx) + (and-let* ((tmp-dir (var-ref ctx register))) + (fs:remove (context-connection ctx) tmp-dir #:recurse? #t) + (var-delete! ctx register))) + (interceptor + (format #f "create-tmp-dir ~a" register) + #:enter (lambda (ctx) + (var-set! ctx register (fs:create-tmp-dir (context-connection ctx)))) + #:leave cleanup + #:error cleanup)) diff --git a/modules/ordo/interceptor/debug.scm b/modules/ordo/interceptor/debug.scm index ca4707a..025f9b8 100644 --- a/modules/ordo/interceptor/debug.scm +++ b/modules/ordo/interceptor/debug.scm @@ -3,9 +3,9 @@ #:use-module ((srfi srfi-1) #:select (concatenate)) #:use-module ((srfi srfi-69) #:select (hash-table-keys)) #:use-module (ordo interceptor) - #:export (debug-vars-interceptor)) + #:export (debug-vars)) -(define (debug-vars-interceptor . var-names) +(define (debug-vars . var-names) (interceptor "debug-vars" #:enter (lambda (ctx) diff --git a/modules/ordo/interceptor/errors.scm b/modules/ordo/interceptor/errors.scm deleted file mode 100644 index 7dbf012..0000000 --- a/modules/ordo/interceptor/errors.scm +++ /dev/null @@ -1,14 +0,0 @@ -(define-module (ordo interceptor errors) - #:use-module (logging logger) - #:use-module (srfi srfi-26) - #:use-module (ordo interceptor) - #:export (errors-interceptor)) - -(define (errors-interceptor) - "Interceptor to log (and clear) the context error. This will allow any - earlier #:leave handlers in the chain to run normally." - (interceptor - "handle-errors" - #:error (lambda (ctx) - (and=> (context-error ctx) (cut log-msg 'ERROR <>)) - (set-context-error! ctx #f)))) diff --git a/modules/ordo/interceptor/install-file.scm b/modules/ordo/interceptor/install-file.scm new file mode 100644 index 0000000..3732fa2 --- /dev/null +++ b/modules/ordo/interceptor/install-file.scm @@ -0,0 +1,28 @@ +(define-module (ordo interceptor install-file) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo action filesystem) + #:export (install-file)) + +(define* (install-file name #:key path owner group mode content + local-src remote-src backup? register) + (assume path "install path is required") + (assume (or (not register) (symbol? register)) "register should be a symbol" register) + (assume (= 1 (length (filter identity (list content local-src remote-src)))) + "exactly one of content, local-src, or remote-src is required") + (interceptor + name + #:enter (lambda (ctx) + (let ((path (expand-vars ctx path))) + (fs:install-file (context-connection ctx) + path + #:owner (expand-vars ctx owner) + #:group (expand-vars ctx group) + #:mode (expand-vars ctx mode) + #:content (expand-vars ctx content) + #:local-src (expand-vars ctx local-src) + #:remote-src (expand-vars ctx remote-src) + #:backup? (expand-vars ctx backup?)) + (when register + (var-set! ctx register path)))))) diff --git a/modules/ordo/interceptor/stat-file.scm b/modules/ordo/interceptor/stat-file.scm new file mode 100644 index 0000000..42b4668 --- /dev/null +++ b/modules/ordo/interceptor/stat-file.scm @@ -0,0 +1,17 @@ +(define-module (ordo interceptor stat-file) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo action filesystem) + #:export (stat-file)) + +(define* (stat-file name #:key path register) + (assume (string? name) "name is required and should be a string" name) + (assume path "path is required" path) + (assume (or (not register) (symbol? register)) "register should be a symbol" register) + (interceptor + name + #:enter (lambda (ctx) + (let* ((path (expand-vars ctx path)) + (st (fs:stat (context-connection ctx) path))) + (when register + (var-set! ctx register st)))))) diff --git a/modules/ordo/interceptor/tmp-dir.scm b/modules/ordo/interceptor/tmp-dir.scm deleted file mode 100644 index f1d0acd..0000000 --- a/modules/ordo/interceptor/tmp-dir.scm +++ /dev/null @@ -1,20 +0,0 @@ -(define-module (ordo interceptor tmp-dir) - #:use-module (ice-9 format) - #:use-module (ordo connection) - #:use-module (ordo interceptor) - #:export (tmp-dir-interceptor)) - -(define (tmp-dir-interceptor var-name) - (define (create-tmp-dir ctx) - (run (context-connection ctx) "mktemp" "--directory" #:check? #t #:return car)) - (define (cleanup-tmp-dir ctx) - (and=> (var-ref ctx var-name #f) - (lambda (dir-name) - (run (context-connection ctx) "rm" "-rf" dir-name))) - (var-delete! ctx var-name)) - (interceptor - (format #f "manage-tmp-dir ~a" var-name) - #:enter create-tmp-dir - #:register var-name - #:leave cleanup-tmp-dir - #:error cleanup-tmp-dir)) diff --git a/modules/ordo/interceptor/user-info.scm b/modules/ordo/interceptor/user-info.scm new file mode 100644 index 0000000..987d1b8 --- /dev/null +++ b/modules/ordo/interceptor/user-info.scm @@ -0,0 +1,43 @@ +(define-module (ordo interceptor user-info) + #:use-module (rx irregex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-145) + #:use-module (ordo connection) + #:use-module (ordo interceptor) + #:export (user-info)) + +(define (parse-id s) + (let ((data (reverse (irregex-fold (irregex '(seq (=> id integer) "(" (=> name (+ alphanumeric)) ")")) + (lambda (_ m accum) + (cons `((#:id . ,(string->number (irregex-match-substring m 'id))) + (#:name . ,(irregex-match-substring m 'name))) + accum)) + '() + s)))) + `((#:user-id . ,(assoc-ref (first data) #:id)) + (#:user-name . ,(assoc-ref (first data) #:name)) + (#:group-id . ,(assoc-ref (second data) #:id)) + (#:group-name . ,(assoc-ref (second data) #:name)) + (#:groups . ,(drop data 2))))) + +(define (parse-passwd-entry s) + (map cons + '(#:user-name #:password #:user-id #:group-id #:gecos #:home-dir #:shell) + (string-split s #\:))) + +(define* (user-info #:key (register 'user-info)) + (assume (symbol? register) "register should be a symbol" register) + (interceptor + "user-info" + #:enter (lambda (ctx) + (let* ((conn (context-connection ctx)) + (id (run conn "id" + #:check? #t #:return (compose parse-id car))) + (pwent (run conn "getent" "passwd" (assoc-ref id #:user-name) + #:check? #t #:return (compose parse-passwd-entry car)))) + (var-set! ctx register (fold (lambda (key alist) + (acons key (assoc-ref pwent key) alist)) + id + (list #:gecos #:home-dir #:shell))))) + #:leave (lambda (ctx) (var-delete! ctx register)) + #:error (lambda (ctx) (var-delete! ctx register)))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm deleted file mode 100644 index 0b62d8d..0000000 --- a/modules/ordo/task.scm +++ /dev/null @@ -1,48 +0,0 @@ -(define-module (ordo task) - #:use-module (srfi srfi-9) - #:use-module (logging logger) - #:use-module (ordo context) - #:export (task - task? - task-name - task-tags - task-action - task-condition - task-register-play-var - task-register-playbook-var - task-triggers - run-task)) - -(define-record-type - (make-task name tags action condition register-play-var register-playbook-var triggers) - task? - (name task-name) - (tags task-tags) - (action task-action) - (condition task-condition) - (register-play-var task-register-play-var) - (register-playbook-var task-register-playbook-var) - (triggers task-triggers)) - -(define* (%task name action #:key (tags '()) (condition (const #t)) (register-play-var #f) (register-playbook-var #f) (triggers '())) - (make-task name tags action condition register-play-var register-playbook-var triggers)) - -(define-syntax task - (syntax-rules () - ((task (f args ...) kwargs ...) - (%task (symbol->string 'f) (lambda () (f args ...) kwargs ...))) - ((task name (f args ...) kwargs ...) - (%task name (lambda () (f args ...)) kwargs ...)))) - -(define (run-task t) - (when (check-filter-tags (task-tags t)) - (if (not ((task-condition t))) - (log-msg 'NOTICE "Skipping task: " (task-name t) " (precondition not met)") - (begin - (log-msg 'NOTICE "Running task: " (task-name t)) - (let ((result ((task-action t)))) - (when (task-register-play-var t) - (set-play-var! (task-register-play-var t) result)) - (when (task-register-playbook-var t) - (set-playbook-var! (task-register-playbook-var t) result)) - (add-play-triggers! (task-triggers t))))))) From d79dbaddedfe42b1b1c30c74c8249eff9c8dfaf1 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 25 Jan 2025 15:46:12 +0000 Subject: [PATCH 3/7] Update modules to work with interceptors --- bin/ordo.sh | 5 ++ bin/play.scm | 43 ---------------- examples/interceptor.scm | 48 +++++++++--------- examples/inventory.scm | 3 +- modules/ordo.scm | 10 ---- modules/ordo/cli.scm | 18 ++++--- modules/ordo/condition.scm | 9 ++-- modules/ordo/connection.scm | 21 ++------ modules/ordo/interceptor.scm | 8 ++- modules/ordo/interceptor/connection.scm | 22 +++++++++ modules/ordo/interceptor/user-info.scm | 3 +- modules/ordo/{host.scm => inventory.scm} | 23 ++++++--- modules/ordo/play.scm | 62 ++++++++---------------- modules/ordo/playbook.scm | 13 ++--- 14 files changed, 115 insertions(+), 173 deletions(-) create mode 100755 bin/ordo.sh delete mode 100755 bin/play.scm delete mode 100644 modules/ordo.scm create mode 100644 modules/ordo/interceptor/connection.scm rename modules/ordo/{host.scm => inventory.scm} (65%) diff --git a/bin/ordo.sh b/bin/ordo.sh new file mode 100755 index 0000000..9ecc787 --- /dev/null +++ b/bin/ordo.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +MODULES_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )/../modules" &> /dev/null && pwd ) + +exec guile -L "${MODULES_DIR}" --no-auto-compile -e '(@ (ordo cli) main)' -- "$@" diff --git a/bin/play.scm b/bin/play.scm deleted file mode 100755 index 103e6c7..0000000 --- a/bin/play.scm +++ /dev/null @@ -1,43 +0,0 @@ -#!/usr/bin/env -S guile --no-auto-compile -e main -s -!# -(use-modules (srfi srfi-11) - (ice-9 getopt-long) - (ice-9 format) - (ordo util filesystem)) - -(define (tar . args) - (unless (zero? (apply system* "tar" args)) - (error (format #f "Non-zero exit from tar ~a" args)))) - -(define* (usage #:optional errmsg) - (with-output-to-port (current-error-port) - (lambda () - (when errmsg - (format #t "Error: ~a~%~%" errmsg)) - (display "Usage: play -t TARGET PLAYBOOK") - (newline))) - (exit (if errmsg EXIT_FAILURE EXIT_SUCCESS))) - -(define (process-options args) - (let* ((option-spec '((help (single-char #\h) (value #f)) - (target (single-char #\t) (value #t) (required? #t)))) - (options (getopt-long args option-spec)) - (help-wanted (option-ref options 'help #f)) - (target (option-ref options 'target #f)) - (args (option-ref options '() '()))) - (cond - (help-wanted (usage)) - ((not (= 1 (length args))) - (usage "Expected exactly one playbook"))) - (values (canonicalize-path (car args)) target))) - -(define (main args) - (let-values (((playbook-path target) (process-options args))) - (define playbook (load playbook-path)) - (define top-dir (dirname (dirname (current-filename)))) - (call-with-temporary-directory - (lambda (tmp-dir) - (define tarball (string-append tmp-dir "/payload.tar")) - (tar "--create" "--file" tarball "--directory" top-dir "modules" "bin") - (tar "--append" "--file" tarball "--transform" "s/.*/playbook.scm/" playbook-path) - (tar "tf" tarball))))) diff --git a/examples/interceptor.scm b/examples/interceptor.scm index b0d1631..d01ec6f 100644 --- a/examples/interceptor.scm +++ b/examples/interceptor.scm @@ -1,33 +1,31 @@ (use-modules (ice-9 filesystem) - (srfi srfi-2) - (srfi srfi-71) - (logging logger) - (ordo connection) + (ordo playbook) + (ordo play) (ordo interceptor) (ordo interceptor install-file) (ordo interceptor create-tmp-dir) (ordo interceptor stat-file) (ordo interceptor user-info) - (ordo interceptor debug) - (ordo logger)) + (ordo interceptor debug)) -(define chain - (list (connection-interceptor (local-connection)) - (create-tmp-dir #:register 'tmp-dir) - (user-info) - (debug-vars 'user-info) - (install-file - "install-hello" - #:path (let-vars (tmp-dir) (file-name-join* tmp-dir "hello.txt")) - #:content "Hello, world!\n" - #:register 'hello) - (stat-file - "stat-hello" - #:path (let-vars (hello) hello) - #:register 'hello-stat) - (debug-vars 'hello 'hello-stat))) - -(setup-logging #:level 'INFO) -(execute (init-context) chain) -(shutdown-logging) +(playbook + #:name "Test some basic filesystem operations" + #:vars '((file-content . "This is shadowed by the play variable.")) + #:plays (list (play + #:name "Basic filesystem operations" + #:host "localhost" + #:vars '((file-content . "Hello, world!\n")) + #:interceptors (list (create-tmp-dir #:register 'tmp-dir) + (user-info) + (debug-vars 'user-info) + (install-file + "install-hello" + #:path (let-vars (tmp-dir) (file-name-join* tmp-dir "hello.txt")) + #:content (let-vars (file-content) file-content) + #:register 'hello) + (stat-file + "stat-hello" + #:path (let-vars (hello) hello) + #:register 'hello-stat) + (debug-vars))))) diff --git a/examples/inventory.scm b/examples/inventory.scm index 01c0a25..00bee3e 100644 --- a/examples/inventory.scm +++ b/examples/inventory.scm @@ -1,4 +1,5 @@ -(use-modules (ordo)) +(use-modules (ordo inventory) + (ordo connection)) (add-host! "little-rascal" (local-connection) diff --git a/modules/ordo.scm b/modules/ordo.scm deleted file mode 100644 index 7c3741f..0000000 --- a/modules/ordo.scm +++ /dev/null @@ -1,10 +0,0 @@ -(define-module (ordo) - #:use-module (ice-9 match) - #:use-module (ordo playbook) - #:use-module (ordo play) - #:use-module (ordo task) - #:use-module (ordo handler) - #:use-module (ordo connection) - #:use-module (ordo context) - #:use-module (ordo logger) - #:re-export (add-host! local-connection ssh-connection current-connection run playbook play task handler $)) diff --git a/modules/ordo/cli.scm b/modules/ordo/cli.scm index 519e3f1..0038916 100644 --- a/modules/ordo/cli.scm +++ b/modules/ordo/cli.scm @@ -1,16 +1,20 @@ (define-module (ordo cli) + #:use-module (ice-9 filesystem) #:use-module (ice-9 match) + #:use-module (logging logger) #:use-module (ordo logger) - #:use-module (ordo context) #:use-module (ordo playbook) #:declarative? #f #:export (main)) (define (main args) (match-let (((_ inventory-path playbook-path) args)) - (setup-logging #:level 'DEBUG) - (init-context!) - (load inventory-path) - (let ((playbook (load playbook-path))) - (run-playbook playbook)) - (quit))) + (let ((inventory-path (expand-file-name inventory-path)) + (playbook-path (expand-file-name playbook-path))) + (setup-logging #:level 'INFO) + (load inventory-path) + (log-msg 'DEBUG "Loaded inventory: " inventory-path) + (let ((playbook (load playbook-path))) + (log-msg 'DEBUG "Loaded playbook: " playbook-path) + (run-playbook playbook)) + (quit)))) diff --git a/modules/ordo/condition.scm b/modules/ordo/condition.scm index 4834ab6..11e559c 100644 --- a/modules/ordo/condition.scm +++ b/modules/ordo/condition.scm @@ -1,6 +1,7 @@ (define-module (ordo condition) #:use-module (srfi srfi-71) - #:use-module (ordo context) + #:use-module (ordo connection) + #:use-module (ordo interceptor) #:use-module (ordo action filesystem)) (define-public (cond:any preds) @@ -25,15 +26,15 @@ (define-public (cond:command-available? cmd-name) (lambda (ctx) - (let ((_ rc (run "which" `(,cmd-name)))) + (let ((_ rc (run (context-connection ctx) "which" cmd-name))) (zero? rc)))) (define-public (cond:directory? path) (lambda (ctx) - (let ((st ((action:stat path) ctx))) + (let ((st (fs:stat (context-connection ctx) path))) (and st (string=? "directory" (assoc-ref st 'file-type)))))) (define-public (cond:regular-file? path) (lambda (ctx) - (let ((st ((action:stat path) ctx))) + (let ((st (fs:stat (context-connection ctx) path))) (and st (string=? "regular-file" (assoc-ref st 'file-type)))))) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 2e4c9b7..d5e3223 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -9,16 +9,15 @@ #:use-module (ordo connection local) #:use-module (ordo connection ssh) #:use-module (ordo connection sudo) - #:use-module (ordo interceptor) #:use-module (ordo util flatten) #:use-module (ordo util shell-quote) #:use-module (ordo util keyword-args) - #:export (connection-interceptor - connection? + #:export (connection? local-connection ssh-connection call-with-connection - run)) + run) + #:re-export (conn:setup conn:teardown)) (define (connection? c) (is-a? c )) @@ -68,17 +67,3 @@ (make-external-error) (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog))))) (values (return out) rc))))) - -(define* (connection-interceptor c #:key sudo? sudo-user sudo-password) - "Interceptor to manage the current connection." - (interceptor - "manage-connection" - #:enter (lambda (ctx) - (let ((c (if sudo? - (make #:connection c #:become-user sudo-user #:become-password sudo-password) - c))) - (conn:setup c) - (set-context-connection! ctx c))) - #:leave (lambda (ctx) - (and=> (context-connection ctx) conn:teardown) - (set-context-connection! ctx #f)))) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm index 8e9036d..af3a4ec 100644 --- a/modules/ordo/interceptor.scm +++ b/modules/ordo/interceptor.scm @@ -32,7 +32,7 @@ (make-exception-with-irritants name))))) (define-record-type - (make-context connection vars stack queue terminators error suppressed) + (make-context vars stack queue terminators error suppressed) context? (connection context-connection set-context-connection!) (vars context-vars set-context-vars!) @@ -42,14 +42,12 @@ (error context-error set-context-error!) (suppressed context-suppressed set-context-suppressed!)) -(define* (init-context #:key conn (vars '())) +(define* (init-context #:key (vars '())) "Initialize a context with optional connection and vars." (for-each check-var-name (map car vars)) (make-context - ;; connection - conn ;; vars - (alist->hash-table vars equal?) + (alist->hash-table vars eqv?) ;; stack '() ;; queue diff --git a/modules/ordo/interceptor/connection.scm b/modules/ordo/interceptor/connection.scm new file mode 100644 index 0000000..5b80078 --- /dev/null +++ b/modules/ordo/interceptor/connection.scm @@ -0,0 +1,22 @@ +(define-module (ordo interceptor connection) + #:use-module (oop goops) + #:use-module (ordo interceptor) + #:use-module (ordo connection) + #:use-module (ordo connection sudo) + #:export (connection)) + +(define* (connection c #:key sudo? sudo-user sudo-password) + "Interceptor to manage the current connection." + (define (cleanup ctx) + (and=> (context-connection ctx) conn:teardown) + (set-context-connection! ctx #f)) + (interceptor + "connection" + #:enter (lambda (ctx) + (let ((c (if sudo? + (make #:connection c #:become-user sudo-user #:become-password sudo-password) + c))) + (conn:setup c) + (set-context-connection! ctx c))) + #:leave cleanup + #:error cleanup)) diff --git a/modules/ordo/interceptor/user-info.scm b/modules/ordo/interceptor/user-info.scm index 987d1b8..291e5c7 100644 --- a/modules/ordo/interceptor/user-info.scm +++ b/modules/ordo/interceptor/user-info.scm @@ -4,6 +4,7 @@ #:use-module (srfi srfi-145) #:use-module (ordo connection) #:use-module (ordo interceptor) + #:use-module (ordo util shell-quote) #:export (user-info)) (define (parse-id s) @@ -33,7 +34,7 @@ (let* ((conn (context-connection ctx)) (id (run conn "id" #:check? #t #:return (compose parse-id car))) - (pwent (run conn "getent" "passwd" (assoc-ref id #:user-name) + (pwent (run conn "getent" "passwd" (string-shell-quote (assoc-ref id #:user-name)) #:check? #t #:return (compose parse-passwd-entry car)))) (var-set! ctx register (fold (lambda (key alist) (acons key (assoc-ref pwent key) alist)) diff --git a/modules/ordo/host.scm b/modules/ordo/inventory.scm similarity index 65% rename from modules/ordo/host.scm rename to modules/ordo/inventory.scm index fa19045..37294f2 100644 --- a/modules/ordo/host.scm +++ b/modules/ordo/inventory.scm @@ -1,15 +1,18 @@ -(define-module (ordo host) +(define-module (ordo inventory) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) - #:use-module (ordo connection) + #:use-module ((ordo connection) #:select (local-connection)) #:export (make-host host? host-name host-connection host-tags + add-host! resolve-hosts)) +(define *inventory* '()) + (define-record-type (make-host name connection tags) host? @@ -17,6 +20,10 @@ (connection host-connection) (tags host-tags)) +(define (add-host! name connection . tags) + (set! *inventory* (cons (make-host name connection tags) + *inventory*))) + (define (tagged-all? wanted-tags) (lambda (h) (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) @@ -29,11 +36,11 @@ (lambda (h) (string=? (host-name h) hostname))) -(define (resolve-hosts inventory) +(define resolve-hosts (match-lambda - ("localhost" (list (or (find (named? "localhost") inventory) + ("localhost" (list (or (find (named? "localhost") *inventory*) (make-host "localhost" (local-connection) '())))) - ((? string? hostname) (filter (named? hostname) inventory)) - ('all inventory) - (('every-tag tag . tags) (filter (tagged-all? (cons tag tags)) inventory)) - (('any-tag tag . tags) (filter (tagged-any? (cons tag tags)) inventory)))) + ((? string? hostname) (filter (named? hostname) *inventory*)) + ('all *inventory*) + (('every-tag tag . tags) (filter (tagged-all? (cons tag tags)) *inventory*)) + (('any-tag tag . tags) (filter (tagged-any? (cons tag tags)) *inventory*)))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index 8586425..669027a 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -3,12 +3,10 @@ #:use-module (srfi srfi-26) #:use-module (logging logger) #:use-module (ordo connection) - #:use-module (ordo context) - #:use-module (ordo task) - #:use-module (ordo handler) - #:use-module (ordo context) - #:use-module (ordo host) - #:use-module (ordo facts) + #:use-module (ordo interceptor) + #:use-module (ordo interceptor connection) + #:use-module (ordo inventory) + #:use-module (ordo util flatten) #:export (play play? play-host @@ -16,13 +14,11 @@ play-sudo-user play-sudo-password play-vars - play-tasks - play-handlers - play-gather-facts + play-interceptors run-play)) (define-record-type - (make-play name host sudo? sudo-user sudo-password vars gather-facts tasks handlers) + (make-play name host sudo? sudo-user sudo-password vars interceptors) play? (name play-name) (host play-host) @@ -30,42 +26,24 @@ (sudo-user play-sudo-user) (sudo-password play-sudo-password) (vars play-vars) - (tasks play-tasks) - (handlers play-handlers) - (gather-facts play-gather-facts)) + (interceptors play-interceptors)) -(define* (play name #:key host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (gather-facts #t) . more) - (let ((tasks (filter task? more)) - (handlers (filter handler? more))) - (make-play name host sudo? sudo-user sudo-password vars gather-facts tasks handlers))) +(define* (play #:key name host (sudo? #f) (sudo-user #f) (sudo-password #f) (vars '()) (interceptors '())) + (make-play name host sudo? sudo-user sudo-password vars interceptors)) -(define (run-play p) +(define (run-play p playbook-vars) (log-msg 'NOTICE "Running play: " (play-name p)) - (let ((hosts ((resolve-hosts (current-inventory)) (play-host p)))) + (let ((hosts (resolve-hosts (play-host p)))) (if (null? hosts) (log-msg 'WARN "No hosts matched: " (play-host p)) - (for-each (lambda (h) (run-host-play p h)) hosts)))) + (for-each (lambda (h) (run-host-play p h playbook-vars)) hosts)))) -(define (run-host-play p h) +(define (run-host-play p h playbook-vars) (log-msg 'NOTICE "Running play: " (play-name p) " on host: " (host-name h)) - (call-with-connection - (host-connection h) - (play-sudo? p) - (play-sudo-user p) - (play-sudo-password p) - (lambda (conn) - (dynamic-wind - (lambda () - (set-current-connection! conn) - (set-current-host! (host-name h)) - (init-play-vars! (play-vars p))) - (lambda () - (when (play-gather-facts p) (gather-facts)) - (for-each run-task (play-tasks p)) - (for-each run-handler - (filter (compose play-triggered? handler-name) (play-handlers p)))) - (lambda () - (set-current-connection! #f) - (set-current-host! #f) - (reset-play-vars!) - (reset-play-triggers!)))))) + (let ((chain (flatten (cons (connection (host-connection h) + #:sudo? (play-sudo? p) + #:sudo-user (play-sudo-user p) + #:sudo-password (play-sudo-password p)) + (play-interceptors p)))) + (ctx (init-context #:vars (append (play-vars p) playbook-vars)))) + (execute ctx chain))) diff --git a/modules/ordo/playbook.scm b/modules/ordo/playbook.scm index b8a1169..414efbc 100644 --- a/modules/ordo/playbook.scm +++ b/modules/ordo/playbook.scm @@ -1,8 +1,8 @@ (define-module (ordo playbook) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) #:use-module (logging logger) #:use-module (ordo play) - #:use-module (ordo context) #:export (playbook playbook? playbook-name @@ -17,15 +17,10 @@ (vars playbook-vars) (plays playbook-plays)) -(define* (playbook name #:key (vars '()) . plays) +(define* (playbook #:key name (vars '()) plays) (make-playbook name vars plays)) (define (run-playbook pb) (log-msg 'NOTICE "Running playbook: " (playbook-name pb)) - (dynamic-wind - (lambda () - (init-playbook-vars! (playbook-vars pb))) - (lambda () - (for-each run-play (playbook-plays pb))) - (lambda () - (reset-playbook-vars!)))) + (for-each (cut run-play <> (playbook-vars pb)) + (playbook-plays pb))) From 7cf4e5a4dfc9626b914e70dcc52d98a9dda05b77 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sat, 25 Jan 2025 18:05:52 +0000 Subject: [PATCH 4/7] Implement install-aws-cli as an interceptor chain --- examples/install-aws-cli.scm | 84 ++++++++++++++----- modules/ordo/interceptor/require-commands.scm | 28 +++++++ 2 files changed, 89 insertions(+), 23 deletions(-) create mode 100644 modules/ordo/interceptor/require-commands.scm diff --git a/examples/install-aws-cli.scm b/examples/install-aws-cli.scm index 15ea839..58df289 100644 --- a/examples/install-aws-cli.scm +++ b/examples/install-aws-cli.scm @@ -1,28 +1,66 @@ (use-modules (ice-9 filesystem) - (ordo)) + (srfi srfi-71) + (ordo playbook) + (ordo play) + (ordo interceptor) + (ordo connection) + (ordo interceptor create-tmp-dir) + (ordo interceptor require-commands) + (ordo interceptor user-info) + (ordo util flatten)) + +;; TODO: this should be in (ordo interceptor download) and it needs arg validation +(define* (download name #:key url target-dir register) + (interceptor + name + #:enter (lambda (ctx) + (let* ((url target-dir (expand-vars ctx url target-dir)) + (file-name (file-name-join* target-dir (file-basename url)))) + (run (context-connection ctx) "wget" "-O" file-name url #:check? #t) + (when register + (var-set! ctx register file-name)))) + #:leave (lambda (ctx) (when register (var-delete! ctx register))) + #:error (lambda (ctx) (when register (var-delete! ctx register))))) + +;; TODO: this should be in (ordo interceptor unzip) and it needs arg validation +(define* (unzip name #:key file-name target-dir) + (interceptor + name + #:enter (lambda (ctx) + (let ((file-name target-dir (expand-vars ctx file-name target-dir))) + (run (context-connection ctx) "unzip" file-name "-d" target-dir #:check? #t))))) + +;; TODO: this should be in (ordo interceptor command) +;; Maybe it could expose more of the run functionality? +(define (command name prog . args) + (interceptor + name + #:enter (lambda (ctx) + (run (context-connection ctx) + (expand-vars ctx prog) + (map (lambda (a) (expand-vars ctx a)) (flatten args)) + #:check? #t)))) (define* (install-aws-cli #:key (url "https://awscli.amazonaws.com/awscli-exe-linux-x86_64.zip") update? install-dir bin-dir) - (let* ((conn (current-connection)) - (tmp-dir (run conn "mktemp" "-d" #:return car #:check? #t))) - (dynamic-wind - (const #t) - (lambda () - (let ((zipfile (file-name-join* tmp-dir (file-basename url)))) - (run conn "wget" "-O" zipfile url #:check? #t) - (run conn "unzip" zipfile "-d" tmp-dir #:check? #t) - (run conn (file-name-join* tmp-dir "aws" "install") - (when install-dir `("-i" ,install-dir)) - (when bin-dir `("-b" ,bin-dir)) - (when update? "-u") - #:check? #t))) - (lambda () - (run conn "rm" "-rf" tmp-dir))))) + (list (require-commands "wget" "unzip") + (create-tmp-dir #:register 'aws-cli-tmp) + (download "download-aws-cli" #:url url #:target-dir (let-vars (aws-cli-tmp) aws-cli-tmp) #:register 'aws-cli-zipfile) + (unzip "extract-aws-cli" #:file-name (let-vars (aws-cli-zipfile) aws-cli-zipfile) #:target-dir (let-vars (aws-cli-tmp) aws-cli-tmp)) + (command "run-aws-cli-installer" + (let-vars (aws-cli-tmp) (file-name-join* aws-cli-tmp "aws" "install")) + (when install-dir `("-i" ,install-dir)) + (when bin-dir `("-b" ,bin-dir)) + (when update? "-u")))) -(playbook "Test Playbook" - (play "Test play" - #:host "localhost" - (task - (install-aws-cli #:update? #t - #:install-dir (file-name-join* ($ #:fact.home-dir) ".local" "aws-cli") - #:bin-dir (file-name-join* ($ #:fact.home-dir) ".local" "bin"))))) +(playbook + #:name "Test Playbook" + #:plays (list + (play + #:name "Install AWS CLI" + #:host "localhost" + #:interceptors (list + (user-info) + (install-aws-cli #:update? #t + #:install-dir (let-vars (user-info) (file-name-join* (assoc-ref user-info #:home-dir) ".local" "aws-cli")) + #:bin-dir (let-vars (user-info) (file-name-join* (assoc-ref user-info #:home-dir) ".local" "bin"))))))) diff --git a/modules/ordo/interceptor/require-commands.scm b/modules/ordo/interceptor/require-commands.scm new file mode 100644 index 0000000..f31586c --- /dev/null +++ b/modules/ordo/interceptor/require-commands.scm @@ -0,0 +1,28 @@ +(define-module (ordo interceptor require-commands) + #:use-module (ice-9 exceptions) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo connection) + #:export (require-commands)) + +(define-exception-type &missing-command-error &external-error + make-missing-command-error + missing-command-error? + (command-name missing-command-error-command-name)) + +(define (require-commands . commands) + (assume (every string? commands) "commands should be strings" commands) + (interceptor + (string-append "require-commands " (string-join commands ",")) + #:enter (lambda (ctx) + (for-each (lambda (cmd) + (let ((out rc (run (context-connection ctx) "which" cmd))) + (unless (zero? rc) + (if (string-contains (car out) (format #f "which: no ~a in" cmd)) + (raise-exception (make-missing-command-error cmd)) + (raise-exception (make-exception + (make-external-error) + (make-exception-with-message (string-append "error running which: " (car out))))))))) + commands)))) From dd885ce55928f3666747ab65d2064cde35a2632a Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 26 Jan 2025 14:02:19 +0000 Subject: [PATCH 5/7] Tidy up the AWS CLI interceptor example. --- examples/install-aws-cli.scm | 53 +++++++-------------------- examples/interceptor.scm | 7 +++- modules/ordo/interceptor.scm | 15 ++++++-- modules/ordo/interceptor/command.scm | 22 +++++++++++ modules/ordo/interceptor/download.scm | 22 +++++++++++ modules/ordo/interceptor/unzip.scm | 16 ++++++++ 6 files changed, 90 insertions(+), 45 deletions(-) create mode 100644 modules/ordo/interceptor/command.scm create mode 100644 modules/ordo/interceptor/download.scm create mode 100644 modules/ordo/interceptor/unzip.scm diff --git a/examples/install-aws-cli.scm b/examples/install-aws-cli.scm index 58df289..8ced506 100644 --- a/examples/install-aws-cli.scm +++ b/examples/install-aws-cli.scm @@ -8,50 +8,25 @@ (ordo interceptor create-tmp-dir) (ordo interceptor require-commands) (ordo interceptor user-info) - (ordo util flatten)) - -;; TODO: this should be in (ordo interceptor download) and it needs arg validation -(define* (download name #:key url target-dir register) - (interceptor - name - #:enter (lambda (ctx) - (let* ((url target-dir (expand-vars ctx url target-dir)) - (file-name (file-name-join* target-dir (file-basename url)))) - (run (context-connection ctx) "wget" "-O" file-name url #:check? #t) - (when register - (var-set! ctx register file-name)))) - #:leave (lambda (ctx) (when register (var-delete! ctx register))) - #:error (lambda (ctx) (when register (var-delete! ctx register))))) - -;; TODO: this should be in (ordo interceptor unzip) and it needs arg validation -(define* (unzip name #:key file-name target-dir) - (interceptor - name - #:enter (lambda (ctx) - (let ((file-name target-dir (expand-vars ctx file-name target-dir))) - (run (context-connection ctx) "unzip" file-name "-d" target-dir #:check? #t))))) - -;; TODO: this should be in (ordo interceptor command) -;; Maybe it could expose more of the run functionality? -(define (command name prog . args) - (interceptor - name - #:enter (lambda (ctx) - (run (context-connection ctx) - (expand-vars ctx prog) - (map (lambda (a) (expand-vars ctx a)) (flatten args)) - #:check? #t)))) + (ordo interceptor download) + (ordo interceptor unzip) + (ordo interceptor command)) +;; This example shows that a function can act a bit like an ansible role by +;; returning a list of interceptors to be added to the caller's interceptor +;; chain. (The list will be flattened to construct the final chain.) (define* (install-aws-cli #:key (url "https://awscli.amazonaws.com/awscli-exe-linux-x86_64.zip") update? install-dir bin-dir) (list (require-commands "wget" "unzip") (create-tmp-dir #:register 'aws-cli-tmp) - (download "download-aws-cli" #:url url #:target-dir (let-vars (aws-cli-tmp) aws-cli-tmp) #:register 'aws-cli-zipfile) - (unzip "extract-aws-cli" #:file-name (let-vars (aws-cli-zipfile) aws-cli-zipfile) #:target-dir (let-vars (aws-cli-tmp) aws-cli-tmp)) + (download "download-aws-cli" #:url url #:target-dir (var aws-cli-tmp) #:register 'aws-cli-zipfile) + (unzip "extract-aws-cli" #:file-name (var aws-cli-zipfile) #:target-dir (var aws-cli-tmp)) (command "run-aws-cli-installer" - (let-vars (aws-cli-tmp) (file-name-join* aws-cli-tmp "aws" "install")) - (when install-dir `("-i" ,install-dir)) - (when bin-dir `("-b" ,bin-dir)) - (when update? "-u")))) + (list + (let-vars (aws-cli-tmp) (file-name-join* aws-cli-tmp "aws" "install")) + (when install-dir `("-i" ,install-dir)) + (when bin-dir `("-b" ,bin-dir)) + (when update? "-u") + #:check? #t)))) (playbook #:name "Test Playbook" diff --git a/examples/interceptor.scm b/examples/interceptor.scm index d01ec6f..92018a2 100644 --- a/examples/interceptor.scm +++ b/examples/interceptor.scm @@ -7,6 +7,7 @@ (ordo interceptor create-tmp-dir) (ordo interceptor stat-file) (ordo interceptor user-info) + (ordo interceptor command) (ordo interceptor debug)) (playbook @@ -22,10 +23,12 @@ (install-file "install-hello" #:path (let-vars (tmp-dir) (file-name-join* tmp-dir "hello.txt")) - #:content (let-vars (file-content) file-content) + #:content (var file-content) #:register 'hello) (stat-file "stat-hello" - #:path (let-vars (hello) hello) + #:path (var hello) #:register 'hello-stat) + (command "list-tmp-dir" (list "ls" "-l" (var tmp-dir) #:check? #t) #:register 'dir-list) + (command "list-root-dir" (list "ls" "-l" "/root" #:check? #f) #:register 'root-list) (debug-vars))))) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm index af3a4ec..18cbdd6 100644 --- a/modules/ordo/interceptor.scm +++ b/modules/ordo/interceptor.scm @@ -20,7 +20,9 @@ var-set! var-delete! let-vars + var expand-vars + delayed-var-ref? terminate-when execute)) @@ -83,13 +85,18 @@ expr exprs ...))))) +(define-syntax var + (syntax-rules () + ((var var-name) + (let-vars (var-name) var-name)))) + +(define (delayed-var-ref? v) + (and (procedure? v) (procedure-property v 'delayed-var-ref?))) + (define-syntax expand-vars (syntax-rules () ((expand-vars ctx v ...) - (values (if (and (procedure? v) (procedure-property v 'delayed-var-ref?)) - (v ctx) - v) - ...)))) + (values (if (delayed-var-ref? v) (v ctx) v) ...)))) (define-record-type (make-interceptor name enter leave error) diff --git a/modules/ordo/interceptor/command.scm b/modules/ordo/interceptor/command.scm new file mode 100644 index 0000000..9199c82 --- /dev/null +++ b/modules/ordo/interceptor/command.scm @@ -0,0 +1,22 @@ +(define-module (ordo interceptor command) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo connection) + #:use-module (ordo util flatten) + #:export (command)) + +(define* (command name prog-and-args #:key register) + (assume (string? name) "interceptor name should be a string" name) + (assume (list? prog-and-args) "prog-and-args should be a list" prog-and-args) + (assume (or (not register) (symbol? register)) "register should be a symbol" register) + (interceptor + name + #:enter (lambda (ctx) + (let ((prog-and-args (map (lambda (v) (expand-vars ctx v)) (flatten prog-and-args)))) + (pk prog-and-args) + (call-with-values + (lambda () (apply run (context-connection ctx) prog-and-args)) + (lambda result + (when register + (var-set! ctx register result)))))))) diff --git a/modules/ordo/interceptor/download.scm b/modules/ordo/interceptor/download.scm new file mode 100644 index 0000000..579963f --- /dev/null +++ b/modules/ordo/interceptor/download.scm @@ -0,0 +1,22 @@ +(define-module (ordo interceptor download) + #:use-module (ice-9 filesystem) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo connection) + #:export (download)) + +(define* (download name #:key url target-dir register) + (assume (string? name) "interceptor name should be a string" name) + (assume (or (string? url) (delayed-var-ref? url)) "url is required and should be a string" url) + (assume (or (not register) (symbol? register)) "register should be a symbol" register) + (interceptor + name + #:enter (lambda (ctx) + (let* ((url target-dir (expand-vars ctx url target-dir)) + (file-name (file-name-join* target-dir (file-basename url)))) + (run (context-connection ctx) "wget" "-O" file-name url #:check? #t) + (when register + (var-set! ctx register file-name)))) + #:leave (lambda (ctx) (when register (var-delete! ctx register))) + #:error (lambda (ctx) (when register (var-delete! ctx register))))) diff --git a/modules/ordo/interceptor/unzip.scm b/modules/ordo/interceptor/unzip.scm new file mode 100644 index 0000000..d6acf61 --- /dev/null +++ b/modules/ordo/interceptor/unzip.scm @@ -0,0 +1,16 @@ +(define-module (ordo interceptor unzip) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-145) + #:use-module (ordo interceptor) + #:use-module (ordo connection) + #:export (unzip)) + +(define* (unzip name #:key file-name target-dir) + (assume (string? name) "interceptor name is required and should be a string" name) + (assume (or (string? file-name) (delayed-var-ref? file-name)) "file-name is required and should be a string" file-name) + (assume (or (string? target-dir) (delayed-var-ref? target-dir)) "target-dir is required and should be a string" target-dir) + (interceptor + name + #:enter (lambda (ctx) + (let ((file-name target-dir (expand-vars ctx file-name target-dir))) + (run (context-connection ctx) "unzip" file-name "-d" target-dir #:check? #t))))) From 1784234385b3823e5f171f1375700e5e4040063a Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 26 Jan 2025 14:30:04 +0000 Subject: [PATCH 6/7] Implement apt interceptors --- examples/ubuntu.scm | 17 +++++++++++ modules/ordo/action/apt.scm | 42 --------------------------- modules/ordo/connection.scm | 5 ++-- modules/ordo/interceptor/apt.scm | 49 ++++++++++++++++++++++++++++++++ modules/ordo/inventory.scm | 7 +++-- 5 files changed, 72 insertions(+), 48 deletions(-) create mode 100644 examples/ubuntu.scm delete mode 100644 modules/ordo/action/apt.scm create mode 100644 modules/ordo/interceptor/apt.scm diff --git a/examples/ubuntu.scm b/examples/ubuntu.scm new file mode 100644 index 0000000..eb6ede4 --- /dev/null +++ b/examples/ubuntu.scm @@ -0,0 +1,17 @@ +(use-modules + (ordo playbook) + (ordo play) + (ordo interceptor) + (ordo interceptor apt)) + +(playbook + #:name "APT operations" + #:plays (list + (play + #:name "Test APT operations" + ;;#:host '(tagged #:ubuntu) + #:host "localhost" + #:interceptors (list + (apt:update) + (apt:dist-upgrade) + (map apt:install (list "curl" "ca-certificates")))))) diff --git a/modules/ordo/action/apt.scm b/modules/ordo/action/apt.scm deleted file mode 100644 index 6a19462..0000000 --- a/modules/ordo/action/apt.scm +++ /dev/null @@ -1,42 +0,0 @@ -(define-module (ordo action apt) - #:use-module ((ordo connection) #:select (run))) - -(define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive") - ("APT_LISTCHANGES_FRONTEND" . "none"))) - -(define-syntax define-apt-operation - (syntax-rules () - ((define-apt-operation (name args ...) apt-args ...) - (define-public (name conn args ...) - (run conn "apt-get" "-q" "-y" apt-args ... args ... #:env noninteractive-env))) - ((define-apt-operation name apt-args ...) - (define-public (name conn) - (run conn "apt-get" "-q" "-y" apt-args ... #:env noninteractive-env))))) - -(define-apt-operation apt:update "update") - -(define-apt-operation apt:upgrade "upgrade") - -(define-apt-operation apt:dist-upgrade "dist-upgrade") - -(define-apt-operation (apt:install package-name) "install") - -(define-apt-operation (apt:install-minimal package-name) "install" "--no-install-recommends") - -(define-apt-operation (apt:reinstall package-name) "reinstall") - -(define-apt-operation (apt:remove package-name) "remove") - -(define-apt-operation (apt:purge package-name) "purge") - -(define-apt-operation (apt:build-dep package-name) "build-dep") - -(define-apt-operation apt:clean "clean") - -(define-apt-operation apt:autoclean "autoclean") - -(define-apt-operation apt:distclean "distclean") - -(define-apt-operation apt:autoremove "autoremove") - -(define-apt-operation apt:autopurge "autopurge") diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index d5e3223..0c75ac9 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -49,9 +49,8 @@ (string-join xs " "))) (define (run conn prog . args) - (let* ((args (flatten args)) - (args kwargs (break keyword? args)) - (args (remove unspecified? args)) + (let* ((args kwargs (break keyword? args)) + (args (remove unspecified? (flatten args))) (pwd (keyword-arg kwargs #:pwd)) (env (keyword-arg kwargs #:env)) (return (keyword-arg kwargs #:return identity)) diff --git a/modules/ordo/interceptor/apt.scm b/modules/ordo/interceptor/apt.scm new file mode 100644 index 0000000..88d85c5 --- /dev/null +++ b/modules/ordo/interceptor/apt.scm @@ -0,0 +1,49 @@ +(define-module (ordo interceptor apt) + #:use-module (ordo interceptor) + #:use-module ((ordo connection) #:select (run))) + +(define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive") + ("APT_LISTCHANGES_FRONTEND" . "none"))) + +(define-syntax define-apt-interceptor + (syntax-rules () + ((define-apt-interceptor (name arg) apt-args ...) + (define-public (name arg) + (interceptor + (string-append (symbol->string 'name) " " arg) + #:enter (lambda (ctx) + (run (context-connection ctx) "apt-get" "-q" "-y" apt-args ... arg #:env noninteractive-env #:check? #t))))) + ((define-apt-interceptor name apt-args ...) + (define-public (name) + (interceptor + (symbol->string 'name) + #:enter (lambda (ctx) + (run (context-connection ctx) "apt-get" "-q" "-y" apt-args ... #:env noninteractive-env #:check? #t))))))) + +(define-apt-interceptor apt:update "update") + +(define-apt-interceptor apt:upgrade "upgrade") + +(define-apt-interceptor apt:dist-upgrade "dist-upgrade") + +(define-apt-interceptor (apt:install package-name) "install") + +(define-apt-interceptor (apt:install-minimal package-name) "install" "--no-install-recommends") + +(define-apt-interceptor (apt:reinstall package-name) "reinstall") + +(define-apt-interceptor (apt:remove package-name) "remove") + +(define-apt-interceptor (apt:purge package-name) "purge") + +(define-apt-interceptor (apt:build-dep package-name) "build-dep") + +(define-apt-interceptor apt:clean "clean") + +(define-apt-interceptor apt:autoclean "autoclean") + +(define-apt-interceptor apt:distclean "distclean") + +(define-apt-interceptor apt:autoremove "autoremove") + +(define-apt-interceptor apt:autopurge "autopurge") diff --git a/modules/ordo/inventory.scm b/modules/ordo/inventory.scm index 37294f2..47924ea 100644 --- a/modules/ordo/inventory.scm +++ b/modules/ordo/inventory.scm @@ -24,7 +24,7 @@ (set! *inventory* (cons (make-host name connection tags) *inventory*))) -(define (tagged-all? wanted-tags) +(define (tagged-every? wanted-tags) (lambda (h) (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) @@ -42,5 +42,6 @@ (make-host "localhost" (local-connection) '())))) ((? string? hostname) (filter (named? hostname) *inventory*)) ('all *inventory*) - (('every-tag tag . tags) (filter (tagged-all? (cons tag tags)) *inventory*)) - (('any-tag tag . tags) (filter (tagged-any? (cons tag tags)) *inventory*)))) + (('tagged tag) (filter (tagged-every? (list tag)) *inventory*)) + (('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) *inventory*)) + (('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) *inventory*)))) From 9b2afb81cc7f61de263d789700f0fc7ee4546155 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 26 Jan 2025 14:39:25 +0000 Subject: [PATCH 7/7] Host specifier for debian/ubuntu --- examples/ubuntu.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/examples/ubuntu.scm b/examples/ubuntu.scm index eb6ede4..e993b2c 100644 --- a/examples/ubuntu.scm +++ b/examples/ubuntu.scm @@ -1,7 +1,6 @@ (use-modules (ordo playbook) (ordo play) - (ordo interceptor) (ordo interceptor apt)) (playbook @@ -9,8 +8,7 @@ #:plays (list (play #:name "Test APT operations" - ;;#:host '(tagged #:ubuntu) - #:host "localhost" + #:host '(tagged/any #:ubuntu #:debian) #:interceptors (list (apt:update) (apt:dist-upgrade)