diff options
| -rw-r--r-- | Command/Unused.hs | 1 | ||||
| -rw-r--r-- | Common.hs | 4 | ||||
| -rw-r--r-- | Init.hs | 1 | ||||
| -rw-r--r-- | Remote/Git.hs | 1 | ||||
| -rw-r--r-- | Remote/Rsync.hs | 1 | ||||
| -rw-r--r-- | Remote/S3real.hs | 1 | ||||
| -rw-r--r-- | Remote/Web.hs | 1 | ||||
| -rw-r--r-- | Upgrade/V1.hs | 1 | ||||
| -rw-r--r-- | Upgrade/V2.hs | 1 | ||||
| -rw-r--r-- | Utility.hs | 106 | ||||
| -rw-r--r-- | Utility/Misc.hs | 29 | ||||
| -rw-r--r-- | Utility/Monad.hs | 26 | ||||
| -rw-r--r-- | Utility/Path.hs | 22 | ||||
| -rw-r--r-- | Utility/RsyncFile.hs | 2 | ||||
| -rw-r--r-- | Utility/TempFile.hs | 39 | ||||
| -rw-r--r-- | Utility/Url.hs | 2 |
16 files changed, 126 insertions, 112 deletions
diff --git a/Command/Unused.hs b/Command/Unused.hs index 874b0ca06..a90174752 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -16,6 +16,7 @@ import Common.Annex import Command import Annex.Content import Utility.FileMode +import Utility.TempFile import Logs.Location import qualified Annex import qualified Git @@ -15,7 +15,7 @@ module Common ( module System.Posix.IO, module System.Posix.Process, module System.Exit, - module Utility, + module Utility.Misc, module Utility.Conditional, module Utility.SafeCommand, module Utility.Path, @@ -40,7 +40,7 @@ import System.Posix.IO import System.Posix.Process hiding (executeFile) import System.Exit -import Utility +import Utility.Misc import Utility.Conditional import Utility.SafeCommand import Utility.Path @@ -12,6 +12,7 @@ module Init ( ) where import Common.Annex +import Utility.TempFile import qualified Git import qualified Annex.Branch import Annex.Version diff --git a/Remote/Git.hs b/Remote/Git.hs index 8857d821d..5d31770a2 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -20,6 +20,7 @@ import qualified Annex import Annex.UUID import qualified Annex.Content import qualified Utility.Url as Url +import Utility.TempFile import Config import Init diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 321656747..e79762a38 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -13,7 +13,6 @@ import qualified Data.Map as M import Common.Annex import Types.Remote import qualified Git -import Logs.UUID import Config import Annex.Content import Remote.Helper.Special diff --git a/Remote/S3real.hs b/Remote/S3real.hs index 40d7d905d..89b032637 100644 --- a/Remote/S3real.hs +++ b/Remote/S3real.hs @@ -21,7 +21,6 @@ import Common.Annex import Types.Remote import Types.Key import qualified Git -import Logs.UUID import Config import Remote.Helper.Special import Remote.Helper.Encryptable diff --git a/Remote/Web.hs b/Remote/Web.hs index 3fea94531..393932d47 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -13,6 +13,7 @@ import qualified Git import Config import Logs.Web import qualified Utility.Url as Url +import Utility.Monad remote :: RemoteType Annex remote = RemoteType { diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 6c6531ace..331328e81 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -21,6 +21,7 @@ import qualified Git.LsFiles as LsFiles import Backend import Annex.Version import Utility.FileMode +import Utility.TempFile import qualified Upgrade.V2 -- v2 adds hashing of filenames of content and location log files. diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index d6334ed65..1ad41266a 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -12,6 +12,7 @@ import qualified Git import qualified Annex.Branch import Logs.Location import Annex.Content +import Utility.TempFile olddir :: Git.Repo -> FilePath olddir g diff --git a/Utility.hs b/Utility.hs deleted file mode 100644 index 8ef60a081..000000000 --- a/Utility.hs +++ /dev/null @@ -1,106 +0,0 @@ -{- general purpose utility functions - - - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Utility ( - hGetContentsStrict, - readFileStrict, - readMaybe, - viaTmp, - withTempFile, - dirContents, - myHomeDir, - catchBool, - inPath, - firstM, - anyM -) where - -import Control.Applicative -import IO (bracket) -import System.IO -import System.Posix.Process hiding (executeFile) -import System.Posix.User -import System.FilePath -import System.Directory -import Utility.Path -import Data.Maybe -import Control.Monad (liftM) - -{- A version of hgetContents that is not lazy. Ensures file is - - all read before it gets closed. -} -hGetContentsStrict :: Handle -> IO String -hGetContentsStrict h = hGetContents h >>= \s -> length s `seq` return s - -{- A version of readFile that is not lazy. -} -readFileStrict :: FilePath -> IO String -readFileStrict f = readFile f >>= \s -> length s `seq` return s - -{- Attempts to read a value from a String. -} -readMaybe :: (Read a) => String -> Maybe a -readMaybe s = case reads s of - ((x,_):_) -> Just x - _ -> Nothing - -{- Runs an action like writeFile, writing to a tmp file first and - - then moving it into place. -} -viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO () -viaTmp a file content = do - pid <- getProcessID - let tmpfile = file ++ ".tmp" ++ show pid - createDirectoryIfMissing True (parentDir file) - a tmpfile content - renameFile tmpfile file - -{- Runs an action with a temp file, then removes the file. -} -withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a -withTempFile template a = bracket create remove use - where - create = do - tmpdir <- catch getTemporaryDirectory (const $ return ".") - openTempFile tmpdir template - remove (name, handle) = do - hClose handle - catchBool (removeFile name >> return True) - use (name, handle) = a name handle - -{- Lists the contents of a directory. - - Unlike getDirectoryContents, paths are not relative to the directory. -} -dirContents :: FilePath -> IO [FilePath] -dirContents d = map (d </>) . filter notcruft <$> getDirectoryContents d - where - notcruft "." = False - notcruft ".." = False - notcruft _ = True - -{- Current user's home directory. -} -myHomeDir :: IO FilePath -myHomeDir = homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID) - -{- Catches IO errors and returns a Bool -} -catchBool :: IO Bool -> IO Bool -catchBool = flip catch (const $ return False) - -{- Return the first value from a list, if any, satisfying the given - - predicate -} -firstM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a) -firstM _ [] = return Nothing -firstM p (x:xs) = do - q <- p x - if q - then return (Just x) - else firstM p xs - -{- Returns true if any value in the list satisfies the preducate, - - stopping once one is found. -} -anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool -anyM p = liftM isJust . firstM p - -{- Checks if a command is available in PATH. -} -inPath :: String -> IO Bool -inPath command = getSearchPath >>= anyM indir - where - indir d = doesFileExist $ d </> command diff --git a/Utility/Misc.hs b/Utility/Misc.hs new file mode 100644 index 000000000..bc1834774 --- /dev/null +++ b/Utility/Misc.hs @@ -0,0 +1,29 @@ +{- misc utility functions + - + - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Misc where + +import System.IO + +{- A version of hgetContents that is not lazy. Ensures file is + - all read before it gets closed. -} +hGetContentsStrict :: Handle -> IO String +hGetContentsStrict h = hGetContents h >>= \s -> length s `seq` return s + +{- A version of readFile that is not lazy. -} +readFileStrict :: FilePath -> IO String +readFileStrict f = readFile f >>= \s -> length s `seq` return s + +{- Attempts to read a value from a String. -} +readMaybe :: (Read a) => String -> Maybe a +readMaybe s = case reads s of + ((x,_):_) -> Just x + _ -> Nothing + +{- Catches IO errors and returns a Bool -} +catchBool :: IO Bool -> IO Bool +catchBool = flip catch (const $ return False) diff --git a/Utility/Monad.hs b/Utility/Monad.hs new file mode 100644 index 000000000..9523e1716 --- /dev/null +++ b/Utility/Monad.hs @@ -0,0 +1,26 @@ +{- monadic stuff + - + - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Monad where + +import Data.Maybe +import Control.Monad (liftM) + +{- Return the first value from a list, if any, satisfying the given + - predicate -} +firstM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a) +firstM _ [] = return Nothing +firstM p (x:xs) = do + q <- p x + if q + then return (Just x) + else firstM p xs + +{- Returns true if any value in the list satisfies the preducate, + - stopping once one is found. -} +anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool +anyM p = liftM isJust . firstM p diff --git a/Utility/Path.hs b/Utility/Path.hs index 1c68b87bb..38e7bd05c 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -14,6 +14,9 @@ import System.Directory import Data.List import Data.Maybe import Control.Applicative +import System.Posix.User + +import Utility.Monad {- Returns the parent directory of a path. Parent of / is "" -} parentDir :: FilePath -> FilePath @@ -112,3 +115,22 @@ preserveOrder (l:ls) new = found ++ preserveOrder ls rest -} runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath] runPreserveOrder a files = preserveOrder files <$> a files + +{- Lists the contents of a directory. + - Unlike getDirectoryContents, paths are not relative to the directory. -} +dirContents :: FilePath -> IO [FilePath] +dirContents d = map (d </>) . filter notcruft <$> getDirectoryContents d + where + notcruft "." = False + notcruft ".." = False + notcruft _ = True + +{- Current user's home directory. -} +myHomeDir :: IO FilePath +myHomeDir = homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID) + +{- Checks if a command is available in PATH. -} +inPath :: String -> IO Bool +inPath command = getSearchPath >>= anyM indir + where + indir d = doesFileExist $ d </> command diff --git a/Utility/RsyncFile.hs b/Utility/RsyncFile.hs index b6c2267e8..056bd8d11 100644 --- a/Utility/RsyncFile.hs +++ b/Utility/RsyncFile.hs @@ -1,4 +1,4 @@ -{- git-annex file copying with rsync +{- file copying with rsync - - Copyright 2010 Joey Hess <joey@kitenet.net> - diff --git a/Utility/TempFile.hs b/Utility/TempFile.hs new file mode 100644 index 000000000..1e823c10e --- /dev/null +++ b/Utility/TempFile.hs @@ -0,0 +1,39 @@ +{- temp file functions + - + - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.TempFile where + +import IO (bracket) +import System.IO +import System.Posix.Process hiding (executeFile) +import System.Directory + +import Utility.Misc +import Utility.Path + +{- Runs an action like writeFile, writing to a temp file first and + - then moving it into place. The temp file is stored in the same + - directory as the final file to avoid cross-device renames. -} +viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO () +viaTmp a file content = do + pid <- getProcessID + let tmpfile = file ++ ".tmp" ++ show pid + createDirectoryIfMissing True (parentDir file) + a tmpfile content + renameFile tmpfile file + +{- Runs an action with a temp file, then removes the file. -} +withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a +withTempFile template a = bracket create remove use + where + create = do + tmpdir <- catch getTemporaryDirectory (const $ return ".") + openTempFile tmpdir template + remove (name, handle) = do + hClose handle + catchBool (removeFile name >> return True) + use (name, handle) = a name handle diff --git a/Utility/Url.hs b/Utility/Url.hs index b5f5b78c0..617fe3f4d 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -17,7 +17,7 @@ import Network.HTTP import Network.URI import Utility.SafeCommand -import Utility +import Utility.Path type URLString = String |