ray/ordo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Rework actions for new context implementation

Browse source
This commit is contained in:
Ray Miller 2025-01-21 20:57:17 +00:00
parent 1843544e49
commit 47b63da25e
Signed by: ray
GPG key ID: 043F786C4CD681B8
2 changed files with 84 additions and 77 deletions
Download patch file Download diff file Expand all files Collapse all files

6
modules/ordo/action/apt.scm
View file

@ -1,12 +1,12 @@
(define-module (ordo action apt) (define-module (ordo action apt)
#:use-module (ordo context)) #:use-module (ordo))
(define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive") (define noninteractive-env '(("DEBIAN_FRONTEND" . "noninteractive")
("APT_LISTCHANGES_FRONTEND" . "none"))) ("APT_LISTCHANGES_FRONTEND" . "none")))
(define (apt-get . args) (define (apt-get . args)
(lambda (ctx) (lambda ()
(must ctx "apt-get" (cons* "-q" "-y" args) #:env noninteractive-env))) (run (current-connection) "apt-get" (cons* "-q" "-y" args) #:env noninteractive-env)))
(define-public (action:apt-update) (define-public (action:apt-update)
(apt-get "update")) (apt-get "update"))

155
modules/ordo/action/filesystem.scm
View file

@ -7,8 +7,7 @@
#:use-module (srfi srfi-26) ; cut #:use-module (srfi srfi-26) ; cut
#:use-module (srfi srfi-71) ; extended let #:use-module (srfi srfi-71) ; extended let
#:use-module ((srfi srfi-197) #:select (chain-when)) #:use-module ((srfi srfi-197) #:select (chain-when))
#:use-module (ordo connection) #:use-module (ordo)
#:use-module (ordo context)
#:export (action:create-tmp-dir #:export (action:create-tmp-dir
action:install-dir action:install-dir
action:install-file action:install-file
@ -30,61 +29,68 @@
(atime . ,atime) (atime . ,atime)
(mtime . ,mtime) (mtime . ,mtime)
(ctime . ,ctime)))) (ctime . ,ctime))))
(lambda (ctx) (let ((result rc (run (current-connection) "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path))))
(let ((result rc (run ctx "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path)))) (cond
(cond ((zero? rc) (parse-stat-result (first result)))
((zero? rc) (parse-stat-result (first result))) ((string-contains (first result) "No such file or directory") #f)
((string-contains (first result) "No such file or directory") #f) (else (error (format #f "stat ~a: ~a" path (first result)))))))
(else (error (format #f "stat ~a: ~a" path (first result))))))))
(define* (action:remove path #:key (recurse? #f) (force? #f) (verbose? #t)) (define* (action:remove path #:key (recurse? #f) (force? #f) (verbose? #t))
(lambda (ctx) (run (current-connection)
(must ctx "rm" (chain-when '() "rm" (chain-when '()
(verbose? (append _ '("-v"))) (verbose? (append _ '("-v")))
(recurse? (append _ '("-r"))) (recurse? (append _ '("-r")))
(force? (append _ '("-f"))) (force? (append _ '("-f")))
(#t (append _ `(,path))))))) (#t (append _ `(,path))))
#:check? #t))
(define* (action:link target link-name #:key (symbolic? #f) (force? #f) (backup? #f)) (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}." "Create a link to @code{target} with the name @code{link-name}."
(must ctx "ln" (chain-when '() (run (current-connection)
(symbolic? (append _ '("--symbolic"))) "ln" (chain-when '()
(force? (append _ '("--force"))) (symbolic? (append _ '("--symbolic")))
(backup? (append _ '("--backup" "numbered"))) (force? (append _ '("--force")))
(#t (append `(,target ,link-name)))))) (backup? (append _ '("--backup" "numbered")))
(#t (append `(,target ,link-name))))
#:check? #t))
(define* (action:create-tmp-dir #:key tmpdir suffix template) (define* (action:create-tmp-dir #:key tmpdir suffix template)
(lambda (ctx) (match-let (((tmp-dir) (run (current-connection)
(match-let (((tmp-dir) (must ctx "mktemp" (chain-when "mktemp" (chain-when
'("--directory") '("--directory")
(tmpdir (append _ `("--tmpdir" tmpdir))) (tmpdir (append _ `("--tmpdir" tmpdir)))
(suffix (append _ `("--suffix" suffix))) (suffix (append _ `("--suffix" suffix)))
(template (append _ `(template))))))) (template (append _ `(template))))
tmp-dir))) #:check? #t)))
tmp-dir))
(define* (action:install-dir path #:key owner group mode) (define* (action:install-dir path #:key owner group mode)
(lambda (ctx) ;; If owner/group/mode is unspecified and the destination directory already exists,
;; If owner/group/mode is unspecified and the destination directory already exists, ;; preserve the current ownership and mode.
;; preserve the current ownership and mode. ;; TODO: this does not make much sense: if the object exists but is not a directory
(unless (and owner group mode) ;; then the install will fail. If the object exists an *is* a directory, then we
(let ((st ((action:stat path) ctx))) ;; should just chmod/chown it.
(when st (unless (and owner group mode)
(set! owner (or owner (assoc-ref st 'user))) (let ((st (action:stat path)))
(set! group (or group (assoc-ref st 'group))) (when st
(set! mode (or mode (assoc-ref st 'mode)))))) (set! owner (or owner (assoc-ref st 'user)))
(when (integer? mode) (set! group (or group (assoc-ref st 'group)))
(set! mode (number->string mode 8))) (set! mode (or mode (assoc-ref st 'mode))))))
(must ctx "install" (chain-when (when (integer? mode)
'("--directory") (set! mode (number->string mode 8)))
(owner (append _ `("--owner" ,owner))) (run (current-connection)
(group (append _ `("--group" ,group))) "install" (chain-when
(mode (append _ `("--mode" ,mode))) '("--directory")
(#t (append _ `(,path))))) (owner (append _ `("--owner" ,owner)))
path)) (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) (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) (lambda (output-port)
(let loop ((data (get-bytevector-some input-port))) (let loop ((data (get-bytevector-some input-port)))
(unless (eof-object? data) (unless (eof-object? data)
@ -92,44 +98,45 @@
(loop (get-bytevector-some input-port)))) (loop (get-bytevector-some input-port))))
(close-port output-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, ;; If owner/group/mode is unspecified and the destination file already exists,
;; preserve the current ownership and mode. ;; preserve the current ownership and mode.
(unless (and owner group mode) (unless (and owner group mode)
(let ((st ((action:stat dest) ctx))) (let ((st (action:stat dest)))
(when st (when st
(set! owner (or owner (assoc-ref st 'owner))) (set! owner (or owner (assoc-ref st 'owner)))
(set! group (or group (assoc-ref st 'group))) (set! group (or group (assoc-ref st 'group)))
(set! mode (or mode (assoc-ref st 'mode)))))) (set! mode (or mode (assoc-ref st 'mode))))))
(when (integer? mode) (when (integer? mode)
(set! mode (number->string mode 8))) (set! mode (number->string mode 8)))
(must ctx "install" (chain-when (run (current-connection)
'() "install" (chain-when
(owner (append _ `("--owner" ,owner))) '()
(group (append _ `("--group" ,group))) (owner (append _ `("--owner" ,owner)))
(mode (append _ `("--mode" ,mode))) (group (append _ `("--group" ,group)))
(backup? (append _ '("--backup" "numbered"))) (mode (append _ `("--mode" ,mode)))
(#t (append _ (list src dest)))))) (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?) (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))))) (when (not (= 1 (length (filter identity (list content local-src remote-src)))))
(error "exactly one of #:content, #:local-src, or #:remote-src is required")) (error "exactly one of #:content, #:local-src, or #:remote-src is required"))
(lambda (ctx) (if remote-src
(if remote-src (install-remote-file remote-src path owner group mode backup?)
(install-remote-file ctx remote-src path owner group mode backup?) ;; Because we might need sudo to install the remote file, we first
;; 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
;; upload the source to a temporary file, then call @code{install-remote-file} to ;; install the temporary file to the target path.
;; install the temporary file to the target path. (let ((tmp-file (run (current-connection) "mktemp" #:check? #t #:result car)))
(match-let (((tmp-file) (must ctx "mktemp" '()))) (dynamic-wind
(dynamic-wind (const #t)
(const #t) (lambda ()
(lambda () (cond
(cond (local-src (call-with-input-file local-src (upload-tmp-file tmp-file)))
(local-src (call-with-input-file local-src (upload-tmp-file ctx tmp-file))) ((string? content) (call-with-input-string content (upload-tmp-file 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 tmp-file)))
((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx tmp-file))) (else (error "unsupported type for #:content")))
(else (error "unsupported type for #:content"))) (install-remote-file tmp-file path owner group mode backup?))
(install-remote-file ctx tmp-file path owner group mode backup?)) (lambda ()
(lambda () (action:remove tmp-file #:force? #t)))))
((action:remove tmp-file #:force? #t) ctx))))) path)
path))