diff --git a/bin/play.scm b/bin/play.scm new file mode 100755 index 0000000..8ff84d0 --- /dev/null +++ b/bin/play.scm @@ -0,0 +1,42 @@ +#!/usr/bin/env -S guile --no-auto-compile -e main -s +!# +(use-modules (srfi srfi-11) + (ice-9 getopt-long) + (ice-9 format) + (ordo util tmpdir)) + +(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* (usage #:optional errmsg) + (with-output-to-port (current-error-port) + (lambda () + (when errmsg + (format #t "Error: ~a~%~%" errmsg)) + (display "Usage: play -t TARGET PLAYBOOK") + (newline))) + (exit (if errmsg EXIT_FAILURE EXIT_SUCCESS))) + +(define (process-options args) + (let* ((option-spec '((help (single-char #\h) (value #f)) + (target (single-char #\t) (value #t) (required? #t)))) + (options (getopt-long args option-spec)) + (help-wanted (option-ref options 'help #f)) + (target (option-ref options 'target #f)) + (args (option-ref options '() '()))) + (cond + (help-wanted (usage)) + ((not (= 1 (length args))) + (usage "Expected exactly one playbook"))) + (values (car args) target))) + +(define (main args) + (let-values (((playbook-path target) (process-options args))) + (define playbook (load (canonicalize-path 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"))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm new file mode 100644 index 0000000..f41af1e --- /dev/null +++ b/modules/ordo/task.scm @@ -0,0 +1,60 @@ +(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)) + +;; 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) + task? + (want-skip task-want-skip) + (name task-name) + (prerequisite-data task-prerequisite-data) + (action task-action)) + +(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))) + +;; 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)))) diff --git a/ordo/task/command.scm b/modules/ordo/task/command.scm similarity index 73% rename from ordo/task/command.scm rename to modules/ordo/task/command.scm index 181d3cc..6e9462d 100644 --- a/ordo/task/command.scm +++ b/modules/ordo/task/command.scm @@ -3,13 +3,13 @@ #:use-module (srfi srfi-11) #:use-module (ordo task) #:use-module (ordo util run) - #:export (task-command)) + #:export (command)) - -(define* (task-command name cmd #:optional (args '()) - #:key (fail-ok? #f) (stdin #f) (cwd #f) (env #f)) +(define* (command name cmd #:optional (args '()) + #:key (fail-ok? #f) (stdin #f) (cwd #f) (env #f) (skip? #f)) (make-task name - #f + '() + skip? (lambda () (let-values (((exit-code output) (run cmd args #:stdin stdin #:cwd cwd #:env env #:combine-output #t))) (if (or fail-ok? (zero? exit-code)) diff --git a/modules/ordo/task/file.scm b/modules/ordo/task/file.scm new file mode 100644 index 0000000..c766485 --- /dev/null +++ b/modules/ordo/task/file.scm @@ -0,0 +1,4 @@ +(define-module (ordo task file) + #:use-module (ordo task)) + +(define (file )) diff --git a/ordo/util/run.scm b/modules/ordo/util/run.scm similarity index 100% rename from ordo/util/run.scm rename to modules/ordo/util/run.scm diff --git a/modules/ordo/util/tmpdir.scm b/modules/ordo/util/tmpdir.scm new file mode 100644 index 0000000..6f16aec --- /dev/null +++ b/modules/ordo/util/tmpdir.scm @@ -0,0 +1,36 @@ +(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)))))) diff --git a/ordo/task.scm b/ordo/task.scm deleted file mode 100644 index 2d10793..0000000 --- a/ordo/task.scm +++ /dev/null @@ -1,10 +0,0 @@ -(define-module (ordo task) - #:use-module (srfi srfi-9) - #:export (make-task task? task-name task-prerequisite-data set-task-prerequisite-data! task-action set-task-action!)) - -(define-record-type - (make-task name prerequisite-data action) - task? - (name task-name) - (prerequisite-data task-prerequisite-data set-task-prerequisite-data!) - (action task-action set-task-action!)) diff --git a/playbooks/tryme.scm b/playbooks/tryme.scm new file mode 100644 index 0000000..72fd903 --- /dev/null +++ b/playbooks/tryme.scm @@ -0,0 +1,3 @@ +(define x 7) + +(lambda () (* x x))