From bf460a0a98d7e4c7f4eac525fcf300629db582b6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Nov 2011 15:34:10 -0400 Subject: [PATCH] reorder repo parameters last Many functions took the repo as their first parameter. Changing it consistently to be the last parameter allows doing some useful things with currying, that reduce boilerplate. In particular, g <- gitRepo is almost never needed now, instead use inRepo to run an IO action in the repo, and fromRepo to get a value from the repo. This also provides more opportunities to use monadic and applicative combinators. --- Annex.hs | 16 ++++++- Annex/Branch.hs | 60 ++++++++++------------- Annex/CatFile.hs | 3 +- Annex/Content.hs | 32 +++++-------- Annex/Queue.hs | 3 +- Annex/UUID.hs | 14 +++--- Annex/Version.hs | 10 ++-- Backend.hs | 19 +++----- Backend/SHA.hs | 3 +- Command.hs | 2 +- Command/Add.hs | 4 +- Command/AddUrl.hs | 3 +- Command/DropUnused.hs | 8 ++-- Command/Fsck.hs | 20 ++++---- Command/Map.hs | 3 +- Command/Migrate.hs | 7 ++- Command/SendKey.hs | 3 +- Command/Unannex.hs | 16 +++---- Command/Uninit.hs | 17 +++---- Command/Unlock.hs | 5 +- Command/Unused.hs | 20 ++++---- Common/Annex.hs | 2 +- Config.hs | 16 +++---- Git.hs | 100 ++++++++++++++++++++------------------- Git/CatFile.hs | 2 +- Git/LsFiles.hs | 43 +++++++++-------- Git/LsTree.hs | 6 +-- Git/Queue.hs | 8 ++-- Git/UnionMerge.hs | 54 +++++++++++---------- GitAnnex.hs | 5 +- Init.hs | 6 +-- Locations.hs | 12 ++--- Remote.hs | 14 +++--- Remote/Bup.hs | 17 ++++--- Remote/Directory.hs | 6 +-- Remote/Git.hs | 19 +++----- Remote/Helper/Special.hs | 10 ++-- Remote/Hook.hs | 9 ++-- Remote/Rsync.hs | 13 ++--- Remote/S3real.hs | 7 ++- Remote/Web.hs | 2 +- Seek.hs | 34 +++++++------ Upgrade/V0.hs | 3 +- Upgrade/V1.hs | 28 +++++------ Upgrade/V2.hs | 40 ++++++++-------- git-union-merge.hs | 4 +- 46 files changed, 338 insertions(+), 390 deletions(-) diff --git a/Annex.hs b/Annex.hs index 2c6402ac35..501e54c662 100644 --- a/Annex.hs +++ b/Annex.hs @@ -17,7 +17,9 @@ module Annex ( eval, getState, changeState, - gitRepo + gitRepo, + inRepo, + fromRepo, ) where import Control.Monad.IO.Control @@ -114,6 +116,16 @@ getState = gets changeState :: (AnnexState -> AnnexState) -> Annex () changeState = modify -{- Returns the git repository being acted on -} +{- Returns the annex's git repository. -} gitRepo :: Annex Git.Repo gitRepo = getState repo + +{- Runs an IO action in the annex's git repository. -} +inRepo :: (Git.Repo -> IO a) -> Annex a +inRepo a = do + g <- gitRepo + liftIO $ a g + +{- Extracts a value from the annex's git repisitory. -} +fromRepo :: (Git.Repo -> a) -> Annex a +fromRepo a = a <$> gitRepo diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 163c9ec60f..189289ad39 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -56,21 +56,19 @@ index g = gitAnnexDir g "index" - and merge in changes from other branches. -} genIndex :: Git.Repo -> IO () -genIndex g = Git.UnionMerge.ls_tree g fullname >>= Git.UnionMerge.update_index g +genIndex g = Git.UnionMerge.ls_tree fullname g >>= Git.UnionMerge.update_index g {- Runs an action using the branch's index file. -} withIndex :: Annex a -> Annex a withIndex = withIndex' False withIndex' :: Bool -> Annex a -> Annex a withIndex' bootstrapping a = do - g <- gitRepo - let f = index g - + f <- fromRepo $ index bracketIO (Git.useIndex f) id $ do unlessM (liftIO $ doesFileExist f) $ do unless bootstrapping create liftIO $ createDirectoryIfMissing True $ takeDirectory f - unless bootstrapping $ liftIO $ genIndex g + unless bootstrapping $ inRepo genIndex a withIndexUpdate :: Annex a -> Annex a @@ -103,19 +101,17 @@ getCache file = getState >>= go {- Creates the branch, if it does not already exist. -} create :: Annex () create = unlessM hasBranch $ do - g <- gitRepo e <- hasOrigin if e - then liftIO $ Git.run g "branch" [Param name, Param originname] + then inRepo $ Git.run "branch" [Param name, Param originname] else withIndex' True $ - liftIO $ Git.commit g "branch created" fullname [] + inRepo $ Git.commit "branch created" fullname [] {- Stages the journal, and commits staged changes to the branch. -} commit :: String -> Annex () commit message = whenM journalDirty $ lockJournal $ do stageJournalFiles - g <- gitRepo - withIndex $ liftIO $ Git.commit g message fullname [fullname] + withIndex $ inRepo $ Git.commit message fullname [fullname] {- Ensures that the branch is up-to-date; should be called before data is - read from it. Runs only once per git-annex run. @@ -134,7 +130,6 @@ commit message = whenM journalDirty $ lockJournal $ do -} update :: Annex () update = onceonly $ do - g <- gitRepo -- check what needs updating before taking the lock dirty <- journalDirty c <- filterM (changedBranch name . snd) =<< siblingBranches @@ -151,10 +146,10 @@ update = onceonly $ do - documentation advises users not to directly - modify the branch. -} - liftIO $ Git.UnionMerge.merge_index g branches + inRepo $ \g -> Git.UnionMerge.merge_index g branches ff <- if dirty then return False else tryFastForwardTo refs - unless ff $ - liftIO $ Git.commit g "update" fullname (nub $ fullname:refs) + unless ff $ inRepo $ + Git.commit "update" fullname (nub $ fullname:refs) invalidateCache where onceonly a = unlessM (branchUpdated <$> getState) $ do @@ -165,14 +160,13 @@ update = onceonly $ do {- Checks if the second branch has any commits not present on the first - branch. -} changedBranch :: String -> String -> Annex Bool -changedBranch origbranch newbranch = do - g <- gitRepo - diffs <- liftIO $ Git.pipeRead g [ - Param "log", - Param (origbranch ++ ".." ++ newbranch), - Params "--oneline -n1" - ] - return $ not $ L.null diffs +changedBranch origbranch newbranch = not . L.null <$> diffs + where + diffs = inRepo $ Git.pipeRead + [ Param "log" + , Param (origbranch ++ ".." ++ newbranch) + , Params "--oneline -n1" + ] {- Given a set of refs that are all known to have commits not - on the git-annex branch, tries to update the branch by a @@ -195,8 +189,7 @@ tryFastForwardTo (first:rest) = do where no_ff = return False do_ff branch = do - g <- gitRepo - liftIO $ Git.run g "update-ref" [Param fullname, Param branch] + inRepo $ Git.run "update-ref" [Param fullname, Param branch] return True findbest c [] = return $ Just c findbest c (r:rs) @@ -223,10 +216,8 @@ disableUpdate = Annex.changeState setupdated {- Checks if a git ref exists. -} refExists :: GitRef -> Annex Bool -refExists ref = do - g <- gitRepo - liftIO $ Git.runBool g "show-ref" - [Param "--verify", Param "-q", Param ref] +refExists ref = inRepo $ Git.runBool "show-ref" + [Param "--verify", Param "-q", Param ref] {- Does the main git-annex branch exist? -} hasBranch :: Annex Bool @@ -244,8 +235,7 @@ hasSomeBranch = not . null <$> siblingBranches - from remotes. Duplicate refs are filtered out. -} siblingBranches :: Annex [(String, String)] siblingBranches = do - g <- gitRepo - r <- liftIO $ Git.pipeRead g [Param "show-ref", Param name] + r <- inRepo $ Git.pipeRead [Param "show-ref", Param name] return $ nubBy uref $ map (pair . words . L.unpack) (L.lines r) where pair l = (head l, last l) @@ -280,8 +270,7 @@ get file = fromcache =<< getCache file {- Lists all files on the branch. There may be duplicates in the list. -} files :: Annex [FilePath] files = withIndexUpdate $ do - g <- gitRepo - bfiles <- liftIO $ Git.pipeNullSplit g + bfiles <- inRepo $ Git.pipeNullSplit [Params "ls-tree --name-only -r -z", Param fullname] jfiles <- getJournalledFiles return $ jfiles ++ bfiles @@ -349,8 +338,8 @@ stageJournalFiles = do where index_lines shas = map genline . zip shas genline (sha, file) = Git.UnionMerge.update_index_line sha file - git_hash_object g = Git.gitCommandLine g - [Param "hash-object", Param "-w", Param "--stdin-paths"] + git_hash_object g = Git.gitCommandLine + [Param "hash-object", Param "-w", Param "--stdin-paths"] g {- Checks if there are changes in the journal. -} @@ -379,8 +368,7 @@ fileJournal = replace "//" "_" . replace "_" "/" - contention with other git-annex processes. -} lockJournal :: Annex a -> Annex a lockJournal a = do - g <- gitRepo - let file = gitAnnexJournalLock g + file <- fromRepo $ gitAnnexJournalLock bracketIO (lock file) unlock a where lock file = do diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs index 2707ed3ea3..a043e1ae3d 100644 --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -17,8 +17,7 @@ catFile :: String -> FilePath -> Annex String catFile branch file = maybe startup go =<< Annex.getState Annex.catfilehandle where startup = do - g <- gitRepo - h <- liftIO $ Git.CatFile.catFileStart g + h <- inRepo $ Git.CatFile.catFileStart Annex.changeState $ \s -> s { Annex.catfilehandle = Just h } go h go h = liftIO $ Git.CatFile.catFile h branch file diff --git a/Annex/Content.hs b/Annex/Content.hs index aafdf6f2e6..fc2c2d0921 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -37,18 +37,18 @@ import Config {- Checks if a given key is currently present in the gitAnnexLocation. -} inAnnex :: Key -> Annex Bool inAnnex key = do - g <- gitRepo - when (Git.repoIsUrl g) $ error "inAnnex cannot check remote repo" - liftIO $ doesFileExist $ gitAnnexLocation g key + whenM (fromRepo Git.repoIsUrl) $ + error "inAnnex cannot check remote repo" + inRepo $ doesFileExist . gitAnnexLocation key {- Calculates the relative path to use to link a file to a key. -} calcGitLink :: FilePath -> Key -> Annex FilePath calcGitLink file key = do - g <- gitRepo cwd <- liftIO getCurrentDirectory let absfile = fromMaybe whoops $ absNormPath cwd file + top <- fromRepo Git.workTree return $ relPathDirToFile (parentDir absfile) - (Git.workTree g) ".git" annexLocation key + top ".git" annexLocation key where whoops = error $ "unable to normalize " ++ file @@ -65,8 +65,7 @@ logStatus key status = do - the annex as a key's content. -} getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool getViaTmp key action = do - g <- gitRepo - let tmp = gitAnnexTmpLocation g key + tmp <- fromRepo $ gitAnnexTmpLocation key -- Check that there is enough free disk space. -- When the temp file already exists, count the space @@ -84,8 +83,7 @@ getViaTmp key action = do prepTmp :: Key -> Annex FilePath prepTmp key = do - g <- gitRepo - let tmp = gitAnnexTmpLocation g key + tmp <- fromRepo $ gitAnnexTmpLocation key liftIO $ createDirectoryIfMissing True (parentDir tmp) return tmp @@ -162,8 +160,7 @@ checkDiskSpace' adjustment key = do -} moveAnnex :: Key -> FilePath -> Annex () moveAnnex key src = do - g <- gitRepo - let dest = gitAnnexLocation g key + dest <- fromRepo $ gitAnnexLocation key let dir = parentDir dest e <- liftIO $ doesFileExist dest if e @@ -177,8 +174,7 @@ moveAnnex key src = do withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a withObjectLoc key a = do - g <- gitRepo - let file = gitAnnexLocation g key + file <- fromRepo $gitAnnexLocation key let dir = parentDir file a (dir, file) @@ -201,9 +197,9 @@ fromAnnex key dest = withObjectLoc key $ \(dir, file) -> liftIO $ do - returns the file it was moved to. -} moveBad :: Key -> Annex FilePath moveBad key = do - g <- gitRepo - let src = gitAnnexLocation g key - let dest = gitAnnexBadDir g takeFileName src + src <- fromRepo $ gitAnnexLocation key + bad <- fromRepo $ gitAnnexBadDir + let dest = bad takeFileName src liftIO $ do createDirectoryIfMissing True (parentDir dest) allowWrite (parentDir src) @@ -214,9 +210,7 @@ moveBad key = do {- List of keys whose content exists in .git/annex/objects/ -} getKeysPresent :: Annex [Key] -getKeysPresent = do - g <- gitRepo - getKeysPresent' $ gitAnnexObjectDir g +getKeysPresent = getKeysPresent' =<< fromRepo gitAnnexObjectDir getKeysPresent' :: FilePath -> Annex [Key] getKeysPresent' dir = do exists <- liftIO $ doesDirectoryExist dir diff --git a/Annex/Queue.hs b/Annex/Queue.hs index 4c1182750a..f611cf02eb 100644 --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -34,8 +34,7 @@ flush silent = do unless (0 == Git.Queue.size q) $ do unless silent $ showSideAction "Recording state in git" - g <- gitRepo - q' <- liftIO $ Git.Queue.flush g q + q' <- inRepo $ Git.Queue.flush q store q' store :: Git.Queue.Queue -> Annex () diff --git a/Annex/UUID.hs b/Annex/UUID.hs index d3d674dcc6..6fc04c0f09 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -45,23 +45,23 @@ getUUID = getRepoUUID =<< gitRepo {- Looks up a repo's UUID. May return "" if none is known. -} getRepoUUID :: Git.Repo -> Annex UUID getRepoUUID r = do - g <- gitRepo - - let c = cached g + c <- fromRepo cached let u = getUncachedUUID r if c /= u && u /= NoUUID then do - updatecache g u + updatecache u return u else return c where - cached g = toUUID $ Git.configGet g cachekey "" - updatecache g u = when (g /= r) $ storeUUID cachekey u + cached g = toUUID $ Git.configGet cachekey "" g + updatecache u = do + g <- gitRepo + when (g /= r) $ storeUUID cachekey u cachekey = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-uuid" getUncachedUUID :: Git.Repo -> UUID -getUncachedUUID r = toUUID $ Git.configGet r configkey "" +getUncachedUUID = toUUID . Git.configGet configkey "" {- Make sure that the repo has an annex.uuid setting. -} prepUUID :: Annex () diff --git a/Annex/Version.hs b/Annex/Version.hs index 935f777abf..9e694faf14 100644 --- a/Annex/Version.hs +++ b/Annex/Version.hs @@ -26,12 +26,10 @@ versionField :: String versionField = "annex.version" getVersion :: Annex (Maybe Version) -getVersion = do - g <- gitRepo - let v = Git.configGet g versionField "" - if not $ null v - then return $ Just v - else return Nothing +getVersion = handle <$> fromRepo (Git.configGet versionField "") + where + handle [] = Nothing + handle v = Just v setVersion :: Annex () setVersion = setConfig versionField defaultVersion diff --git a/Backend.hs b/Backend.hs index 9a40e54598..f7990c22c1 100644 --- a/Backend.hs +++ b/Backend.hs @@ -47,10 +47,7 @@ orderedList = do l' <- (lookupBackendName name :) <$> standard Annex.changeState $ \s -> s { Annex.backends = l' } return l' - standard = do - g <- gitRepo - return $ parseBackendList $ - Git.configGet g "annex.backends" "" + standard = fromRepo $ parseBackendList . Git.configGet "annex.backends" "" parseBackendList [] = list parseBackendList s = map lookupBackendName $ words s @@ -96,16 +93,14 @@ type BackendFile = (Maybe (Backend Annex), FilePath) - That can be configured on a per-file basis in the gitattributes file. -} chooseBackends :: [FilePath] -> Annex [BackendFile] -chooseBackends fs = do - g <- gitRepo - forced <- Annex.getState Annex.forcebackend - if isJust forced - then do +chooseBackends fs = Annex.getState Annex.forcebackend >>= go + where + go Nothing = do + pairs <- inRepo $ Git.checkAttr "annex.backend" fs + return $ map (\(f,b) -> (maybeLookupBackendName b, f)) pairs + go (Just _) = do l <- orderedList return $ map (\f -> (Just $ head l, f)) fs - else do - pairs <- liftIO $ Git.checkAttr g "annex.backend" fs - return $ map (\(f,b) -> (maybeLookupBackendName b, f)) pairs {- Looks up a backend by name. May fail if unknown. -} lookupBackendName :: String -> Backend Annex diff --git a/Backend/SHA.hs b/Backend/SHA.hs index d449821172..a3846a410b 100644 --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -98,9 +98,8 @@ keyValueE size file = keyValue size file >>= maybe (return Nothing) addE {- A key's checksum is checked during fsck. -} checkKeyChecksum :: SHASize -> Key -> Annex Bool checkKeyChecksum size key = do - g <- gitRepo fast <- Annex.getState Annex.fast - let file = gitAnnexLocation g key + file <- fromRepo $ gitAnnexLocation key present <- liftIO $ doesFileExist file if not present || fast then return True diff --git a/Command.hs b/Command.hs index c11b906103..c436c5b628 100644 --- a/Command.hs +++ b/Command.hs @@ -78,7 +78,7 @@ notBareRepo a = do a isBareRepo :: Annex Bool -isBareRepo = Git.repoIsLocalBare <$> gitRepo +isBareRepo = fromRepo Git.repoIsLocalBare {- Used for commands that have an auto mode that checks the number of known - copies of a key. diff --git a/Command/Add.hs b/Command/Add.hs index a633db7b36..ab104b53cc 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -60,8 +60,8 @@ undo file key e = do -- fromAnnex could fail if the file ownership is weird tryharder :: IOException -> Annex () tryharder _ = do - g <- gitRepo - liftIO $ renameFile (gitAnnexLocation g key) file + src <- fromRepo $ gitAnnexLocation key + liftIO $ renameFile src file cleanup :: FilePath -> Key -> Bool -> CommandCleanup cleanup file key hascontent = do diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index b717e271d1..945848e9f7 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -41,10 +41,9 @@ perform url file = do download :: String -> FilePath -> CommandPerform download url file = do - g <- gitRepo showAction $ "downloading " ++ url ++ " " let dummykey = Backend.URL.fromUrl url - let tmp = gitAnnexTmpLocation g dummykey + tmp <- fromRepo $ gitAnnexTmpLocation dummykey liftIO $ createDirectoryIfMissing True (parentDir tmp) ok <- liftIO $ Url.download url tmp if ok diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 70dcc4cc72..55c21f83bf 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -58,17 +58,15 @@ perform key = maybe droplocal dropremote =<< Annex.getState Annex.fromremote next $ Command.Drop.cleanupRemote key r droplocal = Command.Drop.performLocal key (Just 0) -- force drop -performOther :: (Git.Repo -> Key -> FilePath) -> Key -> CommandPerform +performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther filespec key = do - g <- gitRepo - let f = filespec g key + f <- fromRepo $ filespec key liftIO $ whenM (doesFileExist f) $ removeFile f next $ return True readUnusedLog :: FilePath -> Annex UnusedMap readUnusedLog prefix = do - g <- gitRepo - let f = gitAnnexUnusedLog prefix g + f <- fromRepo $ gitAnnexUnusedLog prefix e <- liftIO $ doesFileExist f if e then M.fromList . map parse . lines <$> liftIO (readFile f) diff --git a/Command/Fsck.hs b/Command/Fsck.hs index d1abb29e37..3feabeb9ee 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -79,26 +79,26 @@ check = sequence >=> dispatch in this repository only. -} verifyLocationLog :: Key -> String -> Annex Bool verifyLocationLog key desc = do - g <- gitRepo present <- inAnnex key -- Since we're checking that a key's file is present, throw -- in a permission fixup here too. - when present $ liftIO $ do - let f = gitAnnexLocation g key - preventWrite f - preventWrite (parentDir f) + when present $ do + f <- fromRepo $ gitAnnexLocation key + liftIO $ do + preventWrite f + preventWrite (parentDir f) u <- getUUID uuids <- keyLocations key case (present, u `elem` uuids) of (True, False) -> do - fix g u InfoPresent + fix u InfoPresent -- There is no data loss, so do not fail. return True (False, True) -> do - fix g u InfoMissing + fix u InfoMissing warning $ "** Based on the location log, " ++ desc ++ "\n** was expected to be present, " ++ @@ -107,16 +107,16 @@ verifyLocationLog key desc = do _ -> return True where - fix g u s = do + fix u s = do showNote "fixing location log" + g <- gitRepo logChange g key u s {- The size of the data for a key is checked against the size encoded in - the key's metadata, if available. -} checkKeySize :: Key -> Annex Bool checkKeySize key = do - g <- gitRepo - let file = gitAnnexLocation g key + file <- fromRepo $ gitAnnexLocation key present <- liftIO $ doesFileExist file case (present, Types.Key.keySize key) of (_, Nothing) -> return True diff --git a/Command/Map.hs b/Command/Map.hs index 11808ed636..f72cb107ad 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -31,8 +31,7 @@ seek = [withNothing start] start :: CommandStart start = do - g <- gitRepo - rs <- spider g + rs <- spider =<< gitRepo umap <- uuidMap trusted <- trustGet Trusted diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 2d4d24a224..a823466dc7 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -42,14 +42,13 @@ upgradableKey key = isNothing $ Types.Key.keySize key perform :: FilePath -> Key -> Backend Annex -> CommandPerform perform file oldkey newbackend = do - g <- gitRepo - -- Store the old backend's cached key in the new backend -- (the file can't be stored as usual, because it's already a symlink). -- The old backend's key is not dropped from it, because there may -- be other files still pointing at that key. - let src = gitAnnexLocation g oldkey - let tmpfile = gitAnnexTmpDir g takeFileName file + src <- fromRepo $ gitAnnexLocation oldkey + tmp <- fromRepo $ gitAnnexTmpDir + let tmpfile = tmp takeFileName file liftIO $ createLink src tmpfile k <- Backend.genKey tmpfile $ Just newbackend liftIO $ cleantmp tmpfile diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 318ea56d03..5737478671 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -21,8 +21,7 @@ seek = [withKeys start] start :: Key -> CommandStart start key = do - g <- gitRepo - let file = gitAnnexLocation g key + file <- fromRepo $ gitAnnexLocation key whenM (inAnnex key) $ liftIO $ rsyncServerSend file -- does not return warning "requested key is not present" diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 825f819390..d24f921a93 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -31,8 +31,8 @@ start file = isAnnexed file $ \(key, _) -> do then do force <- Annex.getState Annex.force unless force $ do - g <- gitRepo - staged <- liftIO $ LsFiles.staged g [Git.workTree g] + top <- fromRepo Git.workTree + staged <- inRepo $ LsFiles.staged [top] unless (null staged) $ error "This command cannot be run when there are already files staged for commit." Annex.changeState $ \s -> s { Annex.force = True } @@ -46,19 +46,19 @@ perform file key = next $ cleanup file key cleanup :: FilePath -> Key -> CommandCleanup cleanup file key = do - g <- gitRepo - liftIO $ removeFile file - liftIO $ Git.run g "rm" [Params "--quiet --", File file] + inRepo $ Git.run "rm" [Params "--quiet --", File file] -- git rm deletes empty directories; put them back liftIO $ createDirectoryIfMissing True (parentDir file) fast <- Annex.getState Annex.fast if fast - then liftIO $ do + then do -- fast mode: hard link to content in annex - createLink (gitAnnexLocation g key) file - allowWrite file + src <- fromRepo $ gitAnnexLocation key + liftIO $ do + createLink src file + allowWrite file else do fromAnnex key file logStatus key InfoMissing diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 5a6ee0be25..f317b7620d 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -28,11 +28,9 @@ check = do when (b == Annex.Branch.name) $ error $ "cannot uninit when the " ++ b ++ " branch is checked out" where - current_branch = do - g <- gitRepo - b <- liftIO $ - Git.pipeRead g [Params "rev-parse --abbrev-ref HEAD"] - return $ head $ lines $ B.unpack b + current_branch = head . lines . B.unpack <$> revhead + revhead = inRepo $ Git.pipeRead + [Params "rev-parse --abbrev-ref HEAD"] seek :: [CommandSeek] seek = [withFilesInGit startUnannex, withNothing start] @@ -53,12 +51,11 @@ perform = next cleanup cleanup :: CommandCleanup cleanup = do - g <- gitRepo + annexdir <- fromRepo $ gitAnnexDir uninitialize mapM_ removeAnnex =<< getKeysPresent - liftIO $ removeDirectoryRecursive (gitAnnexDir g) + liftIO $ removeDirectoryRecursive annexdir -- avoid normal shutdown saveState - liftIO $ do - Git.run g "branch" [Param "-D", Param Annex.Branch.name] - exitSuccess + inRepo $ Git.run "branch" [Param "-D", Param Annex.Branch.name] + liftIO $ exitSuccess diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 7ecaf0b7fa..590b753111 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -37,9 +37,8 @@ perform dest key = do checkDiskSpace key - g <- gitRepo - let src = gitAnnexLocation g key - let tmpdest = gitAnnexTmpLocation g key + src <- fromRepo $ gitAnnexLocation key + tmpdest <- fromRepo $ gitAnnexTmpLocation key liftIO $ createDirectoryIfMissing True (parentDir tmpdest) showAction "copying" ok <- liftIO $ copyFileExternal src tmpdest diff --git a/Command/Unused.hs b/Command/Unused.hs index 7e9ffa01f5..9d56d1ff11 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -75,8 +75,8 @@ checkRemoteUnused' r = do writeUnusedFile :: FilePath -> [(Int, Key)] -> Annex () writeUnusedFile prefix l = do - g <- gitRepo - liftIO $ viaTmp writeFile (gitAnnexUnusedLog prefix g) $ + logfile <- fromRepo $ gitAnnexUnusedLog prefix + liftIO $ viaTmp writeFile logfile $ unlines $ map (\(n, k) -> show n ++ " " ++ show k) l table :: [(Int, Key)] -> [String] @@ -147,8 +147,7 @@ unusedKeys = do excludeReferenced :: [Key] -> Annex [Key] excludeReferenced [] = return [] -- optimisation excludeReferenced l = do - g <- gitRepo - c <- liftIO $ Git.pipeRead g [Param "show-ref"] + c <- inRepo $ Git.pipeRead [Param "show-ref"] removewith (getKeysReferenced : map getKeysReferencedInGit (refs c)) (S.fromList l) where @@ -183,8 +182,8 @@ exclude smaller larger = S.toList $ remove larger $ S.fromList smaller {- List of keys referenced by symlinks in the git repo. -} getKeysReferenced :: Annex [Key] getKeysReferenced = do - g <- gitRepo - files <- liftIO $ LsFiles.inRepo g [Git.workTree g] + top <- fromRepo Git.workTree + files <- inRepo $ LsFiles.inRepo [top] keypairs <- mapM Backend.lookupFile files return $ map fst $ catMaybes keypairs @@ -192,8 +191,7 @@ getKeysReferenced = do getKeysReferencedInGit :: String -> Annex [Key] getKeysReferencedInGit ref = do showAction $ "checking " ++ Git.refDescribe ref - g <- gitRepo - findkeys [] =<< liftIO (LsTree.lsTree g ref) + findkeys [] =<< inRepo (LsTree.lsTree ref) where findkeys c [] = return c findkeys c (l:ls) @@ -217,16 +215,14 @@ staleKeysPrune dirspec present = do let stale = contents `exclude` present let dups = contents `exclude` stale - g <- gitRepo - let dir = dirspec g + dir <- fromRepo dirspec liftIO $ forM_ dups $ \t -> removeFile $ dir keyFile t return stale staleKeys :: (Git.Repo -> FilePath) -> Annex [Key] staleKeys dirspec = do - g <- gitRepo - let dir = dirspec g + dir <- fromRepo dirspec exists <- liftIO $ doesDirectoryExist dir if not exists then return [] diff --git a/Common/Annex.hs b/Common/Annex.hs index f802ec2533..6b5bc31de2 100644 --- a/Common/Annex.hs +++ b/Common/Annex.hs @@ -10,6 +10,6 @@ module Common.Annex ( import Common import Types import Types.UUID (toUUID, fromUUID) -import Annex (gitRepo) +import Annex (gitRepo, inRepo, fromRepo) import Locations import Messages diff --git a/Config.hs b/Config.hs index bf929219df..c24ab9d04d 100644 --- a/Config.hs +++ b/Config.hs @@ -16,19 +16,17 @@ type ConfigKey = String {- Changes a git config setting in both internal state and .git/config -} setConfig :: ConfigKey -> String -> Annex () setConfig k value = do - g <- gitRepo - liftIO $ Git.run g "config" [Param k, Param value] + inRepo $ Git.run "config" [Param k, Param value] -- re-read git config and update the repo's state - g' <- liftIO $ Git.configRead g - Annex.changeState $ \s -> s { Annex.repo = g' } + newg <- inRepo $ Git.configRead + Annex.changeState $ \s -> s { Annex.repo = newg } {- Looks up a per-remote config setting in git config. - Failing that, tries looking for a global config option. -} getConfig :: Git.Repo -> ConfigKey -> String -> Annex String getConfig r key def = do - g <- gitRepo - let def' = Git.configGet g ("annex." ++ key) def - return $ Git.configGet g (remoteConfig r key) def' + def' <- fromRepo $ Git.configGet ("annex." ++ key) def + fromRepo $ Git.configGet (remoteConfig r key) def' remoteConfig :: Git.Repo -> ConfigKey -> String remoteConfig r key = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-" ++ key @@ -87,7 +85,5 @@ getNumCopies v = Annex.getState Annex.forcenumcopies >>= maybe (use v) (return . id) where use (Just n) = return n - use Nothing = do - g <- gitRepo - return $ read $ Git.configGet g config "1" + use Nothing = read <$> fromRepo (Git.configGet config "1") config = "annex.numcopies" diff --git a/Git.hs b/Git.hs index b05c3b2d5e..6fb6e8361c 100644 --- a/Git.hs +++ b/Git.hs @@ -188,13 +188,13 @@ repoRemoteName Repo { remoteName = Just name } = Just name repoRemoteName _ = Nothing {- Sets the name of a remote. -} -repoRemoteNameSet :: Repo -> String -> Repo -repoRemoteNameSet r n = r { remoteName = Just n } +repoRemoteNameSet :: String -> Repo -> Repo +repoRemoteNameSet n r = r { remoteName = Just n } {- Sets the name of a remote based on the git config key, such as "remote.foo.url". -} -repoRemoteNameFromKey :: Repo -> String -> Repo -repoRemoteNameFromKey r k = repoRemoteNameSet r basename +repoRemoteNameFromKey :: String -> Repo -> Repo +repoRemoteNameFromKey k = repoRemoteNameSet basename where basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k @@ -280,8 +280,8 @@ workTree Repo { location = Unknown } = undefined - is itself a symlink). But, if the cwd is "/tmp/repo/subdir", - it's best to refer to "../foo". -} -workTreeFile :: Repo -> FilePath -> IO FilePath -workTreeFile repo@(Repo { location = Dir d }) file = do +workTreeFile :: FilePath -> Repo -> IO FilePath +workTreeFile file repo@(Repo { location = Dir d }) = do cwd <- getCurrentDirectory let file' = absfile cwd unless (inrepo file') $ @@ -296,7 +296,7 @@ workTreeFile repo@(Repo { location = Dir d }) file = do absfile c = fromMaybe file $ secureAbsNormPath c file inrepo f = absrepo `isPrefixOf` f bad = error $ "bad repo" ++ repoDescribe repo -workTreeFile repo _ = assertLocal repo $ error "internal" +workTreeFile _ repo = assertLocal repo $ error "internal" {- Path of an URL repo. -} urlPath :: Repo -> String @@ -350,23 +350,23 @@ urlAuthPart a Repo { location = Url u } = a auth urlAuthPart _ repo = assertUrl repo $ error "internal" {- Constructs a git command line operating on the specified repo. -} -gitCommandLine :: Repo -> [CommandParam] -> [CommandParam] -gitCommandLine repo@(Repo { location = Dir _ } ) params = +gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] +gitCommandLine params repo@(Repo { location = Dir _ } ) = -- force use of specified repo via --git-dir and --work-tree [ Param ("--git-dir=" ++ gitDir repo) , Param ("--work-tree=" ++ workTree repo) ] ++ params -gitCommandLine repo _ = assertLocal repo $ error "internal" +gitCommandLine _ repo = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} -runBool :: Repo -> String -> [CommandParam] -> IO Bool -runBool repo subcommand params = assertLocal repo $ - boolSystem "git" $ gitCommandLine repo $ Param subcommand : params +runBool :: String -> [CommandParam] -> Repo -> IO Bool +runBool subcommand params repo = assertLocal repo $ + boolSystem "git" $ gitCommandLine (Param subcommand : params) repo {- Runs git in the specified repo, throwing an error if it fails. -} -run :: Repo -> String -> [CommandParam] -> IO () -run repo subcommand params = assertLocal repo $ - runBool repo subcommand params +run :: String -> [CommandParam] -> Repo -> IO () +run subcommand params repo = assertLocal repo $ + runBool subcommand params repo >>! error $ "git " ++ show params ++ " failed" {- Runs a git subcommand and returns its output, lazily. @@ -374,26 +374,26 @@ run repo subcommand params = assertLocal repo $ - Note that this leaves the git process running, and so zombies will - result unless reap is called. -} -pipeRead :: Repo -> [CommandParam] -> IO L.ByteString -pipeRead repo params = assertLocal repo $ do - (_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine repo params +pipeRead :: [CommandParam] -> Repo -> IO L.ByteString +pipeRead params repo = assertLocal repo $ do + (_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo hSetBinaryMode h True L.hGetContents h {- Runs a git subcommand, feeding it input. - You should call either getProcessStatus or forceSuccess on the PipeHandle. -} -pipeWrite :: Repo -> [CommandParam] -> L.ByteString -> IO PipeHandle -pipeWrite repo params s = assertLocal repo $ do - (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine repo params) +pipeWrite :: [CommandParam] -> L.ByteString -> Repo -> IO PipeHandle +pipeWrite params s repo = assertLocal repo $ do + (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) L.hPut h s hClose h return p {- Runs a git subcommand, feeding it input, and returning its output. - You should call either getProcessStatus or forceSuccess on the PipeHandle. -} -pipeWriteRead :: Repo -> [CommandParam] -> L.ByteString -> IO (PipeHandle, L.ByteString) -pipeWriteRead repo params s = assertLocal repo $ do - (p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine repo params) +pipeWriteRead :: [CommandParam] -> L.ByteString -> Repo -> IO (PipeHandle, L.ByteString) +pipeWriteRead params s repo = assertLocal repo $ do + (p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo) hSetBinaryMode from True L.hPut to s hClose to @@ -402,13 +402,13 @@ pipeWriteRead repo params s = assertLocal repo $ do {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it. -} -pipeNullSplit :: Repo -> [CommandParam] -> IO [String] -pipeNullSplit repo params = map L.unpack <$> pipeNullSplitB repo params +pipeNullSplit :: [CommandParam] -> Repo -> IO [String] +pipeNullSplit params repo = map L.unpack <$> pipeNullSplitB params repo {- For when Strings are not needed. -} -pipeNullSplitB :: Repo -> [CommandParam] -> IO [L.ByteString] -pipeNullSplitB repo params = filter (not . L.null) . L.split '\0' <$> - pipeRead repo params +pipeNullSplitB ::[CommandParam] -> Repo -> IO [L.ByteString] +pipeNullSplitB params repo = filter (not . L.null) . L.split '\0' <$> + pipeRead params repo {- Reaps any zombie git processes. -} reap :: IO () @@ -448,15 +448,15 @@ shaSize = 40 {- Commits the index into the specified branch, - with the specified parent refs. -} -commit :: Repo -> String -> String -> [String] -> IO () -commit g message newref parentrefs = do +commit :: String -> String -> [String] -> Repo -> IO () +commit message newref parentrefs repo = do tree <- getSha "write-tree" $ asString $ - pipeRead g [Param "write-tree"] + pipeRead [Param "write-tree"] repo sha <- getSha "commit-tree" $ asString $ - ignorehandle $ pipeWriteRead g + ignorehandle $ pipeWriteRead (map Param $ ["commit-tree", tree] ++ ps) - (L.pack message) - run g "update-ref" [Param newref, Param sha] + (L.pack message) repo + run "update-ref" [Param newref, Param sha] repo where ignorehandle a = snd <$> a asString a = L.unpack <$> a @@ -478,13 +478,13 @@ configRead r = assertLocal r $ error "internal" hConfigRead :: Repo -> Handle -> IO Repo hConfigRead repo h = do val <- hGetContentsStrict h - configStore repo val + configStore val repo {- Stores a git config into a repo, returning the new version of the repo. - The git config may be multiple lines, or a single line. Config settings - can be updated inrementally. -} -configStore :: Repo -> String -> IO Repo -configStore repo s = do +configStore :: String -> Repo -> IO Repo +configStore s repo = do let repo' = repo { config = configParse s `M.union` config repo } rs <- configRemotes repo' return $ repo' { remotes = rs } @@ -507,13 +507,11 @@ configRemotes repo = mapM construct remotepairs filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isremote isremote k = startswith "remote." k && endswith ".url" k - construct (k,v) = do - r <- genRemote repo v - return $ repoRemoteNameFromKey r k + construct (k,v) = repoRemoteNameFromKey k <$> genRemote v repo {- Generates one of a repo's remotes using a given location (ie, an url). -} -genRemote :: Repo -> String -> IO Repo -genRemote repo = gen . calcloc +genRemote :: String -> Repo -> IO Repo +genRemote s repo = gen $ calcloc s where filterconfig f = filter f $ M.toList $ config repo gen v @@ -549,8 +547,8 @@ configTrue :: String -> Bool configTrue s = map toLower s == "true" {- Returns a single git config setting, or a default value if not set. -} -configGet :: Repo -> String -> String -> String -configGet repo key defaultValue = +configGet :: String -> String -> Repo -> String +configGet key defaultValue repo = M.findWithDefault defaultValue key (config repo) {- Access to raw config Map -} @@ -558,8 +556,8 @@ configMap :: Repo -> M.Map String String configMap = config {- Efficiently looks up a gitattributes value for each file in a list. -} -checkAttr :: Repo -> String -> [FilePath] -> IO [(FilePath, String)] -checkAttr repo attr files = do +checkAttr :: String -> [FilePath] -> Repo -> IO [(FilePath, String)] +checkAttr attr files repo = do -- git check-attr needs relative filenames input; it will choke -- on some absolute filenames. This also means it will output -- all relative filenames. @@ -574,7 +572,11 @@ checkAttr repo attr files = do hClose toh (map topair . lines) <$> hGetContents fromh where - params = gitCommandLine repo [Param "check-attr", Param attr, Params "-z --stdin"] + params = gitCommandLine + [ Param "check-attr" + , Param attr + , Params "-z --stdin" + ] repo topair l = (file, value) where file = decodeGitFile $ join sep $ take end bits diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 64857c66a9..51fa585a82 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -25,7 +25,7 @@ type CatFileHandle = (PipeHandle, Handle, Handle) {- Starts git cat-file running in batch mode in a repo and returns a handle. -} catFileStart :: Repo -> IO CatFileHandle catFileStart repo = hPipeBoth "git" $ toCommand $ - Git.gitCommandLine repo [Param "cat-file", Param "--batch"] + Git.gitCommandLine [Param "cat-file", Param "--batch"] repo {- Stops git cat-file. -} catFileStop :: CatFileHandle -> IO () diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 28e007a4dc..bceee26fcd 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -19,51 +19,52 @@ import Git import Utility.SafeCommand {- Scans for files that are checked into git at the specified locations. -} -inRepo :: Repo -> [FilePath] -> IO [FilePath] -inRepo repo l = pipeNullSplit repo $ Params "ls-files --cached -z --" : map File l +inRepo :: [FilePath] -> Repo -> IO [FilePath] +inRepo l repo = pipeNullSplit (Params "ls-files --cached -z --" : map File l) repo {- Scans for files at the specified locations that are not checked into git. -} -notInRepo :: Repo -> Bool -> [FilePath] -> IO [FilePath] -notInRepo repo include_ignored l = pipeNullSplit repo $ - [Params "ls-files --others"] ++ exclude ++ - [Params "-z --"] ++ map File l +notInRepo :: Bool -> [FilePath] -> Repo -> IO [FilePath] +notInRepo include_ignored l repo = pipeNullSplit params repo where + params = [Params "ls-files --others"] ++ exclude ++ + [Params "-z --"] ++ map File l exclude | include_ignored = [] | otherwise = [Param "--exclude-standard"] {- Returns a list of all files that are staged for commit. -} -staged :: Repo -> [FilePath] -> IO [FilePath] -staged repo l = staged' repo l [] +staged :: [FilePath] -> Repo -> IO [FilePath] +staged = staged' [] {- Returns a list of the files, staged for commit, that are being added, - moved, or changed (but not deleted), from the specified locations. -} -stagedNotDeleted :: Repo -> [FilePath] -> IO [FilePath] -stagedNotDeleted repo l = staged' repo l [Param "--diff-filter=ACMRT"] +stagedNotDeleted :: [FilePath] -> Repo -> IO [FilePath] +stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] -staged' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath] -staged' repo l middle = pipeNullSplit repo $ start ++ middle ++ end +staged' :: [CommandParam] -> [FilePath] -> Repo -> IO [FilePath] +staged' middle l = pipeNullSplit $ start ++ middle ++ end where start = [Params "diff --cached --name-only -z"] end = Param "--" : map File l {- Returns a list of files that have unstaged changes. -} -changedUnstaged :: Repo -> [FilePath] -> IO [FilePath] -changedUnstaged repo l = pipeNullSplit repo $ - Params "diff --name-only -z --" : map File l +changedUnstaged :: [FilePath] -> Repo -> IO [FilePath] +changedUnstaged l = pipeNullSplit params + where + params = Params "diff --name-only -z --" : map File l {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} -typeChangedStaged :: Repo -> [FilePath] -> IO [FilePath] -typeChangedStaged repo l = typeChanged' repo l [Param "--cached"] +typeChangedStaged :: [FilePath] -> Repo -> IO [FilePath] +typeChangedStaged = typeChanged' [Param "--cached"] {- Returns a list of the files in the specified locations whose type has - changed. Files only staged for commit will not be included. -} -typeChanged :: Repo -> [FilePath] -> IO [FilePath] -typeChanged repo l = typeChanged' repo l [] +typeChanged :: [FilePath] -> Repo -> IO [FilePath] +typeChanged = typeChanged' [] -typeChanged' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath] -typeChanged' repo l middle = pipeNullSplit repo $ start ++ middle ++ end +typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO [FilePath] +typeChanged' middle l = pipeNullSplit $ start ++ middle ++ end where start = [Params "diff --name-only --diff-filter=T -z"] end = Param "--" : map File l diff --git a/Git/LsTree.hs b/Git/LsTree.hs index c072ef5be9..1fcdf13ed5 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -29,9 +29,9 @@ data TreeItem = TreeItem } deriving Show {- Lists the contents of a Treeish -} -lsTree :: Repo -> Treeish -> IO [TreeItem] -lsTree repo t = map parseLsTree <$> - pipeNullSplitB repo [Params "ls-tree --full-tree -z -r --", File t] +lsTree :: Treeish -> Repo -> IO [TreeItem] +lsTree t repo = map parseLsTree <$> + pipeNullSplitB [Params "ls-tree --full-tree -z -r --", File t] repo {- Parses a line of ls-tree output. - (The --long format is not currently supported.) -} diff --git a/Git/Queue.hs b/Git/Queue.hs index 25b9ffad08..70c766d044 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -72,8 +72,8 @@ full :: Queue -> Bool full (Queue n _) = n > maxSize {- Runs a queue on a git repository. -} -flush :: Repo -> Queue -> IO Queue -flush repo (Queue _ m) = do +flush :: Queue -> Repo -> IO Queue +flush (Queue _ m) repo = do forM_ (M.toList m) $ uncurry $ runAction repo return empty @@ -87,6 +87,6 @@ runAction :: Repo -> Action -> [FilePath] -> IO () runAction repo action files = pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs where - params = toCommand $ gitCommandLine repo - (Param (getSubcommand action):getParams action) + params = toCommand $ gitCommandLine + (Param (getSubcommand action):getParams action) repo feedxargs h = hPutStr h $ join "\0" files diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index 859a66ca07..32966c846d 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -27,24 +27,25 @@ import Git - - Should be run with a temporary index file configured by Git.useIndex. -} -merge :: Repo -> String -> String -> IO () -merge g x y = do - a <- ls_tree g x - b <- merge_trees g x y - update_index g (a++b) +merge :: String -> String -> Repo -> IO () +merge x y repo = do + a <- ls_tree x repo + b <- merge_trees x y repo + update_index repo (a++b) {- Merges a list of branches into the index. Previously staged changed in - the index are preserved (and participate in the merge). -} merge_index :: Repo -> [String] -> IO () -merge_index g bs = update_index g =<< concat <$> mapM (merge_tree_index g) bs +merge_index repo bs = + update_index repo =<< concat <$> mapM (\b -> merge_tree_index b repo) bs {- Feeds a list into update-index. Later items in the list can override - earlier ones, so the list can be generated from any combination of - ls_tree, merge_trees, and merge_tree_index. -} update_index :: Repo -> [String] -> IO () -update_index g l = togit ["update-index", "-z", "--index-info"] (join "\0" l) +update_index repo l = togit ["update-index", "-z", "--index-info"] (join "\0" l) where - togit ps content = pipeWrite g (map Param ps) (L.pack content) + togit ps content = pipeWrite (map Param ps) (L.pack content) repo >>= forceSuccess {- Generates a line suitable to be fed into update-index, to add @@ -53,27 +54,28 @@ update_index_line :: String -> FilePath -> String update_index_line sha file = "100644 blob " ++ sha ++ "\t" ++ file {- Gets the contents of a tree in a format suitable for update_index. -} -ls_tree :: Repo -> String -> IO [String] -ls_tree g x = pipeNullSplit g $ - map Param ["ls-tree", "-z", "-r", "--full-tree", x] +ls_tree :: String -> Repo -> IO [String] +ls_tree x = pipeNullSplit params + where + params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] {- For merging two trees. -} -merge_trees :: Repo -> String -> String -> IO [String] -merge_trees g x y = calc_merge g $ "diff-tree":diff_opts ++ [x, y] +merge_trees :: String -> String -> Repo -> IO [String] +merge_trees x y = calc_merge $ "diff-tree":diff_opts ++ [x, y] {- For merging a single tree into the index. -} -merge_tree_index :: Repo -> String -> IO [String] -merge_tree_index g x = calc_merge g $ "diff-index":diff_opts ++ ["--cached", x] +merge_tree_index :: String -> Repo -> IO [String] +merge_tree_index x = calc_merge $ "diff-index":diff_opts ++ ["--cached", x] diff_opts :: [String] diff_opts = ["--raw", "-z", "-r", "--no-renames", "-l0"] {- Calculates how to perform a merge, using git to get a raw diff, - and returning a list suitable for update_index. -} -calc_merge :: Repo -> [String] -> IO [String] -calc_merge g differ = do - diff <- pipeNullSplit g $ map Param differ - l <- mapM (mergeFile g) (pairs diff) +calc_merge :: [String] -> Repo -> IO [String] +calc_merge differ repo = do + diff <- pipeNullSplit (map Param differ) repo + l <- mapM (\p -> mergeFile p repo) (pairs diff) return $ catMaybes l where pairs [] = [] @@ -81,9 +83,9 @@ calc_merge g differ = do pairs (a:b:rest) = (a,b):pairs rest {- Injects some content into git, returning its hash. -} -hashObject :: Repo -> L.ByteString -> IO String -hashObject repo content = getSha subcmd $ do - (h, s) <- pipeWriteRead repo (map Param params) content +hashObject :: L.ByteString -> Repo -> IO String +hashObject content repo = getSha subcmd $ do + (h, s) <- pipeWriteRead (map Param params) content repo L.length s `seq` do forceSuccess h reap -- XXX unsure why this is needed @@ -95,13 +97,13 @@ hashObject repo content = getSha subcmd $ do {- Given an info line from a git raw diff, and the filename, generates - a line suitable for update_index that union merges the two sides of the - diff. -} -mergeFile :: Repo -> (String, FilePath) -> IO (Maybe String) -mergeFile g (info, file) = case filter (/= nullsha) [asha, bsha] of +mergeFile :: (String, FilePath) -> Repo -> IO (Maybe String) +mergeFile (info, file) repo = case filter (/= nullsha) [asha, bsha] of [] -> return Nothing (sha:[]) -> return $ Just $ update_index_line sha file shas -> do - content <- pipeRead g $ map Param ("show":shas) - sha <- hashObject g $ unionmerge content + content <- pipeRead (map Param ("show":shas)) repo + sha <- hashObject (unionmerge content) repo return $ Just $ update_index_line sha file where [_colonamode, _bmode, asha, bsha, _status] = words info diff --git a/GitAnnex.hs b/GitAnnex.hs index 399b26ef7f..f416b7bead 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -116,9 +116,8 @@ options = commonOptions ++ setnumcopies v = Annex.changeState $ \s -> s {Annex.forcenumcopies = readMaybe v } setgitconfig :: String -> Annex () setgitconfig v = do - g <- gitRepo - g' <- liftIO $ Git.configStore g v - Annex.changeState $ \s -> s { Annex.repo = g' } + newg <- inRepo $ Git.configStore v + Annex.changeState $ \s -> s { Annex.repo = newg } header :: String header = "Usage: git-annex command [option ..]" diff --git a/Init.hs b/Init.hs index 8cec98c5fc..d03e10031f 100644 --- a/Init.hs +++ b/Init.hs @@ -68,12 +68,10 @@ gitPreCommitHookUnWrite = unlessBare $ do " Edit it to remove call to git annex." unlessBare :: Annex () -> Annex () -unlessBare = unlessM $ Git.repoIsLocalBare <$> gitRepo +unlessBare = unlessM $ fromRepo $ Git.repoIsLocalBare preCommitHook :: Annex FilePath -preCommitHook = do - g <- gitRepo - return $ Git.gitDir g ++ "/hooks/pre-commit" +preCommitHook = () <$> fromRepo Git.gitDir <*> pure "hooks/pre-commit" preCommitScript :: String preCommitScript = diff --git a/Locations.hs b/Locations.hs index ceb6246b98..83897f488f 100644 --- a/Locations.hs +++ b/Locations.hs @@ -65,8 +65,8 @@ annexLocation key = objectDir hashDirMixed key f f f = keyFile key {- Annexed file's absolute location in a repository. -} -gitAnnexLocation :: Git.Repo -> Key -> FilePath -gitAnnexLocation r key +gitAnnexLocation :: Key -> Git.Repo -> FilePath +gitAnnexLocation key r | Git.repoIsLocalBare r = Git.workTree r annexLocation key | otherwise = Git.workTree r ".git" annexLocation key @@ -88,16 +88,16 @@ gitAnnexTmpDir :: Git.Repo -> FilePath gitAnnexTmpDir r = addTrailingPathSeparator $ gitAnnexDir r "tmp" {- The temp file to use for a given key. -} -gitAnnexTmpLocation :: Git.Repo -> Key -> FilePath -gitAnnexTmpLocation r key = gitAnnexTmpDir r keyFile key +gitAnnexTmpLocation :: Key -> Git.Repo -> FilePath +gitAnnexTmpLocation key r = gitAnnexTmpDir r keyFile key {- .git/annex/bad/ is used for bad files found during fsck -} gitAnnexBadDir :: Git.Repo -> FilePath gitAnnexBadDir r = addTrailingPathSeparator $ gitAnnexDir r "bad" {- The bad file to use for a given key. -} -gitAnnexBadLocation :: Git.Repo -> Key -> FilePath -gitAnnexBadLocation r key = gitAnnexBadDir r keyFile key +gitAnnexBadLocation :: Key -> Git.Repo -> FilePath +gitAnnexBadLocation key r = gitAnnexBadDir r keyFile key {- .git/annex/*unused is used to number possibly unused keys -} gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath diff --git a/Remote.hs b/Remote.hs index 6d55cee243..82af21bde4 100644 --- a/Remote.hs +++ b/Remote.hs @@ -130,10 +130,10 @@ nameToUUID n = byName' n >>= go - of the UUIDs. -} prettyPrintUUIDs :: String -> [UUID] -> Annex String prettyPrintUUIDs desc uuids = do - here <- getUUID + hereu <- getUUID m <- M.unionWith addname <$> uuidMap <*> remoteMap - maybeShowJSON [(desc, map (jsonify m here) uuids)] - return $ unwords $ map (\u -> "\t" ++ prettify m here u ++ "\n") uuids + maybeShowJSON [(desc, map (jsonify m hereu) uuids)] + return $ unwords $ map (\u -> "\t" ++ prettify m hereu u ++ "\n") uuids where addname d n | d == n = d @@ -141,20 +141,20 @@ prettyPrintUUIDs desc uuids = do | otherwise = n ++ " (" ++ d ++ ")" remoteMap = M.fromList . map (\r -> (uuid r, name r)) <$> genList findlog m u = M.findWithDefault "" u m - prettify m here u + prettify m hereu u | not (null d) = fromUUID u ++ " -- " ++ d | otherwise = fromUUID u where - ishere = here == u + ishere = hereu == u n = findlog m u d | null n && ishere = "here" | ishere = addname n "here" | otherwise = n - jsonify m here u = toJSObject + jsonify m hereu u = toJSObject [ ("uuid", toJSON $ fromUUID u) , ("description", toJSON $ findlog m u) - , ("here", toJSON $ here == u) + , ("here", toJSON $ hereu == u) ] {- Filters a list of remotes to ones that have the listed uuids. -} diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 3e621ce569..b8d7cd3172 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -102,15 +102,13 @@ bupSplitParams r buprepo k src = do store :: Git.Repo -> BupRepo -> Key -> Annex Bool store r buprepo k = do - g <- gitRepo - let src = gitAnnexLocation g k + src <- fromRepo $ gitAnnexLocation k params <- bupSplitParams r buprepo k (File src) liftIO $ boolSystem "bup" params storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted r buprepo (cipher, enck) k = do - g <- gitRepo - let src = gitAnnexLocation g k + src <- fromRepo $ gitAnnexLocation k params <- bupSplitParams r buprepo enck (Param "-") liftIO $ catchBool $ withEncryptedHandle cipher (L.readFile src) $ \h -> @@ -147,7 +145,7 @@ checkPresent r bupr k showAction $ "checking " ++ Git.repoDescribe r ok <- onBupRemote bupr boolSystem "git" params return $ Right ok - | otherwise = liftIO $ try $ boolSystem "git" $ Git.gitCommandLine bupr params + | otherwise = liftIO $ try $ boolSystem "git" $ Git.gitCommandLine params bupr where params = [ Params "show-ref --quiet --verify" @@ -165,9 +163,10 @@ storeBupUUID u buprepo = do >>! error "ssh failed" else liftIO $ do r' <- Git.configRead r - let olduuid = Git.configGet r' "annex.uuid" "" - when (olduuid == "") $ Git.run r' "config" - [Param "annex.uuid", Param v] + let olduuid = Git.configGet "annex.uuid" "" r' + when (olduuid == "") $ + Git.run "config" + [Param "annex.uuid", Param v] r' where v = fromUUID u @@ -194,7 +193,7 @@ getBupUUID r u | otherwise = liftIO $ do ret <- try $ Git.configRead r case ret of - Right r' -> return (toUUID $ Git.configGet r' "annex.uuid" "", r') + Right r' -> return (toUUID $ Git.configGet "annex.uuid" "" r', r') Left _ -> return (NoUUID, r) {- Converts a bup remote path spec into a Git.Repo. There are some diff --git a/Remote/Directory.hs b/Remote/Directory.hs index e8cf05a0e5..8e306e228b 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -70,15 +70,13 @@ dirKey d k = d hashDirMixed k f f store :: FilePath -> Key -> Annex Bool store d k = do - g <- gitRepo - let src = gitAnnexLocation g k + src <- fromRepo $ gitAnnexLocation k let dest = dirKey d k liftIO $ catchBool $ storeHelper dest $ copyFileExternal src dest storeEncrypted :: FilePath -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted d (cipher, enck) k = do - g <- gitRepo - let src = gitAnnexLocation g k + src <- fromRepo $ gitAnnexLocation k let dest = dirKey d enck liftIO $ catchBool $ storeHelper dest $ encrypt src dest where diff --git a/Remote/Git.hs b/Remote/Git.hs index 4c76e8ce6d..75f0ac7576 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -35,19 +35,16 @@ remote = RemoteType { list :: Annex [Git.Repo] list = do - g <- gitRepo - let c = Git.configMap g - mapM (tweakurl c) $ Git.remotes g + c <- fromRepo Git.configMap + mapM (tweakurl c) =<< fromRepo Git.remotes where annexurl n = "remote." ++ n ++ ".annexurl" tweakurl c r = do let n = fromJust $ Git.repoRemoteName r case M.lookup (annexurl n) c of Nothing -> return r - Just url -> do - g <- gitRepo - r' <- liftIO $ Git.genRemote g url - return $ Git.repoRemoteNameSet r' n + Just url -> Git.repoRemoteNameSet n <$> + inRepo (Git.genRemote url) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen r u _ = do @@ -178,7 +175,7 @@ copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool copyFromRemote r key file | not $ Git.repoIsUrl r = do params <- rsyncParams r - rsyncOrCopyFile params (gitAnnexLocation r key) file + rsyncOrCopyFile params (gitAnnexLocation key r) file | Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key file | Git.repoIsHttp r = liftIO $ Url.download (keyUrl r key) file | otherwise = error "copying from non-ssh, non-http repo not supported" @@ -187,8 +184,7 @@ copyFromRemote r key file copyToRemote :: Git.Repo -> Key -> Annex Bool copyToRemote r key | not $ Git.repoIsUrl r = do - g <- gitRepo - let keysrc = gitAnnexLocation g key + keysrc <- fromRepo $ gitAnnexLocation key params <- rsyncParams r -- run copy from perspective of remote liftIO $ onLocal r $ do @@ -197,8 +193,7 @@ copyToRemote r key Annex.Content.saveState return ok | Git.repoIsSsh r = do - g <- gitRepo - let keysrc = gitAnnexLocation g key + keysrc <- fromRepo $ gitAnnexLocation key rsyncHelper =<< rsyncParamsRemote r False key keysrc | otherwise = error "copying to non-ssh repo not supported" diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 38f24eb373..6cea170347 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -23,16 +23,16 @@ findSpecialRemotes s = do return $ map construct $ remotepairs g where remotepairs r = M.toList $ M.filterWithKey match $ Git.configMap r - construct (k,_) = Git.repoRemoteNameFromKey Git.repoFromUnknown k + construct (k,_) = Git.repoRemoteNameFromKey k Git.repoFromUnknown match k _ = startswith "remote." k && endswith (".annex-"++s) k {- Sets up configuration for a special remote in .git/config. -} gitConfigSpecialRemote :: UUID -> RemoteConfig -> String -> String -> Annex () gitConfigSpecialRemote u c k v = do - g <- gitRepo - liftIO $ do - Git.run g "config" [Param (configsetting $ "annex-"++k), Param v] - Git.run g "config" [Param (configsetting "annex-uuid"), Param $ fromUUID u] + set ("annex-"++k) v + set ("annex-uuid") (fromUUID u) where + set a b = inRepo $ Git.run "config" + [Param (configsetting a), Param b] remotename = fromJust (M.lookup "name" c) configsetting s = "remote." ++ remotename ++ "." ++ s diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 8b6a6cecfc..06568a3cb5 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -98,14 +98,13 @@ runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype h store :: String -> Key -> Annex Bool store h k = do - g <- gitRepo - runHook h "store" k (Just $ gitAnnexLocation g k) $ return True + src <- fromRepo $ gitAnnexLocation k + runHook h "store" k (Just src) $ return True storeEncrypted :: String -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted h (cipher, enck) k = withTmp enck $ \tmp -> do - g <- gitRepo - let f = gitAnnexLocation g k - liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s + src <- fromRepo $ gitAnnexLocation k + liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp runHook h "store" enck (Just tmp) $ return True retrieve :: String -> Key -> FilePath -> Annex Bool diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index e79762a382..0dfad72935 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -90,15 +90,12 @@ rsyncKeyDir :: RsyncOpts -> Key -> String rsyncKeyDir o k = rsyncUrl o hashDirMixed k shellEscape (keyFile k) store :: RsyncOpts -> Key -> Annex Bool -store o k = do - g <- gitRepo - rsyncSend o k (gitAnnexLocation g k) +store o k = rsyncSend o k =<< fromRepo (gitAnnexLocation k) storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do - g <- gitRepo - let f = gitAnnexLocation g k - liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s + src <- fromRepo $ gitAnnexLocation k + liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp rsyncSend o enck tmp retrieve :: RsyncOpts -> Key -> FilePath -> Annex Bool @@ -151,9 +148,9 @@ partialParams = Params "--no-inplace --partial --partial-dir=.rsync-partial" - up trees for rsync. -} withRsyncScratchDir :: (FilePath -> Annex Bool) -> Annex Bool withRsyncScratchDir a = do - g <- gitRepo pid <- liftIO getProcessID - let tmp = gitAnnexTmpDir g "rsynctmp" show pid + t <- fromRepo gitAnnexTmpDir + let tmp = t "rsynctmp" show pid nuke tmp liftIO $ createDirectoryIfMissing True tmp res <- a tmp diff --git a/Remote/S3real.hs b/Remote/S3real.hs index 1281c27861..b201b5aadb 100644 --- a/Remote/S3real.hs +++ b/Remote/S3real.hs @@ -112,8 +112,8 @@ s3Setup u c = handlehost $ M.lookup "host" c store :: Remote Annex -> Key -> Annex Bool store r k = s3Action r False $ \(conn, bucket) -> do - g <- gitRepo - res <- liftIO $ storeHelper (conn, bucket) r k $ gitAnnexLocation g k + dest <- fromRepo $ gitAnnexLocation k + res <- liftIO $ storeHelper (conn, bucket) r k dest s3Bool res storeEncrypted :: Remote Annex -> (Cipher, Key) -> Key -> Annex Bool @@ -121,8 +121,7 @@ storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) -> -- To get file size of the encrypted content, have to use a temp file. -- (An alternative would be chunking to to a constant size.) withTmp enck $ \tmp -> do - g <- gitRepo - let f = gitAnnexLocation g k + f <- fromRepo $ gitAnnexLocation k liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s res <- liftIO $ storeHelper (conn, bucket) r enck tmp s3Bool res diff --git a/Remote/Web.hs b/Remote/Web.hs index 393932d478..da7f384727 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -27,7 +27,7 @@ remote = RemoteType { -- (If the web should cease to exist, remove this module and redistribute -- a new release to the survivors by carrier pigeon.) list :: Annex [Git.Repo] -list = return [Git.repoRemoteNameSet Git.repoFromUnknown "web"] +list = return [Git.repoRemoteNameSet "web" Git.repoFromUnknown] gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen r _ _ = diff --git a/Seek.hs b/Seek.hs index 4ae943157b..3c83ebc35d 100644 --- a/Seek.hs +++ b/Seek.hs @@ -20,16 +20,18 @@ import qualified Git import qualified Git.LsFiles as LsFiles import qualified Limit +seekHelper :: ([FilePath] -> Git.Repo -> IO [FilePath]) -> [FilePath] -> Annex [FilePath] +seekHelper a params = do + g <- gitRepo + liftIO $ runPreserveOrder (\p -> a p g) params + withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek -withFilesInGit a params = do - repo <- gitRepo - prepFiltered a $ liftIO $ runPreserveOrder (LsFiles.inRepo repo) params +withFilesInGit a params = prepFiltered a $ seekHelper LsFiles.inRepo params withAttrFilesInGit :: String -> ((FilePath, String) -> CommandStart) -> CommandSeek withAttrFilesInGit attr a params = do - repo <- gitRepo - files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params - prepFilteredGen a fst $ liftIO $ Git.checkAttr repo attr files + files <- seekHelper LsFiles.inRepo params + prepFilteredGen a fst $ inRepo $ Git.checkAttr attr files withNumCopies :: (FilePath -> Maybe Int -> CommandStart) -> CommandSeek withNumCopies a params = withAttrFilesInGit "annex.numcopies" go params @@ -38,8 +40,7 @@ withNumCopies a params = withAttrFilesInGit "annex.numcopies" go params withBackendFilesInGit :: (BackendFile -> CommandStart) -> CommandSeek withBackendFilesInGit a params = do - repo <- gitRepo - files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params + files <- seekHelper LsFiles.inRepo params prepBackendPairs a files withFilesMissing :: (String -> CommandStart) -> CommandSeek @@ -49,9 +50,8 @@ withFilesMissing a params = prepFiltered a $ liftIO $ filterM missing params withFilesNotInGit :: (BackendFile -> CommandStart) -> CommandSeek withFilesNotInGit a params = do - repo <- gitRepo force <- Annex.getState Annex.force - newfiles <- liftIO $ runPreserveOrder (LsFiles.notInRepo repo force) params + newfiles <- seekHelper (LsFiles.notInRepo force) params prepBackendPairs a newfiles withWords :: ([String] -> CommandStart) -> CommandSeek @@ -61,10 +61,8 @@ withStrings :: (String -> CommandStart) -> CommandSeek withStrings a params = return $ map a params withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek -withFilesToBeCommitted a params = do - repo <- gitRepo - prepFiltered a $ - liftIO $ runPreserveOrder (LsFiles.stagedNotDeleted repo) params +withFilesToBeCommitted a params = prepFiltered a $ + seekHelper LsFiles.stagedNotDeleted params withFilesUnlocked :: (BackendFile -> CommandStart) -> CommandSeek withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged @@ -72,13 +70,13 @@ withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged withFilesUnlockedToBeCommitted :: (BackendFile -> CommandStart) -> CommandSeek withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged -withFilesUnlocked' :: (Git.Repo -> [FilePath] -> IO [FilePath]) -> (BackendFile -> CommandStart) -> CommandSeek +withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO [FilePath]) -> (BackendFile -> CommandStart) -> CommandSeek withFilesUnlocked' typechanged a params = do -- unlocked files have changed type from a symlink to a regular file - repo <- gitRepo - typechangedfiles <- liftIO $ runPreserveOrder (typechanged repo) params + top <- fromRepo $ Git.workTree + typechangedfiles <- seekHelper typechanged params unlockedfiles <- liftIO $ filterM notSymlink $ - map (\f -> Git.workTree repo ++ "/" ++ f) typechangedfiles + map (\f -> top ++ "/" ++ f) typechangedfiles prepBackendPairs a unlockedfiles withKeys :: (Key -> CommandStart) -> CommandSeek diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs index b1443fa460..eae5c87ce4 100644 --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -16,10 +16,9 @@ import qualified Upgrade.V1 upgrade :: Annex Bool upgrade = do showAction "v0 to v1" - g <- gitRepo -- do the reorganisation of the key files - let olddir = gitAnnexDir g + olddir <- fromRepo gitAnnexDir keys <- getKeysPresent0 olddir forM_ keys $ \k -> moveAnnex k $ olddir keyFile0 k diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index be9a977ad7..fe59ad3da8 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -50,9 +50,9 @@ import qualified Upgrade.V2 upgrade :: Annex Bool upgrade = do showAction "v1 to v2" - - g <- gitRepo - if Git.repoIsLocalBare g + + bare <- fromRepo $ Git.repoIsLocalBare + if bare then do moveContent setVersion @@ -83,8 +83,8 @@ moveContent = do updateSymlinks :: Annex () updateSymlinks = do showAction "updating symlinks" - g <- gitRepo - files <- liftIO $ LsFiles.inRepo g [Git.workTree g] + top <- fromRepo Git.workTree + files <- inRepo $ LsFiles.inRepo [top] forM_ files fixlink where fixlink f = do @@ -104,8 +104,7 @@ moveLocationLogs = do forM_ logkeys move where oldlocationlogs = do - g <- gitRepo - let dir = Upgrade.V2.gitStateDir g + dir <- fromRepo Upgrade.V2.gitStateDir exists <- liftIO $ doesDirectoryExist dir if exists then do @@ -113,9 +112,8 @@ moveLocationLogs = do return $ mapMaybe oldlog2key contents else return [] move (l, k) = do - g <- gitRepo - let dest = logFile2 g k - let dir = Upgrade.V2.gitStateDir g + dest <- fromRepo $ logFile2 k + dir <- fromRepo $ Upgrade.V2.gitStateDir let f = dir l liftIO $ createDirectoryIfMissing True (parentDir dest) -- could just git mv, but this way deals with @@ -206,9 +204,7 @@ lookupFile1 file = do " (unknown backend " ++ bname ++ ")" getKeyFilesPresent1 :: Annex [FilePath] -getKeyFilesPresent1 = do - g <- gitRepo - getKeyFilesPresent1' $ gitAnnexObjectDir g +getKeyFilesPresent1 = getKeyFilesPresent1' =<< fromRepo gitAnnexObjectDir getKeyFilesPresent1' :: FilePath -> Annex [FilePath] getKeyFilesPresent1' dir = do exists <- liftIO $ doesDirectoryExist dir @@ -228,11 +224,11 @@ getKeyFilesPresent1' dir = do logFile1 :: Git.Repo -> Key -> String logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log" -logFile2 :: Git.Repo -> Key -> String +logFile2 :: Key -> Git.Repo -> String logFile2 = logFile' hashDirLower -logFile' :: (Key -> FilePath) -> Git.Repo -> Key -> String -logFile' hasher repo key = +logFile' :: (Key -> FilePath) -> Key -> Git.Repo -> String +logFile' hasher key repo = gitStateDir repo ++ hasher key ++ keyFile key ++ ".log" stateDir :: FilePath diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index 67f0205c14..7ef2a4d18e 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -37,45 +37,46 @@ olddir g upgrade :: Annex Bool upgrade = do showAction "v2 to v3" - g <- gitRepo - let bare = Git.repoIsLocalBare g + bare <- fromRepo Git.repoIsLocalBare + old <- fromRepo olddir Annex.Branch.create showProgress - e <- liftIO $ doesDirectoryExist (olddir g) + e <- liftIO $ doesDirectoryExist old when e $ do - mapM_ (\(k, f) -> inject f $ logFile k) =<< locationLogs g - mapM_ (\f -> inject f f) =<< logFiles (olddir g) + mapM_ (\(k, f) -> inject f $ logFile k) =<< locationLogs + mapM_ (\f -> inject f f) =<< logFiles old saveState showProgress - when e $ liftIO $ do - Git.run g "rm" [Param "-r", Param "-f", Param "-q", File (olddir g)] - unless bare $ gitAttributesUnWrite g + when e $ do + inRepo $ Git.run "rm" [Param "-r", Param "-f", Param "-q", File old] + unless bare $ inRepo $ gitAttributesUnWrite showProgress unless bare push return True -locationLogs :: Git.Repo -> Annex [(Key, FilePath)] -locationLogs repo = liftIO $ do - levela <- dirContents dir - levelb <- mapM tryDirContents levela - files <- mapM tryDirContents (concat levelb) - return $ mapMaybe islogfile (concat files) +locationLogs :: Annex [(Key, FilePath)] +locationLogs = do + dir <- fromRepo gitStateDir + liftIO $ do + levela <- dirContents dir + levelb <- mapM tryDirContents levela + files <- mapM tryDirContents (concat levelb) + return $ mapMaybe islogfile (concat files) where tryDirContents d = catch (dirContents d) (return . const []) - dir = gitStateDir repo islogfile f = maybe Nothing (\k -> Just (k, f)) $ logFileKey $ takeFileName f inject :: FilePath -> FilePath -> Annex () inject source dest = do - g <- gitRepo - new <- liftIO (readFile $ olddir g source) + old <- fromRepo olddir + new <- liftIO (readFile $ old source) Annex.Branch.change dest $ \prev -> unlines $ nub $ lines prev ++ lines new @@ -102,8 +103,7 @@ push = do Annex.Branch.update -- just in case showAction "pushing new git-annex branch to origin" showOutput - g <- gitRepo - liftIO $ Git.run g "push" [Param "origin", Param Annex.Branch.name] + inRepo $ Git.run "push" [Param "origin", Param Annex.Branch.name] _ -> do -- no origin exists, so just let the user -- know about the new branch @@ -126,7 +126,7 @@ gitAttributesUnWrite repo = do c <- readFileStrict attributes liftIO $ viaTmp writeFile attributes $ unlines $ filter (`notElem` attrLines) $ lines c - Git.run repo "add" [File attributes] + Git.run "add" [File attributes] repo stateDir :: FilePath stateDir = addTrailingPathSeparator ".git-annex" diff --git a/git-union-merge.hs b/git-union-merge.hs index 0d1d0819d2..10ae842177 100644 --- a/git-union-merge.hs +++ b/git-union-merge.hs @@ -41,6 +41,6 @@ main = do g <- Git.configRead =<< Git.repoFromCwd _ <- Git.useIndex (tmpIndex g) setup g - Git.UnionMerge.merge g aref bref - Git.commit g "union merge" newref [aref, bref] + Git.UnionMerge.merge aref bref g + Git.commit "union merge" newref [aref, bref] g cleanup g