Some refactoring and new functionality.

* Rename util/run to util/process.
* Rename `run` to `capture` to better reflect functionality.
* Implement `with-env`.
* Rename util/tmpdir to util/filesystem.
* Implement `delete-file-recursively`.
* Implement `call-with-temporary-directory`.
* Flesh out creation of tarball for transfer to remote system.

bin/play.scm

@@ -3,13 +3,11 @@
 (use-modules (srfi srfi-11)
              (ice-9 getopt-long)
              (ice-9 format)
-             (ordo util tmpdir))
+             (ordo util filesystem))
 
-(define (collect-files tarball dir . files)
-  (let* ((mode (if (file-exists? tarball) "--append" "--create"))
-         (rc (apply system* "tar" mode "--gzip" "--directory" dir "--file" tarball files)))
-    (unless (zero? rc)
-      (error (string-append "Error collecting files")))))
+(define (tar . args)
+  (unless (zero? (apply system* "tar" args))
+    (error (format #f "Non-zero exit from tar ~a" args))))
 
 (define* (usage #:optional errmsg)
   (with-output-to-port (current-error-port)
@@ -31,12 +29,15 @@
      (help-wanted (usage))
      ((not (= 1 (length args)))
       (usage "Expected exactly one playbook")))
-    (values (car args) target)))
+    (values (canonicalize-path (car args)) target)))
 
 (define (main args)
   (let-values (((playbook-path target) (process-options args)))
-    (define playbook (load (canonicalize-path playbook-path)))
+    (define playbook (load playbook-path))
     (define top-dir (dirname (dirname (current-filename))))
-    (define tmp-dir (create-temporary-directory))
-    (define tarball (string-append tmp-dir "/payload.tar.gz"))
-    (collect-files tarball top-dir "modules" "bin")))
+    (call-with-temporary-directory
+     (lambda (tmp-dir)
+       (define tarball (string-append tmp-dir "/payload.tar"))
+       (tar "--create" "--file" tarball "--directory" top-dir "modules" "bin")
+       (tar "--append" "--file" tarball "--transform" "s/.*/playbook.scm/" playbook-path)
+       (tar "tf" tarball)))))

modules/ordo/task/command.scm

@@ -2,7 +2,7 @@
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-11)
   #:use-module (ordo task)
