Ray Miller
52f011267b
* Don't export record field setters (unless required) * Remove get- prefix from record getters * Introduce handlers (simplified tasks)
64 lines
3.5 KiB
Scheme
64 lines
3.5 KiB
Scheme
(define-module (ordo action filesystem)
|
|
#:use-module (ice-9 binary-ports)
|
|
#:use-module (rnrs bytevectors)
|
|
#: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)
|
|
#:export (create-temporary-directory
|
|
install-directory
|
|
install-file))
|
|
|
|
(define* (create-temporary-directory #:key tmpdir suffix template)
|
|
(lambda (conn ctx)
|
|
(connection-must conn "mktemp" (chain-when
|
|
'("--directory")
|
|
(tmpdir (append _ `("--tmpdir" tmpdir)))
|
|
(suffix (append _ `("--suffix" suffix)))
|
|
(template (append _ `(template)))
|
|
(#t (resolve-context-refs ctx _))))))
|
|
|
|
(define* (install-directory path #:key owner group mode)
|
|
(lambda (conn ctx)
|
|
(connection-must conn "install" (chain-when
|
|
'("--directory")
|
|
(owner (append _ `("--owner" ,owner)))
|
|
(group (append _ `("--group" ,group)))
|
|
(mode (append _ `("--mode" ,mode)))
|
|
(#t (append _ `(,path)))
|
|
(#t (resolve-context-refs ctx _))))))
|
|
|
|
;; Helper not intended for use outside of this module
|
|
(define (upload-tmp-file conn ctx)
|
|
(lambda (input-port)
|
|
(let ((tmp-path (car (connection-must conn "mktemp" `("-p" ,(context-scratch-dir ctx))))))
|
|
(connection-call-with-output-file conn 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 (conn ctx)
|
|
(let ((remote-src (cond
|
|
(remote-src remote-src)
|
|
(local-src (call-with-input-file local-src (upload-tmp-file conn ctx)))
|
|
((string? content) (call-with-input-string content (upload-tmp-file conn ctx)))
|
|
((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn ctx)))
|
|
(else (error "unsupported type for #:content")))))
|
|
(connection-must conn "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)))
|
|
(#t (resolve-context-refs ctx _)))))))
|