added ifM and nuked 11 lines of code

no behavior changes
This commit is contained in:
Joey Hess 2012-03-14 17:43:34 -04:00
parent a4f72c9625
commit 60ab3d84e1
17 changed files with 151 additions and 162 deletions

View file

@ -150,16 +150,16 @@ prepTmp key = do
getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmpUnchecked key action = do getViaTmpUnchecked key action = do
tmp <- prepTmp key tmp <- prepTmp key
success <- action tmp ifM (action tmp)
if success ( do
then do
moveAnnex key tmp moveAnnex key tmp
logStatus key InfoPresent logStatus key InfoPresent
return True return True
else do , do
-- the tmp file is left behind, in case caller wants -- the tmp file is left behind, in case caller wants
-- to resume its transfer -- to resume its transfer
return False return False
)
{- Creates a temp file, runs an action on it, and cleans up the temp file. -} {- Creates a temp file, runs an action on it, and cleans up the temp file. -}
withTmp :: Key -> (FilePath -> Annex a) -> Annex a withTmp :: Key -> (FilePath -> Annex a) -> Annex a
@ -230,15 +230,15 @@ moveAnnex :: Key -> FilePath -> Annex ()
moveAnnex key src = do moveAnnex key src = do
dest <- inRepo $ gitAnnexLocation key dest <- inRepo $ gitAnnexLocation key
let dir = parentDir dest let dir = parentDir dest
e <- liftIO $ doesFileExist dest liftIO $ ifM (doesFileExist dest)
if e ( removeFile src
then liftIO $ removeFile src , do
else liftIO $ do
createDirectoryIfMissing True dir createDirectoryIfMissing True dir
allowWrite dir -- in case the directory already exists allowWrite dir -- in case the directory already exists
moveFile src dest moveFile src dest
preventWrite dest preventWrite dest
preventWrite dir preventWrite dir
)
withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a
withObjectLoc key a = do withObjectLoc key a = do
@ -314,12 +314,12 @@ getKeysPresent = liftIO . traverse (2 :: Int) =<< fromRepo gitAnnexObjectDir
saveState :: Bool -> Annex () saveState :: Bool -> Annex ()
saveState oneshot = do saveState oneshot = do
Annex.Queue.flush False Annex.Queue.flush False
unless oneshot $ do unless oneshot $
alwayscommit <- fromMaybe True . Git.configTrue ifM alwayscommit
( Annex.Branch.commit "update" , Annex.Branch.stage)
where
alwayscommit = fromMaybe True . Git.configTrue
<$> fromRepo (Git.Config.get "annex.alwayscommit" "") <$> fromRepo (Git.Config.get "annex.alwayscommit" "")
if alwayscommit
then Annex.Branch.commit "update"
else Annex.Branch.stage
{- Downloads content from any of a list of urls. -} {- Downloads content from any of a list of urls. -}
downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
@ -338,10 +338,9 @@ preseedTmp key file = go =<< inAnnex key
ok <- copy ok <- copy
when ok $ liftIO $ allowWrite file when ok $ liftIO $ allowWrite file
return ok return ok
copy = do copy = ifM (liftIO $ doesFileExist file)
present <- liftIO $ doesFileExist file ( return True
if present , do
then return True
else do
s <- inRepo $ gitAnnexLocation key s <- inRepo $ gitAnnexLocation key
liftIO $ copyFileExternal s file liftIO $ copyFileExternal s file
)

View file

