summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Command/Drop.hs5
-rw-r--r--Command/DropUnused.hs5
-rw-r--r--Command/Find.hs5
-rw-r--r--Command/Migrate.hs10
-rw-r--r--Command/RecvKey.hs6
-rw-r--r--Command/SendKey.hs7
-rw-r--r--Command/Uninit.hs7
-rw-r--r--Command/Unlock.hs6
-rw-r--r--Content.hs6
-rw-r--r--CopyFile.hs4
-rw-r--r--GitRepo.hs6
-rw-r--r--Remote/Bup.hs9
-rw-r--r--Remote/Directory.hs4
-rw-r--r--Remote/Rsync.hs7
-rw-r--r--Utility.hs32
-rw-r--r--git-annex-shell.hs4
16 files changed, 60 insertions, 63 deletions
diff --git a/Command/Drop.hs b/Command/Drop.hs
index 05c956fdd..07cec1a67 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -7,8 +7,6 @@
module Command.Drop where
-import Control.Monad (when)
-
import Command
import qualified Backend
import LocationLog
@@ -46,7 +44,6 @@ perform key backend numcopies = do
cleanup :: Key -> CommandCleanup
cleanup key = do
- inannex <- inAnnex key
- when inannex $ removeAnnex key
+ whenM (inAnnex key) $ removeAnnex key
logStatus key ValueMissing
return True
diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs
index 965a99ed5..1bb3b7f97 100644
--- a/Command/DropUnused.hs
+++ b/Command/DropUnused.hs
@@ -7,7 +7,6 @@
module Command.DropUnused where
-import Control.Monad (when)
import Control.Monad.State (liftIO)
import qualified Data.Map as M
import System.Directory
@@ -24,6 +23,7 @@ import qualified Remote
import qualified GitRepo as Git
import Backend
import Key
+import Utility
type UnusedMap = M.Map String Key
@@ -72,8 +72,7 @@ performOther :: (Git.Repo -> Key -> FilePath) -> Key -> CommandPerform
performOther filespec key = do
g <- Annex.gitRepo
let f = filespec g key
- e <- liftIO $ doesFileExist f
- when e $ liftIO $ removeFile f
+ liftIO $ whenM (doesFileExist f) $ removeFile f
next $ return True
readUnusedLog :: FilePath -> Annex UnusedMap
diff --git a/Command/Find.hs b/Command/Find.hs
index eecf3cd7d..9d760ff5a 100644
--- a/Command/Find.hs
+++ b/Command/Find.hs
@@ -7,11 +7,11 @@
module Command.Find where
-import Control.Monad (when)
import Control.Monad.State (liftIO)
import Command
import Content
+import Utility
command :: [Command]
command = [repoCommand "find" (paramOptional $ paramRepeating paramPath) seek
@@ -23,6 +23,5 @@ seek = [withFilesInGit start]
{- Output a list of files. -}
start :: CommandStartString
start file = isAnnexed file $ \(key, _) -> do
- exists <- inAnnex key
- when exists $ liftIO $ putStrLn file
+ whenM (inAnnex key) $ liftIO $ putStrLn file
stop
diff --git a/Command/Migrate.hs b/Command/Migrate.hs
index 790d5d365..09ff6df7d 100644
--- a/Command/Migrate.hs
+++ b/Command/Migrate.hs
@@ -8,7 +8,6 @@
module Command.Migrate where
import Control.Monad.State (liftIO)
-import Control.Monad (unless, when)
import System.Posix.Files
import System.Directory
import System.FilePath
@@ -20,6 +19,7 @@ import Locations
import Types
import Content
import Messages
+import Utility
import qualified Command.Add
command :: [Command]
@@ -63,9 +63,7 @@ perform file oldkey newbackend = do
ok <- getViaTmpUnchecked newkey $ \t -> do
-- Make a hard link to the old backend's
-- cached key, to avoid wasting disk space.
- liftIO $ do
- exists <- doesFileExist t
- unless exists $ createLink src t
+ liftIO $ unlessM (doesFileExist t) $ createLink src t
return True
if ok
then do
@@ -74,6 +72,4 @@ perform file oldkey newbackend = do
next $ Command.Add.cleanup file newkey
else stop
where
- cleantmp t = do
- exists <- doesFileExist t
- when exists $ removeFile t
+ cleantmp t = whenM (doesFileExist t) $ removeFile t
diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs
index 126608f61..b49116de4 100644
--- a/Command/RecvKey.hs
+++ b/Command/RecvKey.hs
@@ -7,13 +7,13 @@
module Command.RecvKey where
-import Control.Monad (when)
import Control.Monad.State (liftIO)
import System.Exit
import Command
import CmdLine
import Content
+import Utility
import RsyncFile
command :: [Command]
@@ -25,9 +25,7 @@ seek = [withKeys start]
start :: CommandStartKey
start key = do
- present <- inAnnex key
- when present $
- error "key is already present in annex"
+ whenM (inAnnex key) $ error "key is already present in annex"
ok <- getViaTmp key (liftIO . rsyncServerReceive)
if ok
diff --git a/Command/SendKey.hs b/Command/SendKey.hs
index 871a530af..7497ce3bf 100644
--- a/Command/SendKey.hs
+++ b/Command/SendKey.hs
@@ -7,7 +7,6 @@
module Command.SendKey where
-import Control.Monad (when)
import Control.Monad.State (liftIO)
import System.Exit
@@ -15,6 +14,7 @@ import Locations
import qualified Annex
import Command
import Content
+import Utility
import RsyncFile
command :: [Command]
@@ -26,9 +26,8 @@ seek = [withKeys start]
start :: CommandStartKey
start key = do
- present <- inAnnex key
g <- Annex.gitRepo
let file = gitAnnexLocation g key
- when present $
- liftIO $ rsyncServerSend file
+ whenM (inAnnex key) $
+ liftIO $ rsyncServerSend file -- does not return
liftIO exitFailure
diff --git a/Command/Uninit.hs b/Command/Uninit.hs
index d3d7ac339..1e96e1e6f 100644
--- a/Command/Uninit.hs
+++ b/Command/Uninit.hs
@@ -8,7 +8,6 @@
module Command.Uninit where
import Control.Monad.State (liftIO)
-import Control.Monad (when)
import System.Directory
import Command
@@ -44,8 +43,7 @@ perform = do
gitPreCommitHookUnWrite :: Git.Repo -> Annex ()
gitPreCommitHookUnWrite repo = do
let hook = Command.Init.preCommitHook repo
- hookexists <- liftIO $ doesFileExist hook
- when hookexists $ do
+ whenM (liftIO $ doesFileExist hook) $ do
c <- liftIO $ readFile hook
if c == Command.Init.preCommitScript
then liftIO $ removeFile hook
@@ -56,8 +54,7 @@ gitPreCommitHookUnWrite repo = do
gitAttributesUnWrite :: Git.Repo -> IO ()
gitAttributesUnWrite repo = do
let attributes = Git.attributes repo
- attrexists <- doesFileExist attributes
- when attrexists $ do
+ whenM (doesFileExist attributes) $ do
c <- readFileStrict attributes
safeWriteFile attributes $ unlines $
filter (\l -> not $ l `elem` Command.Init.attrLines) $ lines c
diff --git a/Command/Unlock.hs b/Command/Unlock.hs
index d65579ec7..161df2ddf 100644
--- a/Command/Unlock.hs
+++ b/Command/Unlock.hs
@@ -7,7 +7,6 @@
module Command.Unlock where
-import Control.Monad (when)
import Control.Monad.State (liftIO)
import System.Directory hiding (copyFile)
@@ -19,6 +18,7 @@ import Messages
import Locations
import Content
import CopyFile
+import Utility
command :: [Command]
command =
@@ -38,9 +38,7 @@ start file = isAnnexed file $ \(key, _) -> do
perform :: FilePath -> Key -> CommandPerform
perform dest key = do
- inbackend <- Backend.hasKey key
- when (not inbackend) $
- error "content not present"
+ unlessM (Backend.hasKey key) $ error "content not present"
checkDiskSpace key
diff --git a/Content.hs b/Content.hs
index 0758fcdb1..ec7a3776b 100644
--- a/Content.hs
+++ b/Content.hs
@@ -134,8 +134,7 @@ withTmp key action = do
let tmp = gitAnnexTmpLocation g key
liftIO $ createDirectoryIfMissing True (parentDir tmp)
res <- action tmp
- tmp_exists <- liftIO $ doesFileExist tmp
- when tmp_exists $ liftIO $ removeFile tmp
+ liftIO $ whenM (doesFileExist tmp) $ liftIO $ removeFile tmp
return res
{- Checks that there is disk space available to store a given key,
@@ -160,8 +159,7 @@ checkDiskSpace' adjustment key = do
megabyte :: Integer
megabyte = 1000000
needmorespace n = do
- force <- Annex.getState Annex.force
- unless force $
+ unlessM (Annex.getState Annex.force) $
error $ "not enough free space, need " ++
roughSize storageUnits True n ++
" more (use --force to override this check or adjust annex.diskreserve)"
diff --git a/CopyFile.hs b/CopyFile.hs
index 4575fb08a..b08ede3c8 100644
--- a/CopyFile.hs
+++ b/CopyFile.hs
@@ -7,7 +7,6 @@
module CopyFile (copyFile) where
-import Control.Monad (when)
import System.Directory (doesFileExist, removeFile)
import Utility
@@ -17,8 +16,7 @@ import qualified SysConfig
- and because this allows easy access to features like cp --reflink. -}
copyFile :: FilePath -> FilePath -> IO Bool
copyFile src dest = do
- e <- doesFileExist dest
- when e $
+ whenM (doesFileExist dest) $
removeFile dest
boolSystem "cp" [params, File src, File dest]
where
diff --git a/GitRepo.hs b/GitRepo.hs
index 87cceece4..d070bc89e 100644
--- a/GitRepo.hs
+++ b/GitRepo.hs
@@ -329,9 +329,9 @@ gitCommandLine repo _ = assertLocal repo $ error "internal"
{- Runs git in the specified repo, throwing an error if it fails. -}
run :: Repo -> String -> [CommandParam] -> IO ()
-run repo subcommand params = assertLocal repo $ do
- ok <- boolSystem "git" (gitCommandLine repo ((Param subcommand):params))
- unless ok $ error $ "git " ++ show params ++ " failed"
+run repo subcommand params = assertLocal repo $
+ boolSystem "git" (gitCommandLine repo ((Param subcommand):params))
+ <|> error $ "git " ++ show params ++ " failed"
{- Runs a git subcommand and returns it output, lazily.
-
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index d2b771bf7..51a5d05d1 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -11,7 +11,7 @@ import qualified Data.ByteString.Lazy.Char8 as L
import IO
import Control.Exception.Extensible (IOException)
import qualified Data.Map as M
-import Control.Monad (unless, when)
+import Control.Monad (when)
import Control.Monad.State (liftIO)
import System.Process
import System.Exit
@@ -75,8 +75,7 @@ bupSetup u c = do
-- bup init will create the repository.
-- (If the repository already exists, bup init again appears safe.)
showNote "bup init"
- ok <- bup "init" buprepo []
- unless ok $ error "bup init failed"
+ bup "init" buprepo [] <|> error "bup init failed"
storeBupUUID u buprepo
@@ -172,9 +171,9 @@ storeBupUUID u buprepo = do
if Git.repoIsUrl r
then do
showNote "storing uuid"
- ok <- onBupRemote r boolSystem "git"
+ onBupRemote r boolSystem "git"
[Params $ "config annex.uuid " ++ u]
- unless ok $ do error "ssh failed"
+ <|> error "ssh failed"
else liftIO $ do
r' <- Git.configRead r
let olduuid = Git.configGet r' "annex.uuid" ""
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 0cd3760d6..f69aa1256 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -62,8 +62,8 @@ directorySetup u c = do
-- verify configuration is sane
let dir = maybe (error "Specify directory=") id $
M.lookup "directory" c
- e <- liftIO $ doesDirectoryExist dir
- when (not e) $ error $ "Directory does not exist: " ++ dir
+ liftIO $ doesDirectoryExist dir
+ <|> error $ "Directory does not exist: " ++ dir
c' <- encryptionSetup c
-- The directory is stored in git config, not in this remote's
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index c15ab37a7..53418a9ef 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -10,7 +10,7 @@ module Remote.Rsync (remote) where
import qualified Data.ByteString.Lazy.Char8 as L
import Control.Exception.Extensible (IOException)
import qualified Data.Map as M
-import Control.Monad.State (liftIO, when)
+import Control.Monad.State (liftIO)
import System.FilePath
import System.Directory
import System.Posix.Files
@@ -168,9 +168,8 @@ withRsyncScratchDir a = do
nuke tmp
return res
where
- nuke d = liftIO $ do
- e <- doesDirectoryExist d
- when e $ liftIO $ removeDirectoryRecursive d
+ nuke d = liftIO $
+ doesDirectoryExist d <&> removeDirectoryRecursive d
rsyncRemote :: RsyncOpts -> [CommandParam] -> Annex Bool
rsyncRemote o params = do
diff --git a/Utility.hs b/Utility.hs
index 6dd7d329c..5aa0afea7 100644
--- a/Utility.hs
+++ b/Utility.hs
@@ -1,4 +1,4 @@
-{- git-annex utility functions
+{- general purpose utility functions
-
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
-
@@ -26,6 +26,10 @@ module Utility (
dirContents,
myHomeDir,
catchBool,
+ whenM,
+ (<&>),
+ unlessM,
+ (<|>),
prop_idempotent_shellEscape,
prop_idempotent_shellEscape_multiword,
@@ -46,7 +50,8 @@ import System.FilePath
import System.Directory
import Foreign (complement)
import Data.List
-import Control.Monad (liftM2)
+import Data.Maybe
+import Control.Monad (liftM2, when, unless)
{- A type for parameters passed to a shell command. A command can
- be passed either some Params (multiple parameters can be included,
@@ -110,7 +115,7 @@ shellEscape f = "'" ++ escaped ++ "'"
{- Unescapes a set of shellEscaped words or filenames. -}
shellUnEscape :: String -> [String]
shellUnEscape [] = []
-shellUnEscape s = word:(shellUnEscape rest)
+shellUnEscape s = word : shellUnEscape rest
where
(word, rest) = findword "" s
findword w [] = (w, "")
@@ -165,7 +170,7 @@ prop_parentDir_basics dir
dirContains :: FilePath -> FilePath -> Bool
dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'
where
- norm p = maybe "" id $ absNormPath p "."
+ norm p = fromMaybe "" $ absNormPath p "."
a' = norm a
b' = norm b
@@ -178,7 +183,7 @@ absPath file = do
{- Converts a filename into a normalized, absolute path
- from the specified cwd. -}
absPathFrom :: FilePath -> FilePath -> FilePath
-absPathFrom cwd file = maybe bad id $ absNormPath cwd file
+absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file
where
bad = error $ "unable to normalize " ++ file
@@ -258,3 +263,20 @@ myHomeDir = do
{- Catches IO errors and returns a Bool -}
catchBool :: IO Bool -> IO Bool
catchBool = flip catch (const $ return False)
+
+{- when with a monadic conditional -}
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM c a = c >>= flip when a
+
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM c a = c >>= flip unless a
+
+(<&>) :: Monad m => m Bool -> m () -> m ()
+(<&>) = whenM
+
+(<|>) :: Monad m => m Bool -> m () -> m ()
+(<|>) = unlessM
+
+-- low fixity allows eg, foo bar <|> error $ "failed " ++ meep
+infixr 0 <&>
+infixr 0 <|>
diff --git a/git-annex-shell.hs b/git-annex-shell.hs
index e8a744748..1487a6161 100644
--- a/git-annex-shell.hs
+++ b/git-annex-shell.hs
@@ -6,7 +6,6 @@
-}
import System.Environment
-import Control.Monad (when)
import Data.List
import qualified GitRepo as Git
@@ -66,8 +65,7 @@ builtin cmd dir params = do
external :: [String] -> IO ()
external params = do
- ret <- boolSystem "git-shell" $ map Param $ ("-c":filterparams params)
- when (not ret) $
+ unlessM (boolSystem "git-shell" $ map Param $ "-c":filterparams params) $
error "git-shell failed"
-- Drop all args after "--".
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-03 21:58:15 +0000