enable-tor: No longer needs to be run as root.

When run by not root, su's to root automatically.

This commit was sponsored by Brock Spratlen on Patreon.

1 files changed, 54 insertions, 0 deletions

diff --git a/Utility/Su.hs b/Utility/Su.hs
new file mode 100644
index 000000000..4244074d7
--- /dev/null
+++ b/Utility/Su.hs
@@ -0,0 +1,54 @@
+{- su to root
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.Su where
+
+import Common
+import Utility.Env
+import Utility.Path
+
+import System.Posix.Terminal
+
+-- Runs a command as root, fairly portably.
+--
+-- Does not use sudo commands if something else is available, because
+-- the user may not be in sudoers and we couldn't differentiate between
+-- that and the command failing. Although, some commands like gksu
+-- decide based on the system's configuration whether sudo should be used.
+runAsRoot :: String -> [CommandParam] -> IO Bool
+runAsRoot cmd ps = go =<< firstM (inPath . fst) =<< selectcmds
+  where
+	go Nothing = return False
+	go (Just (cmd', ps')) = boolSystem cmd' ps'
+
+	selectcmds = ifM (inx <||> (not <$> atconsole))
+		( return (graphicalcmds ++ consolecmds)
+		, return consolecmds
+		)
+	
+	inx = isJust <$> getEnv "DISPLAY"
+	atconsole = queryTerminal stdInput
+
+	-- These will only work when the user is logged into a desktop.
+	graphicalcmds =
+		[ ("gksu", [Param shellcmd])
+		, ("kdesu", [Param shellcmd])
+		-- Available in Debian's menu package; knows about lots of
+		-- ways to gain root.
+		, ("su-to-root", [Param "-X", Param "-c", Param shellcmd])
+		-- OSX native way to run a command as root, prompts in GUI
+		, ("osascript", [Param "-e", Param ("do shell script \"" ++ shellcmd ++ "\" with administrator privileges")])
+		]
+	
+	-- These will only work when run in a console.
+	consolecmds = 
+		[ ("su", [Param "-c", Param "--", Param cmd] ++ ps)
+		, ("sudo", [Param cmd] ++ ps)
+		, ("su-to-root", [Param "-c", Param shellcmd])
+		]
+	
+	shellcmd = unwords $ map shellEscape (cmd:toCommand ps)