From 79cbdf35b1188d83e64a713efa82bc7a0a72a181 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 1 Apr 2014 13:51:58 -0400 Subject: better method of starting propellor simplesh inside docker --- Propellor.hs | 5 + Propellor/CmdLine.hs | 19 +-- Propellor/PrivData.hs | 9 -- Propellor/Property/Cron.hs | 1 - Propellor/Property/Docker.hs | 99 +++++++++------ Propellor/SimpleSh.hs | 20 ++- Propellor/Types.hs | 20 +++ Utility/Path.hs | 293 +++++++++++++++++++++++++++++++++++++++++++ Utility/ThreadScheduler.hs | 73 +++++++++++ Utility/UserInfo.hs | 55 ++++++++ propellor.cabal | 3 + 11 files changed, 532 insertions(+), 65 deletions(-) create mode 100644 Utility/Path.hs create mode 100644 Utility/ThreadScheduler.hs create mode 100644 Utility/UserInfo.hs diff --git a/Propellor.hs b/Propellor.hs index ebf117a5..e39fc97d 100644 --- a/Propellor.hs +++ b/Propellor.hs @@ -32,6 +32,7 @@ module Propellor ( , module Propellor.PrivData , module Propellor.Engine , module Propellor.Message + , localdir , module X ) where @@ -61,3 +62,7 @@ import Control.Applicative as X import Control.Monad as X import Data.Monoid as X import Control.Monad.IfElse as X + +-- | This is where propellor installs itself when deploying a host. +localdir :: FilePath +localdir = "/usr/local/propellor" diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs index 8edfe19e..73254165 100644 --- a/Propellor/CmdLine.hs +++ b/Propellor/CmdLine.hs @@ -9,21 +9,10 @@ import System.Log.Handler (setFormatter, LogHandler) import System.Log.Handler.Simple import Propellor -import Propellor.SimpleSh +import qualified Propellor.Property.Docker as Docker import Utility.FileMode import Utility.SafeCommand -data CmdLine - = Run HostName - | Spin HostName - | Boot HostName - | Set HostName PrivDataField - | AddKey String - | Continue CmdLine - | SimpleSh FilePath - | Chain HostName - deriving (Read, Show, Eq) - usage :: IO a usage = do putStrLn $ unlines @@ -49,7 +38,6 @@ processCmdLine = go =<< getArgs go ("--continue":s:[]) = case readish s of Just cmdline -> return $ Continue cmdline Nothing -> errorMessage "--continue serialization failure" - go ("--simplesh":f:[]) = return $ SimpleSh f go ("--chain":h:[]) = return $ Chain h go (h:[]) | "--" `isPrefixOf` h = usage @@ -71,8 +59,8 @@ defaultMain getprops = do go _ (Continue cmdline) = go False cmdline go _ (Set host field) = setPrivData host field go _ (AddKey keyid) = addKey keyid - go _ (SimpleSh f) = simpleSh f go _ (Chain host) = withprops host $ print <=< ensureProperties' + go _ (ChainDocker host) = Docker.chain host go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline go False (Spin host) = withprops host $ const $ spin host @@ -296,9 +284,6 @@ keyring = privDataDir "keyring.gpg" gpgopts :: [String] gpgopts = ["--options", "/dev/null", "--no-default-keyring", "--keyring", keyring] -localdir :: FilePath -localdir = "/usr/local/propellor" - getUrl :: IO String getUrl = maybe nourl return =<< getM get urls where diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs index 98a1da62..d97a7725 100644 --- a/Propellor/PrivData.hs +++ b/Propellor/PrivData.hs @@ -18,15 +18,6 @@ import Utility.Tmp import Utility.SafeCommand import Utility.Misc --- | Note that removing or changing field names will break the --- serialized privdata files, so don't do that! --- It's fine to add new fields. -data PrivDataField - = DockerAuthentication - | SshPrivKey UserName - | Password UserName - deriving (Read, Show, Ord, Eq) - withPrivData :: PrivDataField -> (String -> IO Result) -> IO Result withPrivData field a = maybe missing a =<< getPrivData field where diff --git a/Propellor/Property/Cron.hs b/Propellor/Property/Cron.hs index 212e94e9..10e28ed7 100644 --- a/Propellor/Property/Cron.hs +++ b/Propellor/Property/Cron.hs @@ -3,7 +3,6 @@ module Propellor.Property.Cron where import Propellor import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt -import Propellor.CmdLine type CronTimes = String diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs index 56ec0bde..d849497d 100644 --- a/Propellor/Property/Docker.hs +++ b/Propellor/Property/Docker.hs @@ -3,11 +3,13 @@ module Propellor.Property.Docker where import Propellor -import Propellor.CmdLine import Propellor.SimpleSh import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import Utility.SafeCommand +import Utility.Path + +import Control.Concurrent.Async dockercmd :: String dockercmd = "docker.io" @@ -76,6 +78,9 @@ containerProperties findcontainer = \h -> case toContainerId h of Just (Container _ cprops) -> Just $ fromContainerized cprops +containerDesc :: ContainerId -> Desc -> Desc +containerDesc cid d = "docker container " ++ fromContainerId cid ++ " " ++ d + -- | Ensures that a docker container is set up and running. The container -- has its own Properties which are handled by running propellor -- inside the container. @@ -84,22 +89,20 @@ hasContainer -> ContainerName -> (HostName -> ContainerName -> Maybe (Container)) -> Property -hasContainer hn cn findcontainer = +hasContainer hn cn findcontainer = case findcontainer hn cn of - Nothing -> Property desc $ do + Nothing -> Property (containerDesc cid "") $ do warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid return FailedChange Just (Container image containerprops) -> - Property desc (provisionContainer cid) - `requires` - Property desc (ensureContainer cid image containerprops) + provisionContainer cid + `requires` + runningContainer cid image containerprops where cid = ContainerId hn cn - desc = "docker container " ++ fromContainerId cid - -ensureContainer :: ContainerId -> Image -> [Containerized Property] -> IO Result -ensureContainer cid@(ContainerId hn cn) image containerprops = do +runningContainer :: ContainerId -> Image -> [Containerized Property] -> Property +runningContainer cid@(ContainerId hn cn) image containerprops = Property (containerDesc cid "running") $ do l <- listContainers RunningContainers if cid `elem` l then do @@ -123,11 +126,9 @@ ensureContainer cid@(ContainerId hn cn) image containerprops = do -- is also started, so the user can attach and use it if desired. startsimplesh = ["sh", "-c", "./propellor --simplesh " ++ namedPipe cid ++ " & bash -l"] - getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ - pure . headMaybe . catMaybes . map readish . catMaybes . map getStdout - setrunningident = simpleShClient (namedPipe cid) "sh" - ["-c", "echo '" ++ show ident ++ "' > " ++ propellorIdent] - (const noop) + getrunningident = catchDefaultIO Nothing $ + simpleShClient (namedPipe cid) "cat" [propellorIdent] $ + pure . headMaybe . catMaybes . map readish . catMaybes . map getStdout runps = getRunParams $ containerprops ++ -- expose propellor directory inside the container @@ -140,15 +141,55 @@ ensureContainer cid@(ContainerId hn cn) image containerprops = do ] go img = ifM (runContainer img (runps ++ ["-i", "-d", "-t"]) startsimplesh) - ( do - setrunningident - return MadeChange + ( return MadeChange , return FailedChange ) -provisionContainer :: ContainerId -> IO Result -provisionContainer cid = do - simpleShClient (namedPipe cid) "./propellor" [show params] (go Nothing) +-- | Two containers with the same ContainerIdent were started from +-- the same base image (possibly a different version though), and +-- with the same RunParams. +data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam] + deriving (Read, Show, Eq) + +-- | The ContainerIdent of a container is written to +-- /.propellor-ident inside it. This can be checked to see if +-- the container has the same ident later. +propellorIdent :: FilePath +propellorIdent = "/.propellor-ident" + +-- | Named pipe used for communication with the container. +namedPipe :: ContainerId -> FilePath +namedPipe cid = "docker/" ++ fromContainerId cid + +-- | Called when propellor is running inside a docker container. +-- The string should be the container's ContainerIdent. +-- +-- Fork a thread to run the SimpleSh server in the background. +-- In the foreground, run an interactive bash (or sh) shell, +-- so that the user can interact with it when attached to the container. +chain :: String -> IO () +chain s = case readish s of + Nothing -> error $ "Invalid ContainerId: " ++ s + Just ident@(ContainerIdent _image hn cn _rp) -> do + let cid = ContainerId hn cn + writeFile propellorIdent (show ident) + t <- async $ simpleSh $ namedPipe cid + void $ ifM (inPath "bash") + ( boolSystem "bash" [Param "-l"] + , boolSystem "/bin/sh" [] + ) + wait t + +-- | Once a container is running, propellor can be run inside +-- it to provision it. +-- +-- Note that there is a race here, between the simplesh +-- server starting up in the container, and this property +-- being run. So, retry connections to the client for up to +-- 1 minute. +provisionContainer :: ContainerId -> Property +provisionContainer cid = Property (containerDesc cid "provision") $ + simpleShClientRetry 60 (namedPipe cid) "./propellor" [show params] (go Nothing) where params = Chain $ fromContainerId cid @@ -169,22 +210,6 @@ provisionContainer cid = do ret lastline = return $ fromMaybe FailedChange $ readish =<< lastline --- | Two containers with the same ContainerIdent were started from --- the same base image (possibly a different version though), and --- with the same RunParams. -data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam] - deriving (Read, Show, Eq) - --- | The ContainerIdent of a container is written to --- /.propellor-ident inside it. This can be checked to see if --- the container has the same ident later. -propellorIdent :: FilePath -propellorIdent = "/.propellor-ident" - --- | Named pipe used for communication with the container. -namedPipe :: ContainerId -> FilePath -namedPipe cid = "docker/" ++ fromContainerId cid - stopContainer :: ContainerId -> IO Bool stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] diff --git a/Propellor/SimpleSh.hs b/Propellor/SimpleSh.hs index 25a154a9..741c1bc8 100644 --- a/Propellor/SimpleSh.hs +++ b/Propellor/SimpleSh.hs @@ -12,6 +12,8 @@ import System.Process (std_in, std_out, std_err) import System.Exit import Propellor +import Utility.FileMode +import Utility.ThreadScheduler data Cmd = Cmd String [String] deriving (Read, Show) @@ -22,7 +24,9 @@ data Resp = StdoutLine String | StderrLine String | Done ExitCode simpleSh :: FilePath -> IO () simpleSh namedpipe = do nukeFile namedpipe - createDirectoryIfMissing True (takeDirectory namedpipe) + let dir = takeDirectory namedpipe + createDirectoryIfMissing True dir + modifyFileMode dir (removeModes otherGroupModes) s <- socket AF_UNIX Stream defaultProtocol bind s (SockAddrUnix namedpipe) listen s 2 @@ -73,6 +77,20 @@ simpleShClient namedpipe cmd params handler = do resps <- catMaybes . map readish . lines <$> hGetContents h hClose h `after` handler resps +simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a +simpleShClientRetry retries namedpipe cmd params handler = go retries + where + run = simpleShClient namedpipe cmd params handler + go n + | n < 1 = run + | otherwise = do + v <- tryIO run + case v of + Right r -> return r + Left _ -> do + threadDelaySeconds (Seconds 1) + go (n - 1) + getStdout :: Resp -> Maybe String getStdout (StdoutLine s) = Just s getStdout _ = Nothing diff --git a/Propellor/Types.hs b/Propellor/Types.hs index aef62de4..df139dd6 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -37,3 +37,23 @@ instance ActionResult Result where getActionResult NoChange = ("unchanged", Dull, Green) getActionResult MadeChange = ("done", Vivid, Green) getActionResult FailedChange = ("failed", Vivid, Red) + +data CmdLine + = Run HostName + | Spin HostName + | Boot HostName + | Set HostName PrivDataField + | AddKey String + | Continue CmdLine + | Chain HostName + | ChainDocker HostName + deriving (Read, Show, Eq) + +-- | Note that removing or changing field names will break the +-- serialized privdata files, so don't do that! +-- It's fine to add new fields. +data PrivDataField + = DockerAuthentication + | SshPrivKey UserName + | Password UserName + deriving (Read, Show, Ord, Eq) diff --git a/Utility/Path.hs b/Utility/Path.hs new file mode 100644 index 00000000..570350d6 --- /dev/null +++ b/Utility/Path.hs @@ -0,0 +1,293 @@ +{- path manipulation + - + - Copyright 2010-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE PackageImports, CPP #-} + +module Utility.Path where + +import Data.String.Utils +import System.FilePath +import System.Directory +import Data.List +import Data.Maybe +import Data.Char +import Control.Applicative + +#ifdef mingw32_HOST_OS +import qualified System.FilePath.Posix as Posix +#else +import System.Posix.Files +#endif + +import qualified "MissingH" System.Path as MissingH +import Utility.Monad +import Utility.UserInfo + +{- Simplifies a path, removing any ".." or ".", and removing the trailing + - path separator. + - + - On Windows, preserves whichever style of path separator might be used in + - the input FilePaths. This is done because some programs in Windows + - demand a particular path separator -- and which one actually varies! + - + - This does not guarantee that two paths that refer to the same location, + - and are both relative to the same location (or both absolute) will + - yeild the same result. Run both through normalise from System.FilePath + - to ensure that. + -} +simplifyPath :: FilePath -> FilePath +simplifyPath path = dropTrailingPathSeparator $ + joinDrive drive $ joinPath $ norm [] $ splitPath path' + where + (drive, path') = splitDrive path + + norm c [] = reverse c + norm c (p:ps) + | p' == ".." = norm (drop 1 c) ps + | p' == "." = norm c ps + | otherwise = norm (p:c) ps + where + p' = dropTrailingPathSeparator p + +{- Makes a path absolute. + - + - The first parameter is a base directory (ie, the cwd) to use if the path + - is not already absolute. + - + - Does not attempt to deal with edge cases or ensure security with + - untrusted inputs. + -} +absPathFrom :: FilePath -> FilePath -> FilePath +absPathFrom dir path = simplifyPath (combine dir path) + +{- On Windows, this converts the paths to unix-style, in order to run + - MissingH's absNormPath on them. Resulting path will use / separators. -} +absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath +#ifndef mingw32_HOST_OS +absNormPathUnix dir path = MissingH.absNormPath dir path +#else +absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path) + where + fromdos = replace "\\" "/" + todos = replace "/" "\\" +#endif + +{- Returns the parent directory of a path. + - + - To allow this to be easily used in loops, which terminate upon reaching the + - top, the parent of / is "" -} +parentDir :: FilePath -> FilePath +parentDir dir + | null dirs = "" + | otherwise = joinDrive drive (join s $ init dirs) + where + -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" + (drive, path) = splitDrive dir + dirs = filter (not . null) $ split s path + s = [pathSeparator] + +prop_parentDir_basics :: FilePath -> Bool +prop_parentDir_basics dir + | null dir = True + | dir == "/" = parentDir dir == "" + | otherwise = p /= dir + where + p = parentDir dir + +{- Checks if the first FilePath is, or could be said to contain the second. + - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc + - are all equivilant. + -} +dirContains :: FilePath -> FilePath -> Bool +dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b' + where + a' = norm a + b' = norm b + norm = normalise . simplifyPath + +{- Converts a filename into an absolute path. + - + - Unlike Directory.canonicalizePath, this does not require the path + - already exists. -} +absPath :: FilePath -> IO FilePath +absPath file = do + cwd <- getCurrentDirectory + return $ absPathFrom cwd file + +{- Constructs a relative path from the CWD to a file. + - + - For example, assuming CWD is /tmp/foo/bar: + - relPathCwdToFile "/tmp/foo" == ".." + - relPathCwdToFile "/tmp/foo/bar" == "" + -} +relPathCwdToFile :: FilePath -> IO FilePath +relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f + +{- Constructs a relative path from a directory to a file. + - + - Both must be absolute, and cannot contain .. etc. (eg use absPath first). + -} +relPathDirToFile :: FilePath -> FilePath -> FilePath +relPathDirToFile from to = join s $ dotdots ++ uncommon + where + s = [pathSeparator] + pfrom = split s from + pto = split s to + common = map fst $ takeWhile same $ zip pfrom pto + same (c,d) = c == d + uncommon = drop numcommon pto + dotdots = replicate (length pfrom - numcommon) ".." + numcommon = length common + +prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool +prop_relPathDirToFile_basics from to + | from == to = null r + | otherwise = not (null r) + where + r = relPathDirToFile from to + +prop_relPathDirToFile_regressionTest :: Bool +prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference + where + {- Two paths have the same directory component at the same + - location, but it's not really the same directory. + - Code used to get this wrong. -} + same_dir_shortcurcuits_at_difference = + relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) + (joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) + == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] + +{- Given an original list of paths, and an expanded list derived from it, + - generates a list of lists, where each sublist corresponds to one of the + - original paths. When the original path is a directory, any items + - in the expanded list that are contained in that directory will appear in + - its segment. + -} +segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] +segmentPaths [] new = [new] +segmentPaths [_] new = [new] -- optimisation +segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest + where + (found, rest)=partition (l `dirContains`) new + +{- This assumes that it's cheaper to call segmentPaths on the result, + - than it would be to run the action separately with each path. In + - the case of git file list commands, that assumption tends to hold. + -} +runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]] +runSegmentPaths a paths = segmentPaths paths <$> a paths + +{- Converts paths in the home directory to use ~/ -} +relHome :: FilePath -> IO String +relHome path = do + home <- myHomeDir + return $ if dirContains home path + then "~/" ++ relPathDirToFile home path + else path + +{- Checks if a command is available in PATH. + - + - The command may be fully-qualified, in which case, this succeeds as + - long as it exists. -} +inPath :: String -> IO Bool +inPath command = isJust <$> searchPath command + +{- Finds a command in PATH and returns the full path to it. + - + - The command may be fully qualified already, in which case it will + - be returned if it exists. + -} +searchPath :: String -> IO (Maybe FilePath) +searchPath command + | isAbsolute command = check command + | otherwise = getSearchPath >>= getM indir + where + indir d = check $ d command + check f = firstM doesFileExist +#ifdef mingw32_HOST_OS + [f, f ++ ".exe"] +#else + [f] +#endif + +{- Checks if a filename is a unix dotfile. All files inside dotdirs + - count as dotfiles. -} +dotfile :: FilePath -> Bool +dotfile file + | f == "." = False + | f == ".." = False + | f == "" = False + | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file) + where + f = takeFileName file + +{- Converts a DOS style path to a Cygwin style path. Only on Windows. + - Any trailing '\' is preserved as a trailing '/' -} +toCygPath :: FilePath -> FilePath +#ifndef mingw32_HOST_OS +toCygPath = id +#else +toCygPath p + | null drive = recombine parts + | otherwise = recombine $ "/cygdrive" : driveletter drive : parts + where + (drive, p') = splitDrive p + parts = splitDirectories p' + driveletter = map toLower . takeWhile (/= ':') + recombine = fixtrailing . Posix.joinPath + fixtrailing s + | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s + | otherwise = s +#endif + +{- Maximum size to use for a file in a specified directory. + - + - Many systems have a 255 byte limit to the name of a file, + - so that's taken as the max if the system has a larger limit, or has no + - limit. + -} +fileNameLengthLimit :: FilePath -> IO Int +#ifdef mingw32_HOST_OS +fileNameLengthLimit _ = return 255 +#else +fileNameLengthLimit dir = do + l <- fromIntegral <$> getPathVar dir FileNameLimit + if l <= 0 + then return 255 + else return $ minimum [l, 255] + where +#endif + +{- Given a string that we'd like to use as the basis for FilePath, but that + - was provided by a third party and is not to be trusted, returns the closest + - sane FilePath. + - + - All spaces and punctuation and other wacky stuff are replaced + - with '_', except for '.' "../" will thus turn into ".._", which is safe. + -} +sanitizeFilePath :: String -> FilePath +sanitizeFilePath = map sanitize + where + sanitize c + | c == '.' = c + | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' + | otherwise = c + +{- Similar to splitExtensions, but knows that some things in FilePaths + - after a dot are too long to be extensions. -} +splitShortExtensions :: FilePath -> (FilePath, [String]) +splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg" +splitShortExtensions' :: Int -> FilePath -> (FilePath, [String]) +splitShortExtensions' maxextension = go [] + where + go c f + | len > 0 && len <= maxextension && not (null base) = + go (ext:c) base + | otherwise = (f, c) + where + (base, ext) = splitExtension f + len = length ext diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs new file mode 100644 index 00000000..9d4cfd0a --- /dev/null +++ b/Utility/ThreadScheduler.hs @@ -0,0 +1,73 @@ +{- thread scheduling + - + - Copyright 2012, 2013 Joey Hess + - Copyright 2011 Bas van Dijk & Roel van Dijk + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Utility.ThreadScheduler where + +import Control.Monad +import Control.Monad.IfElse +import System.Posix.IO +import Control.Concurrent +#ifndef mingw32_HOST_OS +import System.Posix.Signals +#ifndef __ANDROID__ +import System.Posix.Terminal +#endif +#endif + +newtype Seconds = Seconds { fromSeconds :: Int } + deriving (Eq, Ord, Show) + +type Microseconds = Integer + +{- Runs an action repeatedly forever, sleeping at least the specified number + - of seconds in between. -} +runEvery :: Seconds -> IO a -> IO a +runEvery n a = forever $ do + threadDelaySeconds n + a + +threadDelaySeconds :: Seconds -> IO () +threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond) + +{- Like threadDelay, but not bounded by an Int. + - + - There is no guarantee that the thread will be rescheduled promptly when the + - delay has expired, but the thread will never continue to run earlier than + - specified. + - + - Taken from the unbounded-delay package to avoid a dependency for 4 lines + - of code. + -} +unboundDelay :: Microseconds -> IO () +unboundDelay time = do + let maxWait = min time $ toInteger (maxBound :: Int) + threadDelay $ fromInteger maxWait + when (maxWait /= time) $ unboundDelay (time - maxWait) + +{- Pauses the main thread, letting children run until program termination. -} +waitForTermination :: IO () +waitForTermination = do +#ifdef mingw32_HOST_OS + runEvery (Seconds 600) $ + void getLine +#else + lock <- newEmptyMVar + let check sig = void $ + installHandler sig (CatchOnce $ putMVar lock ()) Nothing + check softwareTermination +#ifndef __ANDROID__ + whenM (queryTerminal stdInput) $ + check keyboardSignal +#endif + takeMVar lock +#endif + +oneSecond :: Microseconds +oneSecond = 1000000 diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs new file mode 100644 index 00000000..9c3bfd42 --- /dev/null +++ b/Utility/UserInfo.hs @@ -0,0 +1,55 @@ +{- user info + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Utility.UserInfo ( + myHomeDir, + myUserName, + myUserGecos, +) where + +import Control.Applicative +import System.PosixCompat + +import Utility.Env + +{- Current user's home directory. + - + - getpwent will fail on LDAP or NIS, so use HOME if set. -} +myHomeDir :: IO FilePath +myHomeDir = myVal env homeDirectory + where +#ifndef mingw32_HOST_OS + env = ["HOME"] +#else + env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin +#endif + +{- Current user's user name. -} +myUserName :: IO String +myUserName = myVal env userName + where +#ifndef mingw32_HOST_OS + env = ["USER", "LOGNAME"] +#else + env = ["USERNAME", "USER", "LOGNAME"] +#endif + +myUserGecos :: IO String +#ifdef __ANDROID__ +myUserGecos = return "" -- userGecos crashes on Android +#else +myUserGecos = myVal [] userGecos +#endif + +myVal :: [String] -> (UserEntry -> String) -> IO String +myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars + where + check [] = return Nothing + check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v + getpwent = getUserEntryForID =<< getEffectiveUserID diff --git a/propellor.cabal b/propellor.cabal index d6070fa1..d44b387a 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -75,11 +75,14 @@ Library Utility.FileSystemEncoding Utility.Misc Utility.Monad + Utility.Path Utility.PartialPrelude Utility.PosixFiles Utility.Process Utility.SafeCommand + Utility.ThreadScheduler Utility.Tmp + Utility.UserInfo source-repository head type: git -- cgit v1.2.3