add LOCALSUDO and LOCALHD

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

4 files changed, 45 insertions, 3 deletions

diff --git a/src/deployment.lisp b/src/deployment.lisp
index 0703c37..2ac6697 100644
--- a/src/deployment.lisp
+++ b/src/deployment.lisp
@@ -189,6 +189,42 @@ You can then eval (NAME) to execute this deployment."
                           (make-propspec
                            :propspec (props eseqprops ,@properties))))))
 
+(defun hostname-f ()
+  (stripln (run-program '("hostname" "-f") :output :string)))
+
+(defmacro localsudo (&rest properties)
+  "Deploy PROPERTIES to localhost using a :SUDO connection.
+
+It is assumed that on this system the shell command 'hostname -f' will return
+the full hostname, and that sudo is configured to ask for a password.  Useful
+for testing properties at the REPL.  See also EVALS."
+  (with-gensyms (username hostname host)
+    `(let* ((,username (parse-username-from-id
+                        (run-program '("id") :output :string)))
+            (,hostname (hostname-f))
+            (,host (or (symbol-value (find-symbol (string-upcase ,hostname)))
+                       (make-host :hostattrs `(:hostname (,,hostname))))))
+       (deploy-these*
+        `((:sudo :as ,(format nil "~A@~A" ,username ,hostname)))
+        ,host
+        (let ((*host* (shallow-copy-host ,host)))
+          (make-propspec :propspec (props eseqprops ,@properties)))))))
+
+(defmacro localhd (&rest properties)
+  "Deploy PROPERTIES to localhost using HOSTDEPLOY-THESE*.
+
+It is assumed that on this system the shell command 'hostname -f' will return
+the full hostname.  Useful for testing properties at the REPL.  See also
+EVALS."
+  (with-gensyms (hostname host)
+    `(let* ((,hostname (hostname-f))
+            (,host (or (symbol-value (find-symbol (string-upcase ,hostname)))
+                       (error "Localhost not defined using DEFHOST?"))))
+       (hostdeploy-these*
+        ,host
+        (let ((*host* (shallow-copy-host ,host)))
+          (make-propspec :propspec (props eseqprops ,@properties)))))))
+
 (defprop deploys :posix (connections host &optional additional-properties)
   "Execute the deployment which is defined by the pair (CONNECTIONS . HOST),
 except possibly with the property application specification
diff --git a/src/package.lisp b/src/package.lisp
index edd90ca..8b98198 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -198,6 +198,8 @@
            #:hostdeploy*
            #:hostdeploy-these
            #:hostdeploy-these*
+           #:localsudo
+           #:localhd
            #:continue-deploy*
            #:evals
 
diff --git a/src/property.lisp b/src/property.lisp
index 02871a3..6c35a96 100644
--- a/src/property.lisp
+++ b/src/property.lisp
@@ -511,9 +511,7 @@ apply or unapply properties.")
   "Get the remote username."
   (or (slot-value *connection* 'remote-user)
       (setf (slot-value *connection* 'remote-user)
-            (multiple-value-bind (match groups)
-                (re:scan-to-strings "^uid=[0-9]+\\(([^)]+)" (mrun "id"))
-              (and match (elt groups 0))))))
+            (parse-username-from-id (mrun "id")))))
 
 (defun assert-connection-supports (type)
   (unless (or (eq type :posix) (lisp-connection-p))
diff --git a/src/util.lisp b/src/util.lisp
index ab372ed..cbc21c2 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -195,6 +195,12 @@ one-dimensional collections of values."
   "Like UIOP:ESCAPE-SH-COMMAND, but also escape the empty string."
   (uiop:escape-command token s 'escape-sh-token))
 
+(defun parse-username-from-id (output)
+  "Where OUTPUT is the output of the id(1) command, extract the username."
+  (multiple-value-bind (match groups)
+      (re:scan-to-strings "^uid=[0-9]+\\(([^)]+)" output)
+    (and match (elt groups 0))))
+
 
 ;;;; Progress & debug printing