summaryrefslogtreecommitdiff
path: root/src/Utility
diff options
context:
space:
mode:
authorJoey Hess2015-01-06 19:07:40 -0400
committerJoey Hess2015-01-06 19:07:40 -0400
commit16a5f561f52f35f95a59976b5ee61d99945b0d55 (patch)
tree791803645efedbc481cafcd907d2bcf73c03d1af /src/Utility
parentf4a57ca27d2009b3069c6b33904d198e6aa73f79 (diff)
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.
Diffstat (limited to 'src/Utility')
-rw-r--r--src/Utility/Applicative.hs2
-rw-r--r--src/Utility/Data.hs2
-rw-r--r--src/Utility/Env.hs31
-rw-r--r--src/Utility/FileSystemEncoding.hs4
-rw-r--r--src/Utility/LinuxMkLibs.hs9
-rw-r--r--src/Utility/Misc.hs2
-rw-r--r--src/Utility/Monad.hs2
-rw-r--r--src/Utility/Path.hs34
-rw-r--r--src/Utility/PosixFiles.hs2
-rw-r--r--src/Utility/QuickCheck.hs2
-rw-r--r--src/Utility/SafeCommand.hs2
-rw-r--r--src/Utility/Scheduled.hs28
-rw-r--r--src/Utility/ThreadScheduler.hs5
-rw-r--r--src/Utility/UserInfo.hs26
14 files changed, 80 insertions, 71 deletions
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 <id@joeyh.name>
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
-
- 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 <id@joeyh.name>
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
- 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 <id@joeyh.name>
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
-
- 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