diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index d731d24..855eb85 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -5,33 +5,34 @@ #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module (ordo connection) + #:use-module (ordo context) #:export (create-temporary-directory install-directory install-file)) -(define* (create-temporary-directory #:key tmpdir suffix template) - (lambda (conn) - (connection-must conn "mktemp" (chain-when - '("--directory") - (tmpdir (append _ `("--tmpdir" tmpdir))) - (suffix (append _ `("--suffix" suffix))) - (template (append _ `(template))))))) +(define* (create-temporary-directory ctx #:key tmpdir suffix template) + (connection-must (context-connection ctx) + "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template)))))) -(define* (install-directory path #:key owner group mode) - (lambda (conn) - (format #t "install-directory ~a~%" path) - (connection-must conn "install" (chain-when - '("--directory") - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (#t (append _ `(,path))))))) +(define* (install-directory ctx path #:key owner group mode) + (connection-must (context-connection ctx) + "install" (chain-when + '("--directory") + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (#t (append _ `(,path)))))) ;; Helper not intended for use outside of this module -(define (upload-tmp-file conn) +(define (upload-tmp-file ctx) (lambda (input-port) - (let ((tmp-path (car (connection-must conn "mktemp" '())))) - (connection-call-with-output-file conn tmp-path + (let ((tmp-path (car (connection-must (context-connection ctx) + "mktemp" `("-p" ,(context-scratch-dir ctx)))))) + (connection-call-with-output-file (context-connection ctx) tmp-path (lambda (output-port) (let loop ((data (get-bytevector-some input-port))) (unless (eof-object? data) @@ -42,21 +43,21 @@ ;; Because we might need sudo to install the remote file, we first ;; upload the source to a temporary file. -(define* (install-file path #:key owner group mode content local-src remote-src backup?) +(define* (install-file ctx path #:key owner group mode content local-src remote-src backup?) (when (not (= 1 (length (filter identity (list content local-src remote-src))))) (error "exactly one of #:content, #:local-src, or #:remote-src is required")) - (lambda (conn) - (format #t "install-file ~a~%" path) - (let ((remote-src (cond - (remote-src remote-src) - (local-src (call-with-input-file local-src (upload-tmp-file conn))) - ((string? content) (call-with-input-string content (upload-tmp-file conn))) - ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn))) - (else (error "unsupported type for #:content"))))) - (connection-must conn "install" (chain-when - '() - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (backup? (append _ '("--backup" "numbered"))) - (#t (append _ (list remote-src path)))))))) + (format #t "install-file ~a~%" path) + (let ((remote-src (cond + (remote-src remote-src) + (local-src (call-with-input-file local-src (upload-tmp-file ctx))) + ((string? content) (call-with-input-string content (upload-tmp-file ctx))) + ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx))) + (else (error "unsupported type for #:content"))))) + (connection-must (context-connection ctx) + "install" (chain-when + '() + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append _ (list remote-src path))))))) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 71884ee..57fff62 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -11,7 +11,8 @@ #:use-module (ssh popen) #:use-module (ssh sftp) #:use-module (ordo util shell-quote) - #:export (local-connection + #:export ( + local-connection ssh-connection init-connection! close-connection! diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm index 92c66df..a698199 100644 --- a/modules/ordo/context.scm +++ b/modules/ordo/context.scm @@ -2,33 +2,30 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) - #:export (context + #:export (make-context context? + context-connection context-scratch-dir + set-context-scratch-dir! add-context-triggers! get-context-triggers context-triggered? register-context-var! - resolve-context-refs)) + context-ref)) (define-record-type - (make-context scratch-dir vars) + (make-context connection vars scratch-dir) context? + (connection context-connection) (scratch-dir context-scratch-dir set-context-scratch-dir!) (vars context-vars set-context-vars!) (triggers context-triggers set-context-triggers!)) -(define* (context #:key scratch-dir init-vars) - (make-context scratch-dir init-vars)) - -;; TODO: (resolve-content-refs ctx (lambda (x) x)) fails -(define-syntax resolve-context-refs - (syntax-rules ($) - ((_ ctx ($ x)) - (assoc-ref (context-vars ctx) x)) - ((_ ctx (f x ...)) - (f (resolve-context-refs ctx x) ...)) - ((_ ctx x) x))) +(define (context-ref ctx var-name) + (let ((kv (assoc var-name (context-vars ctx)))) + (if kv + (cdr kv) + (error (format #f "failed to resolve context reference: ~a" var-name))))) (define (add-context-triggers! ctx triggers) (when triggers diff --git a/modules/ordo/handler.scm b/modules/ordo/handler.scm index 14ee08a..a7ddf41 100644 --- a/modules/ordo/handler.scm +++ b/modules/ordo/handler.scm @@ -16,19 +16,10 @@ (description handler-description) (action handler-action)) -(define* (handler% description action) - (make-handler description action)) +(define handler make-handler) -(define-syntax handler - (syntax-rules () - ((_ description (action arg ...)) - (handler% - description - (lambda (ctx) - (action (resolve-context-refs ctx arg) ...)))))) - -(define (run-handler conn ctx h) +(define (run-handler ctx h) (match h (($ description action) (format #t "RUNNING HANDLER ~a~%" description) - ((action ctx) conn)))) + (action ctx)))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index e480bfe..f3ebc0e 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -1,4 +1,5 @@ (define-module (ordo play) + #:use-module (oop goops) #:use-module (ice-9 match) #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-9) ; records @@ -19,10 +20,11 @@ (handlers play-handlers)) (define* (play description #:key connection tasks (vars '()) (handlers '())) - ;; TODO: validation could be better - check for non-empty tasks list, check - ;; type of connection, tasks, and handlers, etc. (unless connection (error "connection is required")) - (unless tasks (error "tasks are required")) + (unless (is-a? connection ) (error (format #f "invalid connection: ~a" connection))) + (unless (and tasks (not (null? tasks))) (error "tasks are required")) + (unless (every task? tasks) (error "invalid tasks")) + (unless (every (compose handler? cdr) handlers) (error "invalid handlers")) (for-each (lambda (task) (for-each (lambda (trigger) (unless (assoc-ref handlers trigger) @@ -31,13 +33,7 @@ trigger)))) (task-triggers task))) tasks) - (make-play description connection vars tasks handlers)) - -(define (run-trigger conn ctx handlers trigger) - (let ((h (assoc-ref handlers trigger))) - (unless h - (error (format #f "no handler defined for trigger ~a" trigger))) - (run-handler conn ctx h))) + (make-play description connection (fold (match-lambda* (((k . v) accum) (alist-cons k v accum))) '() vars) tasks handlers)) (define (run-play play) (format #t "RUNNING PLAY ~a~%" (play-description play)) @@ -45,14 +41,15 @@ (play-connection play) (lambda (c) (let* ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) - (ctx (context #:scratch-dir tmp-dir #:init-vars (play-vars play)))) + (ctx (make-context c (play-vars play) tmp-dir))) + (pk ctx) (dynamic-wind (const #t) (lambda () - (for-each (cut run-task c ctx <>) (play-tasks play)) + (for-each (cut run-task ctx <>) (play-tasks play)) (for-each (match-lambda ((name . handler) (when (context-triggered? ctx name) - (run-handler c ctx handler)))) + (run-handler ctx handler)))) (play-handlers play))) (lambda () (connection-must c "rm" `("-rf" ,tmp-dir)))))))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index b2a48ba..a307d0a 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -20,23 +20,14 @@ (register task-register) (triggers task-triggers)) -(define* (task% description action #:key (register #f) (triggers '())) +(define* (task description action #:key (register #f) (triggers '())) (make-task description action register triggers)) -(define-syntax task - (syntax-rules () - ((_ description (action arg ...) kwarg ...) - (task% - description - (lambda (ctx) - (action (resolve-context-refs ctx arg) ...)) - kwarg ...)))) - -(define (run-task conn ctx t) +(define (run-task ctx t) (match t (($ description action register triggers) (format #t "RUNNING TASK ~a~%" description) - (let ((result ((action ctx) conn))) + (let ((result (action ctx))) (when register (register-context-var! ctx register result)) (when triggers diff --git a/tryme.scm b/tryme.scm index d899983..8f2ac87 100644 --- a/tryme.scm +++ b/tryme.scm @@ -1,11 +1,26 @@ (use-modules (ice-9 filesystem) (ordo connection) + (ordo context ) (ordo action filesystem) (ordo play) (ordo task) (ordo handler)) +;; uname -a => Linux little-rascal 6.11.10-gnu #1 SMP PREEMPT_DYNAMIC 1 x86_64 GNU/Linux +;; kernel name: Linux +;; node name: little-rascal +;; kernel release: 6.11.10-gnu +;; kernel version: #1 +;; machine: SMP PREEMPT_DYNAMIC +;; processor: 1 +;; hardware platform: x86_64 +;; operating system: GNU/Linux +;; +;; Linux toolbox 6.12.6-200.fc41.x86_64 #1 SMP PREEMPT_DYNAMIC Thu Dec 19 21:06:34 UTC 2024 x86_64 x86_64 x86_64 GNU/Linux +;; uname --kernel-name --nodename --kernel-release --machine --operating-system +;; Linux little-rascal 6.11.10-gnu x86_64 GNU/Linux + (define test-play (play "Test play" #:connection (local-connection) @@ -15,17 +30,21 @@ (const "/home/ray/ordo-test-again") #:register 'base-dir) (task "Create test directory" - (install-directory ($ 'base-dir))) + (lambda (ctx) + (install-directory ctx (context-ref ctx 'base-dir)))) (task "Create test file from string content" - (install-file (file-name-join* ($ 'base-dir) "foo") - #:content "Hello, world!\n")) + (lambda (ctx) + (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "foo") + #:content "Hello, world!\n"))) (task "Create test file from local source" - (install-file (file-name-join* ($ 'base-dir) "bar") - #:local-src (file-name-join* ($ 'base-dir) "foo")) + (lambda (ctx) + (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "bar") + #:local-src (file-name-join* (context-ref ctx 'base-dir) "foo"))) #:triggers '(fritz)) (task "Create test file from remote source" - (install-file (file-name-join* ($ 'base-dir) "baz") - #:remote-src (file-name-join* ($ 'base-dir) "bar")) + (lambda (ctx) + (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "baz") + #:remote-src (file-name-join* (context-ref ctx 'base-dir) "bar"))) #:triggers '(frobnicate))) #:handlers `((frobnicate . ,(handler "Frobnicate" (const #t))) (fritz . ,(handler "Fritz" (const #t)))