diff --git a/Annex/Content.hs b/Annex/Content.hs index ccaff5c564..fad5f51349 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -150,16 +150,16 @@ prepTmp key = do getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool getViaTmpUnchecked key action = do tmp <- prepTmp key - success <- action tmp - if success - then do + ifM (action tmp) + ( do moveAnnex key tmp logStatus key InfoPresent return True - else do + , do -- the tmp file is left behind, in case caller wants -- to resume its transfer return False + ) {- Creates a temp file, runs an action on it, and cleans up the temp file. -} withTmp :: Key -> (FilePath -> Annex a) -> Annex a @@ -230,15 +230,15 @@ moveAnnex :: Key -> FilePath -> Annex () moveAnnex key src = do dest <- inRepo $ gitAnnexLocation key let dir = parentDir dest - e <- liftIO $ doesFileExist dest - if e - then liftIO $ removeFile src - else liftIO $ do + liftIO $ ifM (doesFileExist dest) + ( removeFile src + , do createDirectoryIfMissing True dir allowWrite dir -- in case the directory already exists moveFile src dest preventWrite dest preventWrite dir + ) withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a withObjectLoc key a = do @@ -314,12 +314,12 @@ getKeysPresent = liftIO . traverse (2 :: Int) =<< fromRepo gitAnnexObjectDir saveState :: Bool -> Annex () saveState oneshot = do Annex.Queue.flush False - unless oneshot $ do - alwayscommit <- fromMaybe True . Git.configTrue + unless oneshot $ + ifM alwayscommit + ( Annex.Branch.commit "update" , Annex.Branch.stage) + where + alwayscommit = fromMaybe True . Git.configTrue <$> 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. -} downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool @@ -338,10 +338,9 @@ preseedTmp key file = go =<< inAnnex key ok <- copy when ok $ liftIO $ allowWrite file return ok - copy = do - present <- liftIO $ doesFileExist file - if present - then return True - else do + copy = ifM (liftIO $ doesFileExist file) + ( return True + , do s <- inRepo $ gitAnnexLocation key liftIO $ copyFileExternal s file + ) diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 39983ab250..79cfbe908b 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -37,15 +37,17 @@ sshParams (host, port) opts = go =<< sshInfo (host, port) sshCleanup sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) -sshInfo (host, port) = do - caching <- fromMaybe SysConfig.sshconnectioncaching . Git.configTrue - <$> fromRepo (Git.Config.get "annex.sshcaching" "") - if caching - then do - dir <- fromRepo gitAnnexSshDir - let socketfile = dir hostport2socket host port - return (Just socketfile, cacheParams socketfile) - else return (Nothing, []) +sshInfo (host, port) = ifM caching + ( do + dir <- fromRepo gitAnnexSshDir + let socketfile = dir hostport2socket host port + return (Just socketfile, cacheParams socketfile) + , return (Nothing, []) + ) + where + caching = fromMaybe SysConfig.sshconnectioncaching + . Git.configTrue + <$> fromRepo (Git.Config.get "annex.sshcaching" "") cacheParams :: FilePath -> [CommandParam] cacheParams socketfile = diff --git a/Annex/UUID.hs b/Annex/UUID.hs index 48bf71f104..0ab2e7e521 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -34,11 +34,11 @@ genUUID :: IO UUID genUUID = pOpen ReadFromPipe command params $ liftM toUUID . hGetLine where command = SysConfig.uuid - params = if command == "uuid" + params -- request a random uuid be generated - then ["-m"] + | command == "uuid" = ["-m"] -- uuidgen generates random uuid by default - else [] + | otherwise = [] {- Get current repository's UUID. -} getUUID :: Annex UUID diff --git a/Command.hs b/Command.hs index 13ea167bbc..0dff0c862e 100644 --- a/Command.hs +++ b/Command.hs @@ -65,9 +65,7 @@ stop = return Nothing {- Stops unless a condition is met. -} stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a) -stopUnless c a = do - ok <- c - if ok then a else stop +stopUnless c a = ifM c ( a , stop ) {- Prepares to run a command via the check and seek stages, returning a - list of actions to perform to run the command. -} diff --git a/Command/Add.hs b/Command/Add.hs index b6b5753af7..ef839b2a30 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -85,8 +85,9 @@ cleanup file key hascontent = do mtime <- modificationTime <$> getFileStatus file touch file (TimeSpec mtime) False - force <- Annex.getState Annex.force - if force - then Annex.Queue.add "add" [Param "-f", Param "--"] [file] - else Annex.Queue.add "add" [Param "--"] [file] + params <- ifM (Annex.getState Annex.force) + ( return [Param "-f"] + , return [] + ) + Annex.Queue.add "add" (params++[Param "--"]) [file] return True diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 6c945baf93..c87399f5dc 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -51,17 +51,17 @@ perform url file = ifAnnexed file addurl geturl where geturl = do liftIO $ createDirectoryIfMissing True (parentDir file) - fast <- Annex.getState Annex.fast - if fast then nodownload url file else download url file - addurl (key, _backend) = do - ok <- liftIO $ Url.check url (keySize key) - if ok - then do + ifM (Annex.getState Annex.fast) + ( nodownload url file , download url file ) + addurl (key, _backend) = + ifM (liftIO $ Url.check url $ keySize key) + ( do setUrlPresent key url next $ return True - else do + , do warning $ "failed to verify url: " ++ url stop + ) download :: String -> FilePath -> CommandPerform download url file = do diff --git a/Command/Fsck.hs b/Command/Fsck.hs index d8d0db23be..dac3bfac96 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -62,17 +62,18 @@ perform key file backend numcopies = check {- To fsck a remote, the content is retrieved to a tmp file, - and checked locally. -} performRemote :: Key -> FilePath -> Backend -> Maybe Int -> Remote -> CommandPerform -performRemote key file backend numcopies remote = do - v <- Remote.hasKey remote key - case v of - Left err -> do +performRemote key file backend numcopies remote = + dispatch =<< Remote.hasKey remote key + where + dispatch (Left err) = do showNote err stop - Right True -> withtmp $ \tmpfile -> do - copied <- getfile tmpfile - if copied then go True (Just tmpfile) else go True Nothing - Right False -> go False Nothing - where + dispatch (Right True) = withtmp $ \tmpfile -> + ifM (getfile tmpfile) + ( go True (Just tmpfile) + , go True Nothing + ) + dispatch (Right False) = go False Nothing go present localcopy = check [ verifyLocationLogRemote key file remote present , checkKeySizeRemote key remote localcopy @@ -87,15 +88,14 @@ performRemote key file backend numcopies remote = do let cleanup = liftIO $ catchIO (removeFile tmp) (const $ return ()) cleanup cleanup `after` a tmp - getfile tmp = do - ok <- Remote.retrieveKeyFileCheap remote key tmp - if ok - then return ok - else do - fast <- Annex.getState Annex.fast - if fast - then return False - else Remote.retrieveKeyFile remote key tmp + getfile tmp = + ifM (Remote.retrieveKeyFileCheap remote key tmp) + ( return True + , ifM (Annex.getState Annex.fast) + ( return False + , Remote.retrieveKeyFile remote key tmp + ) + ) {- To fsck a bare repository, fsck each key in the location log. -} withBarePresentKeys :: (Key -> CommandStart) -> CommandSeek @@ -205,10 +205,10 @@ verifyLocationLog' key desc present u bad = do checkKeySize :: Key -> Annex Bool checkKeySize key = do file <- inRepo $ gitAnnexLocation key - present <- liftIO $ doesFileExist file - if present - then checkKeySize' key file badContent - else return True + ifM (liftIO $ doesFileExist file) + ( checkKeySize' key file badContent + , return True + ) checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool 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 Nothing -> return True Just size -> do - stat <- liftIO $ getFileStatus file - let size' = fromIntegral (fileSize stat) - if size == size' - then return True - else do - msg <- bad key - warning $ "Bad file size (" ++ - compareSizes storageUnits True size size' ++ - "); " ++ msg - return False + size' <- fromIntegral . fileSize + <$> (liftIO $ getFileStatus file) + comparesizes size size' + where + comparesizes a b = do + let same = a == b + unless same $ badsize a b + return same + badsize a b = do + msg <- bad key + warning $ concat + [ "Bad file size (" + , compareSizes storageUnits True a b + , "); " + , msg + ] checkBackend :: Backend -> Key -> Annex Bool checkBackend backend key = do diff --git a/Command/Get.hs b/Command/Get.hs index 9b12b95994..772fbd90c2 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -42,37 +42,29 @@ perform key = stopUnless (getViaTmp key $ getKeyFile key) $ {- Try to find a copy of the file in one of the remotes, - and copy it to here. -} getKeyFile :: Key -> FilePath -> Annex Bool -getKeyFile key file = do - remotes <- Remote.keyPossibilities key - if null remotes - then do +getKeyFile key file = dispatch =<< Remote.keyPossibilities key + where + dispatch [] = do showNote "not available" Remote.showLocations key [] return False - else trycopy remotes remotes - where + dispatch remotes = trycopy remotes remotes trycopy full [] = do Remote.showTriedRemotes full Remote.showLocations key [] return False - trycopy full (r:rs) = do - probablythere <- probablyPresent r - if probablythere - then docopy r (trycopy full rs) - else trycopy full rs + trycopy full (r:rs) = + ifM (probablyPresent r) + ( docopy r (trycopy full rs) + , trycopy full rs + ) -- This check is to avoid an ugly message if a remote is a -- drive that is not mounted. - probablyPresent r = - if Remote.hasKeyCheap r - then do - res <- Remote.hasKey r key - case res of - Right b -> return b - Left _ -> return False - else return True + probablyPresent r + | Remote.hasKeyCheap r = + either (const False) id <$> Remote.hasKey r key + | otherwise = return True docopy r continue = do showAction $ "from " ++ Remote.name r - copied <- Remote.retrieveKeyFile r key file - if copied - then return True - else continue + ifM (Remote.retrieveKeyFile r key file) + ( return True , continue) diff --git a/Command/Map.hs b/Command/Map.hs index da7a048a4d..bdb86f95a5 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -41,14 +41,14 @@ start = do trusted <- trustGet Trusted liftIO $ writeFile file (drawMap rs umap trusted) - next $ next $ do - fast <- Annex.getState Annex.fast - if fast - then return True - else do + next $ next $ + ifM (Annex.getState Annex.fast) + ( return True + , do showLongNote $ "running: dot -Tx11 " ++ file showOutput liftIO $ boolSystem "dot" [Param "-Tx11", File file] + ) where file = "map.dot" diff --git a/Command/Move.hs b/Command/Move.hs index 6b58f711aa..8612c9f2db 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -131,13 +131,13 @@ fromOk src key return $ u /= Remote.uuid src && any (== src) remotes fromPerform :: Remote -> Bool -> Key -> CommandPerform fromPerform src move key = moveLock move key $ do - ishere <- inAnnex key - if ishere - then handle move True - else do + ifM (inAnnex key) + ( handle move True + , do showAction $ "from " ++ Remote.name src ok <- getViaTmp key $ Remote.retrieveKeyFile src key handle move ok + ) where handle _ False = stop -- failed handle False True = next $ return True -- copy complete diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index b0328ca190..06140fa52a 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -7,6 +7,7 @@ module Command.PreCommit where +import Common.Annex import Command import qualified Command.Add import qualified Command.Fix @@ -26,7 +27,6 @@ start file = next $ perform file perform :: FilePath -> CommandPerform perform file = do - ok <- doCommand $ Command.Add.start file - if ok - then next $ return True - else error $ "failed to add " ++ file ++ "; canceling commit" + unlessM (doCommand $ Command.Add.start file) $ + error $ "failed to add " ++ file ++ "; canceling commit" + next $ return True diff --git a/Command/Sync.hs b/Command/Sync.hs index 51b6d6f636..b9ef0bc979 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -51,11 +51,7 @@ remoteBranch :: Remote -> Git.Ref -> Git.Ref remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote syncRemotes :: [String] -> Annex [Remote] -syncRemotes rs = do - fast <- Annex.getState Annex.fast - if fast - then nub <$> pickfast - else wanted +syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) where pickfast = (++) <$> listed <*> (good =<< fastest <$> available) wanted @@ -113,11 +109,11 @@ pullRemote remote branch = do showStart "pull" (Remote.name remote) next $ do showOutput - fetched <- inRepo $ Git.Command.runBool "fetch" + stopUnless fetch $ + next $ mergeRemote remote branch + where + fetch = inRepo $ Git.Command.runBool "fetch" [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. - 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 b = do let r = remoteBranch remote b - e <- inRepo $ Git.Ref.exists r - if e - then inRepo $ Git.Branch.changed b r - else return False + ifM (inRepo $ Git.Ref.exists r) + ( inRepo $ Git.Branch.changed b r + , return False + ) newer :: Remote -> Git.Ref -> Annex Bool newer remote b = do let r = remoteBranch remote b - e <- inRepo $ Git.Ref.exists r - if e - then inRepo $ Git.Branch.changed r b - else return True + ifM (inRepo $ Git.Ref.exists r) + ( inRepo $ Git.Branch.changed r b + , return True + ) diff --git a/Command/Unannex.hs b/Command/Unannex.hs index fee67429df..1e7313711c 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -47,16 +47,16 @@ cleanup file key = do Params "-m", Param "content removed from git annex", Param "--", File file] - fast <- Annex.getState Annex.fast - if fast - then do + ifM (Annex.getState Annex.fast) + ( do -- fast mode: hard link to content in annex src <- inRepo $ gitAnnexLocation key liftIO $ do createLink src file allowWrite file - else do + , do fromAnnex key file logStatus key InfoMissing + ) return True diff --git a/Command/Unused.hs b/Command/Unused.hs index b878ab2650..246929f715 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -299,11 +299,11 @@ staleKeysPrune dirspec = do staleKeys :: (Git.Repo -> FilePath) -> Annex [Key] staleKeys dirspec = do dir <- fromRepo dirspec - exists <- liftIO $ doesDirectoryExist dir - if not exists - then return [] - else do + ifM (liftIO $ doesDirectoryExist dir) + ( do contents <- liftIO $ getDirectoryContents dir files <- liftIO $ filterM doesFileExist $ map (dir ) contents return $ mapMaybe (fileKey . takeFileName) files + , return [] + ) diff --git a/Init.hs b/Init.hs index c9d5bb909a..f3d8bd0171 100644 --- a/Init.hs +++ b/Init.hs @@ -38,23 +38,22 @@ uninitialize = gitPreCommitHookUnWrite ensureInitialized :: Annex () ensureInitialized = getVersion >>= maybe needsinit checkVersion where - needsinit = do - annexed <- Annex.Branch.hasSibling - if annexed - then initialize Nothing - else error "First run: git-annex init" + needsinit = ifM Annex.Branch.hasSibling + ( initialize Nothing + , error "First run: git-annex init" + ) {- set up a git pre-commit hook, if one is not already present -} gitPreCommitHookWrite :: Annex () gitPreCommitHookWrite = unlessBare $ do hook <- preCommitHook - exists <- liftIO $ doesFileExist hook - if exists - then warning $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring" - else liftIO $ do + ifM (liftIO $ doesFileExist hook) + ( warning $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring" + , liftIO $ do viaTmp writeFile hook preCommitScript p <- getPermissions hook setPermissions hook $ p {executable = True} + ) gitPreCommitHookUnWrite :: Annex () gitPreCommitHookUnWrite = unlessBare $ do diff --git a/Remote.hs b/Remote.hs index b3f464f5c2..aac45fae9d 100644 --- a/Remote.hs +++ b/Remote.hs @@ -70,19 +70,13 @@ addName desc n - (Or it can be a UUID.) Only finds currently configured git remotes. -} byName :: Maybe String -> Annex (Maybe Remote) byName Nothing = return Nothing -byName (Just n) = do - res <- byName' n - case res of - Left e -> error e - Right r -> return $ Just r +byName (Just n) = either error Just <$> byName' n byName' :: String -> Annex (Either String Remote) byName' "" = return $ Left "no remote specified" -byName' n = do - match <- filter matching <$> remoteList - if null match - then return $ Left $ "there is no git remote named \"" ++ n ++ "\"" - else return $ Right $ Prelude.head match +byName' n = handle . filter matching <$> remoteList 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 {- Looks up a remote by name (or by UUID, or even by description), diff --git a/Utility/Monad.hs b/Utility/Monad.hs index 28aa33ee82..23c0c4c194 100644 --- a/Utility/Monad.hs +++ b/Utility/Monad.hs @@ -1,6 +1,6 @@ {- monadic stuff - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -14,11 +14,7 @@ import Control.Monad (liftM) - 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 +firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs) {- Returns true if any value in the list satisfies the predicate, - 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 = 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. -} observe :: Monad m => (a -> m b) -> m a -> m a observe observer a = do