-  #:use-module (ordo util run)
+  #:use-module (ordo util process)
   #:export (command))
 
 (define* (command name cmd #:optional (args '())

modules/ordo/util/filesystem.scm

@@ -0,0 +1,63 @@
+(define-module (ordo util filesystem)
+  #:use-module (system foreign)
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
+  #:export (delete-file-recursively
+            create-temporary-directory
+            call-with-temporary-directory))
+
+(define* (delete-file-recursively filename #:key (verbose #f))
+  (define dev (stat:dev (stat filename)))
+  (define (enter? name stat result)
+    (= (stat:dev stat) dev))
+  (define (leaf name stat result)
+    (if (false-if-exception (delete-file name))
+        (and verbose (format #t "delete-file ~a OK~%" name))
+        (format (current-error-port) "warning: delete-file ~a failed~%" name))
+    result)
+  (define (down name stat result)
+    result)
+  (define (up name stat result)
+    (if (false-if-exception (rmdir name))
+        (and verbose (format #t "rmdir ~a OK~%" name))
+        (format (current-error-port) "warning: rmdir ~a failed~%" name))
+    result)
+  (define (skip name state result)
+    result)
+  (define (error name stat errno result)
+    (format (current-error-port) "warning: ~a: ~a~%"
+            name (strerror errno))
+    result)
+  (file-system-fold enter? leaf down up skip error #f filename))
+
+
+;; This is based on reading guix/build/syscalls.scm but less general
+;; than their implementation.
+(define mkdtemp!
+  (let* ((ptr (dynamic-func "mkdtemp" (dynamic-link)))
+         (proc (pointer->procedure '* ptr '(*) #:return-errno? #t)))
+    (lambda (tmpl)
+      (let-values (((result err) (proc (string->pointer tmpl))))
+        (when (null-pointer? result)
+          (error (format #f "mkdtemp! ~a: ~a" tmpl (strerror err))))
+        (pointer->string result)))))
+
+(define (create-temporary-directory)
+  (let* ((directory (or (getenv "TMPDIR") "/tmp"))
+         (template (string-append directory "/ordo.XXXXXX")))
+    (mkdtemp! template)))
+
+;; This is borrowed from guix/util.scm
+(define (call-with-temporary-directory proc)
+  "Call PROC with a name of a temporary directory; close the directory and
+delete it when leaving the dynamic extent of this call."
+  (let* ((directory (or (getenv "TMPDIR") "/tmp"))
+         (template  (string-append directory "/ordo.XXXXXX"))
+         (tmp-dir   (mkdtemp! template)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (proc tmp-dir))
+      (lambda ()
+        (false-if-exception (delete-file-recursively tmp-dir))))))

modules/ordo/util/process.scm

@@ -1,4 +1,4 @@
-(define-module (ordo util run)
+(define-module (ordo util process)
   #:use-module (ice-9 textual-ports)
   #:export (run with-cwd))
 
@@ -11,7 +11,26 @@
          (lambda () body ...)
          (lambda () (chdir original-dir)))))))
 
-(define* (run cmd #:optional (args '()) #:key (combine-output #f) (env #f) (stdin #f) (cwd #f))
+;; Not needed for CAPTURE, which supports an environment override,
+;; but might be useful for SYSTEM and SYSTEM*
+(define-syntax with-env
+  (syntax-rules ()
+    ((_ new-env body ...)
+     (let ((original-env (environ)))
+       (dynamic-wind
+         (lambda () (environ new-env))
+         (lambda () body ...)
+         (lambda () (environ original-env)))))))
+
+;; Run a command and capture the output. Currently this only supports
+;; text input and output. If necessary, we could use the (rnrs io ports)
+;; module and use PUT-BYTEVECTOR / GET-BYTEVECTOR-ALL and examine the type
+;; of STDIN to determine whether to call PUT-STRING or PUT-BYTEVECTOR. For
+;; STDOUT, we'd need to add a #:binary argument so the caller could indicate
+;; they are expecting binary output. Not implemented yet incase YAGNI.
+(define* (capture cmd
+                  #:optional (args '())
+                  #:key (combine-output #f) (env #f) (stdin #f) (cwd #f))
   (if cwd
       (with-cwd cwd (run cmd args #:combine-output combine-output #:env env #:stdin stdin))
       (let* ((input-pipe (pipe))

modules/ordo/util/tmpdir.scm

@@ -1,36 +0,0 @@
-(define-module (ordo util tmpdir)
-  #:use-module (system foreign)
-  #:use-module (srfi srfi-11)
-  #:use-module (ice-9 format)
-  #:export (create-temporary-directory))
-
-;; This is based on reading guix/build/syscalls.scm but less general
-;; than their implementation.
-(define mkdtemp!
-  (let* ((ptr (dynamic-func "mkdtemp" (dynamic-link)))
-         (proc (pointer->procedure '* ptr '(*) #:return-errno? #t)))
-    (lambda (tmpl)
-      (let-values (((result err) (proc (string->pointer tmpl))))
-        (when (null-pointer? result)
-          (error (format #f "mkdtemp! ~a: ~a" tmpl (strerror err))))
-        (pointer->string result)))))
-
-(define (create-temporary-directory)
-  (let* ((directory (or (getenv "TMPDIR") "/tmp"))
-         (template (string-append directory "/ordo.XXXXXX")))
-    (mkdtemp! template)))
-
-;; This is borrowed from guix/util.scm
-;; TODO: we also need to borrow their delete-file-recursively
-;; (define (call-with-temporary-directory proc)
-;;   "Call PROC with a name of a temporary directory; close the directory and
-;; delete it when leaving the dynamic extent of this call."
-;;   (let* ((directory (or (getenv "TMPDIR") "/tmp"))
-;;          (template  (string-append directory "/ordo.XXXXXX"))
-;;          (tmp-dir   (mkdtemp! template)))
-;;     (dynamic-wind
-;;       (const #t)
-;;       (lambda ()
-;;         (proc tmp-dir))
-;;       (lambda ()
-;;         (false-if-exception (delete-file-recursively tmp-dir))))))