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

Make actions take conn argument

Browse source 
...rather than using (current-connection).

Rework apt module with a helper macro.
This commit is contained in:
Ray Miller 2025-01-22 09:49:59 +00:00
parent c126639016
commit de18c1d771
Signed by: ray
GPG key ID: 043F786C4CD681B8
2 changed files with 63 additions and 78 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -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")

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

@ -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)