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

Support for context vars without macros

Browse source
This commit is contained in:
Ray Miller 2025-01-07 18:09:10 +00:00
parent af16ee29b6
commit b4cdfc341a
Signed by: ray
GPG key ID: 043F786C4CD681B8
7 changed files with 91 additions and 94 deletions
Download patch file Download diff file Expand all files Collapse all files

71
modules/ordo/action/filesystem.scm
View file

@ -5,33 +5,34 @@
#:use-module (srfi srfi-71) ; extended let #:use-module (srfi srfi-71) ; extended let
#:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module ((srfi srfi-197) #:select (chain-when))
#:use-module (ordo connection) #:use-module (ordo connection)
#:use-module (ordo context)
#:export (create-temporary-directory #:export (create-temporary-directory
install-directory install-directory
install-file)) install-file))
(define* (create-temporary-directory #:key tmpdir suffix template) (define* (create-temporary-directory ctx #:key tmpdir suffix template)
(lambda (conn) (connection-must (context-connection ctx)
(connection-must conn "mktemp" (chain-when "mktemp" (chain-when
'("--directory") '("--directory")
(tmpdir (append _ `("--tmpdir" tmpdir))) (tmpdir (append _ `("--tmpdir" tmpdir)))
(suffix (append _ `("--suffix" suffix))) (suffix (append _ `("--suffix" suffix)))
(template (append _ `(template))))))) (template (append _ `(template))))))
(define* (install-directory path #:key owner group mode) (define* (install-directory ctx path #:key owner group mode)
(lambda (conn) (connection-must (context-connection ctx)
(format #t "install-directory ~a~%" path) "install" (chain-when
(connection-must conn "install" (chain-when '("--directory")
'("--directory") (owner (append _ `("--owner" ,owner)))
(owner (append _ `("--owner" ,owner))) (group (append _ `("--group" ,group)))
(group (append _ `("--group" ,group))) (mode (append _ `("--mode" ,mode)))
(mode (append _ `("--mode" ,mode))) (#t (append _ `(,path))))))
(#t (append _ `(,path)))))))
;; Helper not intended for use outside of this module ;; Helper not intended for use outside of this module
(define (upload-tmp-file conn) (define (upload-tmp-file ctx)
(lambda (input-port) (lambda (input-port)
(let ((tmp-path (car (connection-must conn "mktemp" '())))) (let ((tmp-path (car (connection-must (context-connection ctx)
(connection-call-with-output-file conn tmp-path "mktemp" `("-p" ,(context-scratch-dir ctx))))))
(connection-call-with-output-file (context-connection ctx) tmp-path
(lambda (output-port) (lambda (output-port)
(let loop ((data (get-bytevector-some input-port))) (let loop ((data (get-bytevector-some input-port)))
(unless (eof-object? data) (unless (eof-object? data)
@ -42,21 +43,21 @@
;; Because we might need sudo to install the remote file, we first ;; Because we might need sudo to install the remote file, we first
;; upload the source to a temporary file. ;; upload the source to a temporary file.
(define* (install-file path #:key owner group mode content local-src remote-src backup?) (define* (install-file ctx path #:key owner group mode content local-src remote-src backup?)
(when (not (= 1 (length (filter identity (list content local-src remote-src))))) (when (not (= 1 (length (filter identity (list content local-src remote-src)))))
(error "exactly one of #:content, #:local-src, or #:remote-src is required")) (error "exactly one of #:content, #:local-src, or #:remote-src is required"))
(lambda (conn) (format #t "install-file ~a~%" path)
(format #t "install-file ~a~%" path) (let ((remote-src (cond
(let ((remote-src (cond (remote-src remote-src)
(remote-src remote-src) (local-src (call-with-input-file local-src (upload-tmp-file ctx)))
(local-src (call-with-input-file local-src (upload-tmp-file conn))) ((string? content) (call-with-input-string content (upload-tmp-file ctx)))
((string? content) (call-with-input-string content (upload-tmp-file conn))) ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx)))
((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn))) (else (error "unsupported type for #:content")))))
(else (error "unsupported type for #:content"))))) (connection-must (context-connection ctx)
(connection-must conn "install" (chain-when "install" (chain-when
'() '()
(owner (append _ `("--owner" ,owner))) (owner (append _ `("--owner" ,owner)))
(group (append _ `("--group" ,group))) (group (append _ `("--group" ,group)))
(mode (append _ `("--mode" ,mode))) (mode (append _ `("--mode" ,mode)))
(backup? (append _ '("--backup" "numbered"))) (backup? (append _ '("--backup" "numbered")))
(#t (append _ (list remote-src path)))))))) (#t (append _ (list remote-src path)))))))

3
modules/ordo/connection.scm
View file

@ -11,7 +11,8 @@
#:use-module (ssh popen) #:use-module (ssh popen)
#:use-module (ssh sftp) #:use-module (ssh sftp)
#:use-module (ordo util shell-quote) #:use-module (ordo util shell-quote)
#:export (local-connection #:export (<connection>
local-connection
ssh-connection ssh-connection
init-connection! init-connection!
close-connection! close-connection!

25
modules/ordo/context.scm
View file

@ -2,33 +2,30 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:export (context #:export (make-context
context? context?
context-connection
context-scratch-dir context-scratch-dir
set-context-scratch-dir!
add-context-triggers! add-context-triggers!
get-context-triggers get-context-triggers
context-triggered? context-triggered?
register-context-var! register-context-var!
resolve-context-refs)) context-ref))
(define-record-type <context> (define-record-type <context>
(make-context scratch-dir vars) (make-context connection vars scratch-dir)
context? context?
(connection context-connection)
(scratch-dir context-scratch-dir set-context-scratch-dir!) (scratch-dir context-scratch-dir set-context-scratch-dir!)
(vars context-vars set-context-vars!) (vars context-vars set-context-vars!)
(triggers context-triggers set-context-triggers!)) (triggers context-triggers set-context-triggers!))
(define* (context #:key scratch-dir init-vars) (define (context-ref ctx var-name)
(make-context scratch-dir init-vars)) (let ((kv (assoc var-name (context-vars ctx))))
(if kv
;; TODO: (resolve-content-refs ctx (lambda (x) x)) fails (cdr kv)
(define-syntax resolve-context-refs (error (format #f "failed to resolve context reference: ~a" var-name)))))
(syntax-rules ($)
((_ ctx ($ x))
(assoc-ref (context-vars ctx) x))
((_ ctx (f x ...))
(f (resolve-context-refs ctx x) ...))
((_ ctx x) x)))
(define (add-context-triggers! ctx triggers) (define (add-context-triggers! ctx triggers)
(when triggers (when triggers

15
modules/ordo/handler.scm
View file

@ -16,19 +16,10 @@
(description handler-description) (description handler-description)
(action handler-action)) (action handler-action))
(define* (handler% description action) (define handler make-handler)
(make-handler description action))
(define-syntax handler (define (run-handler ctx h)
(syntax-rules ()
((_ description (action arg ...))
(handler%
description
(lambda (ctx)
(action (resolve-context-refs ctx arg) ...))))))
(define (run-handler conn ctx h)
(match h (match h
(($ <handler> description action) (($ <handler> description action)
(format #t "RUNNING HANDLER ~a~%" description) (format #t "RUNNING HANDLER ~a~%" description)
((action ctx) conn)))) (action ctx))))

23
modules/ordo/play.scm
View file

@ -1,4 +1,5 @@
(define-module (ordo play) (define-module (ordo play)
#:use-module (oop goops)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-1) ; list utils
#:use-module (srfi srfi-9) ; records #:use-module (srfi srfi-9) ; records
@ -19,10 +20,11 @@
(handlers play-handlers)) (handlers play-handlers))
(define* (play description #:key connection tasks (vars '()) (handlers '())) (define* (play description #:key connection tasks (vars '()) (handlers '()))
;; TODO: validation could be better - check for non-empty tasks list, check
;; type of connection, tasks, and handlers, etc.
(unless connection (error "connection is required")) (unless connection (error "connection is required"))
(unless tasks (error "tasks are required")) (unless (is-a? connection <connection>) (error (format #f "invalid connection: ~a" connection)))
(unless (and tasks (not (null? tasks))) (error "tasks are required"))
(unless (every task? tasks) (error "invalid tasks"))
(unless (every (compose handler? cdr) handlers) (error "invalid handlers"))
(for-each (lambda (task) (for-each (lambda (task)
(for-each (lambda (trigger) (for-each (lambda (trigger)
(unless (assoc-ref handlers trigger) (unless (assoc-ref handlers trigger)
@ -31,13 +33,7 @@
trigger)))) trigger))))
(task-triggers task))) (task-triggers task)))
tasks) tasks)
(make-play description connection vars tasks handlers)) (make-play description connection (fold (match-lambda* (((k . v) accum) (alist-cons k v accum))) '() vars) tasks handlers))
(define (run-trigger conn ctx handlers trigger)
(let ((h (assoc-ref handlers trigger)))
(unless h
(error (format #f "no handler defined for trigger ~a" trigger)))
(run-handler conn ctx h)))
(define (run-play play) (define (run-play play)
(format #t "RUNNING PLAY ~a~%" (play-description play)) (format #t "RUNNING PLAY ~a~%" (play-description play))
@ -45,14 +41,15 @@
(play-connection play) (play-connection play)
(lambda (c) (lambda (c)
(let* ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) (let* ((tmp-dir (car (connection-must c "mktemp" '("--directory"))))
(ctx (context #:scratch-dir tmp-dir #:init-vars (play-vars play)))) (ctx (make-context c (play-vars play) tmp-dir)))
(pk ctx)
(dynamic-wind (dynamic-wind
(const #t) (const #t)
(lambda () (lambda ()
(for-each (cut run-task c ctx <>) (play-tasks play)) (for-each (cut run-task ctx <>) (play-tasks play))
(for-each (match-lambda (for-each (match-lambda
((name . handler) ((name . handler)
(when (context-triggered? ctx name) (when (context-triggered? ctx name)
(run-handler c ctx handler)))) (run-handler ctx handler))))
(play-handlers play))) (play-handlers play)))
(lambda () (connection-must c "rm" `("-rf" ,tmp-dir)))))))) (lambda () (connection-must c "rm" `("-rf" ,tmp-dir))))))))

15
modules/ordo/task.scm
View file

@ -20,23 +20,14 @@
(register task-register) (register task-register)
(triggers task-triggers)) (triggers task-triggers))
(define* (task% description action #:key (register #f) (triggers '())) (define* (task description action #:key (register #f) (triggers '()))
(make-task description action register triggers)) (make-task description action register triggers))
(define-syntax task (define (run-task ctx t)
(syntax-rules ()
((_ description (action arg ...) kwarg ...)
(task%
description
(lambda (ctx)
(action (resolve-context-refs ctx arg) ...))
kwarg ...))))
(define (run-task conn ctx t)
(match t (match t
(($ <task> description action register triggers) (($ <task> description action register triggers)
(format #t "RUNNING TASK ~a~%" description) (format #t "RUNNING TASK ~a~%" description)
(let ((result ((action ctx) conn))) (let ((result (action ctx)))
(when register (when register
(register-context-var! ctx register result)) (register-context-var! ctx register result))
(when triggers (when triggers

33
tryme.scm
View file

@ -1,11 +1,26 @@
(use-modules (use-modules
(ice-9 filesystem) (ice-9 filesystem)
(ordo connection) (ordo connection)
(ordo context )
(ordo action filesystem) (ordo action filesystem)
(ordo play) (ordo play)
(ordo task) (ordo task)
(ordo handler)) (ordo handler))
;; uname -a => Linux little-rascal 6.11.10-gnu #1 SMP PREEMPT_DYNAMIC 1 x86_64 GNU/Linux
;; kernel name: Linux
;; node name: little-rascal
;; kernel release: 6.11.10-gnu
;; kernel version: #1
;; machine: SMP PREEMPT_DYNAMIC
;; processor: 1
;; hardware platform: x86_64
;; operating system: GNU/Linux
;;
;; Linux toolbox 6.12.6-200.fc41.x86_64 #1 SMP PREEMPT_DYNAMIC Thu Dec 19 21:06:34 UTC 2024 x86_64 x86_64 x86_64 GNU/Linux
;; uname --kernel-name --nodename --kernel-release --machine --operating-system
;; Linux little-rascal 6.11.10-gnu x86_64 GNU/Linux
(define test-play (define test-play
(play "Test play" (play "Test play"
#:connection (local-connection) #:connection (local-connection)
@ -15,17 +30,21 @@
(const "/home/ray/ordo-test-again") (const "/home/ray/ordo-test-again")
#:register 'base-dir) #:register 'base-dir)
(task "Create test directory" (task "Create test directory"
(install-directory ($ 'base-dir))) (lambda (ctx)
(install-directory ctx (context-ref ctx 'base-dir))))
(task "Create test file from string content" (task "Create test file from string content"
(install-file (file-name-join* ($ 'base-dir) "foo") (lambda (ctx)
#:content "Hello, world!\n")) (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "foo")
#:content "Hello, world!\n")))
(task "Create test file from local source" (task "Create test file from local source"
(install-file (file-name-join* ($ 'base-dir) "bar") (lambda (ctx)
#:local-src (file-name-join* ($ 'base-dir) "foo")) (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "bar")
#:local-src (file-name-join* (context-ref ctx 'base-dir) "foo")))
#:triggers '(fritz)) #:triggers '(fritz))
(task "Create test file from remote source" (task "Create test file from remote source"
(install-file (file-name-join* ($ 'base-dir) "baz") (lambda (ctx)
#:remote-src (file-name-join* ($ 'base-dir) "bar")) (install-file ctx (file-name-join* (context-ref ctx 'base-dir) "baz")
#:remote-src (file-name-join* (context-ref ctx 'base-dir) "bar")))
#:triggers '(frobnicate))) #:triggers '(frobnicate)))
#:handlers `((frobnicate . ,(handler "Frobnicate" (const #t))) #:handlers `((frobnicate . ,(handler "Frobnicate" (const #t)))
(fritz . ,(handler "Fritz" (const #t))) (fritz . ,(handler "Fritz" (const #t)))