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

Some refactoring, and implement stat

Browse source 
Add convenience functions run and must to the context module, and remove
the similar functions from connection.

In the connection module, rename %run to connection-run now that that
function has moved to context.
This commit is contained in:
Ray Miller 2025-01-08 18:27:46 +00:00
parent 3153469a2c
commit 93820dc307
Signed by: ray
GPG key ID: 043F786C4CD681B8
5 changed files with 78 additions and 57 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,8 @@
(define-module (ordo action filesystem) (define-module (ordo action filesystem)
#:use-module (ice-9 binary-ports) #:use-module (ice-9 binary-ports)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1) ; list utils
#:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-26) ; cut
#: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))
@ -8,32 +10,30 @@
#:use-module (ordo context) #:use-module (ordo context)
#:export (create-temporary-directory #:export (create-temporary-directory
install-directory install-directory
install-file)) install-file
fs:stat))
(define* (create-temporary-directory #:key tmpdir suffix template) (define* (create-temporary-directory #:key tmpdir suffix template)
(lambda (ctx) (lambda (ctx)
(connection-must (context-connection ctx) (must ctx "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 path #:key owner group mode)
(lambda (ctx) (lambda (ctx)
(connection-must (context-connection ctx) (must ctx "install" (chain-when
"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 ctx) (define (upload-tmp-file ctx)
(lambda (input-port) (lambda (input-port)
(let ((tmp-path (car (connection-must (context-connection ctx) (let ((tmp-path (first (must ctx "mktemp" `("-p" ,(context-scratch-dir ctx))))))
"mktemp" `("-p" ,(context-scratch-dir ctx))))))
(connection-call-with-output-file (context-connection ctx) tmp-path (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)))
@ -55,11 +55,32 @@
((string? content) (call-with-input-string content (upload-tmp-file ctx))) ((string? content) (call-with-input-string content (upload-tmp-file ctx)))
((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx))) ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx)))
(else (error "unsupported type for #:content"))))) (else (error "unsupported type for #:content")))))
(connection-must (context-connection ctx) (must ctx "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)))))))) path)))
(define (fs:stat path)
(define (parse-stat-result s)
(match-let* (((file-type user group . rest) (string-split s #\:))
((uid gid size mode atime mtime ctime) (map string->number rest)))
`((file-type . ,file-type)
(user . ,user)
(group . ,group)
(uid . ,uid)
(gid . ,gid)
(size . ,size)
(mode . ,mode)
(atime . ,atime)
(mtime . ,mtime)
(ctime . ,ctime))))
(lambda (ctx)
(let ((result rc (run ctx "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path))))
(cond
((zero? rc) (parse-stat-result (first result)))
((string-contains? (first result) "No such file or directory") #f)
(else (error (format #f "stat ~a: ~a" path (first result))))))))

16
modules/ordo/connection.scm
View file

@ -17,7 +17,6 @@
init-connection! init-connection!
close-connection! close-connection!
connection-run connection-run
connection-must
connection-call-with-input-file connection-call-with-input-file
connection-call-with-output-file connection-call-with-output-file
call-with-connection)) call-with-connection))
@ -92,14 +91,14 @@
(list "2>&1"))) (list "2>&1")))
(#t (string-join _ " "))))) (#t (string-join _ " ")))))
(define-method (run% (c <local-connection>) pwd env prog args) (define-method (connection-run (c <local-connection>) pwd env prog args)
(let* ((cmd (build-command c pwd env prog args)) (let* ((cmd (build-command c pwd env prog args))
(port (open-input-pipe cmd)) (port (open-input-pipe cmd))
(output (read-lines port)) (output (read-lines port))
(exit-status (status:exit-val (close-pipe port)))) (exit-status (status:exit-val (close-pipe port))))
(values output exit-status))) (values output exit-status)))
(define-method (run% (c <ssh-connection>) pwd env prog args) (define-method (connection-run (c <ssh-connection>) pwd env prog args)
(let* ((cmd (build-command c pwd env prog args)) (let* ((cmd (build-command c pwd env prog args))
(channel (open-remote-input-pipe (get-session c) cmd)) (channel (open-remote-input-pipe (get-session c) cmd))
(output (read-lines channel)) (output (read-lines channel))
@ -107,17 +106,6 @@
(close channel) (close channel)
(values output exit-status))) (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>)) (define-method (connection-call-with-input-file (c <local-connection>) (filename <string>) (proc <procedure>))
(call-with-input-file filename proc)) (call-with-input-file filename proc))

19
modules/ordo/context.scm
View file

@ -2,6 +2,8 @@
#: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)
#:use-module (srfi srfi-71)
#:use-module (ordo connection)
#:export (make-context #:export (make-context
context? context?
context-connection context-connection
@ -12,10 +14,12 @@
context-triggered? context-triggered?
register-context-var! register-context-var!
context-ref context-ref
bind-context-vars)) bind-context-vars
run
must))
(define-record-type <context> (define-record-type <context>
(make-context connection vars scratch-dir) (make-context connection vars)
context? context?
(connection context-connection) (connection context-connection)
(scratch-dir context-scratch-dir set-context-scratch-dir!) (scratch-dir context-scratch-dir set-context-scratch-dir!)
@ -45,3 +49,14 @@
(lambda (ctx) (lambda (ctx)
(let ((var-name (context-ref ctx (quote var-name))) ...) (let ((var-name (context-ref ctx (quote var-name))) ...)
(proc ctx)))))) (proc ctx))))))
(define* (run ctx prog args #:key (env #f) (pwd #f))
(connection-run (context-connection ctx) pwd env prog args))
(define* (must ctx prog args #:key (env #f) (pwd #f) (error-msg #f))
(let ((out rc (run ctx 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))))))

8
modules/ordo/play.scm
View file

@ -61,8 +61,8 @@
(call-with-connection (call-with-connection
(play-connection play) (play-connection play)
(lambda (c) (lambda (c)
(let* ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) (let* ((ctx (make-context c (play-vars play))))
(ctx (make-context c (play-vars play) tmp-dir))) (set-context-scratch-dir! ctx (first (must ctx "mktemp" '("--directory"))))
(dynamic-wind (dynamic-wind
(const #t) (const #t)
(lambda () (lambda ()
@ -72,4 +72,6 @@
(when (context-triggered? ctx name) (when (context-triggered? ctx name)
(run-handler ctx handler)))) (run-handler ctx handler))))
(play-handlers play))) (play-handlers play)))
(lambda () (connection-must c "rm" `("-rf" ,tmp-dir)))))))) (lambda ()
(must ctx "rm" `("-rf" ,(context-scratch-dir ctx))))))))
(format #t "COMPLETED PLAY ~a~%" (play-description play)))

23
tryme.scm
View file

@ -36,19 +36,14 @@
(task "Create test file from string content" (task "Create test file from string content"
(bind-context-vars (bind-context-vars
(base-dir) (base-dir)
(install-file (file-name-join* base-dir "foo") #:content "Hello, world!\n"))) (install-file (file-name-join* base-dir "foo") #:content "Hello, world!\n"))
(task "Create test file from local source" #:register 'foo)
(bind-context-vars (task "Get file status"
(base-dir) (bind-context-vars (foo) (fs:stat foo))
(install-file (file-name-join* base-dir "bar") #:local-src (file-name-join* base-dir "foo"))) #:register 'stat-out
#:triggers '(fritz)) #:triggers '(display-stat)))
(task "Create test file from remote source" #:handlers `((display-stat . ,(handler "Display stat"
(bind-context-vars (bind-context-vars (foo stat-out) (lambda _ (pk foo stat-out))))))))
(base-dir)
(install-file (file-name-join* base-dir "baz") #:remote-src (file-name-join* base-dir "bar")))
#:triggers '(frobnicate)))
#:handlers `((frobnicate . ,(handler "Frobnicate" (const #t)))
(fritz . ,(handler "Fritz" (const #t)))
(frotz . ,(handler "Frotz" (const #t))))))
(run-play test-play) (run-play test-play)