@ -37,15 +37,17 @@ sshParams (host, port) opts = go =<< sshInfo (host, port)
sshCleanup sshCleanup
sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
sshInfo (host, port) = do sshInfo (host, port) = ifM caching
caching <- fromMaybe SysConfig.sshconnectioncaching . Git.configTrue ( do
<$> fromRepo (Git.Config.get "annex.sshcaching" "")
if caching
then do
dir <- fromRepo gitAnnexSshDir dir <- fromRepo gitAnnexSshDir
let socketfile = dir </> hostport2socket host port let socketfile = dir </> hostport2socket host port
return (Just socketfile, cacheParams socketfile) return (Just socketfile, cacheParams socketfile)
else return (Nothing, []) , return (Nothing, [])
)
where
caching = fromMaybe SysConfig.sshconnectioncaching
. Git.configTrue
<$> fromRepo (Git.Config.get "annex.sshcaching" "")
cacheParams :: FilePath -> [CommandParam] cacheParams :: FilePath -> [CommandParam]
cacheParams socketfile = cacheParams socketfile =

View file

@ -34,11 +34,11 @@ genUUID :: IO UUID
genUUID = pOpen ReadFromPipe command params $ liftM toUUID . hGetLine genUUID = pOpen ReadFromPipe command params $ liftM toUUID . hGetLine
where where
command = SysConfig.uuid command = SysConfig.uuid
params = if command == "uuid" params
-- request a random uuid be generated -- request a random uuid be generated
then ["-m"] | command == "uuid" = ["-m"]
-- uuidgen generates random uuid by default -- uuidgen generates random uuid by default
else [] | otherwise = []
{- Get current repository's UUID. -} {- Get current repository's UUID. -}
getUUID :: Annex UUID getUUID :: Annex UUID

View file

@ -65,9 +65,7 @@ stop = return Nothing
{- Stops unless a condition is met. -} {- Stops unless a condition is met. -}
stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a) stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a)
stopUnless c a = do stopUnless c a = ifM c ( a , stop )
ok <- c
if ok then a else stop
{- Prepares to run a command via the check and seek stages, returning a {- Prepares to run a command via the check and seek stages, returning a
- list of actions to perform to run the command. -} - list of actions to perform to run the command. -}

View file

@ -85,8 +85,9 @@ cleanup file key hascontent = do
mtime <- modificationTime <$> getFileStatus file mtime <- modificationTime <$> getFileStatus file
touch file (TimeSpec mtime) False touch file (TimeSpec mtime) False
force <- Annex.getState Annex.force params <- ifM (Annex.getState Annex.force)
if force ( return [Param "-f"]
then Annex.Queue.add "add" [Param "-f", Param "--"] [file] , return []
else Annex.Queue.add "add" [Param "--"] [file] )
Annex.Queue.add "add" (params++[Param "--"]) [file]
return True return True

View file

@ -51,17 +51,17 @@ perform url file = ifAnnexed file addurl geturl
where where
geturl = do geturl = do
liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createDirectoryIfMissing True (parentDir file)
fast <- Annex.getState Annex.fast ifM (Annex.getState Annex.fast)
if fast then nodownload url file else download url file ( nodownload url file , download url file )
addurl (key, _backend) = do addurl (key, _backend) =
ok <- liftIO $ Url.check url (keySize key) ifM (liftIO $ Url.check url $ keySize key)
if ok ( do
then do
setUrlPresent key url setUrlPresent key url
next $ return True next $ return True
else do , do
warning $ "failed to verify url: " ++ url warning $ "failed to verify url: " ++ url
stop stop
)
download :: String -> FilePath -> CommandPerform download :: String -> FilePath -> CommandPerform
download url file = do download url file = do

View file

