move LocationLog into Annex monad from IO

It will need to run in Annex so it can use Branch
This commit is contained in:
Joey Hess 2011-06-22 14:27:50 -04:00
parent 78a325b093
commit d3f0106f2e
9 changed files with 25 additions and 27 deletions

View file

@ -14,7 +14,6 @@
module Backend.File (backend, checkKey) where
import Control.Monad.State (liftIO)
import Data.List
import Data.String.Utils
@ -132,7 +131,7 @@ showLocations :: Key -> [UUID] -> Annex ()
showLocations key exclude = do
g <- Annex.gitRepo
u <- getUUID g
uuids <- liftIO $ keyLocations g key
uuids <- keyLocations g key
untrusteduuids <- trustGet UnTrusted
let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids)
let uuidsskipped = filteruuids uuids (u:exclude++uuidswanted)
@ -190,7 +189,7 @@ checkKeyNumCopies :: Key -> Maybe FilePath -> Maybe Int -> Annex Bool
checkKeyNumCopies key file numcopies = do
needed <- getNumCopies numcopies
g <- Annex.gitRepo
locations <- liftIO $ keyLocations g key
locations <- keyLocations g key
untrusted <- trustGet UnTrusted
let untrustedlocations = intersect untrusted locations
let safelocations = filter (`notElem` untrusted) locations

View file

@ -60,7 +60,7 @@ verifyLocationLog key file = do
preventWrite (parentDir f)
u <- getUUID g
uuids <- liftIO $ keyLocations g key
uuids <- keyLocations g key
case (present, u `elem` uuids) of
(True, False) -> do

View file

@ -68,7 +68,7 @@ checkRemoteUnused' r = do
showNote $ "checking for unused data..."
g <- Annex.gitRepo
referenced <- getKeysReferenced
logged <- liftIO $ loggedKeys g
logged <- loggedKeys g
remotehas <- filterM isthere logged
let remoteunused = remotehas `exclude` referenced
let list = number 0 remoteunused
@ -79,7 +79,7 @@ checkRemoteUnused' r = do
where
isthere k = do
g <- Annex.gitRepo
us <- liftIO $ keyLocations g k
us <- keyLocations g k
return $ uuid `elem` us
uuid = Remote.uuid r

View file

@ -7,8 +7,6 @@
module Command.Whereis where
import Control.Monad.State (liftIO)
import qualified Annex
import LocationLog
import Command
@ -31,7 +29,7 @@ start file = isAnnexed file $ \(key, _) -> do
perform :: Key -> CommandPerform
perform key = do
g <- Annex.gitRepo
uuids <- liftIO $ keyLocations g key
uuids <- keyLocations g key
let num = length uuids
showNote $ show num ++ " " ++ copiesplural num
if null $ uuids

View file

@ -81,7 +81,7 @@ logStatusFor :: UUID -> Key -> LogStatus -> Annex ()
logStatusFor u key status = do
g <- Annex.gitRepo
unless (Git.repoIsLocalBare g) $ do
logfile <- liftIO $ logChange g key u status
logfile <- logChange g key u status
rellogfile <- liftIO $ Git.workTreeFile g logfile
AnnexQueue.add "add" [Param "--"] rellogfile

View file

@ -36,6 +36,7 @@ import System.FilePath
import qualified Data.Map as Map
import Control.Monad (when)
import Data.Maybe
import Control.Monad.State (liftIO)
import qualified GitRepo as Git
import Utility
@ -86,7 +87,7 @@ instance Read LogLine where
{- Log a change in the presence of a key's value in a repository,
- and returns the filename of the logfile. -}
logChange :: Git.Repo -> Key -> UUID -> LogStatus -> IO FilePath
logChange :: Git.Repo -> Key -> UUID -> LogStatus -> Annex FilePath
logChange repo key u s = do
when (null u) $
error $ "unknown UUID for " ++ Git.repoDescribe repo ++
@ -100,8 +101,8 @@ logChange repo key u s = do
{- Reads a log file.
- Note that the LogLines returned may be in any order. -}
readLog :: FilePath -> IO [LogLine]
readLog file = catch (return . parseLog =<< readFileStrict file) (const $ return [])
readLog :: FilePath -> Annex [LogLine]
readLog file = liftIO $ catch (return . parseLog =<< readFileStrict file) (const $ return [])
parseLog :: String -> [LogLine]
parseLog s = filter parsable $ map read $ lines s
@ -110,18 +111,18 @@ parseLog s = filter parsable $ map read $ lines s
parsable l = status l /= Undefined
{- Writes a set of lines to a log file -}
writeLog :: FilePath -> [LogLine] -> IO ()
writeLog file ls = safeWriteFile file (unlines $ map show ls)
writeLog :: FilePath -> [LogLine] -> Annex ()
writeLog file ls = liftIO $ safeWriteFile file (unlines $ map show ls)
{- Generates a new LogLine with the current date. -}
logNow :: LogStatus -> UUID -> IO LogLine
logNow :: LogStatus -> UUID -> Annex LogLine
logNow s u = do
now <- getPOSIXTime
now <- liftIO $ getPOSIXTime
return $ LogLine now s u
{- Returns a list of repository UUIDs that, according to the log, have
- the value of a key. -}
keyLocations :: Git.Repo -> Key -> IO [UUID]
keyLocations :: Git.Repo -> Key -> Annex [UUID]
keyLocations thisrepo key = do
ls <- readLog $ logFile thisrepo key
ls' <- readLog $ logFileOld thisrepo key
@ -155,18 +156,18 @@ mapLog m l =
{- Finds all keys that have location log information.
- (There may be duplicate keys in the list.) -}
loggedKeys :: Git.Repo -> IO [Key]
loggedKeys :: Git.Repo -> Annex [Key]
loggedKeys repo = do
exists <- doesDirectoryExist dir
exists <- liftIO $ doesDirectoryExist dir
if exists
then do
-- 2 levels of hashing
levela <- dirContents dir
levela <- liftIO $ dirContents dir
levelb <- mapM tryDirContents levela
files <- mapM tryDirContents (concat levelb)
return $ catMaybes $
map (logFileKey . takeFileName) (concat files)
else return []
where
tryDirContents d = catch (dirContents d) (return . const [])
tryDirContents d = liftIO $ catch (dirContents d) (return . const [])
dir = gitStateDir repo

View file

@ -141,7 +141,7 @@ keyPossibilities key = do
trusted <- trustGet Trusted
-- get uuids of all remotes that are recorded to have the key
uuids <- liftIO $ keyLocations g key
uuids <- keyLocations g key
let validuuids = filter (/= u) uuids
-- note that validuuids is assumed to not have dups

View file

@ -134,9 +134,9 @@ moveLocationLogs = do
-- log files that are not checked into git,
-- as well as merging with already upgraded
-- logs that have been pulled from elsewhere
old <- liftIO $ readLog f
new <- liftIO $ readLog dest
liftIO $ writeLog dest (old++new)
old <- readLog f
new <- readLog dest
writeLog dest (old++new)
AnnexQueue.add "add" [Param "--"] dest
AnnexQueue.add "add" [Param "--"] f
AnnexQueue.add "rm" [Param "--quiet", Param "-f", Param "--"] f

View file

@ -611,7 +611,7 @@ checklocationlog f expected = do
Just (k, _) -> do
uuids <- annexeval $ do
g <- Annex.gitRepo
liftIO $ LocationLog.keyLocations g k
LocationLog.keyLocations g k
assertEqual ("bad content in location log for " ++ f ++ " key " ++ (show k) ++ " uuid " ++ thisuuid)
expected (thisuuid `elem` uuids)