From de18c1d771ae7bc7d2d600c37f1f473c55f712eb Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 22 Jan 2025 09:49:59 +0000 Subject: [PATCH] Make actions take conn argument ...rather than using (current-connection). Rework apt module with a helper macro. --- modules/ordo/action/apt.scm | 56 ++++++++------------ modules/ordo/action/filesystem.scm | 85 ++++++++++++++---------------- 2 files changed, 63 insertions(+), 78 deletions(-) diff --git a/modules/ordo/action/apt.scm b/modules/ordo/action/apt.scm index 60a2648..6a19462 100644 --- a/modules/ordo/action/apt.scm +++ b/modules/ordo/action/apt.scm @@ -1,52 +1,42 @@ (define-module (ordo action apt) - #:use-module ((ordo connection) #:select (run)) - #:use-module ((ordo context) #:select (current-connection))) + #:use-module ((ordo connection) #:select (run))) (define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive") ("APT_LISTCHANGES_FRONTEND" . "none"))) -(define (apt-get . args) - (lambda () - (run (current-connection) "apt-get" (cons* "-q" "-y" args) #:env noninteractive-env))) +(define-syntax define-apt-operation + (syntax-rules () + ((define-apt-operation (name args ...) apt-args ...) + (define-public (name conn args ...) + (run conn "apt-get" "-q" "-y" apt-args ... args ... #:env noninteractive-env))) + ((define-apt-operation name apt-args ...) + (define-public (name conn) + (run conn "apt-get" "-q" "-y" apt-args ... #:env noninteractive-env))))) -(define-public (action:apt-update) - (apt-get "update")) +(define-apt-operation apt:update "update") -(define-public (action:apt-upgrade) - (apt-get "upgrade")) +(define-apt-operation apt:upgrade "upgrade") -(define-public (action:apt-dist-upgrade) - (apt-get "dist-upgrade")) +(define-apt-operation apt:dist-upgrade "dist-upgrade") -(define-public (action:apt-install package-name) - (apt-get "install" package-name)) +(define-apt-operation (apt:install package-name) "install") -(define-public (action:apt-install-minimal package-name) - (apt-get "install" "--no-install-recommends" package-name)) +(define-apt-operation (apt:install-minimal package-name) "install" "--no-install-recommends") -(define-public (action:apt-reinstall package-name) - (apt-get "reinstall" package-name)) +(define-apt-operation (apt:reinstall package-name) "reinstall") -(define-public (action:apt-remove package-name) - (apt-get "remove" package-name)) +(define-apt-operation (apt:remove package-name) "remove") -(define-public (action:apt-purge package-name) - (apt-get "purge" package-name)) +(define-apt-operation (apt:purge package-name) "purge") -(define-public (action:apt-build-dep package-name) - (apt-get "build-dep" package-name)) +(define-apt-operation (apt:build-dep package-name) "build-dep") -(define-public (action:apt-clean) - (apt-get "clean")) +(define-apt-operation apt:clean "clean") -(define-public (action:apt-autoclean) - (apt-get "autoclean")) +(define-apt-operation apt:autoclean "autoclean") -(define-public (action:apt-distclean) - (apt-get "distclean")) +(define-apt-operation apt:distclean "distclean") -(define-public (action:apt-autoremove) - (apt-get "autoremove")) +(define-apt-operation apt:autoremove "autoremove") -(define-public (action:apt-autopurge) - (apt-get "autoperge")) +(define-apt-operation apt:autopurge "autopurge") diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 5d4cfa5..5989e65 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -8,7 +8,6 @@ #:use-module (srfi srfi-71) ; extended let #:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module ((ordo connection) #:select (run)) - #:use-module ((ordo context) #:select (current-connection)) #:export (fs:create-tmp-dir fs:install-dir fs:install-file @@ -16,7 +15,7 @@ fs:remove fs:link)) -(define (fs:stat path) +(define (fs:stat conn 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))) @@ -30,57 +29,53 @@ (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)))) + (let ((result rc (run conn "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* (fs: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)))) +(define* (fs:remove conn path #:key (recurse? #f) (force? #f) (verbose? #t)) + (run conn "rm" (chain-when '() + (verbose? (append _ '("-v"))) + (recurse? (append _ '("-r"))) + (force? (append _ '("-f"))) + (#t (append _ `(,path)))) #:check? #t)) -(define* (fs:link target link-name #:key (symbolic? #f) (force? #f) (backup? #f)) +(define* (fs:link conn 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)))) + (run conn "ln" (chain-when '() + (symbolic? (append _ '("--symbolic"))) + (force? (append _ '("--force"))) + (backup? (append _ '("--backup" "numbered"))) + (#t (append `(,target ,link-name)))) #:check? #t)) -(define* (fs: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)))) +(define* (fs:create-tmp-dir conn #:key tmpdir suffix template) + (match-let (((tmp-dir) (run conn "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template)))) #:check? #t))) tmp-dir)) -(define* (fs:install-dir path #:key owner group mode) +(define* (fs:install-dir conn path #:key owner group 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)))) + (run conn "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) +(define (upload-tmp-file conn tmp-file) (lambda (input-port) - (connection-call-with-output-file (current-connection) tmp-file + (connection-call-with-output-file conn tmp-file (lambda (output-port) (let loop ((data (get-bytevector-some input-port))) (unless (eof-object? data) @@ -88,18 +83,18 @@ (loop (get-bytevector-some input-port)))) (close-port output-port))))) -(define (install-remote-file src dest owner group mode backup?) +(define (install-remote-file conn 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 (fs:stat dest))) + (let ((st (fs:stat conn 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) + (run conn "install" (chain-when '() (owner (append _ `("--owner" ,owner))) @@ -109,24 +104,24 @@ (#t (append _ (list src dest)))) #:check? #t)) -(define* (fs:install-file path #:key owner group mode content local-src remote-src backup?) +(define* (fs:install-file conn 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?) + (install-remote-file conn 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))) + (let ((tmp-file (run conn "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))) + (local-src (call-with-input-file local-src (upload-tmp-file conn tmp-file))) + ((string? content) (call-with-input-string content (upload-tmp-file conn tmp-file))) + ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn tmp-file))) (else (error "unsupported type for #:content"))) - (install-remote-file tmp-file path owner group mode backup?)) + (install-remote-file conn tmp-file path owner group mode backup?)) (lambda () - (fs:remove tmp-file #:force? #t))))) + (fs:remove conn tmp-file #:force? #t))))) path)