diff options
46 files changed, 338 insertions, 390 deletions
@@ -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 163c9ec60..189289ad3 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 2707ed3ea..a043e1ae3 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 aafdf6f2e..fc2c2d092 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 4c1182750..f611cf02e 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 d3d674dcc..6fc04c0f0 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 935f777ab..9e694faf1 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 9a40e5459..f7990c22c 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 d44982117..a3846a410 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 c11b90610..c436c5b62 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 a633db7b3..ab104b53c 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 b717e271d..945848e9f 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 70dcc4cc7..55c21f83b 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 d1abb29e3..3feabeb9e 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 11808ed63..f72cb107a 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 2d4d24a22..a823466dc 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 318ea56d0..573747867 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 825f81939..d24f921a9 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 5a6ee0be2..f317b7620 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 7ecaf0b7f..590b75311 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 7e9ffa01f..9d56d1ff1 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 f802ec253..6b5bc31de 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 @@ -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" @@ -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 64857c66a..51fa585a8 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 28e007a4d..bceee26fc 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 c072ef5be..1fcdf13ed 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 25b9ffad0..70c766d04 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 859a66ca0..32966c846 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 399b26ef7..f416b7bea 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 ..]" @@ -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 ceb6246b9..83897f488 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 @@ -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 3e621ce56..b8d7cd317 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 e8cf05a0e..8e306e228 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 4c76e8ce6..75f0ac757 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 38f24eb37..6cea17034 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 8b6a6cecf..06568a3cb 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 e79762a38..0dfad7293 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 1281c2786..b201b5aad 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 393932d47..da7f38472 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 _ _ = @@ -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 b1443fa46..eae5c87ce 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 be9a977ad..fe59ad3da 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 67f0205c1..7ef2a4d18 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 0d1d0819d..10ae84217 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 |