142 lines
6.3 KiB
Scheme
142 lines
6.3 KiB
Scheme
(define-module (ordo action filesystem)
|
|
#:use-module (ice-9 binary-ports)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (logging logger)
|
|
#: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))
|
|
#:use-module (ordo)
|
|
#:export (action:create-tmp-dir
|
|
action:install-dir
|
|
action:install-file
|
|
action:stat
|
|
action:remove
|
|
action:link))
|
|
|
|
(define (action: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))))
|
|
(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))
|
|
(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}."
|
|
(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)
|
|
(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)
|
|
;; 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 tmp-file)
|
|
(lambda (input-port)
|
|
(connection-call-with-output-file (current-connection) tmp-file
|
|
(lambda (output-port)
|
|
(let loop ((data (get-bytevector-some input-port)))
|
|
(unless (eof-object? data)
|
|
(put-bytevector output-port data)
|
|
(loop (get-bytevector-some input-port))))
|
|
(close-port output-port)))))
|
|
|
|
(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)))
|
|
(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)))
|
|
(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"))
|
|
(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)
|