attempt to implement umask support for CONNECTION-WRITEFILE

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

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