convert git-annex branch access to ByteStrings and Builders
Most of the individual logs are not converted yet, only presense logs have an efficient ByteString Builder implemented so far. The rest convert to and from String.
This commit is contained in:
parent
53905490df
commit
bfc9039ead
27 changed files with 163 additions and 120 deletions
|
@ -182,7 +182,7 @@ updateTo' pairs = do
|
|||
else return $ "merging " ++
|
||||
unwords (map Git.Ref.describe branches) ++
|
||||
" into " ++ fromRef name
|
||||
localtransitions <- parseTransitionsStrictly "local"
|
||||
localtransitions <- parseTransitionsStrictly "local" . decodeBL
|
||||
<$> getLocal transitionsLog
|
||||
unless (null tomerge) $ do
|
||||
showSideAction merge_desc
|
||||
|
@ -209,7 +209,7 @@ updateTo' pairs = do
|
|||
- content is returned.
|
||||
-
|
||||
- Returns an empty string if the file doesn't exist yet. -}
|
||||
get :: FilePath -> Annex String
|
||||
get :: FilePath -> Annex L.ByteString
|
||||
get file = do
|
||||
update
|
||||
getLocal file
|
||||
|
@ -218,21 +218,21 @@ get file = do
|
|||
- reflect changes in remotes.
|
||||
- (Changing the value this returns, and then merging is always the
|
||||
- same as using get, and then changing its value.) -}
|
||||
getLocal :: FilePath -> Annex String
|
||||
getLocal :: FilePath -> Annex L.ByteString
|
||||
getLocal file = go =<< getJournalFileStale file
|
||||
where
|
||||
go (Just journalcontent) = return journalcontent
|
||||
go Nothing = getRef fullname file
|
||||
|
||||
{- Gets the content of a file as staged in the branch's index. -}
|
||||
getStaged :: FilePath -> Annex String
|
||||
getStaged :: FilePath -> Annex L.ByteString
|
||||
getStaged = getRef indexref
|
||||
where
|
||||
-- This makes git cat-file be run with ":file",
|
||||
-- so it looks at the index.
|
||||
indexref = Ref ""
|
||||
|
||||
getHistorical :: RefDate -> FilePath -> Annex String
|
||||
getHistorical :: RefDate -> FilePath -> Annex L.ByteString
|
||||
getHistorical date file =
|
||||
-- This check avoids some ugly error messages when the reflog
|
||||
-- is empty.
|
||||
|
@ -241,27 +241,29 @@ getHistorical date file =
|
|||
, getRef (Git.Ref.dateRef fullname date) file
|
||||
)
|
||||
|
||||
getRef :: Ref -> FilePath -> Annex String
|
||||
getRef ref file = withIndex $ decodeBL <$> catFile ref file
|
||||
getRef :: Ref -> FilePath -> Annex L.ByteString
|
||||
getRef ref file = withIndex $ catFile ref file
|
||||
|
||||
{- Applies a function to modify the content of a file.
|
||||
-
|
||||
- Note that this does not cause the branch to be merged, it only
|
||||
- modifes the current content of the file on the branch.
|
||||
-}
|
||||
change :: FilePath -> (String -> String) -> Annex ()
|
||||
change :: Journalable content => FilePath -> (L.ByteString -> content) -> Annex ()
|
||||
change file f = lockJournal $ \jl -> f <$> getLocal file >>= set jl file
|
||||
|
||||
{- Applies a function which can modify the content of a file, or not. -}
|
||||
maybeChange :: FilePath -> (String -> Maybe String) -> Annex ()
|
||||
maybeChange :: Journalable content => FilePath -> (L.ByteString -> Maybe content) -> Annex ()
|
||||
maybeChange file f = lockJournal $ \jl -> do
|
||||
v <- getLocal file
|
||||
case f v of
|
||||
Just v' | v' /= v -> set jl file v'
|
||||
Just jv ->
|
||||
let b = journalableByteString jv
|
||||
in when (v /= b) $ set jl file b
|
||||
_ -> noop
|
||||
|
||||
{- Records new content of a file into the journal -}
|
||||
set :: JournalLocked -> FilePath -> String -> Annex ()
|
||||
set :: Journalable content => JournalLocked -> FilePath -> content -> Annex ()
|
||||
set = setJournalFile
|
||||
|
||||
{- Commit message used when making a commit of whatever data has changed
|
||||
|
@ -570,7 +572,7 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
|
|||
-}
|
||||
run [] = noop
|
||||
run changers = do
|
||||
trustmap <- calcTrustMap <$> getStaged trustLog
|
||||
trustmap <- calcTrustMap . decodeBL <$> getStaged trustLog
|
||||
fs <- branchFiles
|
||||
forM_ fs $ \f -> do
|
||||
content <- getStaged f
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
{- git-annex branch transitions
|
||||
-
|
||||
- Copyright 2013-2018 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2013-2019 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
@ -10,6 +10,7 @@ module Annex.Branch.Transitions (
|
|||
getTransitionCalculator
|
||||
) where
|
||||
|
||||
import Common
|
||||
import Logs
|
||||
import Logs.Transitions
|
||||
import qualified Logs.UUIDBased as UUIDBased
|
||||
|
@ -22,41 +23,43 @@ import Types.MetaData
|
|||
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Default
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.ByteString.Builder
|
||||
|
||||
data FileTransition
|
||||
= ChangeFile String
|
||||
= ChangeFile L.ByteString
|
||||
| RemoveFile
|
||||
| PreserveFile
|
||||
|
||||
type TransitionCalculator = FilePath -> String -> TrustMap -> FileTransition
|
||||
type TransitionCalculator = FilePath -> L.ByteString -> TrustMap -> FileTransition
|
||||
|
||||
getTransitionCalculator :: Transition -> Maybe TransitionCalculator
|
||||
getTransitionCalculator ForgetGitHistory = Nothing
|
||||
getTransitionCalculator ForgetDeadRemotes = Just dropDead
|
||||
|
||||
dropDead :: FilePath -> String -> TrustMap -> FileTransition
|
||||
dropDead :: FilePath -> L.ByteString -> TrustMap -> FileTransition
|
||||
dropDead f content trustmap = case getLogVariety f of
|
||||
Just UUIDBasedLog
|
||||
-- Don't remove the dead repo from the trust log,
|
||||
-- because git remotes may still exist, and they need
|
||||
-- to still know it's dead.
|
||||
| f == trustLog -> PreserveFile
|
||||
| otherwise -> ChangeFile $ UUIDBased.showLog id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLog Just content
|
||||
Just NewUUIDBasedLog -> ChangeFile $
|
||||
UUIDBased.showLogNew id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLogNew Just content
|
||||
Just (ChunkLog _) -> ChangeFile $
|
||||
Chunk.showLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content
|
||||
| otherwise -> ChangeFile $ encodeBL $
|
||||
UUIDBased.showLog id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLog Just (decodeBL content)
|
||||
Just NewUUIDBasedLog -> ChangeFile $ encodeBL $
|
||||
UUIDBased.showLogNew id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLogNew Just (decodeBL content)
|
||||
Just (ChunkLog _) -> ChangeFile $ encodeBL $
|
||||
Chunk.showLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog (decodeBL content)
|
||||
Just (PresenceLog _) ->
|
||||
let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content
|
||||
in if null newlog
|
||||
then RemoveFile
|
||||
else ChangeFile $ Presence.showLog newlog
|
||||
else ChangeFile $ toLazyByteString $ Presence.buildLog newlog
|
||||
Just RemoteMetaDataLog ->
|
||||
let newlog = dropDeadFromRemoteMetaDataLog trustmap $ MetaData.simplifyLog $ MetaData.parseLog content
|
||||
let newlog = dropDeadFromRemoteMetaDataLog trustmap $ MetaData.simplifyLog $ MetaData.parseLog (decodeBL content)
|
||||
in if S.null newlog
|
||||
then RemoveFile
|
||||
else ChangeFile $ MetaData.showLog newlog
|
||||
else ChangeFile $ encodeBL $ MetaData.showLog newlog
|
||||
Just OtherLog -> PreserveFile
|
||||
Nothing -> PreserveFile
|
||||
|
||||
|
@ -68,7 +71,7 @@ dropDeadFromMapLog trustmap getuuid =
|
|||
- a dead uuid is dropped; any other values are passed through. -}
|
||||
dropDeadFromPresenceLog :: TrustMap -> [Presence.LogLine] -> [Presence.LogLine]
|
||||
dropDeadFromPresenceLog trustmap =
|
||||
filter $ notDead trustmap (toUUID . Presence.info)
|
||||
filter $ notDead trustmap (toUUID . Presence.fromLogInfo . Presence.info)
|
||||
|
||||
dropDeadFromRemoteMetaDataLog :: TrustMap -> MetaData.Log MetaData -> MetaData.Log MetaData
|
||||
dropDeadFromRemoteMetaDataLog trustmap =
|
||||
|
|
|
@ -4,13 +4,11 @@
|
|||
- git-annex branch. Among other things, it ensures that if git-annex is
|
||||
- interrupted, its recorded data is not lost.
|
||||
-
|
||||
- Copyright 2011-2013 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2011-2019 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Annex.Journal where
|
||||
|
||||
import Annex.Common
|
||||
|
@ -19,6 +17,23 @@ import Annex.Perms
|
|||
import Annex.LockFile
|
||||
import Utility.Directory.Stream
|
||||
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString as S
|
||||
import Data.ByteString.Builder
|
||||
|
||||
class Journalable t where
|
||||
writeJournalHandle :: Handle -> t -> IO ()
|
||||
journalableByteString :: t -> L.ByteString
|
||||
|
||||
instance Journalable L.ByteString where
|
||||
writeJournalHandle = L.hPut
|
||||
journalableByteString = id
|
||||
|
||||
-- This is more efficient than the ByteString instance.
|
||||
instance Journalable Builder where
|
||||
writeJournalHandle = hPutBuilder
|
||||
journalableByteString = toLazyByteString
|
||||
|
||||
{- Records content for a file in the branch to the journal.
|
||||
-
|
||||
- Using the journal, rather than immediatly staging content to the index
|
||||
|
@ -28,7 +43,7 @@ import Utility.Directory.Stream
|
|||
- getJournalFileStale to always return a consistent journal file
|
||||
- content, although possibly not the most current one.
|
||||
-}
|
||||
setJournalFile :: JournalLocked -> FilePath -> String -> Annex ()
|
||||
setJournalFile :: Journalable content => JournalLocked -> FilePath -> content -> Annex ()
|
||||
setJournalFile _jl file content = do
|
||||
tmp <- fromRepo gitAnnexTmpMiscDir
|
||||
createAnnexDirectory =<< fromRepo gitAnnexJournalDir
|
||||
|
@ -37,23 +52,27 @@ setJournalFile _jl file content = do
|
|||
jfile <- fromRepo $ journalFile file
|
||||
let tmpfile = tmp </> takeFileName jfile
|
||||
liftIO $ do
|
||||
withFile tmpfile WriteMode $ \h -> do
|
||||
#ifdef mingw32_HOST_OS
|
||||
hSetNewlineMode h noNewlineTranslation
|
||||
#endif
|
||||
hPutStr h content
|
||||
withFile tmpfile WriteMode $ \h -> writeJournalHandle h content
|
||||
moveFile tmpfile jfile
|
||||
|
||||
{- Gets any journalled content for a file in the branch. -}
|
||||
getJournalFile :: JournalLocked -> FilePath -> Annex (Maybe String)
|
||||
getJournalFile :: JournalLocked -> FilePath -> Annex (Maybe L.ByteString)
|
||||
getJournalFile _jl = getJournalFileStale
|
||||
|
||||
{- Without locking, this is not guaranteed to be the most recent
|
||||
- version of the file in the journal, so should not be used as a basis for
|
||||
- changes. -}
|
||||
getJournalFileStale :: FilePath -> Annex (Maybe String)
|
||||
- changes.
|
||||
-
|
||||
- The file is read strictly so that its content can safely be fed into
|
||||
- an operation that modifies the file. While setJournalFile doesn't
|
||||
- write directly to journal files and so probably avoids problems with
|
||||
- writing to the same file that's being read, but there could be
|
||||
- concurrency or other issues with a lazy read, and the minor loss of
|
||||
- laziness doesn't matter much, as the files are not very large.
|
||||
-}
|
||||
getJournalFileStale :: FilePath -> Annex (Maybe L.ByteString)
|
||||
getJournalFileStale file = inRepo $ \g -> catchMaybeIO $
|
||||
readFileStrict $ journalFile file g
|
||||
L.fromStrict <$> S.readFile (journalFile file g)
|
||||
|
||||
{- List of existing journal files, but without locking, may miss new ones
|
||||
- just being added, or may have false positives if the journal is staged
|
||||
|
|
|
@ -24,10 +24,10 @@ recordActivity :: Activity -> UUID -> Annex ()
|
|||
recordActivity act uuid = do
|
||||
c <- liftIO currentVectorClock
|
||||
Annex.Branch.change activityLog $
|
||||
showLog show . changeLog c uuid act . parseLog readish
|
||||
encodeBL . showLog show . changeLog c uuid act . parseLog readish . decodeBL
|
||||
|
||||
lastActivities :: Maybe Activity -> Annex (Log Activity)
|
||||
lastActivities wantact = parseLog onlywanted <$> Annex.Branch.get activityLog
|
||||
lastActivities wantact = parseLog onlywanted . decodeBL <$> Annex.Branch.get activityLog
|
||||
where
|
||||
onlywanted s = case readish s of
|
||||
Just a | wanted a -> Just a
|
||||
|
|
|
@ -38,7 +38,7 @@ chunksStored u k chunkmethod chunkcount = do
|
|||
c <- liftIO currentVectorClock
|
||||
config <- Annex.getGitConfig
|
||||
Annex.Branch.change (chunkLogFile config k) $
|
||||
showLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog
|
||||
encodeBL . showLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog . decodeBL
|
||||
|
||||
chunksRemoved :: UUID -> Key -> ChunkMethod -> Annex ()
|
||||
chunksRemoved u k chunkmethod = chunksStored u k chunkmethod 0
|
||||
|
@ -46,7 +46,7 @@ chunksRemoved u k chunkmethod = chunksStored u k chunkmethod 0
|
|||
getCurrentChunks :: UUID -> Key -> Annex [(ChunkMethod, ChunkCount)]
|
||||
getCurrentChunks u k = do
|
||||
config <- Annex.getGitConfig
|
||||
select . parseLog <$> Annex.Branch.get (chunkLogFile config k)
|
||||
select . parseLog . decodeBL <$> Annex.Branch.get (chunkLogFile config k)
|
||||
where
|
||||
select = filter (\(_m, ct) -> ct > 0)
|
||||
. map (\((_ku, m), l) -> (m, value l))
|
||||
|
|
|
@ -34,7 +34,7 @@ setGlobalConfig' :: ConfigName -> ConfigValue -> Annex ()
|
|||
setGlobalConfig' name new = do
|
||||
c <- liftIO currentVectorClock
|
||||
Annex.Branch.change configLog $
|
||||
showMapLog id id . changeMapLog c name new . parseGlobalConfig
|
||||
encodeBL . showMapLog id id . changeMapLog c name new . parseGlobalConfig . decodeBL
|
||||
|
||||
unsetGlobalConfig :: ConfigName -> Annex ()
|
||||
unsetGlobalConfig name = do
|
||||
|
@ -50,5 +50,5 @@ parseGlobalConfig :: String -> MapLog ConfigName ConfigValue
|
|||
parseGlobalConfig = parseMapLog Just Just
|
||||
|
||||
loadGlobalConfig :: Annex (M.Map ConfigName ConfigValue)
|
||||
loadGlobalConfig = M.filter (not . null) . simpleMap . parseGlobalConfig
|
||||
loadGlobalConfig = M.filter (not . null) . simpleMap . parseGlobalConfig . decodeBL
|
||||
<$> Annex.Branch.get configLog
|
||||
|
|
|
@ -25,14 +25,14 @@ recordDifferences :: Differences -> UUID -> Annex ()
|
|||
recordDifferences ds@(Differences {}) uuid = do
|
||||
c <- liftIO currentVectorClock
|
||||
Annex.Branch.change differenceLog $
|
||||
showLog id . changeLog c uuid (showDifferences ds) . parseLog Just
|
||||
encodeBL . showLog id . changeLog c uuid (showDifferences ds) . parseLog Just . decodeBL
|
||||
recordDifferences UnknownDifferences _ = return ()
|
||||
|
||||
-- Map of UUIDs that have Differences recorded.
|
||||
-- If a new version of git-annex has added a Difference this version
|
||||
-- doesn't know about, it will contain UnknownDifferences.
|
||||
recordedDifferences :: Annex (M.Map UUID Differences)
|
||||
recordedDifferences = parseDifferencesLog <$> Annex.Branch.get differenceLog
|
||||
recordedDifferences = parseDifferencesLog . decodeBL <$> Annex.Branch.get differenceLog
|
||||
|
||||
recordedDifferencesFor :: UUID -> Annex Differences
|
||||
recordedDifferencesFor u = fromMaybe mempty . M.lookup u
|
||||
|
|
|
@ -42,6 +42,7 @@ data ExportChange = ExportChange
|
|||
getExport :: UUID -> Annex [Exported]
|
||||
getExport remoteuuid = nub . mapMaybe get . M.toList . simpleMap
|
||||
. parseExportLog
|
||||
. decodeBL
|
||||
<$> Annex.Branch.get exportLog
|
||||
where
|
||||
get (ep, exported)
|
||||
|
@ -68,10 +69,10 @@ recordExport remoteuuid ec = do
|
|||
let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }
|
||||
let exported = Exported (newTreeish ec) []
|
||||
Annex.Branch.change exportLog $
|
||||
showExportLog
|
||||
encodeBL . showExportLog
|
||||
. changeMapLog c ep exported
|
||||
. M.mapWithKey (updateothers c u)
|
||||
. parseExportLog
|
||||
. parseExportLog . decodeBL
|
||||
where
|
||||
updateothers c u ep le@(LogEntry _ exported@(Exported { exportedTreeish = t }))
|
||||
| u == exportFrom ep || remoteuuid /= exportTo ep || t `notElem` oldTreeish ec = le
|
||||
|
@ -89,12 +90,13 @@ recordExportBeginning remoteuuid newtree = do
|
|||
old <- fromMaybe (Exported emptyTree [])
|
||||
. M.lookup ep . simpleMap
|
||||
. parseExportLog
|
||||
. decodeBL
|
||||
<$> Annex.Branch.get exportLog
|
||||
let new = old { incompleteExportedTreeish = nub (newtree:incompleteExportedTreeish old) }
|
||||
Annex.Branch.change exportLog $
|
||||
showExportLog
|
||||
encodeBL . showExportLog
|
||||
. changeMapLog c ep new
|
||||
. parseExportLog
|
||||
. parseExportLog . decodeBL
|
||||
Annex.Branch.graftTreeish newtree (asTopFilePath "export.tree")
|
||||
|
||||
parseExportLog :: String -> MapLog ExportParticipants Exported
|
||||
|
|
|
@ -37,9 +37,9 @@ groupChange uuid@(UUID _) modifier = do
|
|||
curr <- lookupGroups uuid
|
||||
c <- liftIO currentVectorClock
|
||||
Annex.Branch.change groupLog $
|
||||
showLog (unwords . S.toList) .
|
||||
encodeBL . showLog (unwords . S.toList) .
|
||||
changeLog c uuid (modifier curr) .
|
||||
parseLog (Just . S.fromList . words)
|
||||
parseLog (Just . S.fromList . words) . decodeBL
|
||||
|
||||
-- The changed group invalidates the preferred content cache.
|
||||
Annex.changeState $ \s -> s
|
||||
|
@ -59,7 +59,7 @@ groupMap = maybe groupMapLoad return =<< Annex.getState Annex.groupmap
|
|||
groupMapLoad :: Annex GroupMap
|
||||
groupMapLoad = do
|
||||
m <- makeGroupMap . simpleMap .
|
||||
parseLog (Just . S.fromList . words) <$>
|
||||
parseLog (Just . S.fromList . words) . decodeBL <$>
|
||||
Annex.Branch.get groupLog
|
||||
Annex.changeState $ \s -> s { Annex.groupmap = Just m }
|
||||
return m
|
||||
|
|
|
@ -41,7 +41,6 @@ import Git.Types (RefDate, Ref)
|
|||
import qualified Annex
|
||||
|
||||
import Data.Time.Clock
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
|
||||
{- Log a change in the presence of a key's value in current repository. -}
|
||||
logStatus :: Key -> LogStatus -> Annex ()
|
||||
|
@ -53,10 +52,10 @@ logStatus key s = do
|
|||
logChange :: Key -> UUID -> LogStatus -> Annex ()
|
||||
logChange = logChange' logNow
|
||||
|
||||
logChange' :: (LogStatus -> String -> Annex LogLine) -> Key -> UUID -> LogStatus -> Annex ()
|
||||
logChange' :: (LogStatus -> LogInfo -> Annex LogLine) -> Key -> UUID -> LogStatus -> Annex ()
|
||||
logChange' mklog key u@(UUID _) s = do
|
||||
config <- Annex.getGitConfig
|
||||
maybeAddLog (locationLogFile config key) =<< mklog s (fromUUID u)
|
||||
maybeAddLog (locationLogFile config key) =<< mklog s (LogInfo (fromUUID u))
|
||||
logChange' _ _ NoUUID _ = noop
|
||||
|
||||
{- Returns a list of repository UUIDs that, according to the log, have
|
||||
|
@ -70,12 +69,12 @@ loggedLocationsHistorical = getLoggedLocations . historicalLogInfo
|
|||
|
||||
{- Gets the locations contained in a git ref. -}
|
||||
loggedLocationsRef :: Ref -> Annex [UUID]
|
||||
loggedLocationsRef ref = map toUUID . getLog . L.unpack <$> catObject ref
|
||||
loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref
|
||||
|
||||
getLoggedLocations :: (FilePath -> Annex [String]) -> Key -> Annex [UUID]
|
||||
getLoggedLocations :: (FilePath -> Annex [LogInfo]) -> Key -> Annex [UUID]
|
||||
getLoggedLocations getter key = do
|
||||
config <- Annex.getGitConfig
|
||||
map toUUID <$> getter (locationLogFile config key)
|
||||
map (toUUID . fromLogInfo) <$> getter (locationLogFile config key)
|
||||
|
||||
{- Is there a location log for the key? True even for keys with no
|
||||
- remaining locations. -}
|
||||
|
|
|
@ -110,9 +110,9 @@ addMetaDataClocked' getlogfile k d@(MetaData m) c
|
|||
| otherwise = do
|
||||
config <- Annex.getGitConfig
|
||||
Annex.Branch.change (getlogfile config k) $
|
||||
showLog . simplifyLog
|
||||
encodeBL . showLog . simplifyLog
|
||||
. S.insert (LogEntry c metadata)
|
||||
. parseLog
|
||||
. parseLog . decodeBL
|
||||
where
|
||||
metadata = MetaData $ M.filterWithKey (\f _ -> not (isLastChangedField f)) m
|
||||
|
||||
|
@ -145,8 +145,8 @@ copyMetaData oldkey newkey
|
|||
else do
|
||||
config <- Annex.getGitConfig
|
||||
Annex.Branch.change (metaDataLogFile config newkey) $
|
||||
const $ showLog l
|
||||
const $ encodeBL $ showLog l
|
||||
return True
|
||||
|
||||
readLog :: FilePath -> Annex (Log MetaData)
|
||||
readLog = parseLog <$$> Annex.Branch.get
|
||||
readLog = parseLog . decodeBL <$$> Annex.Branch.get
|
||||
|
|
|
@ -25,7 +25,7 @@ recordFingerprint :: Fingerprint -> UUID -> Annex ()
|
|||
recordFingerprint fp uuid = do
|
||||
c <- liftIO currentVectorClock
|
||||
Annex.Branch.change multicastLog $
|
||||
showLog show . changeLog c uuid fp . parseLog readish
|
||||
encodeBL . showLog show . changeLog c uuid fp . parseLog readish . decodeBL
|
||||
|
||||
knownFingerPrints :: Annex (M.Map UUID Fingerprint)
|
||||
knownFingerPrints = simpleMap . parseLog readish <$> Annex.Branch.get activityLog
|
||||
knownFingerPrints = simpleMap . parseLog readish . decodeBL <$> Annex.Branch.get activityLog
|
||||
|
|
|
@ -74,6 +74,7 @@ preferredRequiredMapsLoad = do
|
|||
configmap <- readRemoteLog
|
||||
let genmap l gm = simpleMap
|
||||
. parseLogWithUUID ((Just .) . makeMatcher groupmap configmap gm)
|
||||
. decodeBL
|
||||
<$> Annex.Branch.get l
|
||||
pc <- genmap preferredContentLog =<< groupPreferredContentMapRaw
|
||||
rc <- genmap requiredContentLog M.empty
|
||||
|
|
|
@ -29,9 +29,9 @@ setLog :: FilePath -> UUID -> PreferredContentExpression -> Annex ()
|
|||
setLog logfile uuid@(UUID _) val = do
|
||||
c <- liftIO currentVectorClock
|
||||
Annex.Branch.change logfile $
|
||||
showLog id
|
||||
encodeBL . showLog id
|
||||
. changeLog c uuid val
|
||||
. parseLog Just
|
||||
. parseLog Just . decodeBL
|
||||
Annex.changeState $ \s -> s
|
||||
{ Annex.preferredcontentmap = Nothing
|
||||
, Annex.requiredcontentmap = Nothing
|
||||
|
@ -43,19 +43,19 @@ groupPreferredContentSet :: Group -> PreferredContentExpression -> Annex ()
|
|||
groupPreferredContentSet g val = do
|
||||
c <- liftIO currentVectorClock
|
||||
Annex.Branch.change groupPreferredContentLog $
|
||||
showMapLog id id
|
||||
encodeBL . showMapLog id id
|
||||
. changeMapLog c g val
|
||||
. parseMapLog Just Just
|
||||
. parseMapLog Just Just . decodeBL
|
||||
Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing }
|
||||
|
||||
preferredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression)
|
||||
preferredContentMapRaw = simpleMap . parseLog Just
|
||||
preferredContentMapRaw = simpleMap . parseLog Just . decodeBL
|
||||
<$> Annex.Branch.get preferredContentLog
|
||||
|
||||
requiredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression)
|
||||
requiredContentMapRaw = simpleMap . parseLog Just
|
||||
requiredContentMapRaw = simpleMap . parseLog Just . decodeBL
|
||||
<$> Annex.Branch.get requiredContentLog
|
||||
|
||||
groupPreferredContentMapRaw :: Annex (M.Map Group PreferredContentExpression)
|
||||
groupPreferredContentMapRaw = simpleMap . parseMapLog Just Just
|
||||
groupPreferredContentMapRaw = simpleMap . parseMapLog Just Just . decodeBL
|
||||
<$> Annex.Branch.get groupPreferredContentLog
|
||||
|
|
|
@ -31,8 +31,8 @@ import Git.Types (RefDate)
|
|||
{- Adds a LogLine to the log, removing any LogLines that are obsoleted by
|
||||
- adding it. -}
|
||||
addLog :: FilePath -> LogLine -> Annex ()
|
||||
addLog file line = Annex.Branch.change file $ \s ->
|
||||
showLog $ compactLog (line : parseLog s)
|
||||
addLog file line = Annex.Branch.change file $ \b ->
|
||||
buildLog $ compactLog (line : parseLog b)
|
||||
|
||||
{- When a LogLine already exists with the same status and info, but an
|
||||
- older timestamp, that LogLine is preserved, rather than updating the log
|
||||
|
@ -41,7 +41,7 @@ addLog file line = Annex.Branch.change file $ \s ->
|
|||
maybeAddLog :: FilePath -> LogLine -> Annex ()
|
||||
maybeAddLog file line = Annex.Branch.maybeChange file $ \s -> do
|
||||
m <- insertNewStatus line $ logMap $ parseLog s
|
||||
return $ showLog $ mapLog m
|
||||
return $ buildLog $ mapLog m
|
||||
|
||||
{- Reads a log file.
|
||||
- Note that the LogLines returned may be in any order. -}
|
||||
|
@ -49,13 +49,13 @@ readLog :: FilePath -> Annex [LogLine]
|
|||
readLog = parseLog <$$> Annex.Branch.get
|
||||
|
||||
{- Generates a new LogLine with the current time. -}
|
||||
logNow :: LogStatus -> String -> Annex LogLine
|
||||
logNow :: LogStatus -> LogInfo -> Annex LogLine
|
||||
logNow s i = do
|
||||
c <- liftIO currentVectorClock
|
||||
return $ LogLine c s i
|
||||
|
||||
{- Reads a log and returns only the info that is still in effect. -}
|
||||
currentLogInfo :: FilePath -> Annex [String]
|
||||
currentLogInfo :: FilePath -> Annex [LogInfo]
|
||||
currentLogInfo file = map info <$> currentLog file
|
||||
|
||||
currentLog :: FilePath -> Annex [LogLine]
|
||||
|
@ -66,6 +66,6 @@ currentLog file = filterPresent <$> readLog file
|
|||
-
|
||||
- The date is formatted as shown in gitrevisions man page.
|
||||
-}
|
||||
historicalLogInfo :: RefDate -> FilePath -> Annex [String]
|
||||
historicalLogInfo :: RefDate -> FilePath -> Annex [LogInfo]
|
||||
historicalLogInfo refdate file = map info . filterPresent . parseLog
|
||||
<$> Annex.Branch.getHistorical refdate file
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
{- git-annex presence log, pure operations
|
||||
-
|
||||
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2010-2019 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
@ -13,11 +13,17 @@ import Logs.Line
|
|||
import Utility.QuickCheck
|
||||
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString as S
|
||||
import Data.ByteString.Builder
|
||||
|
||||
newtype LogInfo = LogInfo { fromLogInfo :: S.ByteString }
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data LogLine = LogLine
|
||||
{ date :: VectorClock
|
||||
, status :: LogStatus
|
||||
, info :: String
|
||||
, info :: LogInfo
|
||||
} deriving (Eq)
|
||||
|
||||
instance Show LogLine where
|
||||
|
@ -27,13 +33,13 @@ data LogStatus = InfoPresent | InfoMissing | InfoDead
|
|||
deriving (Eq, Show, Bounded, Enum)
|
||||
|
||||
{- Parses a log file. Unparseable lines are ignored. -}
|
||||
parseLog :: String -> [LogLine]
|
||||
parseLog = mapMaybe parseline . splitLines
|
||||
parseLog :: L.ByteString -> [LogLine]
|
||||
parseLog = mapMaybe parseline . splitLines . decodeBL
|
||||
where
|
||||
parseline l = LogLine
|
||||
<$> parseVectorClock c
|
||||
<*> parseStatus s
|
||||
<*> pure rest
|
||||
<*> pure (LogInfo (encodeBS rest))
|
||||
where
|
||||
(c, pastc) = separate (== ' ') l
|
||||
(s, rest) = separate (== ' ') pastc
|
||||
|
@ -44,17 +50,20 @@ parseStatus "0" = Just InfoMissing
|
|||
parseStatus "X" = Just InfoDead
|
||||
parseStatus _ = Nothing
|
||||
|
||||
{- Generates a log file. -}
|
||||
showLog :: [LogLine] -> String
|
||||
showLog = unlines . map genline
|
||||
buildLog :: [LogLine] -> Builder
|
||||
buildLog = mconcat . map genline
|
||||
where
|
||||
genline (LogLine c s i) = unwords [formatVectorClock c, genstatus s, i]
|
||||
genstatus InfoPresent = "1"
|
||||
genstatus InfoMissing = "0"
|
||||
genstatus InfoDead = "X"
|
||||
genline (LogLine c s (LogInfo i)) =
|
||||
byteString (encodeBS' (formatVectorClock c)) <> sp <>
|
||||
genstatus s <> sp <> byteString i <> nl
|
||||
sp = charUtf8 ' '
|
||||
nl = charUtf8 '\n'
|
||||
genstatus InfoPresent = charUtf8 '1'
|
||||
genstatus InfoMissing = charUtf8 '0'
|
||||
genstatus InfoDead = charUtf8 'X'
|
||||
|
||||
{- Given a log, returns only the info that is are still in effect. -}
|
||||
getLog :: String -> [String]
|
||||
getLog :: L.ByteString -> [LogInfo]
|
||||
getLog = map info . filterPresent . parseLog
|
||||
|
||||
{- Returns the info from LogLines that are in effect. -}
|
||||
|
@ -66,7 +75,7 @@ filterPresent = filter (\l -> InfoPresent == status l) . compactLog
|
|||
compactLog :: [LogLine] -> [LogLine]
|
||||
compactLog = mapLog . logMap
|
||||
|
||||
type LogMap = M.Map String LogLine
|
||||
type LogMap = M.Map LogInfo LogLine
|
||||
|
||||
mapLog :: LogMap -> [LogLine]
|
||||
mapLog = M.elems
|
||||
|
@ -101,9 +110,11 @@ instance Arbitrary LogLine where
|
|||
arbitrary = LogLine
|
||||
<$> arbitrary
|
||||
<*> elements [minBound..maxBound]
|
||||
<*> arbitrary `suchThat`
|
||||
<*> (LogInfo . encodeBS <$> arbinfo)
|
||||
where
|
||||
arbinfo = arbitrary `suchThat`
|
||||
(\c -> '\n' `notElem` c && '\r' `notElem` c)
|
||||
|
||||
prop_parse_show_log :: [LogLine] -> Bool
|
||||
prop_parse_show_log l = parseLog (showLog l) == l
|
||||
prop_parse_build_log :: [LogLine] -> Bool
|
||||
prop_parse_build_log l = parseLog (toLazyByteString (buildLog l)) == l
|
||||
|
||||
|
|
|
@ -32,11 +32,11 @@ configSet :: UUID -> RemoteConfig -> Annex ()
|
|||
configSet u cfg = do
|
||||
c <- liftIO currentVectorClock
|
||||
Annex.Branch.change remoteLog $
|
||||
showLog showConfig . changeLog c u cfg . parseLog parseConfig
|
||||
encodeBL . showLog showConfig . changeLog c u cfg . parseLog parseConfig . decodeBL
|
||||
|
||||
{- Map of remotes by uuid containing key/value config maps. -}
|
||||
readRemoteLog :: Annex (M.Map UUID RemoteConfig)
|
||||
readRemoteLog = simpleMap . parseLog parseConfig <$> Annex.Branch.get remoteLog
|
||||
readRemoteLog = simpleMap . parseLog parseConfig . decodeBL <$> Annex.Branch.get remoteLog
|
||||
|
||||
parseConfig :: String -> Maybe RemoteConfig
|
||||
parseConfig = Just . keyValToConfig . words
|
||||
|
|
|
@ -25,12 +25,12 @@ setRemoteState u k s = do
|
|||
c <- liftIO currentVectorClock
|
||||
config <- Annex.getGitConfig
|
||||
Annex.Branch.change (remoteStateLogFile config k) $
|
||||
showLogNew id . changeLog c u s . parseLogNew Just
|
||||
encodeBL . showLogNew id . changeLog c u s . parseLogNew Just . decodeBL
|
||||
|
||||
getRemoteState :: UUID -> Key -> Annex (Maybe RemoteState)
|
||||
getRemoteState u k = do
|
||||
config <- Annex.getGitConfig
|
||||
extract . parseLogNew Just
|
||||
extract . parseLogNew Just . decodeBL
|
||||
<$> Annex.Branch.get (remoteStateLogFile config k)
|
||||
where
|
||||
extract m = value <$> M.lookup u m
|
||||
|
|
|
@ -32,14 +32,14 @@ scheduleSet :: UUID -> [ScheduledActivity] -> Annex ()
|
|||
scheduleSet uuid@(UUID _) activities = do
|
||||
c <- liftIO currentVectorClock
|
||||
Annex.Branch.change scheduleLog $
|
||||
showLog id . changeLog c uuid val . parseLog Just
|
||||
encodeBL . showLog id . changeLog c uuid val . parseLog Just . decodeBL
|
||||
where
|
||||
val = fromScheduledActivities activities
|
||||
scheduleSet NoUUID _ = error "unknown UUID; cannot modify"
|
||||
|
||||
scheduleMap :: Annex (M.Map UUID [ScheduledActivity])
|
||||
scheduleMap = simpleMap
|
||||
. parseLogWithUUID parser
|
||||
. parseLogWithUUID parser . decodeBL
|
||||
<$> Annex.Branch.get scheduleLog
|
||||
where
|
||||
parser _uuid = eitherToMaybe . parseScheduledActivities
|
||||
|
|
|
@ -26,7 +26,7 @@ import Annex.VectorClock
|
|||
import qualified Data.Set as S
|
||||
|
||||
readLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Log v)
|
||||
readLog = parseLog <$$> Annex.Branch.get
|
||||
readLog = parseLog . decodeBL <$$> Annex.Branch.get
|
||||
|
||||
getLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Maybe v)
|
||||
getLog = newestValue <$$> readLog
|
||||
|
@ -35,4 +35,4 @@ setLog :: (SingleValueSerializable v) => FilePath -> v -> Annex ()
|
|||
setLog f v = do
|
||||
c <- liftIO currentVectorClock
|
||||
let ent = LogEntry c v
|
||||
Annex.Branch.change f $ \_old -> showLog (S.singleton ent)
|
||||
Annex.Branch.change f $ \_old -> encodeBL (showLog (S.singleton ent))
|
||||
|
|
|
@ -19,6 +19,7 @@ import Annex.VectorClock
|
|||
import Logs.Line
|
||||
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
transitionsLog :: FilePath
|
||||
transitionsLog = "transitions.log"
|
||||
|
@ -81,6 +82,6 @@ transitionList = nub . map transition . S.elems
|
|||
|
||||
{- Typically ran with Annex.Branch.change, but we can't import Annex.Branch
|
||||
- here since it depends on this module. -}
|
||||
recordTransitions :: (FilePath -> (String -> String) -> Annex ()) -> Transitions -> Annex ()
|
||||
recordTransitions :: (FilePath -> (L.ByteString -> L.ByteString) -> Annex ()) -> Transitions -> Annex ()
|
||||
recordTransitions changer t = changer transitionsLog $
|
||||
showTransitions . S.union t . parseTransitionsStrictly "local"
|
||||
encodeBL . showTransitions . S.union t . parseTransitionsStrictly "local" . decodeBL
|
||||
|
|
|
@ -24,13 +24,13 @@ trustSet :: UUID -> TrustLevel -> Annex ()
|
|||
trustSet uuid@(UUID _) level = do
|
||||
c <- liftIO currentVectorClock
|
||||
Annex.Branch.change trustLog $
|
||||
showLog showTrustLog .
|
||||
encodeBL . showLog showTrustLog .
|
||||
changeLog c uuid level .
|
||||
parseLog (Just . parseTrustLog)
|
||||
parseLog (Just . parseTrustLog) . decodeBL
|
||||
Annex.changeState $ \s -> s { Annex.trustmap = Nothing }
|
||||
trustSet NoUUID _ = error "unknown UUID; cannot modify"
|
||||
|
||||
{- Does not include forcetrust or git config values, just those from the
|
||||
- log file. -}
|
||||
trustMapRaw :: Annex TrustMap
|
||||
trustMapRaw = calcTrustMap <$> Annex.Branch.get trustLog
|
||||
trustMapRaw = calcTrustMap . decodeBL <$> Annex.Branch.get trustLog
|
||||
|
|
|
@ -30,7 +30,7 @@ describeUUID :: UUID -> UUIDDesc -> Annex ()
|
|||
describeUUID uuid desc = do
|
||||
c <- liftIO currentVectorClock
|
||||
Annex.Branch.change uuidLog $
|
||||
showLog id . changeLog c uuid (fromUUIDDesc desc) . fixBadUUID . parseLog Just
|
||||
encodeBL . showLog id . changeLog c uuid (fromUUIDDesc desc) . fixBadUUID . parseLog Just . decodeBL
|
||||
|
||||
{- Temporarily here to fix badly formatted uuid logs generated by
|
||||
- versions 3.20111105 and 3.20111025.
|
||||
|
@ -71,7 +71,7 @@ uuidDescMap = maybe uuidDescMapLoad return =<< Annex.getState Annex.uuiddescmap
|
|||
- it may not have been described and otherwise would not appear. -}
|
||||
uuidDescMapLoad :: Annex UUIDDescMap
|
||||
uuidDescMapLoad = do
|
||||
m <- (simpleMap . parseLog (Just . UUIDDesc . encodeBS))
|
||||
m <- (simpleMap . parseLog (Just . UUIDDesc . encodeBS)) . decodeBL
|
||||
<$> Annex.Branch.get uuidLog
|
||||
u <- Annex.UUID.getUUID
|
||||
let m' = M.insertWith preferold u mempty m
|
||||
|
|
13
Logs/Web.hs
13
Logs/Web.hs
|
@ -20,7 +20,6 @@ module Logs.Web (
|
|||
removeTempUrl,
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Annex.Common
|
||||
|
@ -49,7 +48,7 @@ getUrls key = do
|
|||
us <- currentLogInfo l
|
||||
if null us
|
||||
then go ls
|
||||
else return us
|
||||
else return $ map (decodeBS . fromLogInfo) us
|
||||
|
||||
getUrlsWithPrefix :: Key -> String -> Annex [URLString]
|
||||
getUrlsWithPrefix key prefix = filter (prefix `isPrefixOf`)
|
||||
|
@ -61,7 +60,8 @@ setUrlPresent key url = do
|
|||
us <- getUrls key
|
||||
unless (url `elem` us) $ do
|
||||
config <- Annex.getGitConfig
|
||||
addLog (urlLogFile config key) =<< logNow InfoPresent url
|
||||
addLog (urlLogFile config key)
|
||||
=<< logNow InfoPresent (LogInfo (encodeBS url))
|
||||
-- If the url does not have an OtherDownloader, it must be present
|
||||
-- in the web.
|
||||
case snd (getDownloader url) of
|
||||
|
@ -71,7 +71,8 @@ setUrlPresent key url = do
|
|||
setUrlMissing :: Key -> URLString -> Annex ()
|
||||
setUrlMissing key url = do
|
||||
config <- Annex.getGitConfig
|
||||
addLog (urlLogFile config key) =<< logNow InfoMissing url
|
||||
addLog (urlLogFile config key)
|
||||
=<< logNow InfoMissing (LogInfo (encodeBS url))
|
||||
-- If the url was a web url (not OtherDownloader) and none of
|
||||
-- the remaining urls for the key are web urls, the key must not
|
||||
-- be present in the web.
|
||||
|
@ -102,7 +103,9 @@ knownUrls = do
|
|||
Just k -> zip (repeat k) <$> geturls s
|
||||
Nothing -> return []
|
||||
geturls Nothing = return []
|
||||
geturls (Just logsha) = getLog . L.unpack <$> catObject logsha
|
||||
geturls (Just logsha) =
|
||||
map (decodeBS . fromLogInfo) . getLog
|
||||
<$> catObject logsha
|
||||
|
||||
setTempUrl :: Key -> URLString -> Annex ()
|
||||
setTempUrl key url = Annex.changeState $ \s ->
|
||||
|
|
2
Test.hs
2
Test.hs
|
@ -178,7 +178,7 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
|
|||
, testProperty "prop_segment_regressionTest" Utility.Misc.prop_segment_regressionTest
|
||||
, testProperty "prop_read_write_transferinfo" Logs.Transfer.prop_read_write_transferinfo
|
||||
, testProperty "prop_read_show_inodecache" Utility.InodeCache.prop_read_show_inodecache
|
||||
, testProperty "prop_parse_show_log" Logs.Presence.prop_parse_show_log
|
||||
, testProperty "prop_parse_build_log" Logs.Presence.prop_parse_build_log
|
||||
, testProperty "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel
|
||||
, testProperty "prop_parse_show_TrustLog" Logs.Trust.prop_parse_show_TrustLog
|
||||
, testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable
|
||||
|
|
|
@ -10,6 +10,8 @@ module Upgrade.V1 where
|
|||
import System.Posix.Types
|
||||
import Data.Char
|
||||
import Data.Default
|
||||
import Data.ByteString.Builder
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
import Annex.Common
|
||||
import Annex.Content
|
||||
|
@ -177,11 +179,11 @@ fileKey1 file = readKey1 $
|
|||
replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file
|
||||
|
||||
writeLog1 :: FilePath -> [LogLine] -> IO ()
|
||||
writeLog1 file ls = viaTmp writeFile file (showLog ls)
|
||||
writeLog1 file ls = viaTmp L.writeFile file (toLazyByteString $ buildLog ls)
|
||||
|
||||
readLog1 :: FilePath -> IO [LogLine]
|
||||
readLog1 file = catchDefaultIO [] $
|
||||
parseLog <$> readFileStrict file
|
||||
parseLog . encodeBL <$> readFileStrict file
|
||||
|
||||
lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend))
|
||||
lookupFile1 file = do
|
||||
|
|
|
@ -83,7 +83,7 @@ inject source dest = do
|
|||
old <- fromRepo olddir
|
||||
new <- liftIO (readFile $ old </> source)
|
||||
Annex.Branch.change dest $ \prev ->
|
||||
unlines $ nub $ lines prev ++ lines new
|
||||
encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new
|
||||
|
||||
logFiles :: FilePath -> Annex [FilePath]
|
||||
logFiles dir = return . filter (".log" `isSuffixOf`)
|
||||
|
|
Loading…
Reference in a new issue