From 0550ab5b60f5b92ed925ab60fbf9f743b4e6d746 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Fri, 10 Jan 2025 16:02:21 +0000 Subject: [PATCH] Update filesystem actions * Prefix all the exported actions with "action:" * Add new actions for remove, link * Make install-file and install-dir preserve the owner/group/mode of the original unless there's an explicit override * Remove use of context scratch-dir --- modules/ordo/action/filesystem.scm | 164 +++++++++++++++++++---------- 1 file changed, 106 insertions(+), 58 deletions(-) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 76b094e..12a940a 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -8,63 +8,14 @@ #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module (ordo connection) #:use-module (ordo context) - #:export (create-temporary-directory - install-directory - install-file - fs:stat)) + #:export (action:create-tmp-dir + action:install-dir + action:install-file + action:stat + action:remove + action:link)) -(define* (create-temporary-directory #:key tmpdir suffix template) - (lambda (ctx) - (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) - (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 (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))) - (unless (eof-object? data) - (put-bytevector output-port data) - (loop (get-bytevector-some input-port)))) - (close-port output-port))) - tmp-path))) - -;; Because we might need sudo to install the remote file, we first -;; upload the source to a temporary file. -(define* (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) - (let ((remote-src (cond - (remote-src remote-src) - (local-src (call-with-input-file local-src (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))) - (else (error "unsupported type for #:content"))))) - (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 (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))) @@ -81,6 +32,103 @@ (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) + ((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))))))) + +(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)))))) + +(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))) + +(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)) + +(define (upload-tmp-file ctx tmp-file) + (lambda (input-port) + (connection-call-with-output-file (context-connection ctx) 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 ctx 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))) + (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)))))) + +(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))