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:
Joey Hess 2019-01-03 13:21:48 -04:00
parent 53905490df
commit bfc9039ead
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
27 changed files with 163 additions and 120 deletions

View file

@ -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

View file

@ -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 =

View file

@ -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

View file

@ -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

View file

@ -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))

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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. -}

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View 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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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))

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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 ->

View file

@ -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

View file

@ -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

View file

@ -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`)