newtype MapLog

Noticed that Semigroup instance of Map is not suitable to use
for MapLog. For example, it behaved like this:

ghci>  parseTrustLog "foo 1 timestamp=10\nfoo 2 timestamp=11" <> parseTrustLog "foo X timestamp=12"
fromList [(UUID "foo",LogEntry {changed = VectorClock 11s, value = SemiTrusted})]

Which was wrong, it lost the newer DeadTrusted value.

Luckily, nothing used that Semigroup when operating on a MapLog. And this
provides a safe instance.

Sponsored-by: Graham Spencer on Patreon
This commit is contained in:
Joey Hess 2023-11-13 14:16:55 -04:00
parent 5d8b8a8ad0
commit 38b9ebc5fd
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
8 changed files with 74 additions and 44 deletions

View file

@ -18,6 +18,7 @@ import qualified Logs.Presence.Pure as Presence
import qualified Logs.Chunk.Pure as Chunk import qualified Logs.Chunk.Pure as Chunk
import qualified Logs.MetaData.Pure as MetaData import qualified Logs.MetaData.Pure as MetaData
import qualified Logs.Remote.Pure as Remote import qualified Logs.Remote.Pure as Remote
import Logs.MapLog
import Types.TrustLevel import Types.TrustLevel
import Types.UUID import Types.UUID
import Types.MetaData import Types.MetaData
@ -53,7 +54,7 @@ dropDead trustmap remoteconfigmap gc f content
| f == trustLog = PreserveFile | f == trustLog = PreserveFile
| f == remoteLog = ChangeFile $ | f == remoteLog = ChangeFile $
Remote.buildRemoteConfigLog $ Remote.buildRemoteConfigLog $
M.mapWithKey minimizesameasdead $ mapLogWithKey minimizesameasdead $
filterMapLog (notdead trustmap) id $ filterMapLog (notdead trustmap) id $
Remote.parseRemoteConfigLog content Remote.parseRemoteConfigLog content
| otherwise = filterBranch (notdead trustmap') gc f content | otherwise = filterBranch (notdead trustmap') gc f content
@ -95,8 +96,8 @@ filterBranch wantuuid gc f content = case getLogVariety gc f of
Just OtherLog -> PreserveFile Just OtherLog -> PreserveFile
Nothing -> PreserveFile Nothing -> PreserveFile
filterMapLog :: (UUID -> Bool) -> (k -> UUID) -> M.Map k v -> M.Map k v filterMapLog :: (UUID -> Bool) -> (k -> UUID) -> MapLog k v -> MapLog k v
filterMapLog wantuuid getuuid = M.filterWithKey $ \k _v -> wantuuid (getuuid k) filterMapLog wantuuid getuuid = filterMapLogWith (\k _v -> wantuuid (getuuid k))
filterLocationLog :: (UUID -> Bool) -> [Presence.LogLine] -> [Presence.LogLine] filterLocationLog :: (UUID -> Bool) -> [Presence.LogLine] -> [Presence.LogLine]
filterLocationLog wantuuid = filter $ filterLocationLog wantuuid = filter $

View file

@ -73,7 +73,7 @@ start (Expire expire) noact actlog descs u =
trustSet u DeadTrusted trustSet u DeadTrusted
next $ return True next $ return True
where where
lastact = changed <$> M.lookup u actlog lastact = changed <$> M.lookup u (fromMapLog actlog)
whenactive = case lastact of whenactive = case lastact of
Just (VectorClock c) -> do Just (VectorClock c) -> do
d <- liftIO $ durationSince $ posixSecondsToUTCTime c d <- liftIO $ durationSince $ posixSecondsToUTCTime c

View file

@ -54,3 +54,4 @@ getCurrentChunks u k = do
. map (\((_ku, m), l) -> (m, value l)) . map (\((_ku, m), l) -> (m, value l))
. M.toList . M.toList
. M.filterWithKey (\(ku, _m) _ -> ku == u) . M.filterWithKey (\(ku, _m) _ -> ku == u)
. fromMapLog

View file

