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.

debian/changelog

@@ -1,6 +1,7 @@
 propellor (1.3.2) UNRELEASED; urgency=medium
 
   * SSHFP records are also generated for CNAMES of hosts.
+  * Merge Utiity modules from git-annex.
 
  -- Joey Hess <id@joeyh.name>  Sun, 04 Jan 2015 21:25:42 -0400
 

src/Propellor/Property/SiteSpecific/JoeySites.hs

@@ -17,7 +17,6 @@ import qualified Propellor.Property.Apache as Apache
 import qualified Propellor.Property.Postfix as Postfix
 import Utility.SafeCommand
 import Utility.FileMode
-import Utility.Path
 
 import Data.List
 import System.Posix.Files
@@ -313,6 +312,7 @@ twitRss = combineProperties "twitter rss"
 		"./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss")
 
 -- Work around for expired ssl cert.
+-- (no longer expired, TODO remove this and change urls)
 pumpRss :: Property
 pumpRss = Cron.job "pump rss" "15 * * * *" "joey" "/srv/web/tmp.kitenet.net/"
 	"wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom --no-check-certificate 2>/dev/null"
@@ -321,7 +321,7 @@ ircBouncer :: Property
 ircBouncer = propertyList "IRC bouncer"
 	[ Apt.installed ["znc"]
 	, User.accountFor "znc"
-	, File.dirExists (parentDir conf)
+	, File.dirExists (takeDirectory conf)
 	, File.hasPrivContent conf anyContext
 	, File.ownerGroup conf "znc" "znc"
 	, Cron.job "znconboot" "@reboot" "znc" "~" "znc"

src/Propellor/Shim.hs

@@ -9,7 +9,6 @@ module Propellor.Shim (setup, cleanEnv, file) where
 import Propellor
 import Utility.LinuxMkLibs
 import Utility.SafeCommand
-import Utility.Path
 import Utility.FileMode
 import Utility.FileSystemEncoding
 
@@ -34,7 +33,7 @@ setup propellorbin propellorbinpath dest = checkAlreadyShimmed propellorbin $ do
 	let linker = (dest ++) $ 
 		fromMaybe (error "cannot find ld-linux linker") $
 			headMaybe $ filter ("ld-linux" `isInfixOf`) libs'
-	let gconvdir = (dest ++) $ parentDir $
+	let gconvdir = (dest ++) $ takeDirectory $
 		fromMaybe (error "cannot find gconv directory") $
 			headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs
 	let linkerparams = ["--library-path", intercalate ":" libdirs ]
@@ -75,5 +74,5 @@ installFile top f = do
 	createLink f dest `catchIO` (const copy)
   where
 	copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest]
-	destdir = inTop top $ parentDir f
+	destdir = inTop top $ takeDirectory f
 	dest = inTop top f

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
  -}

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
  -}

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,
+ - On Windows, setting a variable to "" unsets it. -}
- - environment varuables must be provided when running a new process. -}
+setEnv :: String -> String -> Bool -> IO ()
-setEnv :: String -> String -> Bool -> IO Bool
 #ifndef mingw32_HOST_OS
-setEnv var val overwrite = do
+setEnv var val overwrite = PE.setEnv var val overwrite
-	PE.setEnv var val overwrite
-	return True
 #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 ()
-unsetEnv :: String -> IO Bool
 #ifndef mingw32_HOST_OS
-unsetEnv var = do
+unsetEnv = PE.unsetEnv
-	PE.unsetEnv var
-	return True
 #else
-unsetEnv _ = return False
+unsetEnv = System.SetEnv.unsetEnv
 #endif
 
 {- Adds the environment variable to the input environment. If already

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
  -}

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 absl = absPathFrom (takeDirectory f) l
-		let target = relPathDirToFile (parentDir f) absl
+		let target = relPathDirToFile (takeDirectory f) absl
 		installfile top absl
 		nukeFile (top ++ f)
 		createSymbolicLink target (inTop top f)

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
  -}

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
  -}

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.
+{- Just the parent directory of a path, or Nothing if the path has no
- -
+ - parent (ie for "/") -}
- - To allow this to be easily used in loops, which terminate upon reaching the
+parentDir :: FilePath -> Maybe FilePath
- - top, the parent of / is "" -}
-parentDir :: FilePath -> FilePath
 parentDir dir
-	| null dirs = ""
+	| null dirs = Nothing
-	| otherwise = joinDrive drive (join s $ init dirs)
+	| 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 == ""
+	| dir == "/" = parentDir dir == Nothing
-	| otherwise = p /= dir
+	| otherwise = p /= Just dir
   where
 	p = parentDir dir
 
@@ -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,7 +268,8 @@ 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

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
  -}

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
  -}

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
  -}

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
  -}

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) $
+	forever $ threadDelaySeconds (Seconds 6000)
-		void getLine
 #else
 	lock <- newEmptyMVar
 	let check sig = void $

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
+myUserGecos :: IO (Maybe String)
-#ifdef __ANDROID__
+-- userGecos crashes on Android and is not available on Windows.
-myUserGecos = return "" -- userGecos crashes on Android
+#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
+#ifndef mingw32_HOST_OS
-	check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v
+	go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID)
-	getpwent = getUserEntryForID =<< getEffectiveUserID
+#else
+	go [] = error $ "environment not set: " ++ show envvars
+#endif
+	go (v:vs) = maybe (go vs) return =<< getEnv v