Rework actions for new context implementation
This commit is contained in:
parent
1843544e49
commit
47b63da25e
GPG key ID:
043F786C4CD681B8
2 changed files with 84 additions and 77 deletions
|
|
@ -1,12 +1,12 @@
|
|||
(define-module (ordo action apt)
|
||||
#:use-module (ordo context))
|
||||
#:use-module (ordo))
|
||||
|
||||
(define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive")
|
||||
("APT_LISTCHANGES_FRONTEND" . "none")))
|
||||
|
||||
(define (apt-get . args)
|
||||
(lambda (ctx)
|
||||
(must ctx "apt-get" (cons* "-q" "-y" args) #:env noninteractive-env)))
|
||||
(lambda ()
|
||||
(run (current-connection) "apt-get" (cons* "-q" "-y" args) #:env noninteractive-env)))
|
||||
|
||||
(define-public (action:apt-update)
|
||||
(apt-get "update"))
|
||||
|
|
|
|||
|
|
@ -7,8 +7,7 @@
|
|||
#: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)
|
||||
#:use-module (ordo)
|
||||
#:export (action:create-tmp-dir
|
||||
action:install-dir
|
||||
action:install-file
|
||||
|
|
@ -30,61 +29,68 @@
|
|||
(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))))))))
|
||||
(let ((result rc (run (current-connection) "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)))))))
|
||||
|
||||
(define* (action:remove path #:key (recurse? #f) (force? #f) (verbose? #t))
|
||||
(lambda (ctx)
|
||||
(must ctx "rm" (chain-when '()
|
||||
(verbose? (append _ '("-v")))
|
||||
(recurse? (append _ '("-r")))
|
||||
(force? (append _ '("-f")))
|
||||
(#t (append _ `(,path)))))))
|
||||
(run (current-connection)
|
||||
"rm" (chain-when '()
|
||||
(verbose? (append _ '("-v")))
|
||||
(recurse? (append _ '("-r")))
|
||||
(force? (append _ '("-f")))
|
||||
(#t (append _ `(,path))))
|
||||
#:check? #t))
|
||||
|
||||
(define* (action:link target link-name #:key (symbolic? #f) (force? #f) (backup? #f))
|
||||
"Create a link to @code{target} with the name @code{link-name}."
|
||||
(must ctx "ln" (chain-when '()
|
||||
(symbolic? (append _ '("--symbolic")))
|
||||
(force? (append _ '("--force")))
|
||||
(backup? (append _ '("--backup" "numbered")))
|
||||
(#t (append `(,target ,link-name))))))
|
||||
(run (current-connection)
|
||||
"ln" (chain-when '()
|
||||
(symbolic? (append _ '("--symbolic")))
|
||||
(force? (append _ '("--force")))
|
||||
(backup? (append _ '("--backup" "numbered")))
|
||||
(#t (append `(,target ,link-name))))
|
||||
#:check? #t))
|
||||
|
||||
(define* (action:create-tmp-dir #:key tmpdir suffix template)
|
||||
(lambda (ctx)
|
||||
(match-let (((tmp-dir) (must ctx "mktemp" (chain-when
|
||||
'("--directory")
|
||||
(tmpdir (append _ `("--tmpdir" tmpdir)))
|
||||
(suffix (append _ `("--suffix" suffix)))
|
||||
(template (append _ `(template)))))))
|
||||
tmp-dir)))
|
||||
(match-let (((tmp-dir) (run (current-connection)
|
||||
"mktemp" (chain-when
|
||||
'("--directory")
|
||||
(tmpdir (append _ `("--tmpdir" tmpdir)))
|
||||
(suffix (append _ `("--suffix" suffix)))
|
||||
(template (append _ `(template))))
|
||||
#:check? #t)))
|
||||
tmp-dir))
|
||||
|
||||
(define* (action:install-dir path #:key owner group mode)
|
||||
(lambda (ctx)
|
||||
;; If owner/group/mode is unspecified and the destination directory already exists,
|
||||
;; preserve the current ownership and mode.
|
||||
(unless (and owner group mode)
|
||||
(let ((st ((action:stat path) ctx)))
|
||||
(when st
|
||||
(set! owner (or owner (assoc-ref st 'user)))
|
||||
(set! group (or group (assoc-ref st 'group)))
|
||||
(set! mode (or mode (assoc-ref st 'mode))))))
|
||||
(when (integer? mode)
|
||||
(set! mode (number->string mode 8)))
|
||||
(must ctx "install" (chain-when
|
||||
'("--directory")
|
||||
(owner (append _ `("--owner" ,owner)))
|
||||
(group (append _ `("--group" ,group)))
|
||||
(mode (append _ `("--mode" ,mode)))
|
||||
(#t (append _ `(,path)))))
|
||||
path))
|
||||
;; If owner/group/mode is unspecified and the destination directory already exists,
|
||||
;; preserve the current ownership and mode.
|
||||
;; TODO: this does not make much sense: if the object exists but is not a directory
|
||||
;; then the install will fail. If the object exists an *is* a directory, then we
|
||||
;; should just chmod/chown it.
|
||||
(unless (and owner group mode)
|
||||
(let ((st (action:stat path)))
|
||||
(when st
|
||||
(set! owner (or owner (assoc-ref st 'user)))
|
||||
(set! group (or group (assoc-ref st 'group)))
|
||||
(set! mode (or mode (assoc-ref st 'mode))))))
|
||||
(when (integer? mode)
|
||||
(set! mode (number->string mode 8)))
|
||||
(run (current-connection)
|
||||
"install" (chain-when
|
||||
'("--directory")
|
||||
(owner (append _ `("--owner" ,owner)))
|
||||
(group (append _ `("--group" ,group)))
|
||||
(mode (append _ `("--mode" ,mode)))
|
||||
(#t (append _ `(,path))))
|
||||
#:check? #t)
|
||||
path)
|
||||
|
||||
(define (upload-tmp-file ctx tmp-file)
|
||||
(define (upload-tmp-file tmp-file)
|
||||
(lambda (input-port)
|
||||
(connection-call-with-output-file (context-connection ctx) tmp-file
|
||||
(connection-call-with-output-file (current-connection) tmp-file
|
||||
(lambda (output-port)
|
||||
(let loop ((data (get-bytevector-some input-port)))
|
||||
(unless (eof-object? data)
|
||||
|
|
@ -92,44 +98,45 @@
|
|||
(loop (get-bytevector-some input-port))))
|
||||
(close-port output-port)))))
|
||||
|
||||
(define (install-remote-file ctx src dest owner group mode backup?)
|
||||
(define (install-remote-file src dest owner group mode backup?)
|
||||
;; If owner/group/mode is unspecified and the destination file already exists,
|
||||
;; preserve the current ownership and mode.
|
||||
(unless (and owner group mode)
|
||||
(let ((st ((action:stat dest) ctx)))
|
||||
(let ((st (action:stat dest)))
|
||||
(when st
|
||||
(set! owner (or owner (assoc-ref st 'owner)))
|
||||
(set! group (or group (assoc-ref st 'group)))
|
||||
(set! mode (or mode (assoc-ref st 'mode))))))
|
||||
(when (integer? mode)
|
||||
(set! mode (number->string mode 8)))
|
||||
(must ctx "install" (chain-when
|
||||
'()
|
||||
(owner (append _ `("--owner" ,owner)))
|
||||
(group (append _ `("--group" ,group)))
|
||||
(mode (append _ `("--mode" ,mode)))
|
||||
(backup? (append _ '("--backup" "numbered")))
|
||||
(#t (append _ (list src dest))))))
|
||||
(run (current-connection)
|
||||
"install" (chain-when
|
||||
'()
|
||||
(owner (append _ `("--owner" ,owner)))
|
||||
(group (append _ `("--group" ,group)))
|
||||
(mode (append _ `("--mode" ,mode)))
|
||||
(backup? (append _ '("--backup" "numbered")))
|
||||
(#t (append _ (list src dest))))
|
||||
#:check? #t))
|
||||
|
||||
(define* (action: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 (ctx)
|
||||
(if remote-src
|
||||
(install-remote-file ctx remote-src path owner group mode backup?)
|
||||
;; Because we might need sudo to install the remote file, we first
|
||||
;; upload the source to a temporary file, then call @code{install-remote-file} to
|
||||
;; install the temporary file to the target path.
|
||||
(match-let (((tmp-file) (must ctx "mktemp" '())))
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda ()
|
||||
(cond
|
||||
(local-src (call-with-input-file local-src (upload-tmp-file ctx tmp-file)))
|
||||
((string? content) (call-with-input-string content (upload-tmp-file ctx tmp-file)))
|
||||
((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx tmp-file)))
|
||||
(else (error "unsupported type for #:content")))
|
||||
(install-remote-file ctx tmp-file path owner group mode backup?))
|
||||
(lambda ()
|
||||
((action:remove tmp-file #:force? #t) ctx)))))
|
||||
path))
|
||||
(if remote-src
|
||||
(install-remote-file remote-src path owner group mode backup?)
|
||||
;; Because we might need sudo to install the remote file, we first
|
||||
;; upload the source to a temporary file, then call @code{install-remote-file} to
|
||||
;; install the temporary file to the target path.
|
||||
(let ((tmp-file (run (current-connection) "mktemp" #:check? #t #:result car)))
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda ()
|
||||
(cond
|
||||
(local-src (call-with-input-file local-src (upload-tmp-file tmp-file)))
|
||||
((string? content) (call-with-input-string content (upload-tmp-file tmp-file)))
|
||||
((bytevector? content) (call-with-input-bytevector content (upload-tmp-file tmp-file)))
|
||||
(else (error "unsupported type for #:content")))
|
||||
(install-remote-file tmp-file path owner group mode backup?))
|
||||
(lambda ()
|
||||
(action:remove tmp-file #:force? #t)))))
|
||||
path)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue