From 47b63da25ef7e692558c7f6801cbfb912162cec0 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Tue, 21 Jan 2025 20:57:17 +0000 Subject: [PATCH] Rework actions for new context implementation --- modules/ordo/action/apt.scm | 6 +- modules/ordo/action/filesystem.scm | 155 +++++++++++++++-------------- 2 files changed, 84 insertions(+), 77 deletions(-) diff --git a/modules/ordo/action/apt.scm b/modules/ordo/action/apt.scm index 7cb7fd4..fc05ef7 100644 --- a/modules/ordo/action/apt.scm +++ b/modules/ordo/action/apt.scm @@ -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")) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index eaac534..f433940 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -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)