@ -62,17 +62,18 @@ perform key file backend numcopies = check
{- To fsck a remote, the content is retrieved to a tmp file, {- To fsck a remote, the content is retrieved to a tmp file,
- and checked locally. -} - and checked locally. -}
performRemote :: Key -> FilePath -> Backend -> Maybe Int -> Remote -> CommandPerform performRemote :: Key -> FilePath -> Backend -> Maybe Int -> Remote -> CommandPerform
performRemote key file backend numcopies remote = do performRemote key file backend numcopies remote =
v <- Remote.hasKey remote key dispatch =<< Remote.hasKey remote key
case v of where
Left err -> do dispatch (Left err) = do
showNote err showNote err
stop stop
Right True -> withtmp $ \tmpfile -> do dispatch (Right True) = withtmp $ \tmpfile ->
copied <- getfile tmpfile ifM (getfile tmpfile)
if copied then go True (Just tmpfile) else go True Nothing ( go True (Just tmpfile)
Right False -> go False Nothing , go True Nothing
where )
dispatch (Right False) = go False Nothing
go present localcopy = check go present localcopy = check
[ verifyLocationLogRemote key file remote present [ verifyLocationLogRemote key file remote present
, checkKeySizeRemote key remote localcopy , checkKeySizeRemote key remote localcopy
@ -87,15 +88,14 @@ performRemote key file backend numcopies remote = do
let cleanup = liftIO $ catchIO (removeFile tmp) (const $ return ()) let cleanup = liftIO $ catchIO (removeFile tmp) (const $ return ())
cleanup cleanup
cleanup `after` a tmp cleanup `after` a tmp
getfile tmp = do getfile tmp =
ok <- Remote.retrieveKeyFileCheap remote key tmp ifM (Remote.retrieveKeyFileCheap remote key tmp)
if ok ( return True
then return ok , ifM (Annex.getState Annex.fast)
else do ( return False
fast <- Annex.getState Annex.fast , Remote.retrieveKeyFile remote key tmp
if fast )
then return False )
else Remote.retrieveKeyFile remote key tmp
{- To fsck a bare repository, fsck each key in the location log. -} {- To fsck a bare repository, fsck each key in the location log. -}
withBarePresentKeys :: (Key -> CommandStart) -> CommandSeek withBarePresentKeys :: (Key -> CommandStart) -> CommandSeek
@ -205,10 +205,10 @@ verifyLocationLog' key desc present u bad = do
checkKeySize :: Key -> Annex Bool checkKeySize :: Key -> Annex Bool
checkKeySize key = do checkKeySize key = do
file <- inRepo $ gitAnnexLocation key file <- inRepo $ gitAnnexLocation key
present <- liftIO $ doesFileExist file ifM (liftIO $ doesFileExist file)
if present ( checkKeySize' key file badContent
then checkKeySize' key file badContent , return True
else return True )
checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool
checkKeySizeRemote _ _ Nothing = return True checkKeySizeRemote _ _ Nothing = return True
@ -219,16 +219,22 @@ checkKeySize' :: Key -> FilePath -> (Key -> Annex String) -> Annex Bool
checkKeySize' key file bad = case Types.Key.keySize key of checkKeySize' key file bad = case Types.Key.keySize key of
Nothing -> return True Nothing -> return True
Just size -> do Just size -> do
stat <- liftIO $ getFileStatus file size' <- fromIntegral . fileSize
let size' = fromIntegral (fileSize stat) <$> (liftIO $ getFileStatus file)
if size == size' comparesizes size size'
then return True where
else do comparesizes a b = do
let same = a == b
unless same $ badsize a b
return same
badsize a b = do
msg <- bad key msg <- bad key
warning $ "Bad file size (" ++ warning $ concat
compareSizes storageUnits True size size' ++ [ "Bad file size ("
"); " ++ msg , compareSizes storageUnits True a b
return False , "); "
, msg
]
checkBackend :: Backend -> Key -> Annex Bool checkBackend :: Backend -> Key -> Annex Bool
checkBackend backend key = do checkBackend backend key = do

View file

@ -42,37 +42,29 @@ perform key = stopUnless (getViaTmp key $ getKeyFile key) $
{- Try to find a copy of the file in one of the remotes, {- Try to find a copy of the file in one of the remotes,
- and copy it to here. -} - and copy it to here. -}
getKeyFile :: Key -> FilePath -> Annex Bool getKeyFile :: Key -> FilePath -> Annex Bool
getKeyFile key file = do getKeyFile key file = dispatch =<< Remote.keyPossibilities key
remotes <- Remote.keyPossibilities key where
if null remotes dispatch [] = do
then do
showNote "not available" showNote "not available"
Remote.showLocations key [] Remote.showLocations key []
return False return False
else trycopy remotes remotes dispatch remotes = trycopy remotes remotes
where
trycopy full [] = do trycopy full [] = do
Remote.showTriedRemotes full Remote.showTriedRemotes full
Remote.showLocations key [] Remote.showLocations key []
return False return False
trycopy full (r:rs) = do trycopy full (r:rs) =
probablythere <- probablyPresent r ifM (probablyPresent r)
if probablythere ( docopy r (trycopy full rs)
then docopy r (trycopy full rs) , trycopy full rs
else trycopy full rs )
-- This check is to avoid an ugly message if a remote is a -- This check is to avoid an ugly message if a remote is a
-- drive that is not mounted. -- drive that is not mounted.
probablyPresent r = probablyPresent r
if Remote.hasKeyCheap r | Remote.hasKeyCheap r =
then do either (const False) id <$> Remote.hasKey r key
res <- Remote.hasKey r key | otherwise = return True
case res of
Right b -> return b
Left _ -> return False
else return True
docopy r continue = do docopy r continue = do
showAction $ "from " ++ Remote.name r showAction $ "from " ++ Remote.name r
copied <- Remote.retrieveKeyFile r key file ifM (Remote.retrieveKeyFile r key file)
if copied ( return True , continue)
then return True
else continue

View file

@ -41,14 +41,14 @@ start = do
trusted <- trustGet Trusted trusted <- trustGet Trusted
liftIO $ writeFile file (drawMap rs umap trusted) liftIO $ writeFile file (drawMap rs umap trusted)
next $ next $ do next $ next $
fast <- Annex.getState Annex.fast ifM (Annex.getState Annex.fast)
if fast ( return True
then return True , do
else do
showLongNote $ "running: dot -Tx11 " ++ file showLongNote $ "running: dot -Tx11 " ++ file
showOutput showOutput
liftIO $ boolSystem "dot" [Param "-Tx11", File file] liftIO $ boolSystem "dot" [Param "-Tx11", File file]
)
where where
file = "map.dot" file = "map.dot"

View file

@ -131,13 +131,13 @@ fromOk src key
return $ u /= Remote.uuid src && any (== src) remotes return $ u /= Remote.uuid src && any (== src) remotes
fromPerform :: Remote -> Bool -> Key -> CommandPerform fromPerform :: Remote -> Bool -> Key -> CommandPerform
fromPerform src move key = moveLock move key $ do fromPerform src move key = moveLock move key $ do
ishere <- inAnnex key ifM (inAnnex key)
if ishere ( handle move True
then handle move True , do
else do
showAction $ "from " ++ Remote.name src showAction $ "from " ++ Remote.name src
ok <- getViaTmp key $ Remote.retrieveKeyFile src key ok <- getViaTmp key $ Remote.retrieveKeyFile src key
handle move ok handle move ok
)
where where
handle _ False = stop -- failed handle _ False = stop -- failed
handle False True = next $ return True -- copy complete handle False True = next $ return True -- copy complete

View file

@ -7,6 +7,7 @@
module Command.PreCommit where module Command.PreCommit where
import Common.Annex
import Command import Command
import qualified Command.Add import qualified Command.Add
import qualified Command.Fix import qualified Command.Fix
@ -26,7 +27,6 @@ start file = next $ perform file
perform :: FilePath -> CommandPerform perform :: FilePath -> CommandPerform
perform file = do perform file = do
ok <- doCommand $ Command.Add.start file unlessM (doCommand $ Command.Add.start file) $
if ok error $ "failed to add " ++ file ++ "; canceling commit"
then next $ return True next $ return True
else error $ "failed to add " ++ file ++ "; canceling commit"

View file

@ -51,11 +51,7 @@ remoteBranch :: Remote -> Git.Ref -> Git.Ref
remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote
syncRemotes :: [String] -> Annex [Remote] syncRemotes :: [String] -> Annex [Remote]
syncRemotes rs = do syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
fast <- Annex.getState Annex.fast
if fast
then nub <$> pickfast
else wanted
where where
pickfast = (++) <$> listed <*> (good =<< fastest <$> available) pickfast = (++) <$> listed <*> (good =<< fastest <$> available)
wanted wanted
@ -113,11 +109,11 @@ pullRemote remote branch = do
showStart "pull" (Remote.name remote) showStart "pull" (Remote.name remote)
next $ do next $ do
showOutput showOutput
fetched <- inRepo $ Git.Command.runBool "fetch" stopUnless fetch $
next $ mergeRemote remote branch
where
fetch = inRepo $ Git.Command.runBool "fetch"
[Param $ Remote.name remote] [Param $ Remote.name remote]
if fetched
then next $ mergeRemote remote branch
else stop
{- The remote probably has both a master and a synced/master branch. {- The remote probably has both a master and a synced/master branch.
- Which to merge from? Well, the master has whatever latest changes - Which to merge from? Well, the master has whatever latest changes
@ -159,15 +155,15 @@ mergeFrom branch = do
changed :: Remote -> Git.Ref -> Annex Bool changed :: Remote -> Git.Ref -> Annex Bool
changed remote b = do changed remote b = do
let r = remoteBranch remote b let r = remoteBranch remote b
e <- inRepo $ Git.Ref.exists r ifM (inRepo $ Git.Ref.exists r)
if e ( inRepo $ Git.Branch.changed b r
then inRepo $ Git.Branch.changed b r , return False
else return False )
newer :: Remote -> Git.Ref -> Annex Bool newer :: Remote -> Git.Ref -> Annex Bool
newer remote b = do newer remote b = do
let r = remoteBranch remote b let r = remoteBranch remote b
e <- inRepo $ Git.Ref.exists r ifM (inRepo $ Git.Ref.exists r)
if e ( inRepo $ Git.Branch.changed r b
then inRepo $ Git.Branch.changed r b , return True
else return True )

View file

@ -47,16 +47,16 @@ cleanup file key = do
Params "-m", Param "content removed from git annex", Params "-m", Param "content removed from git annex",
Param "--", File file] Param "--", File file]
fast <- Annex.getState Annex.fast ifM (Annex.getState Annex.fast)
if fast ( do
then do
-- fast mode: hard link to content in annex -- fast mode: hard link to content in annex
src <- inRepo $ gitAnnexLocation key src <- inRepo $ gitAnnexLocation key
liftIO $ do liftIO $ do
createLink src file createLink src file
allowWrite file allowWrite file
else do , do
fromAnnex key file fromAnnex key file
logStatus key InfoMissing logStatus key InfoMissing
)
return True return True

View file

@ -299,11 +299,11 @@ staleKeysPrune dirspec = do
staleKeys :: (Git.Repo -> FilePath) -> Annex [Key] staleKeys :: (Git.Repo -> FilePath) -> Annex [Key]
staleKeys dirspec = do staleKeys dirspec = do
dir <- fromRepo dirspec dir <- fromRepo dirspec
exists <- liftIO $ doesDirectoryExist dir ifM (liftIO $ doesDirectoryExist dir)
if not exists ( do
then return []
else do
contents <- liftIO $ getDirectoryContents dir contents <- liftIO $ getDirectoryContents dir
files <- liftIO $ filterM doesFileExist $ files <- liftIO $ filterM doesFileExist $
map (dir </>) contents map (dir </>) contents
return $ mapMaybe (fileKey . takeFileName) files return $ mapMaybe (fileKey . takeFileName) files
, return []
)

17
Init.hs
View file

@ -38,23 +38,22 @@ uninitialize = gitPreCommitHookUnWrite
ensureInitialized :: Annex () ensureInitialized :: Annex ()
ensureInitialized = getVersion >>= maybe needsinit checkVersion ensureInitialized = getVersion >>= maybe needsinit checkVersion
where where
needsinit = do needsinit = ifM Annex.Branch.hasSibling
annexed <- Annex.Branch.hasSibling ( initialize Nothing
if annexed , error "First run: git-annex init"
then initialize Nothing )
else error "First run: git-annex init"
{- set up a git pre-commit hook, if one is not already present -} {- set up a git pre-commit hook, if one is not already present -}
gitPreCommitHookWrite :: Annex () gitPreCommitHookWrite :: Annex ()
gitPreCommitHookWrite = unlessBare $ do gitPreCommitHookWrite = unlessBare $ do
hook <- preCommitHook hook <- preCommitHook
exists <- liftIO $ doesFileExist hook ifM (liftIO $ doesFileExist hook)
if exists ( warning $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
then warning $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring" , liftIO $ do
else liftIO $ do
viaTmp writeFile hook preCommitScript viaTmp writeFile hook preCommitScript
p <- getPermissions hook p <- getPermissions hook
setPermissions hook $ p {executable = True} setPermissions hook $ p {executable = True}
)
gitPreCommitHookUnWrite :: Annex () gitPreCommitHookUnWrite :: Annex ()
gitPreCommitHookUnWrite = unlessBare $ do gitPreCommitHookUnWrite = unlessBare $ do

View file

@ -70,19 +70,13 @@ addName desc n
- (Or it can be a UUID.) Only finds currently configured git remotes. -} - (Or it can be a UUID.) Only finds currently configured git remotes. -}
byName :: Maybe String -> Annex (Maybe Remote) byName :: Maybe String -> Annex (Maybe Remote)
byName Nothing = return Nothing byName Nothing = return Nothing
byName (Just n) = do byName (Just n) = either error Just <$> byName' n
res <- byName' n
case res of
Left e -> error e
Right r -> return $ Just r
byName' :: String -> Annex (Either String Remote) byName' :: String -> Annex (Either String Remote)
byName' "" = return $ Left "no remote specified" byName' "" = return $ Left "no remote specified"
byName' n = do byName' n = handle . filter matching <$> remoteList
match <- filter matching <$> remoteList
if null match
then return $ Left $ "there is no git remote named \"" ++ n ++ "\""
else return $ Right $ Prelude.head match
where where
handle [] = Left $ "there is no git remote named \"" ++ n ++ "\""
handle match = Right $ Prelude.head match
matching r = n == name r || toUUID n == uuid r matching r = n == name r || toUUID n == uuid r
{- Looks up a remote by name (or by UUID, or even by description), {- Looks up a remote by name (or by UUID, or even by description),

View file

@ -1,6 +1,6 @@
{- monadic stuff {- monadic stuff
- -
- Copyright 2010-2011 Joey Hess <joey@kitenet.net> - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -14,11 +14,7 @@ import Control.Monad (liftM)
- predicate -} - predicate -}
firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
firstM _ [] = return Nothing firstM _ [] = return Nothing
firstM p (x:xs) = do firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs)
q <- p x
if q
then return (Just x)
else firstM p xs
{- Returns true if any value in the list satisfies the predicate, {- Returns true if any value in the list satisfies the predicate,
- stopping once one is found. -} - stopping once one is found. -}
@ -29,6 +25,12 @@ anyM p = liftM isJust . firstM p
untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool
untilTrue = flip anyM untilTrue = flip anyM
{- if with a monadic conditional. -}
ifM :: Monad m => m Bool -> (m a, m a) -> m a
ifM cond (thenclause, elseclause) = do
c <- cond
if c then thenclause else elseclause
{- Runs an action, passing its value to an observer before returning it. -} {- Runs an action, passing its value to an observer before returning it. -}
observe :: Monad m => (a -> m b) -> m a -> m a observe :: Monad m => (a -> m b) -> m a -> m a
observe observer a = do observe observer a = do