diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm new file mode 100644 index 0000000..c4c01b6 --- /dev/null +++ b/modules/ordo/action/filesystem.scm @@ -0,0 +1,64 @@ +(define-module (ordo action filesystem) + #:use-module (ice-9 binary-ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-26) ; cut + #:use-module (srfi srfi-71) ; extended let + #:use-module ((srfi srfi-197) #:select (chain-when)) + #:use-module (ordo connection) + #:use-module (ordo context) + #:export (create-temporary-directory + install-directory + install-file)) + +(define* (create-temporary-directory #:key tmpdir suffix template) + (lambda (conn ctx) + (connection-must conn "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template))) + (#t (resolve-context-refs ctx _)))))) + +(define* (install-directory path #:key owner group mode) + (lambda (conn ctx) + (connection-must conn "install" (chain-when + '("--directory") + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (#t (append _ `(,path))) + (#t (resolve-context-refs ctx _)))))) + +;; Helper not intended for use outside of this module +(define (upload-tmp-file conn ctx) + (lambda (input-port) + (let ((tmp-path (car (connection-must conn "mktemp" `("-p" ,(get-context-scratch-dir ctx)))))) + (connection-call-with-output-file conn tmp-path + (lambda (output-port) + (let loop ((data (get-bytevector-some input-port))) + (unless (eof-object? data) + (put-bytevector output-port data) + (loop (get-bytevector-some input-port)))) + (close-port output-port))) + tmp-path))) + +;; Because we might need sudo to install the remote file, we first +;; upload the source to a temporary file. +(define* (install-file path #:key owner group mode content local-src remote-src backup?) + (when (not (= 1 (length (filter identity (list content local-src remote-src))))) + (error "exactly one of #:content, #:local-src, or #:remote-src is required")) + (lambda (conn ctx) + (let ((remote-src (cond + (remote-src remote-src) + (local-src (call-with-input-file local-src (upload-tmp-file conn ctx))) + ((string? content) (call-with-input-string content (upload-tmp-file conn ctx))) + ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn ctx))) + (else (error "unsupported type for #:content"))))) + (connection-must conn "install" (chain-when + '() + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append _ (list remote-src path))) + (#t (resolve-context-refs ctx _))))))) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 11c8295..71884ee 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -3,6 +3,7 @@ #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) ; list operations + #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module (ssh session) #:use-module (ssh channel) @@ -15,16 +16,18 @@ init-connection! close-connection! connection-run + connection-must connection-call-with-input-file connection-call-with-output-file call-with-connection)) -(define-class ()) +(define-class () + (sudo #:getter sudo? #:init-keyword #:sudo)) (define-class ()) -(define (local-connection) - (make )) +(define* (local-connection #:key (sudo? #f)) + (make #:sudo sudo?)) (define-class () (user #:getter get-user #:init-keyword #:user) @@ -32,8 +35,8 @@ (session #:getter get-session #:setter set-session!) (sftp-session #:getter get-sftp-session #:setter set-sftp-session!)) -(define (ssh-connection user host) - (make #:user user #:host host)) +(define* (ssh-connection user host #:key (sudo? #f)) + (make #:user user #:host host #:sudo sudo?)) (define-method (init-connection! (c )) #f) @@ -77,8 +80,8 @@ ((equal? (car kwargs) kw) (cadr kwargs)) (else (kw-arg kw (cddr kwargs))))) -(define (build-command pwd env sudo? prog args) - (let ((cmd (list (if sudo? "sudo" "env")))) +(define-method (build-command (c ) pwd env prog args) + (let ((cmd (list (if (sudo? c) "sudo" "env")))) (chain-when cmd (pwd (append _ (list "--chdir" pwd))) (env (append _ (map (lambda (x) (string-append (car x) "=" (string-shell-quote (cdr x)))) env))) @@ -88,21 +91,32 @@ (list "2>&1"))) (#t (string-join _ " "))))) -(define-method (connection-run (c ) pwd env sudo? prog args) - (let* ((cmd (build-command pwd env sudo? prog args)) +(define-method (run% (c ) pwd env prog args) + (let* ((cmd (build-command c pwd env prog args)) (port (open-input-pipe cmd)) (output (read-lines port)) (exit-status (status:exit-val (close-pipe port)))) (values output exit-status))) -(define-method (connection-run (c ) pwd env sudo? prog args) - (let* ((cmd (build-command pwd env sudo? prog args)) +(define-method (run% (c ) pwd env prog args) + (let* ((cmd (build-command c pwd env prog args)) (channel (open-remote-input-pipe (get-session c) cmd)) (output (read-lines channel)) (exit-status (channel-get-exit-status channel))) (close channel) (values output exit-status))) +(define* (connection-run c prog args #:key (env #f) (pwd #f)) + (run% c pwd env prog args)) + +(define* (connection-must c prog args #:key (env #f) (pwd #f) (error-msg #f)) + (let ((out rc (connection-run c prog args #:env env #:pwd pwd))) + (if (zero? rc) + out + (error (if error-msg + (format #f "~a: ~a" error-msg out) + (format #f "~a error: ~a" prog out)))))) + (define-method (connection-call-with-input-file (c ) (filename ) (proc )) (call-with-input-file filename proc)) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm new file mode 100644 index 0000000..b9ff1b6 --- /dev/null +++ b/modules/ordo/context.scm @@ -0,0 +1,40 @@ +(define-module (ordo context) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:export (make-context + context? + get-context-scratch-dir + set-context-scratch-dir! + add-context-triggers! + register-context-var! + context-ref + resolve-context-ref + resolve-context-refs)) + +(define-record-type + (make-context) + context? + (scratch-dir get-context-scratch-dir set-context-scratch-dir!) + (vars get-context-vars set-context-vars!) + (triggers get-context-triggers set-context-triggers!)) + +(define-record-type + (context-ref name) + context-ref? + (name var-name)) + +(define (resolve-context-ref ctx v) + (if (context-ref? v) + (assoc-ref (get-context-vars ctx) (var-name v)) + v)) + +(define (resolve-context-refs ctx args) + (map (cut resolve-context-ref ctx <>) args)) + +(define (add-context-triggers! ctx triggers) + (when triggers + (set-context-triggers! ctx (fold cons (or (get-context-triggers ctx) '()) triggers)))) + +(define (register-context-var! ctx var-name val) + (set-context-vars! ctx (assoc-set! (get-context-vars ctx) var-name val))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm new file mode 100644 index 0000000..c805926 --- /dev/null +++ b/modules/ordo/play.scm @@ -0,0 +1,18 @@ +(define-module (ordo play) + #:use-module (srfi srfi-26) ; cut + #:use-module (ordo connection) + #:use-module (ordo context) + #:use-module (ordo task) + #:export (play)) + +(define (play conn tasks) + (call-with-connection + conn + (lambda (c) + (let ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) + (ctx (make-context))) + (set-context-scratch-dir! ctx tmp-dir) + (dynamic-wind + (const #t) + (lambda () (for-each (cut run-task c ctx <>) tasks)) + (lambda () (connection-must c "rm" `("-rf" ,tmp-dir)))))))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index f41af1e..b93ff8f 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -1,60 +1,29 @@ (define-module (ordo task) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:export (make-task task? task-name task-prerequisite-data task-want-skip task-action task-seq)) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) ; list utils + #:use-module (srfi srfi-9) ; records + #:use-module (srfi srfi-26) ; cut + #:use-module (ordo context) + #:export (task run-task)) -;; Task -;; name - a descriptive name for the task -;; prerequisite-data - list of prerequisite data (local data -;; that must be copied to the remote host -;; in order for the task to run) -;; want-skip - function of no args that should return #t if the -;; the task should be skipped -;; action - function of no args that runs the task (define-record-type - (make-task name prerequisite-data want-skip action) + (make-task description action register triggers) task? - (want-skip task-want-skip) - (name task-name) - (prerequisite-data task-prerequisite-data) - (action task-action)) + (description get-description set-description!) + (action get-action set-action!) + (register get-register set-regiseter!) + (triggers get-triggers set-triggers!)) -(define (combine-prerequisite-data tasks) - ;; TODO: work out what the equality operator should be, which - ;; will depend on how we represent prerequisite data - (apply lset-union = (map task-prerequisite-data tasks))) +(define* (task description action #:key register triggers) + (make-task description action register triggers)) -;; Combine the want-skips functions from a sequence of tasks. -;; If any task has no want-skip function, the combined task cannot -;; be skipped, so simply return #f. Otherwise, return a function that -;; will only return #t if every task's want-skip function returns true. -;; TODO: With this approach, if the top-level want-skip funciton returns -;; #f (so the task action sequence runs), some of the tests will be repeated. -;; Is it preferable always to have the top-level return #f and simply run -;; the subtasks? -(define (combine-want-skips tasks) - (let ((skips (map task-want-skip tasks))) - (if (every identity skips) - (lambda () (every identity (map (lambda (f) (f)) skips))) - #f))) - -;; Return a function that will apply each of the task actions -;; in order. -;; TODO: would it be better to store the list of actions and -;; implement a task runner that would run either a single task -;; or a sequence of tasks with appropriate logging? -;; TODO: the implementation below does not handle skipping -;; tasks in the sequence, this would be handled by a task runner. -(define (combine-actions tasks) - (let ((actions (map task-action tasks))) - (lambda () - (for-each (lambda (f) (f)) actions)))) - -;; Return a task consists of a sequence of other tasks. -(define (task-seq name task . task*) - (let ((tasks (cons task task*))) - (make-task - name - (combine-prerequisite-data tasks) - (combine-want-skips tasks) - (combine-actions tasks)))) +(define (run-task conn ctx task) + (match task + (($ description action register triggers) + (format #t "START ~a~%" description) + (let ((result (action conn ctx))) + (when register + (register-context-var! ctx register result)) + (when triggers + (add-context-triggers! ctx triggers)) + (format #t "END~%"))))) diff --git a/tryme.scm b/tryme.scm new file mode 100644 index 0000000..a321bc4 --- /dev/null +++ b/tryme.scm @@ -0,0 +1,21 @@ +(use-modules + (ordo connection) + (ordo action filesystem) + (ordo play) + (ordo task)) + +(define (tryme) + (play (local-connection) + (list + (task "Create test directory" + (install-directory "/home/ray/ordo-test")) + (task "Create test file from string content" + (install-file "/home/ray/ordo-test/foo" #:content "Hello, world!\n")) + (task "Create test file from local source" + (install-file "/home/ray/ordo-test/bar" #:local-src "/home/ray/ordo-test/foo")) + (task "Create test file from remote source" + (install-file "/home/ray/ordo-test/baz" #:remote-src "/home/ray/ordo-test/bar")) + (task "Expect this to fail" + (install-file "/root/ordo.txt" #:content "Hello from Ordo!"))))) + +(tryme)