diff options
| -rw-r--r-- | Git.hs | 24 | ||||
| -rw-r--r-- | Git/Branch.hs | 10 | ||||
| -rw-r--r-- | Git/Config.hs | 13 | ||||
| -rw-r--r-- | Git/Construct.hs | 59 | ||||
| -rw-r--r-- | Init.hs | 10 | ||||
| -rw-r--r-- | Logs/Presence.hs | 7 | ||||
| -rw-r--r-- | Logs/Remote.hs | 9 | ||||
| -rw-r--r-- | Upgrade/V0.hs | 13 | ||||
| -rw-r--r-- | Upgrade/V1.hs | 56 |
9 files changed, 95 insertions, 106 deletions
@@ -31,7 +31,6 @@ module Git ( import qualified Data.Map as M import Data.Char import Network.URI (uriPath, uriScheme, unEscapeString) -import System.Directory import System.Posix.Files import Common @@ -83,11 +82,14 @@ repoIsLocalBare r@(Repo { location = Dir _ }) = configAvail r && configBare r repoIsLocalBare _ = False assertLocal :: Repo -> a -> a -assertLocal repo action = - if not $ repoIsUrl repo - then action - else error $ "acting on non-local git repo " ++ repoDescribe repo ++ - " not supported" +assertLocal repo action + | repoIsUrl repo = error $ unwords + [ "acting on non-local git repo" + , repoDescribe repo + , "not supported" + ] + | otherwise = action + configBare :: Repo -> Bool configBare repo = maybe unknown (fromMaybe False . configTrue) $ M.lookup "core.bare" $ config repo @@ -113,12 +115,10 @@ gitDir repo hookPath :: String -> Repo -> IO (Maybe FilePath) hookPath script repo = do let hook = gitDir repo </> "hooks" </> script - e <- doesFileExist hook - if e - then do - m <- fileMode <$> getFileStatus hook - return $ if isExecutable m then Just hook else Nothing - else return Nothing + ifM (catchBoolIO $ isexecutable hook) + ( return $ Just hook , return Nothing ) + where + isexecutable f = isExecutable . fileMode <$> getFileStatus f {- Path to a repository's --work-tree, that is, its top. - diff --git a/Git/Branch.hs b/Git/Branch.hs index cd9188228..6edc1c306 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -41,14 +41,14 @@ changed origbranch newbranch repo -} fastForward :: Branch -> [Ref] -> Repo -> IO Bool fastForward _ [] _ = return True -fastForward branch (first:rest) repo = do +fastForward branch (first:rest) repo = -- First, check that the branch does not contain any -- new commits that are not in the first ref. If it does, -- cannot fast-forward. - diverged <- changed first branch repo - if diverged - then no_ff - else maybe no_ff do_ff =<< findbest first rest + ifM (changed first branch repo) + ( no_ff + , maybe no_ff do_ff =<< findbest first rest + ) where no_ff = return False do_ff to = do diff --git a/Git/Config.hs b/Git/Config.hs index 0d73a0b9a..8190a62ad 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -26,16 +26,15 @@ getMaybe key repo = M.lookup key (config repo) {- Runs git config and populates a repo with its config. -} read :: Repo -> IO Repo -read repo@(Repo { location = Dir d }) = do +read repo@(Repo { location = Dir d }) = bracketcd d $ {- Cannot use pipeRead because it relies on the config having been already read. Instead, chdir to the repo. -} - cwd <- getCurrentDirectory - if dirContains d cwd - then go - else bracket_ (changeWorkingDirectory d) (changeWorkingDirectory cwd) go + pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ hRead repo where - go = pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ - hRead repo + bracketcd to a = bracketcd' to a =<< getCurrentDirectory + bracketcd' to a cwd + | dirContains to cwd = a + | otherwise = bracket_ (changeWorkingDirectory to) (changeWorkingDirectory cwd) a read r = assertLocal r $ error $ "internal error; trying to read config of " ++ show r diff --git a/Git/Construct.hs b/Git/Construct.hs index ef6094a21..49905f818 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -69,27 +69,25 @@ fromPath dir = fromAbsPath =<< absPath dir - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir - | "/" `isPrefixOf` dir = do - -- Git always looks for "dir.git" in preference to - -- to "dir", even if dir ends in a "/". - let canondir = dropTrailingPathSeparator dir - let dir' = canondir ++ ".git" - e <- doesDirectoryExist dir' - if e - then ret dir' - else if "/.git" `isSuffixOf` canondir - then do - -- When dir == "foo/.git", git looks - -- for "foo/.git/.git", and failing - -- that, uses "foo" as the repository. - e' <- doesDirectoryExist $ dir </> ".git" - if e' - then ret dir - else ret $ takeDirectory canondir - else ret dir - | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" + | "/" `isPrefixOf` dir = + ifM (doesDirectoryExist dir') ( ret dir' , hunt ) + | otherwise = + error $ "internal error, " ++ dir ++ " is not absolute" where ret = newFrom . Dir + {- Git always looks for "dir.git" in preference to + - to "dir", even if dir ends in a "/". -} + canondir = dropTrailingPathSeparator dir + dir' = canondir ++ ".git" + {- When dir == "foo/.git", git looks for "foo/.git/.git", + - and failing that, uses "foo" as the repository. -} + hunt + | "/.git" `isSuffixOf` canondir = + ifM (doesDirectoryExist $ dir </> ".git") + ( ret dir + , ret $ takeDirectory canondir + ) + | otherwise = ret dir {- Remote Repo constructor. Throws exception on invalid url. - @@ -229,27 +227,20 @@ expandTilde = expandt True | otherwise = findname (n++[c]) cs seekUp :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath) -seekUp want dir = do - ok <- want dir - if ok - then return $ Just dir - else case parentDir dir of +seekUp want dir = + ifM (want dir) + ( return $ Just dir + , case parentDir dir of "" -> return Nothing d -> seekUp want d + ) isRepoTop :: FilePath -> IO Bool -isRepoTop dir = do - r <- isRepo - if r - then return r - else isBareRepo +isRepoTop dir = ifM isRepo ( return True , isBareRepo ) where isRepo = gitSignature (".git" </> "config") - isBareRepo = do - e <- doesDirectoryExist (dir </> "objects") - if not e - then return e - else gitSignature "config" + isBareRepo = ifM (doesDirectoryExist $ dir </> "objects") + ( gitSignature "config" , return False ) gitSignature file = doesFileExist (dir </> file) newFrom :: RepoLocation -> IO Repo @@ -58,13 +58,13 @@ gitPreCommitHookWrite = unlessBare $ do gitPreCommitHookUnWrite :: Annex () gitPreCommitHookUnWrite = unlessBare $ do hook <- preCommitHook - whenM (liftIO $ doesFileExist hook) $ do - c <- liftIO $ readFile hook - if c == preCommitScript - then liftIO $ removeFile hook - else warning $ "pre-commit hook (" ++ hook ++ + whenM (liftIO $ doesFileExist hook) $ + ifM (liftIO $ (==) preCommitScript <$> readFile hook) + ( liftIO $ removeFile hook + , warning $ "pre-commit hook (" ++ hook ++ ") contents modified; not deleting." ++ " Edit it to remove call to git annex." + ) unlessBare :: Annex () -> Annex () unlessBare = unlessM $ fromRepo Git.repoIsLocalBare diff --git a/Logs/Presence.hs b/Logs/Presence.hs index 372af37d5..933426718 100644 --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -99,10 +99,9 @@ type LogMap = M.Map String LogLine {- Inserts a log into a map of logs, if the log has better (ie, newer) - information than the other logs in the map -} mapLog :: LogLine -> LogMap -> LogMap -mapLog l m = - if better - then M.insert i l m - else m +mapLog l m + | better = M.insert i l m + | otherwise = m where better = maybe True newer $ M.lookup i m newer l' = date l' <= date l diff --git a/Logs/Remote.hs b/Logs/Remote.hs index ccfb4bb31..5c9d67df0 100644 --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -72,14 +72,15 @@ configUnEscape = unescape unescape (c:rest) | c == '&' = entity rest | otherwise = c : unescape rest - entity s = if ok - then chr (Prelude.read num) : unescape rest - else '&' : unescape s + entity s + | not (null num) && ";" `isPrefixOf` r = + chr (Prelude.read num) : unescape rest + | otherwise = + '&' : unescape s where num = takeWhile isNumber s r = drop (length num) s rest = drop 1 r - ok = not (null num) && ";" `isPrefixOf` r {- for quickcheck -} prop_idempotent_configEscape :: String -> Bool diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs index c439c7caa..8f3af337e 100644 --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -35,14 +35,11 @@ lookupFile0 :: FilePath -> Annex (Maybe (Key, Backend)) lookupFile0 = Upgrade.V1.lookupFile1 getKeysPresent0 :: FilePath -> Annex [Key] -getKeysPresent0 dir = do - exists <- liftIO $ doesDirectoryExist dir - if not exists - then return [] - else do - contents <- liftIO $ getDirectoryContents dir - files <- liftIO $ filterM present contents - return $ map fileKey0 files +getKeysPresent0 dir = ifM (liftIO $ doesDirectoryExist dir) + ( liftIO $ map fileKey0 + <$> (filterM present =<< getDirectoryContents dir) + , return [] + ) where present d = do result <- tryIO $ diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index ca2bff661..62e3b3b31 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -50,18 +50,18 @@ upgrade :: Annex Bool upgrade = do showAction "v1 to v2" - bare <- fromRepo Git.repoIsLocalBare - if bare - then do + ifM (fromRepo Git.repoIsLocalBare) + ( do moveContent setVersion - else do + , do moveContent updateSymlinks moveLocationLogs Annex.Queue.flush True setVersion + ) Upgrade.V2.upgrade @@ -104,12 +104,11 @@ moveLocationLogs = do where oldlocationlogs = do dir <- fromRepo Upgrade.V2.gitStateDir - exists <- liftIO $ doesDirectoryExist dir - if exists - then do - contents <- liftIO $ getDirectoryContents dir - return $ mapMaybe oldlog2key contents - else return [] + ifM (liftIO $ doesDirectoryExist dir) + ( mapMaybe oldlog2key + <$> (liftIO $ getDirectoryContents dir) + , return [] + ) move (l, k) = do dest <- fromRepo $ logFile2 k dir <- fromRepo Upgrade.V2.gitStateDir @@ -127,14 +126,13 @@ moveLocationLogs = do Annex.Queue.add "rm" [Param "--quiet", Param "-f", Param "--"] [f] oldlog2key :: FilePath -> Maybe (FilePath, Key) -oldlog2key l = - let len = length l - 4 in - if drop len l == ".log" - then let k = readKey1 (take len l) in - if null (keyName k) || null (keyBackendName k) - then Nothing - else Just (l, k) - else Nothing +oldlog2key l + | drop len l == ".log" && sane = Just (l, k) + | otherwise = Nothing + where + len = length l - 4 + k = readKey1 (take len l) + sane = (not . null $ keyName k) && (not . null $ keyBackendName k) -- WORM backend keys: "WORM:mtime:size:filename" -- all the rest: "backend:key" @@ -143,10 +141,14 @@ oldlog2key l = -- v2 and v1; that infelicity is worked around by treating the value -- as the v2 key that it is. readKey1 :: String -> Key -readKey1 v = - if mixup - then fromJust $ readKey $ join ":" $ Prelude.tail bits - else Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t } +readKey1 v + | mixup = fromJust $ readKey $ join ":" $ Prelude.tail bits + | otherwise = Key + { keyName = n + , keyBackendName = b + , keySize = s + , keyMtime = t + } where bits = split ":" v b = Prelude.head bits @@ -205,14 +207,14 @@ lookupFile1 file = do getKeyFilesPresent1 :: Annex [FilePath] getKeyFilesPresent1 = getKeyFilesPresent1' =<< fromRepo gitAnnexObjectDir getKeyFilesPresent1' :: FilePath -> Annex [FilePath] -getKeyFilesPresent1' dir = do - exists <- liftIO $ doesDirectoryExist dir - if not exists - then return [] - else do +getKeyFilesPresent1' dir = + ifM (liftIO $ doesDirectoryExist dir) + ( do dirs <- liftIO $ getDirectoryContents dir let files = map (\d -> dir ++ "/" ++ d ++ "/" ++ takeFileName d) dirs liftIO $ filterM present files + , return [] + ) where present f = do result <- tryIO $ getFileStatus f |