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.
This commit is contained in:
parent
f4a57ca27d
commit
16a5f561f5
|
@ -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
|
||||
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
{- applicative stuff
|
||||
-
|
||||
- Copyright 2012 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
|
|
@ -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
|
||||
-}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
-}
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
-}
|
||||
|
|
|
@ -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
|
||||
-}
|
||||
|
|
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
|
|
@ -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
|
||||
-}
|
||||
|
|
|
@ -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
|
||||
-}
|
||||
|
|
|
@ -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
|
||||
-}
|
||||
|
|
|
@ -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
|
||||
-}
|
||||
|
|
|
@ -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 $
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue