diff --git a/bin/play.scm b/bin/play.scm index 8ff84d0..103e6c7 100755 --- a/bin/play.scm +++ b/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))))) diff --git a/modules/ordo/task/command.scm b/modules/ordo/task/command.scm index 6e9462d..52a68bf 100644 --- a/modules/ordo/task/command.scm +++ b/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 '()) diff --git a/modules/ordo/util/filesystem.scm b/modules/ordo/util/filesystem.scm new file mode 100644 index 0000000..65f6f28 --- /dev/null +++ b/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)))))) diff --git a/modules/ordo/util/run.scm b/modules/ordo/util/process.scm similarity index 53% rename from modules/ordo/util/run.scm rename to modules/ordo/util/process.scm index c394bc7..f3e87e7 100644 --- a/modules/ordo/util/run.scm +++ b/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)) diff --git a/modules/ordo/util/tmpdir.scm b/modules/ordo/util/tmpdir.scm deleted file mode 100644 index 6f16aec..0000000 --- a/modules/ordo/util/tmpdir.scm +++ /dev/null @@ -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))))))