move LocationLog into Annex monad from IO
It will need to run in Annex so it can use Branch
This commit is contained in:
parent
78a325b093
commit
d3f0106f2e
9 changed files with 25 additions and 27 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
2
test.hs
2
test.hs
|
@ -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)
|
||||
|
||||
|
|
Loading…
Reference in a new issue