diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 7eb6a35..76b094e 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -1,6 +1,8 @@ (define-module (ordo action filesystem) #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) ; list utils #:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) @@ -8,32 +10,30 @@ #:use-module (ordo context) #:export (create-temporary-directory install-directory - install-file)) + install-file + fs:stat)) (define* (create-temporary-directory #:key tmpdir suffix template) (lambda (ctx) - (connection-must (context-connection ctx) - "mktemp" (chain-when - '("--directory") - (tmpdir (append _ `("--tmpdir" tmpdir))) - (suffix (append _ `("--suffix" suffix))) - (template (append _ `(template))))))) + (must ctx "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template))))))) (define* (install-directory path #:key owner group mode) (lambda (ctx) - (connection-must (context-connection ctx) - "install" (chain-when - '("--directory") - (owner (append _ `("--owner" ,owner))) - (group (append _ `("--group" ,group))) - (mode (append _ `("--mode" ,mode))) - (#t (append _ `(,path))))))) + (must ctx "install" (chain-when + '("--directory") + (owner (append _ `("--owner" ,owner))) + (group (append _ `("--group" ,group))) + (mode (append _ `("--mode" ,mode))) + (#t (append _ `(,path))))))) ;; Helper not intended for use outside of this module (define (upload-tmp-file ctx) (lambda (input-port) - (let ((tmp-path (car (connection-must (context-connection ctx) - "mktemp" `("-p" ,(context-scratch-dir ctx)))))) + (let ((tmp-path (first (must ctx "mktemp" `("-p" ,(context-scratch-dir ctx)))))) (connection-call-with-output-file (context-connection ctx) tmp-path (lambda (output-port) (let loop ((data (get-bytevector-some input-port))) @@ -55,11 +55,32 @@ ((string? content) (call-with-input-string content (upload-tmp-file ctx))) ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx))) (else (error "unsupported type for #:content"))))) - (connection-must (context-connection ctx) - "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)))))))) + (must ctx "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))))) + 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)))))))) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index 57fff62..afde8d6 100644 --- a/modules/ordo/connection.scm +++ b/modules/ordo/connection.scm @@ -17,7 +17,6 @@ init-connection! close-connection! connection-run - connection-must connection-call-with-input-file connection-call-with-output-file call-with-connection)) @@ -92,14 +91,14 @@ (list "2>&1"))) (#t (string-join _ " "))))) -(define-method (run% (c ) pwd env prog args) +(define-method (connection-run (c ) 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 (run% (c ) pwd env prog args) +(define-method (connection-run (c ) 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)) @@ -107,17 +106,6 @@ (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 ) (filename ) (proc )) (call-with-input-file filename proc)) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm index bc07882..1da0015 100644 --- a/modules/ordo/context.scm +++ b/modules/ordo/context.scm @@ -2,6 +2,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (ordo connection) #:export (make-context context? context-connection @@ -12,10 +14,12 @@ context-triggered? register-context-var! context-ref - bind-context-vars)) + bind-context-vars + run + must)) (define-record-type - (make-context connection vars scratch-dir) + (make-context connection vars) context? (connection context-connection) (scratch-dir context-scratch-dir set-context-scratch-dir!) @@ -45,3 +49,14 @@ (lambda (ctx) (let ((var-name (context-ref ctx (quote var-name))) ...) (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)))))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index aa2036c..8d0450c 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -61,8 +61,8 @@ (call-with-connection (play-connection play) (lambda (c) - (let* ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) - (ctx (make-context c (play-vars play) tmp-dir))) + (let* ((ctx (make-context c (play-vars play)))) + (set-context-scratch-dir! ctx (first (must ctx "mktemp" '("--directory")))) (dynamic-wind (const #t) (lambda () @@ -72,4 +72,6 @@ (when (context-triggered? ctx name) (run-handler ctx handler)))) (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))) diff --git a/tryme.scm b/tryme.scm index 7428ac8..ac49dbf 100644 --- a/tryme.scm +++ b/tryme.scm @@ -36,19 +36,14 @@ (task "Create test file from string content" (bind-context-vars (base-dir) - (install-file (file-name-join* base-dir "foo") #:content "Hello, world!\n"))) - (task "Create test file from local source" - (bind-context-vars - (base-dir) - (install-file (file-name-join* base-dir "bar") #:local-src (file-name-join* base-dir "foo"))) - #:triggers '(fritz)) - (task "Create test file from remote source" - (bind-context-vars - (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)))))) + (install-file (file-name-join* base-dir "foo") #:content "Hello, world!\n")) + #:register 'foo) + (task "Get file status" + (bind-context-vars (foo) (fs:stat foo)) + #:register 'stat-out + #:triggers '(display-stat))) + #:handlers `((display-stat . ,(handler "Display stat" + (bind-context-vars (foo stat-out) (lambda _ (pk foo stat-out)))))))) + (run-play test-play)