better method of starting propellor simplesh inside docker

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"

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

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

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
 

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 ]
 

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

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)

Utility/Path.hs

@@ -0,0 +1,293 @@
+{- path manipulation
+ -
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ -
+ - 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

Utility/ThreadScheduler.hs

@@ -0,0 +1,73 @@
+{- thread scheduling
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - 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

Utility/UserInfo.hs

@@ -0,0 +1,55 @@
+{- user info
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - 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

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