ray/ordo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Implement tasks and plays

Browse source
This commit is contained in:
Ray Miller 2025-01-05 17:43:09 +00:00
parent d5593f4e3d
commit c290a5caea
Signed by: ray
GPG key ID: 043F786C4CD681B8
6 changed files with 191 additions and 65 deletions
Download patch file Download diff file Expand all files Collapse all files

64
modules/ordo/action/filesystem.scm Normal file
View file

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

36
modules/ordo/connection.scm
View file

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

40
modules/ordo/context.scm Normal file
View file

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

18
modules/ordo/play.scm Normal file
View file

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

77
modules/ordo/task.scm
View file

@ -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 <task>
(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
(($ <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~%")))))

21
tryme.scm Normal file
View file

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