Some refactoring, and implement stat
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:
parent
3153469a2c
commit
93820dc307
GPG key ID:
043F786C4CD681B8
5 changed files with 78 additions and 57 deletions
|
|
@ -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))))))))
|
||||
|
|
|
|||
|
|
@ -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 <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))
|
||||
(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 <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))
|
||||
(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 <local-connection>) (filename <string>) (proc <procedure>))
|
||||
(call-with-input-file filename proc))
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <context>
|
||||
(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))))))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
23
tryme.scm
23
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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue