25703e1413
Fourth or fifth try at this and finally found a way to make it work. Absurd amount of busy-work forced on me by change in cabal's behavior. Split up Utility modules that need posix stuff out of ones used by Setup. Various other hacks around inability for Setup to use anything that ifdefs a use of unix. Probably lost a full day of my life to this. This is how build systems make their users hate them. Just saying.
103 lines
3.3 KiB
Haskell
103 lines
3.3 KiB
Haskell
{- su to root
|
|
-
|
|
- Copyright 2016 Joey Hess <id@joeyh.name>
|
|
-
|
|
- License: BSD-2-clause
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Utility.Su where
|
|
|
|
import Common
|
|
|
|
#ifndef mingw32_HOST_OS
|
|
import Utility.Env
|
|
import System.Posix.IO
|
|
import System.Posix.Terminal
|
|
#endif
|
|
|
|
data WhosePassword
|
|
= RootPassword
|
|
| UserPassword
|
|
| SomePassword
|
|
-- ^ may be user or root; su program should indicate which
|
|
deriving (Show)
|
|
|
|
data PasswordPrompt
|
|
= WillPromptPassword WhosePassword
|
|
| MayPromptPassword WhosePassword
|
|
| NoPromptPassword
|
|
deriving (Show)
|
|
|
|
describePasswordPrompt :: PasswordPrompt -> Maybe String
|
|
describePasswordPrompt (WillPromptPassword whose) = Just $
|
|
"You will be prompted for " ++ describeWhosePassword whose ++ " password"
|
|
describePasswordPrompt (MayPromptPassword whose) = Just $
|
|
"You may be prompted for " ++ describeWhosePassword whose ++ " password"
|
|
describePasswordPrompt NoPromptPassword = Nothing
|
|
|
|
describeWhosePassword :: WhosePassword -> String
|
|
describeWhosePassword RootPassword = "root's"
|
|
describeWhosePassword UserPassword = "your"
|
|
describeWhosePassword SomePassword = "a"
|
|
|
|
data SuCommand = SuCommand PasswordPrompt String [CommandParam]
|
|
deriving (Show)
|
|
|
|
describePasswordPrompt' :: Maybe SuCommand -> Maybe String
|
|
describePasswordPrompt' (Just (SuCommand p _ _)) = describePasswordPrompt p
|
|
describePasswordPrompt' Nothing = Nothing
|
|
|
|
runSuCommand :: (Maybe SuCommand) -> IO Bool
|
|
runSuCommand (Just (SuCommand _ cmd ps)) = boolSystem cmd ps
|
|
runSuCommand Nothing = return False
|
|
|
|
-- Generates a SuCommand that 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.
|
|
mkSuCommand :: String -> [CommandParam] -> IO (Maybe SuCommand)
|
|
#ifndef mingw32_HOST_OS
|
|
mkSuCommand cmd ps = firstM (\(SuCommand _ p _) -> inPath p) =<< selectcmds
|
|
where
|
|
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 =
|
|
[ SuCommand (MayPromptPassword SomePassword) "gksu"
|
|
[Param shellcmd]
|
|
, SuCommand (MayPromptPassword SomePassword) "kdesu"
|
|
[Param shellcmd]
|
|
-- Available in Debian's menu package; knows about lots of
|
|
-- ways to gain root.
|
|
, SuCommand (MayPromptPassword SomePassword) "su-to-root"
|
|
[Param "-X", Param "-c", Param shellcmd]
|
|
-- OSX native way to run a command as root, prompts in GUI
|
|
, SuCommand (WillPromptPassword RootPassword) "osascript"
|
|
[Param "-e", Param ("do shell script \"" ++ shellcmd ++ "\" with administrator privileges")]
|
|
]
|
|
|
|
-- These will only work when run in a console.
|
|
consolecmds =
|
|
[ SuCommand (WillPromptPassword RootPassword) "su"
|
|
[Param "-c", Param shellcmd]
|
|
, SuCommand (MayPromptPassword UserPassword) "sudo"
|
|
([Param cmd] ++ ps)
|
|
, SuCommand (MayPromptPassword SomePassword) "su-to-root"
|
|
[Param "-c", Param shellcmd]
|
|
]
|
|
|
|
shellcmd = unwords $ map shellEscape (cmd:toCommand ps)
|
|
#else
|
|
-- For windows, we assume the user has administrator access.
|
|
mkSuCommand cmd ps = return $ Just $ SuCommand NoPromptPassword cmd ps
|
|
#endif
|