diff options
author | Sean Whitton <spwhitton@spwhitton.name> | 2021-02-26 22:54:11 -0700 |
---|---|---|
committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-02-27 13:39:52 -0700 |
commit | db2879636b809e34efc9397c19b646a2695beb51 (patch) | |
tree | 5ea4300b201553e34d845af7870deb4da23cda2f | |
parent | 2e1599f51c803560b6b9063fd8ae95d62a601b62 (diff) | |
download | consfigurator-db2879636b809e34efc9397c19b646a2695beb51.tar.gz |
attempt to implement umask support for CONNECTION-WRITEFILE
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
-rw-r--r-- | consfigurator.asd | 3 | ||||
-rw-r--r-- | src/connection.lisp | 26 | ||||
-rw-r--r-- | src/connection/local.lisp | 32 | ||||
-rw-r--r-- | src/connection/shell-wrap.lisp | 18 | ||||
-rw-r--r-- | src/data.lisp | 4 | ||||
-rw-r--r-- | src/package.lisp | 3 | ||||
-rw-r--r-- | src/property/file.lisp | 5 |
7 files changed, 65 insertions, 26 deletions
diff --git a/consfigurator.asd b/consfigurator.asd index 35d7296..f651cc9 100644 --- a/consfigurator.asd +++ b/consfigurator.asd @@ -8,7 +8,8 @@ #:babel #:babel-streams #:cl-ppcre - #:cl-interpol) + #:cl-interpol + #:cffi) :components ((:file "src/package") (:file "src/util") (:file "src/connection") diff --git a/src/connection.lisp b/src/connection.lisp index ce5adf0..47356c0 100644 --- a/src/connection.lisp +++ b/src/connection.lisp @@ -16,6 +16,7 @@ ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. (in-package :consfigurator) +(named-readtables:in-readtable :interpol-syntax) ;;;; Connections @@ -92,7 +93,7 @@ error condition just because EXIT is non-zero.")) ;; take: a string vs. a path. for a given connection type, they may have same ;; or different implementations. -(defgeneric connection-writefile (connection path input) +(defgeneric connection-writefile (connection path input umask) (:documentation "Subroutine to replace/create the contents of files on the host. @@ -101,8 +102,11 @@ INPUT is the new contents of the file or a stream which will produce it. Implementations can specialise on both the CONNECTION and INPUT arguments, if they need to handle streams and strings differently.")) -(defmethod connection-writefile :around ((connection connection) path contents) - (declare (ignore path contents)) +(defmethod connection-writefile :around ((connection connection) + path + content + umask) + (declare (ignore path content umask)) (let ((*connection* (slot-value connection 'parent))) (call-next-method))) @@ -257,8 +261,20 @@ start with RUN." (defun readfile (&rest args) (apply #'connection-readfile *connection* args)) -(defun writefile (&rest args) - (apply #'connection-writefile *connection* args)) +(defun writefile (path content &key try-preserve (umask #o022)) + (if (and try-preserve (test "-f" path)) + (destructuring-bind (umode gmode wmode uid gid) + ;; seems there is nothing like stat(1) in POSIX + (re:all-matches-as-strings + #?/^.(...)(...)(...).[0-9]+ ([0-9]+) ([0-9]+) / + (mrun "ls" "-nd" path)) + (connection-writefile *connection* path content umask) + (let ((path (escape-sh-token path))) + ;; assume that if we can write it we can chmod it + (mrun #?"chmod u=${umode},g=${gmode},w=${wmode} ${path}") + ;; we may not be able to chown; that's okay + (mrun :may-fail #?"chown ${uid}:${gid} ${path}"))) + (connection-writefile *connection* path content umask))) (defvar *host* nil "Object representing the host at the end of the current connection chain. diff --git a/src/connection/local.lisp b/src/connection/local.lisp index 5f5c260..613a827 100644 --- a/src/connection/local.lisp +++ b/src/connection/local.lisp @@ -44,20 +44,34 @@ root Lisp is running on, as the root Lisp's uid.")) (defmethod connection-readfile ((connection local-connection) path) (read-file-string path)) +(defcfun "umask" :int (mode :int)) + +(defmacro with-umask ((umask) &body forms) + (with-gensyms (old) + `(let ((,old (umask ,umask))) + (unwind-protect + (progn ,@forms) + (umask ,old))))) + (defmethod connection-writefile ((connection local-connection) path - (contents string)) - (with-open-file (stream path :direction :output :if-exists :supersede) - (write-string contents stream))) + (contents string) + umask) + (with-umask (umask) + (with-open-file (stream path :direction :output :if-exists :supersede) + (write-string contents stream)))) (defmethod connection-writefile ((connection local-connection) path - (contents stream)) - (with-open-file (stream path :direction :output - :if-exists :supersede - :element-type (stream-element-type contents)) - (copy-stream-to-stream contents stream - :element-type (stream-element-type contents)))) + (contents stream) + umask + &aux + (type (stream-element-type contents))) + (with-umask (umask) + (with-open-file (stream path :direction :output + :if-exists :supersede + :element-type type) + (copy-stream-to-stream contents stream :element-type type)))) (defmethod connection-upload ((connection local-connection) from to) (copy-file from to)) diff --git a/src/connection/shell-wrap.lisp b/src/connection/shell-wrap.lisp index 883757b..70d094c 100644 --- a/src/connection/shell-wrap.lisp +++ b/src/connection/shell-wrap.lisp @@ -31,10 +31,16 @@ (connection-run c #?"test -r ${path} && cat ${path}" nil)) (if (= 0 exit) out (error "File ~S not readable" path)))) -(defmethod connection-writefile ((conn shell-wrap-connection) path contents) +(defmethod connection-writefile ((conn shell-wrap-connection) + path + contents + umask) (with-remote-temporary-file (temp) - (connection-run conn #?"cat >${temp}" contents) - (connection-run - conn - #?"mv ${(escape-sh-token temp)} ${(escape-sh-token path)}" - nil))) + (connection-run conn + (if umask + (format nil "( umask ~O; cat >~A )" umask temp) + #?"cat >${temp}") + contents) + (connection-run conn + #?"mv ${(escape-sh-token temp)} ${(escape-sh-token path)}" + nil))) diff --git a/src/data.lisp b/src/data.lisp index 8bb81f3..96ef6a6 100644 --- a/src/data.lisp +++ b/src/data.lisp @@ -268,7 +268,7 @@ appropriate. Falls back to CONNECTION-WRITEFILE." nil)) (connection-upload *connection* from to) (with-open-file (s from :element-type '(unsigned-byte 8)) - (connection-writefile *connection* to s)))) + (connection-writefile *connection* to s #o077)))) (defmethod connection-upload-data :around ((data data)) (when (subtypep (class-of *connection*) @@ -300,7 +300,7 @@ appropriate. Falls back to CONNECTION-WRITEFILE." (defmethod connection-upload-data ((data string-data)) (declare (special *dest*)) - (connection-writefile *connection* *dest* (data-string data))) + (connection-writefile *connection* *dest* (data-string data) #o077)) (defun connection-clear-data-cache (iden1 iden2) (let ((dir (ensure-directory-pathname (remote-data-pathname iden1 iden2)))) diff --git a/src/package.lisp b/src/package.lisp index 032d652..d3bd27f 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -2,6 +2,7 @@ (defpackage :consfigurator (:use #:cl #:alexandria) + (:local-nicknames (#:re #:cl-ppcre)) (:shadowing-import-from #:uiop #:strcat #:string-prefix-p @@ -144,7 +145,7 @@ #:consfigurator.connection.shell-wrap)) (defpackage :consfigurator.connection.local - (:use #:cl #:consfigurator #:alexandria) + (:use #:cl #:consfigurator #:alexandria #:cffi) (:export #:local-connection)) (defpackage :consfigurator.connection.debian-sbcl diff --git a/src/property/file.lisp b/src/property/file.lisp index ace5ec3..9ef9765 100644 --- a/src/property/file.lisp +++ b/src/property/file.lisp @@ -26,7 +26,7 @@ point in doing that here because WRITEFILE is synchronous." (new-lines (funcall function orig-lines))) (if (equal orig-lines new-lines) :no-change - (writefile :try-preserve file (unlines new-lines))))) + (writefile file (unlines new-lines) :try-preserve t)))) (defprop has-content :posix (path lines) "Ensure there is a file at PATH whose lines are the elements of LINES." @@ -39,7 +39,8 @@ point in doing that here because WRITEFILE is synchronous." (existing-lines (lines (readfile path)))) (dolist (existing-line existing-lines) (deletef new-lines existing-line :test #'string=)) - (writefile path (unlines (nconc existing-lines new-lines)))))) + (writefile path (unlines (nconc existing-lines new-lines)) + :try-preserve t)))) (defprop data-uploaded :posix (iden1 iden2 destination) (:hostattrs |