Implement tasks and plays

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 _)))))))

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 <connection> ())
+(define-class <connection> ()
+  (sudo #:getter sudo? #:init-keyword #:sudo))
 
 (define-class <local-connection> (<connection>))
 
-(define (local-connection)
+(define* (local-connection #:key (sudo? #f))
-  (make <local-connection>))
+  (make <local-connection> #:sudo sudo?))
 
 (define-class <ssh-connection> (<connection>)
   (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)
+(define* (ssh-connection user host #:key (sudo? #f))
-  (make <ssh-connection> #:user user #:host host))
+  (make <ssh-connection> #:user user #:host host #:sudo sudo?))
 
 (define-method (init-connection! (c <connection>)) #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)
+(define-method (build-command (c <connection>) pwd env prog args)
-  (let ((cmd (list (if sudo? "sudo" "env"))))
+  (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 <local-connection>) pwd env sudo? prog args)
+(define-method (run% (c <local-connection>) pwd env prog args)
-  (let* ((cmd (build-command pwd env sudo? 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 <ssh-connection>) pwd env sudo? prog args)
+(define-method (run% (c <ssh-connection>) pwd env prog args)
-  (let* ((cmd (build-command pwd env sudo? 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 <local-connection>) (filename <string>) (proc <procedure>))
   (call-with-input-file filename proc))
 

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 <context>
+  (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>
+  (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)))

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))))))))

modules/ordo/task.scm

@@ -1,60 +1,29 @@
 (define-module (ordo task)
-  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-1) ; list utils
-  #:export (make-task task? task-name task-prerequisite-data task-want-skip task-action task-seq))
+  #: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 <task>
-  (make-task name prerequisite-data want-skip action)
+  (make-task description action register triggers)
   task?
-  (want-skip task-want-skip)
+  (description get-description set-description!)
-  (name task-name)
+  (action get-action set-action!)
-  (prerequisite-data task-prerequisite-data)
+  (register get-register set-regiseter!)
-  (action task-action))
+  (triggers get-triggers set-triggers!))
 
-(define (combine-prerequisite-data tasks)
+(define* (task description action #:key register triggers)
-  ;; TODO: work out what the equality operator should be, which
+  (make-task description action register triggers))
-  ;; will depend on how we represent prerequisite data
-  (apply lset-union = (map task-prerequisite-data tasks)))
 
-;; Combine the want-skips functions from a sequence of tasks.
+(define (run-task conn ctx task)
-;; If any task has no want-skip function, the combined task cannot
+  (match task
-;; be skipped, so simply return #f. Otherwise, return a function that
+    (($ <task> description action register triggers)
-;; will only return #t if every task's want-skip function returns true.
+     (format #t "START ~a~%" description)
-;; TODO: With this approach, if the top-level want-skip funciton returns
+     (let ((result (action conn ctx)))
-;; #f (so the task action sequence runs), some of the tests will be repeated.
+       (when register
-;; Is it preferable always to have the top-level return #f and simply run
+         (register-context-var! ctx register result))
-;; the subtasks?
+       (when triggers
-(define (combine-want-skips tasks)
+         (add-context-triggers! ctx triggers))
-  (let ((skips (map task-want-skip tasks)))
+       (format #t "END~%")))))
-    (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))))

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)