@ -101,7 +101,7 @@ recordExportUnderway remoteuuid ec = do
Annex.Branch.change ru exportLog $ Annex.Branch.change ru exportLog $
buildExportLog buildExportLog
. changeMapLog c ep exported . changeMapLog c ep exported
. M.mapWithKey (updateForExportChange remoteuuid ec c hereuuid) . mapLogWithKey (updateForExportChange remoteuuid ec c hereuuid)
. parseExportLog . parseExportLog
-- Record information about the export to the git-annex branch. -- Record information about the export to the git-annex branch.

View file

@ -6,7 +6,7 @@
- -
- The field names cannot contain whitespace. - The field names cannot contain whitespace.
- -
- Copyright 2014, 2019 Joey Hess <id@joeyh.name> - Copyright 2014-2023 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -28,6 +28,8 @@ import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Lazy as AL import qualified Data.Attoparsec.ByteString.Lazy as AL
import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.Attoparsec.ByteString.Char8 as A8
import Data.ByteString.Builder import Data.ByteString.Builder
import qualified Data.Semigroup as Sem
import Prelude
data LogEntry v = LogEntry data LogEntry v = LogEntry
{ changed :: VectorClock { changed :: VectorClock
@ -37,10 +39,23 @@ data LogEntry v = LogEntry
instance Arbitrary v => Arbitrary (LogEntry v) where instance Arbitrary v => Arbitrary (LogEntry v) where
arbitrary = LogEntry <$> arbitrary <*> arbitrary arbitrary = LogEntry <$> arbitrary <*> arbitrary
type MapLog f v = M.Map f (LogEntry v) newtype MapLog f v = MapLog (M.Map f (LogEntry v))
deriving (Show, Eq)
instance Ord f => Sem.Semigroup (MapLog f v)
where
a <> MapLog b = foldl' (\m (f, v) -> addMapLog f v m) a (M.toList b)
instance Ord f => Monoid (MapLog f v)
where
mempty = MapLog M.empty
fromMapLog :: MapLog f v -> M.Map f (LogEntry v)
fromMapLog (MapLog m) = m
buildMapLog :: (f -> Builder) -> (v -> Builder) -> MapLog f v -> Builder buildMapLog :: (f -> Builder) -> (v -> Builder) -> MapLog f v -> Builder
buildMapLog fieldbuilder valuebuilder = mconcat . map genline . M.toList buildMapLog fieldbuilder valuebuilder (MapLog m) =
mconcat $ map genline $ M.toList m
where where
genline (f, LogEntry c v) = genline (f, LogEntry c v) =
buildVectorClock c <> sp buildVectorClock c <> sp
@ -50,25 +65,32 @@ buildMapLog fieldbuilder valuebuilder = mconcat . map genline . M.toList
nl = charUtf8 '\n' nl = charUtf8 '\n'
parseMapLog :: Ord f => A.Parser f -> A.Parser v -> L.ByteString -> MapLog f v parseMapLog :: Ord f => A.Parser f -> A.Parser v -> L.ByteString -> MapLog f v
parseMapLog fieldparser valueparser = fromMaybe M.empty . AL.maybeResult parseMapLog fieldparser valueparser =
. AL.parse (mapLogParser fieldparser valueparser) parseMapLogWith (mapLogParser fieldparser valueparser)
parseMapLogWith :: Ord f => A.Parser (MapLog f v) -> L.ByteString -> MapLog f v
parseMapLogWith parser = fromMaybe (MapLog M.empty)
. AL.maybeResult
. AL.parse parser
mapLogParser :: Ord f => A.Parser f -> A.Parser v -> A.Parser (MapLog f v) mapLogParser :: Ord f => A.Parser f -> A.Parser v -> A.Parser (MapLog f v)
mapLogParser fieldparser valueparser = M.fromListWith best <$> parseLogLines go mapLogParser fieldparser valueparser = mapLogParser' $ do
where c <- vectorClockParser
go = do _ <- A8.char ' '
c <- vectorClockParser w <- A8.takeTill (== ' ')
_ <- A8.char ' ' f <- either fail return $
w <- A8.takeTill (== ' ') A.parseOnly (fieldparser <* A.endOfInput) w
f <- either fail return $ _ <- A8.char ' '
A.parseOnly (fieldparser <* A.endOfInput) w v <- valueparser
_ <- A8.char ' ' A.endOfInput
v <- valueparser return (f, LogEntry c v)
A.endOfInput
return (f, LogEntry c v) mapLogParser' :: Ord f => A.Parser (f, LogEntry v) -> A.Parser (MapLog f v)
mapLogParser' p = MapLog . M.fromListWith best
<$> parseLogLines p
changeMapLog :: Ord f => CandidateVectorClock -> f -> v -> MapLog f v -> MapLog f v changeMapLog :: Ord f => CandidateVectorClock -> f -> v -> MapLog f v -> MapLog f v
changeMapLog c f v m = M.insert f (LogEntry c' v) m changeMapLog c f v (MapLog m) = MapLog (M.insert f (LogEntry c' v) m)
where where
c' = case M.lookup f m of c' = case M.lookup f m of
Nothing -> advanceVectorClock c [] Nothing -> advanceVectorClock c []
@ -77,13 +99,19 @@ changeMapLog c f v m = M.insert f (LogEntry c' v) m
{- Only add an LogEntry if it's newer (or at least as new as) than any {- Only add an LogEntry if it's newer (or at least as new as) than any
- existing LogEntry for a field. -} - existing LogEntry for a field. -}
addMapLog :: Ord f => f -> LogEntry v -> MapLog f v -> MapLog f v addMapLog :: Ord f => f -> LogEntry v -> MapLog f v -> MapLog f v
addMapLog = M.insertWith best addMapLog f v (MapLog m) = MapLog (M.insertWith best f v m)
filterMapLogWith :: (f -> LogEntry v -> Bool) -> MapLog f v -> MapLog f v
filterMapLogWith f (MapLog m) = MapLog (M.filterWithKey f m)
mapLogWithKey :: (f -> LogEntry v -> LogEntry v) -> MapLog f v -> MapLog f v
mapLogWithKey f (MapLog m) = MapLog (M.mapWithKey f m)
{- Converts a MapLog into a simple Map without the timestamp information. {- Converts a MapLog into a simple Map without the timestamp information.
- This is a one-way trip, but useful for code that never needs to change - This is a one-way trip, but useful for code that never needs to change
- the log. -} - the log. -}
simpleMap :: MapLog f v -> M.Map f v simpleMap :: MapLog f v -> M.Map f v
simpleMap = M.map value simpleMap (MapLog m) = M.map value m
best :: LogEntry v -> LogEntry v -> LogEntry v best :: LogEntry v -> LogEntry v -> LogEntry v
best new old best new old
@ -93,8 +121,8 @@ best new old
prop_addMapLog_sane :: Bool prop_addMapLog_sane :: Bool
prop_addMapLog_sane = newWins && newestWins prop_addMapLog_sane = newWins && newestWins
where where
newWins = addMapLog ("foo") (LogEntry (VectorClock 1) "new") l == l2 newWins = addMapLog "foo" (LogEntry (VectorClock 1) "new") l == l2
newestWins = addMapLog ("foo") (LogEntry (VectorClock 1) "newest") l2 /= l2 newestWins = addMapLog "foo" (LogEntry (VectorClock 1) "newest") l2 /= l2
l = M.fromList [("foo", LogEntry (VectorClock 0) "old")] l = MapLog (M.fromList [("foo", LogEntry (VectorClock 0) "old")])
l2 = M.fromList [("foo", LogEntry (VectorClock 1) "new")] l2 = MapLog (M.fromList [("foo", LogEntry (VectorClock 1) "new")])

View file

@ -14,6 +14,7 @@ import Annex.Common
import Types.RemoteState import Types.RemoteState
import Logs import Logs
import Logs.UUIDBased import Logs.UUIDBased
import Logs.MapLog
import qualified Annex.Branch import qualified Annex.Branch
import qualified Annex import qualified Annex
@ -39,7 +40,7 @@ buildRemoteState = buildLogNew (byteString . encodeBS)
getRemoteState :: RemoteStateHandle -> Key -> Annex (Maybe RemoteState) getRemoteState :: RemoteStateHandle -> Key -> Annex (Maybe RemoteState)
getRemoteState (RemoteStateHandle u) k = do getRemoteState (RemoteStateHandle u) k = do
config <- Annex.getGitConfig config <- Annex.getGitConfig
extract . parseRemoteState extract . fromMapLog . parseRemoteState
<$> Annex.Branch.get (remoteStateLogFile config k) <$> Annex.Branch.get (remoteStateLogFile config k)
where where
extract m = value <$> M.lookup u m extract m = value <$> M.lookup u m

View file

@ -19,7 +19,10 @@ import qualified Data.Attoparsec.ByteString.Char8 as A8
import Data.ByteString.Builder import Data.ByteString.Builder
calcTrustMap :: L.ByteString -> TrustMap calcTrustMap :: L.ByteString -> TrustMap
calcTrustMap = simpleMap . parseLogOld trustLevelParser calcTrustMap = simpleMap . parseTrustLog
parseTrustLog :: L.ByteString -> Log TrustLevel
parseTrustLog = parseLogOld trustLevelParser
trustLevelParser :: A.Parser TrustLevel trustLevelParser :: A.Parser TrustLevel
trustLevelParser = (totrust <$> A8.anyChar <* A.endOfInput) trustLevelParser = (totrust <$> A8.anyChar <* A.endOfInput)

View file

@ -9,7 +9,7 @@
- -
- New uuid based logs instead use the form: "timestamp UUID INFO" - New uuid based logs instead use the form: "timestamp UUID INFO"
- -
- Copyright 2011-2019 Joey Hess <id@joeyh.name> - Copyright 2011-2023 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -37,12 +37,10 @@ import Common
import Types.UUID import Types.UUID
import Annex.VectorClock import Annex.VectorClock
import Logs.MapLog import Logs.MapLog
import Logs.Line
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Lazy as AL
import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.Attoparsec.ByteString.Char8 as A8
import Data.ByteString.Builder import Data.ByteString.Builder
import qualified Data.DList as D import qualified Data.DList as D
@ -50,7 +48,7 @@ import qualified Data.DList as D
type Log v = MapLog UUID v type Log v = MapLog UUID v
buildLogOld :: (v -> Builder) -> Log v -> Builder buildLogOld :: (v -> Builder) -> Log v -> Builder
buildLogOld builder = mconcat . map genline . M.toList buildLogOld builder = mconcat . map genline . M.toList . fromMapLog
where where
genline (u, LogEntry c@(VectorClock {}) v) = genline (u, LogEntry c@(VectorClock {}) v) =
buildUUID u <> sp <> builder v <> sp buildUUID u <> sp <> builder v <> sp
@ -66,18 +64,16 @@ parseLogOld :: A.Parser a -> L.ByteString -> Log a
parseLogOld = parseLogOldWithUUID . const parseLogOld = parseLogOldWithUUID . const
parseLogOldWithUUID :: (UUID -> A.Parser a) -> L.ByteString -> Log a parseLogOldWithUUID :: (UUID -> A.Parser a) -> L.ByteString -> Log a
parseLogOldWithUUID parser = fromMaybe M.empty . AL.maybeResult parseLogOldWithUUID parser = parseMapLogWith (logParserOld parser)
. AL.parse (logParserOld parser)
logParserOld :: (UUID -> A.Parser a) -> A.Parser (Log a) logParserOld :: (UUID -> A.Parser a) -> A.Parser (Log a)
logParserOld parser = M.fromListWith best <$> parseLogLines go logParserOld parser = mapLogParser' $ do
u <- toUUID <$> A8.takeWhile1 (/= ' ')
(dl, ts) <- accumval D.empty
v <- either fail return $ A.parseOnly (parser u <* A.endOfInput)
(S.intercalate " " $ D.toList dl)
return (u, LogEntry ts v)
where where
go = do
u <- toUUID <$> A8.takeWhile1 (/= ' ')
(dl, ts) <- accumval D.empty
v <- either fail return $ A.parseOnly (parser u <* A.endOfInput)
(S.intercalate " " $ D.toList dl)
return (u, LogEntry ts v)
accumval dl = accumval dl =
((dl,) <$> parsetimestamp) ((dl,) <$> parsetimestamp)
<|> (A8.char ' ' *> (A8.takeWhile (/= ' ')) >>= accumval . D.snoc dl) <|> (A8.char ' ' *> (A8.takeWhile (/= ' ')) >>= accumval . D.snoc dl)