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 --- Utility/Path.hs | 293 +++++++++++++++++++++++++++++++++++++++++++++ Utility/ThreadScheduler.hs | 73 +++++++++++ Utility/UserInfo.hs | 55 +++++++++ 3 files changed, 421 insertions(+) create mode 100644 Utility/Path.hs create mode 100644 Utility/ThreadScheduler.hs create mode 100644 Utility/UserInfo.hs (limited to 'Utility') 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 -- cgit v1.2.3