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

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

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)

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

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

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 $

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