From 16a5f561f52f35f95a59976b5ee61d99945b0d55 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 6 Jan 2015 19:07:40 -0400 Subject: Merge Utiity modules from git-annex. Except for a few that are using the other exception handling library, that propellor has not switched to yet. --- src/Utility/Applicative.hs | 2 +- src/Utility/Data.hs | 2 +- src/Utility/Env.hs | 31 ++++++++++++++++--------------- src/Utility/FileSystemEncoding.hs | 4 ++-- src/Utility/LinuxMkLibs.hs | 9 +++++---- src/Utility/Misc.hs | 2 +- src/Utility/Monad.hs | 2 +- src/Utility/Path.hs | 34 ++++++++++++++++++---------------- src/Utility/PosixFiles.hs | 2 +- src/Utility/QuickCheck.hs | 2 +- src/Utility/SafeCommand.hs | 2 +- src/Utility/Scheduled.hs | 28 ++++++++++++++-------------- src/Utility/ThreadScheduler.hs | 5 ++--- src/Utility/UserInfo.hs | 26 ++++++++++++++++---------- 14 files changed, 80 insertions(+), 71 deletions(-) (limited to 'src/Utility') diff --git a/src/Utility/Applicative.hs b/src/Utility/Applicative.hs index fce3c048..fd8944b2 100644 --- a/src/Utility/Applicative.hs +++ b/src/Utility/Applicative.hs @@ -1,6 +1,6 @@ {- applicative stuff - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Data.hs b/src/Utility/Data.hs index 5ecd218f..2df12b36 100644 --- a/src/Utility/Data.hs +++ b/src/Utility/Data.hs @@ -1,6 +1,6 @@ {- utilities for simple data types - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Env.hs b/src/Utility/Env.hs index dd502fd3..ff6644fb 100644 --- a/src/Utility/Env.hs +++ b/src/Utility/Env.hs @@ -1,6 +1,6 @@ {- portable environment variables - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} @@ -14,6 +14,7 @@ import Utility.Exception import Control.Applicative import Data.Maybe import qualified System.Environment as E +import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif @@ -39,27 +40,27 @@ getEnvironment = PE.getEnvironment getEnvironment = E.getEnvironment #endif -{- Returns True if it could successfully set the environment variable. +{- Sets an environment variable. To overwrite an existing variable, + - overwrite must be True. - - - There is, apparently, no way to do this in Windows. Instead, - - environment varuables must be provided when running a new process. -} -setEnv :: String -> String -> Bool -> IO Bool + - On Windows, setting a variable to "" unsets it. -} +setEnv :: String -> String -> Bool -> IO () #ifndef mingw32_HOST_OS -setEnv var val overwrite = do - PE.setEnv var val overwrite - return True +setEnv var val overwrite = PE.setEnv var val overwrite #else -setEnv _ _ _ = return False +setEnv var val True = System.SetEnv.setEnv var val +setEnv var val False = do + r <- getEnv var + case r of + Nothing -> setEnv var val True + Just _ -> return () #endif -{- Returns True if it could successfully unset the environment variable. -} -unsetEnv :: String -> IO Bool +unsetEnv :: String -> IO () #ifndef mingw32_HOST_OS -unsetEnv var = do - PE.unsetEnv var - return True +unsetEnv = PE.unsetEnv #else -unsetEnv _ = return False +unsetEnv = System.SetEnv.unsetEnv #endif {- Adds the environment variable to the input environment. If already diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs index 4e8f2ffe..fa4b39aa 100644 --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2014 Joey Hess - - License: BSD-2-clause -} @@ -111,7 +111,7 @@ truncateFilePath :: Int -> FilePath -> FilePath #ifndef mingw32_HOST_OS truncateFilePath n = go . reverse where - go f = + go f = let bytes = decodeW8 f in if length bytes <= n then reverse f diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs index d32de1a1..6074ba26 100644 --- a/src/Utility/LinuxMkLibs.hs +++ b/src/Utility/LinuxMkLibs.hs @@ -1,6 +1,6 @@ {- Linux library copier and binary shimmer - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ module Utility.LinuxMkLibs where import Control.Applicative import Data.Maybe import System.Directory +import System.FilePath import Data.List.Utils import System.Posix.Files import Data.Char @@ -28,14 +29,14 @@ installLib installfile top lib = ifM (doesFileExist lib) ( do installfile top lib checksymlink lib - return $ Just $ parentDir lib + return $ Just $ takeDirectory lib , return Nothing ) where checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do l <- readSymbolicLink (inTop top f) - let absl = absPathFrom (parentDir f) l - let target = relPathDirToFile (parentDir f) absl + let absl = absPathFrom (takeDirectory f) l + let target = relPathDirToFile (takeDirectory f) absl installfile top absl nukeFile (top ++ f) createSymbolicLink target (inTop top f) diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs index e4eccac4..949f41e7 100644 --- a/src/Utility/Misc.hs +++ b/src/Utility/Misc.hs @@ -1,6 +1,6 @@ {- misc utility functions - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2011 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Monad.hs b/src/Utility/Monad.hs index 878e0da6..eba3c428 100644 --- a/src/Utility/Monad.hs +++ b/src/Utility/Monad.hs @@ -1,6 +1,6 @@ {- monadic stuff - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2012 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs index ea62157f..7f034912 100644 --- a/src/Utility/Path.hs +++ b/src/Utility/Path.hs @@ -1,6 +1,6 @@ {- path manipulation - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2014 Joey Hess - - License: BSD-2-clause -} @@ -21,6 +21,7 @@ import Control.Applicative import qualified System.FilePath.Posix as Posix #else import System.Posix.Files +import Utility.Exception #endif import qualified "MissingH" System.Path as MissingH @@ -76,14 +77,12 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos 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 +{- Just the parent directory of a path, or Nothing if the path has no + - parent (ie for "/") -} +parentDir :: FilePath -> Maybe FilePath parentDir dir - | null dirs = "" - | otherwise = joinDrive drive (join s $ init dirs) + | null dirs = Nothing + | otherwise = Just $ joinDrive drive (join s $ init dirs) where -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" (drive, path) = splitDrive dir @@ -93,8 +92,8 @@ parentDir dir prop_parentDir_basics :: FilePath -> Bool prop_parentDir_basics dir | null dir = True - | dir == "/" = parentDir dir == "" - | otherwise = p /= dir + | dir == "/" = parentDir dir == Nothing + | otherwise = p /= Just dir where p = parentDir dir @@ -235,11 +234,11 @@ toCygPath p | null drive = recombine parts | otherwise = recombine $ "/cygdrive" : driveletter drive : parts where - (drive, p') = splitDrive p + (drive, p') = splitDrive p parts = splitDirectories p' - driveletter = map toLower . takeWhile (/= ':') + driveletter = map toLower . takeWhile (/= ':') recombine = fixtrailing . Posix.joinPath - fixtrailing s + fixtrailing s | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s | otherwise = s #endif @@ -255,7 +254,9 @@ fileNameLengthLimit :: FilePath -> IO Int fileNameLengthLimit _ = return 255 #else fileNameLengthLimit dir = do - l <- fromIntegral <$> getPathVar dir FileNameLimit + -- getPathVar can fail due to statfs(2) overflow + l <- catchDefaultIO 0 $ + fromIntegral <$> getPathVar dir FileNameLimit if l <= 0 then return 255 else return $ minimum [l, 255] @@ -267,12 +268,13 @@ fileNameLengthLimit dir = do - sane FilePath. - - All spaces and punctuation and other wacky stuff are replaced - - with '_', except for '.' "../" will thus turn into ".._", which is safe. + - with '_', except for '.' + - "../" will thus turn into ".._", which is safe. -} sanitizeFilePath :: String -> FilePath sanitizeFilePath = map sanitize where - sanitize c + sanitize c | c == '.' = c | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' | otherwise = c diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs index 5a94ead0..5abbb578 100644 --- a/src/Utility/PosixFiles.hs +++ b/src/Utility/PosixFiles.hs @@ -2,7 +2,7 @@ - - This is like System.PosixCompat.Files, except with a fixed rename. - - - Copyright 2014 Joey Hess + - Copyright 2014 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs index 54200d3f..a498ee61 100644 --- a/src/Utility/QuickCheck.hs +++ b/src/Utility/QuickCheck.hs @@ -1,6 +1,6 @@ {- QuickCheck with additional instances - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2014 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs index a5556200..86e60db0 100644 --- a/src/Utility/SafeCommand.hs +++ b/src/Utility/SafeCommand.hs @@ -1,6 +1,6 @@ {- safely running shell commands - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2013 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs index 3a1a6cd3..4fa3a29f 100644 --- a/src/Utility/Scheduled.hs +++ b/src/Utility/Scheduled.hs @@ -1,6 +1,6 @@ {- scheduled activities - - - Copyright 2013-2014 Joey Hess + - Copyright 2013-2014 Joey Hess - - License: BSD-2-clause -} @@ -44,7 +44,7 @@ import Data.Char {- Some sort of scheduled event. -} data Schedule = Schedule Recurrance ScheduledTime - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) data Recurrance = Daily @@ -54,7 +54,7 @@ data Recurrance | Divisible Int Recurrance -- ^ Days, Weeks, or Months of the year evenly divisible by a number. -- (Divisible Year is years evenly divisible by a number.) - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) type WeekDay = Int type MonthDay = Int @@ -63,7 +63,7 @@ type YearDay = Int data ScheduledTime = AnyTime | SpecificTime Hour Minute - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) type Hour = Int type Minute = Int @@ -73,7 +73,7 @@ type Minute = Int data NextTime = NextTimeExactly LocalTime | NextTimeWindow LocalTime LocalTime - deriving (Eq, Read, Show) + deriving (Eq, Read, Show) startTime :: NextTime -> LocalTime startTime (NextTimeExactly t) = t @@ -96,9 +96,9 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime NextTimeExactly t -> window (localDay t) (localDay t) | otherwise = NextTimeExactly . startTime <$> findfromtoday False where - findfromtoday anytime = findfrom recurrance afterday today + findfromtoday anytime = findfrom recurrance afterday today where - today = localDay currenttime + today = localDay currenttime afterday = sameaslastrun || toolatetoday toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime sameaslastrun = lastrun == Just today @@ -163,8 +163,8 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate where - skip n = findfrom r False (addDays n candidate) - handlediv n r' getval mmax + skip n = findfrom r False (addDays n candidate) + handlediv n r' getval mmax | n > 0 && maybe True (n <=) mmax = findfromwhere r' (divisible n . getval) afterday candidate | otherwise = Nothing @@ -267,7 +267,7 @@ toRecurrance s = case words s of constructor u | "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u | otherwise = Nothing - withday sd u = do + withday sd u = do c <- constructor u d <- readish sd Just $ c (Just d) @@ -285,7 +285,7 @@ fromScheduledTime AnyTime = "any time" fromScheduledTime (SpecificTime h m) = show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm where - pad n s = take (n - length s) (repeat '0') ++ s + pad n s = take (n - length s) (repeat '0') ++ s (h', ampm) | h == 0 = (12, "AM") | h < 12 = (h, "AM") @@ -304,10 +304,10 @@ toScheduledTime v = case words v of (s:[]) -> go s id _ -> Nothing where - h0 h + h0 h | h == 12 = 0 | otherwise = h - go :: String -> (Int -> Int) -> Maybe ScheduledTime + go :: String -> (Int -> Int) -> Maybe ScheduledTime go s adjust = let (h, m) = separate (== ':') s in SpecificTime @@ -363,7 +363,7 @@ instance Arbitrary Recurrance where ] ] where - arbday = oneof + arbday = oneof [ Just <$> nonNegative arbitrary , pure Nothing ] diff --git a/src/Utility/ThreadScheduler.hs b/src/Utility/ThreadScheduler.hs index eb009742..e6a81aeb 100644 --- a/src/Utility/ThreadScheduler.hs +++ b/src/Utility/ThreadScheduler.hs @@ -1,6 +1,6 @@ {- thread scheduling - - - Copyright 2012, 2013 Joey Hess + - Copyright 2012, 2013 Joey Hess - Copyright 2011 Bas van Dijk & Roel van Dijk - - License: BSD-2-clause @@ -57,8 +57,7 @@ unboundDelay time = do waitForTermination :: IO () waitForTermination = do #ifdef mingw32_HOST_OS - runEvery (Seconds 600) $ - void getLine + forever $ threadDelaySeconds (Seconds 6000) #else lock <- newEmptyMVar let check sig = void $ diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs index e2c248b1..c82f0407 100644 --- a/src/Utility/UserInfo.hs +++ b/src/Utility/UserInfo.hs @@ -1,6 +1,6 @@ {- user info - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - License: BSD-2-clause -} @@ -13,8 +13,10 @@ module Utility.UserInfo ( myUserGecos, ) where -import Control.Applicative import System.PosixCompat +#ifndef mingw32_HOST_OS +import Control.Applicative +#endif import Utility.Env @@ -40,16 +42,20 @@ myUserName = myVal env userName env = ["USERNAME", "USER", "LOGNAME"] #endif -myUserGecos :: IO String -#ifdef __ANDROID__ -myUserGecos = return "" -- userGecos crashes on Android +myUserGecos :: IO (Maybe String) +-- userGecos crashes on Android and is not available on Windows. +#if defined(__ANDROID__) || defined(mingw32_HOST_OS) +myUserGecos = return Nothing #else -myUserGecos = myVal [] userGecos +myUserGecos = Just <$> myVal [] userGecos #endif myVal :: [String] -> (UserEntry -> String) -> IO String -myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars +myVal envvars extract = go envvars where - check [] = return Nothing - check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v - getpwent = getUserEntryForID =<< getEffectiveUserID +#ifndef mingw32_HOST_OS + go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID) +#else + go [] = error $ "environment not set: " ++ show envvars +#endif + go (v:vs) = maybe (go vs) return =<< getEnv v -- cgit v1.2.3