summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-02-12 17:54:28 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-02-12 17:57:32 -0400
commit41e5f8dfe79d6db8b0bd1492d8f28caf6b24ef5f (patch)
treeb39ece56837a212d8ca147c24154fcecaf9a647f
parent595bb1862bb32462ad743b790c1c4e536569e60f (diff)
data types and serialization for metadata
A very haskell commit! Just data types, instances to serialize the metadata to a nice format, and QuickCheck tests. This commit was sponsored by Andreas Leha.
-rw-r--r--Test.hs3
-rw-r--r--Types/MetaData.hs180
-rw-r--r--Utility/QuickCheck.hs6
-rw-r--r--doc/design/metadata.mdwn33
4 files changed, 221 insertions, 1 deletions
diff --git a/Test.hs b/Test.hs
index a78307127..43f5939ee 100644
--- a/Test.hs
+++ b/Test.hs
@@ -45,6 +45,7 @@ import qualified Logs.Remote
import qualified Logs.Unused
import qualified Logs.Transfer
import qualified Logs.Presence
+import qualified Types.MetaData
import qualified Remote
import qualified Types.Key
import qualified Types.Messages
@@ -144,6 +145,8 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
, testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable
, testProperty "prop_schedule_roundtrips" Utility.Scheduled.prop_schedule_roundtrips
, testProperty "prop_duration_roundtrips" Utility.HumanTime.prop_duration_roundtrips
+ , testProperty "prop_updateMetaData_sane" Types.MetaData.prop_updateMetaData_sane
+ , testProperty "prop_metadata_serialize" Types.MetaData.prop_metadata_serialize
]
{- These tests set up the test environment, but also test some basic parts
diff --git a/Types/MetaData.hs b/Types/MetaData.hs
new file mode 100644
index 000000000..ee6ba66a0
--- /dev/null
+++ b/Types/MetaData.hs
@@ -0,0 +1,180 @@
+{- git-annex general metadata
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Types.MetaData (
+ MetaData,
+ MetaField,
+ MetaValue,
+ CurrentlySet(..),
+ MetaSerializable,
+ toMetaField,
+ fromMetaField,
+ toMetaValue,
+ toMetaValue',
+ fromMetaValue,
+ newMetaData,
+ updateMetaData,
+ getCurrentMetaData,
+ getAllMetaData,
+ serialize,
+ deserialize,
+ prop_updateMetaData_sane,
+ prop_metadata_serialize
+) where
+
+import Common
+import Utility.Base64
+import Utility.QuickCheck
+
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Char
+
+newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue))
+ deriving (Show, Eq)
+
+{- A metadata value can be currently be set (True), or may have been
+ - set before and we're remembering it no longer is (False). -}
+newtype CurrentlySet = CurrentlySet Bool
+ deriving (Show, Eq, Ord, Arbitrary)
+
+newtype MetaField = MetaField String
+ deriving (Show, Eq, Ord)
+
+data MetaValue = MetaValue CurrentlySet String
+ deriving (Show, Ord)
+
+{- Metadata values are compared equal whether currently set or not. -}
+instance Eq MetaValue where
+ MetaValue _ a == MetaValue _ b = a == b
+
+{- MetaData is serialized to a format like:
+ -
+ - field1 +val1 +val2 -val3 field2 +val4 +val5
+ -}
+class MetaSerializable v where
+ serialize :: v -> String
+ deserialize :: String -> Maybe v
+
+instance MetaSerializable MetaData where
+ serialize (MetaData m) = unwords $ concatMap go $ M.toList m
+ where
+ go (f, vs) = serialize f : map serialize (S.toList vs)
+ deserialize = Just . getfield newMetaData . words
+ where
+ getfield m [] = m
+ getfield m (w:ws) = maybe m (getvalues m ws) (deserialize w)
+ getvalues m [] _ = m
+ getvalues m l@(w:ws) f = case deserialize w of
+ Just v -> getvalues (updateMetaData f v m) ws f
+ Nothing -> getfield m l
+
+instance MetaSerializable MetaField where
+ serialize (MetaField f) = f
+ deserialize = Just . MetaField
+
+{- Base64 problimatic values. -}
+instance MetaSerializable MetaValue where
+ serialize (MetaValue isset v) =
+ serialize isset ++
+ if any isSpace v || "!" `isPrefixOf` v
+ then '!' : toB64 v
+ else v
+ deserialize (isset:'!':v) = MetaValue
+ <$> deserialize [isset]
+ <*> fromB64Maybe v
+ deserialize (isset:v) = MetaValue
+ <$> deserialize [isset]
+ <*> pure v
+ deserialize [] = Nothing
+
+instance MetaSerializable CurrentlySet where
+ serialize (CurrentlySet True) = "+"
+ serialize (CurrentlySet False) = "-"
+ deserialize "+" = Just (CurrentlySet True)
+ deserialize "-" = Just (CurrentlySet False)
+ deserialize _ = Nothing
+
+{- Fields cannot be empty, contain whitespace, or start with "+-" as
+ - that would break the serialization. -}
+toMetaField :: String -> Maybe MetaField
+toMetaField f
+ | legalField f = Just $ MetaField f
+ | otherwise = Nothing
+
+legalField :: String -> Bool
+legalField f
+ | null f = False
+ | any isSpace f = False
+ | any (`isPrefixOf` f) ["+", "-"] = False
+ | otherwise = True
+
+toMetaValue :: String -> MetaValue
+toMetaValue = MetaValue (CurrentlySet True)
+
+toMetaValue' :: CurrentlySet -> String -> MetaValue
+toMetaValue' = MetaValue
+
+fromMetaField :: MetaField -> String
+fromMetaField (MetaField f) = f
+
+fromMetaValue :: MetaValue -> String
+fromMetaValue (MetaValue _ f) = f
+
+newMetaData :: MetaData
+newMetaData = MetaData M.empty
+
+{- Can be used to set a value, or to unset it, depending on whether
+ - the MetaValue has CurrentlySet or not. -}
+updateMetaData :: MetaField -> MetaValue -> MetaData -> MetaData
+updateMetaData f v (MetaData m) = MetaData $
+ M.insertWith' S.union f (S.singleton v) m
+
+{- Gets only currently set values -}
+getCurrentMetaData :: MetaField -> MetaData -> S.Set MetaValue
+getCurrentMetaData f m = S.filter isSet (getAllMetaData f m)
+
+isSet :: MetaValue -> Bool
+isSet (MetaValue (CurrentlySet isset) _) = isset
+
+{- Gets currently set values, but also values that have been unset. -}
+getAllMetaData :: MetaField -> MetaData -> S.Set MetaValue
+getAllMetaData f (MetaData m) = fromMaybe S.empty (M.lookup f m)
+
+{- Avoid putting too many fields in the map; extremely large maps make
+ - the seriaization test slow due to the sheer amount of data.
+ - It's unlikely that more than 100 fields of metadata will be used. -}
+instance Arbitrary MetaData where
+ arbitrary = do
+ size <- arbitrarySizedBoundedIntegral `suchThat` (< 500)
+ MetaData . M.fromList <$> vector size
+
+instance Arbitrary MetaValue where
+ arbitrary = MetaValue <$> arbitrary <*> arbitrary
+
+instance Arbitrary MetaField where
+ arbitrary = MetaField <$> arbitrary `suchThat` legalField
+
+prop_updateMetaData_sane :: MetaData -> MetaField -> MetaValue -> Bool
+prop_updateMetaData_sane m f v = and
+ [ S.member v $ getAllMetaData f m'
+ , not (isSet v) || S.member v (getCurrentMetaData f m')
+ ]
+ where
+ m' = updateMetaData f v m
+
+prop_metadata_serialize :: MetaField -> MetaValue -> MetaData -> Bool
+prop_metadata_serialize f v m = and
+ [ deserialize (serialize f) == Just f
+ , deserialize (serialize v) == Just v
+ , deserialize (serialize m') == Just m'
+ ]
+ where
+ m' = removeemptyfields m
+ removeemptyfields (MetaData x) = MetaData $ M.filter (not . S.null) x
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
index 82af09f3d..e2539f3d6 100644
--- a/Utility/QuickCheck.hs
+++ b/Utility/QuickCheck.hs
@@ -1,6 +1,6 @@
{- QuickCheck with additional instances
-
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -17,11 +17,15 @@ import Test.QuickCheck as X
import Data.Time.Clock.POSIX
import System.Posix.Types
import qualified Data.Map as M
+import qualified Data.Set as S
import Control.Applicative
instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where
arbitrary = M.fromList <$> arbitrary
+instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where
+ arbitrary = S.fromList <$> arbitrary
+
{- Times before the epoch are excluded. -}
instance Arbitrary POSIXTime where
arbitrary = nonNegative arbitrarySizedIntegral
diff --git a/doc/design/metadata.mdwn b/doc/design/metadata.mdwn
index 6b8b5bdc0..40c085cdc 100644
--- a/doc/design/metadata.mdwn
+++ b/doc/design/metadata.mdwn
@@ -126,6 +126,39 @@ Note that any of these filenames can in theory conflict. May need to use
`.variant-*` like sync does on conflict to allow 2 files with same name in
same filtered branch.
+## union merge properties
+
+While the storage could just list all the current values of a field on a
+line with a timestamp, that's not good enough. Two disconnected
+repositories can make changes to the values of a field (setting and
+unsetting tags for example) and when this is union merged back together,
+the changes need to be able to be replayed in order to determine which
+values we end up with.
+
+To make that work, we log not only when a field is set to a value,
+but when a value is unset as well.
+
+For example, here two different remotes added tags, and then later
+a tag was removed:
+
+ 1287290776.765152s tag +foo +bar
+ 1287290991.152124s tag +baz
+ 1291237510.141453s tag -bar
+
+The end result is that tags foo and baz are set. This can be simplified:
+
+ 1291237510.141453s tag +foo +baz -bar
+
+Note the reuse of the most recent timestamp in the simplified version,
+rather than putting in the timestamp when the simplification was done.
+This ensures that is some other repo is making changes, they won't get
+trampled over. For example:
+
+ 1291237510.141453s tag +foo +baz -bar
+ 1291239999.000000s tag +bar -foo
+
+Now tags bar and baz are set.
+
# efficient metadata lookup
Looking up metadata for filtering so far requires traversing all keys in