module Data.Syncable where
import qualified Data.Map as Map
-type SyncCollection k = Map.Map k ()
+type SyncCollection k v = Map.Map k v
-data (Eq k, Ord k, Show k) =>
- SyncCommand k =
+data (Eq k, Ord k, Show k, Show v) =>
+ SyncCommand k v =
DeleteItem k
- | CopyItem k
+ | CopyItem k v
+ | ModifyContent k v
deriving (Eq, Ord, Show)
-syncBiDir :: (Ord k, Show k) =>
- SyncCollection k -- ^ Present state of master
- -> SyncCollection k -- ^ Present state of child
- -> SyncCollection k -- ^ Last state of child
- -> ([SyncCommand k], [SyncCommand k]) -- ^ Changes to make to (master, child)
+pairToFunc :: (a -> b -> c) -> (a, b) -> c
+pairToFunc func (a, b) = func a b
+
+{- | Perform a bi-directional sync. Compared to the last known state of
+the child, evaluate the new states of the master and child. Return a list of
+changes to make to the master and list of changes to make to the child to
+bring them into proper sync.
+
+In the event that both master and child previously had an item, and the payload
+of the item has changed on both ends, the payload as given in the child
+will take precedence. If both previously had an item, and it changed on only
+one end, the new value "wins".
+
+This relationship should hold:
+
+>let (masterCmds, childCmds) = syncBiDir masterState childState lastChildState
+>unaryApplyChanges masterState masterCmds ==
+> unaryApplyChanges childState childCmds
+
+This relationship is validated in the test suite that accompanies this
+software.
+
+-}
+syncBiDir :: (Ord k, Show k, Show v, Eq v) =>
+ SyncCollection k v -- ^ Present state of master
+ -> SyncCollection k v -- ^ Present state of child
+ -> SyncCollection k v -- ^ Last state of child
+ -> ([SyncCommand k v], [SyncCommand k v]) -- ^ Changes to make to (master, child)
syncBiDir masterstate childstate lastchildstate =
(masterchanges, childchanges)
where masterchanges = (map DeleteItem .
findDeleted childstate masterstate $ lastchildstate)
++
- (map CopyItem .
+ (map (pairToFunc CopyItem) .
findAdded childstate masterstate $ lastchildstate)
+ ++ (map (pairToFunc ModifyContent) . Map.toList $ masterPayloadChanges)
childchanges = (map DeleteItem .
findDeleted masterstate childstate $ lastchildstate)
++
- (map CopyItem .
+ (map (pairToFunc CopyItem) .
findAdded masterstate childstate $ lastchildstate)
+ ++ (map (pairToFunc ModifyContent) . Map.toList $ childPayloadChanges)
+ masterPayloadChanges =
+ Map.union
+ (findModified masterstate childstate childstate lastchildstate)
+ (findModified masterstate childstate reducedChildState masterstate)
+ where reducedChildState =
+ Map.difference childstate lastchildstate
+
+ -- The child's payload takes precedence, so we are going to
+ -- calculate the changes made on the master to apply to the client,
+ -- then subtract out any items in the master changes that have the
+ -- same key.
+ childPayloadChanges =
+ Map.difference (findModified childstate masterstate masterstate lastchildstate)
+ (findModified masterstate childstate childstate lastchildstate)
+
+{- | Compares two SyncCollections, and returns the commands that, when
+applied to the first collection, would yield the second. -}
+diffCollection :: (Ord k, Show k, Eq v, Show v) =>
+ SyncCollection k v
+ -> SyncCollection k v
+ -> [SyncCommand k v]
+diffCollection coll1 coll2 =
+ (map DeleteItem . findDeleted coll2 coll1 $ coll1) ++
+ (map (pairToFunc CopyItem) . findAdded coll2 coll1 $ coll1)
+ {-
+ (map (pairToFunc ModifyContent) . Map.toList .
+ findModified coll1 coll2 $ coll1)
+ -}
{- | Returns a list of keys that exist in state2 and lastchildstate
but not in state1 -}
findDeleted :: Ord k =>
- SyncCollection k -> SyncCollection k -> SyncCollection k ->
+ SyncCollection k v -> SyncCollection k v -> SyncCollection k v ->
[k]
findDeleted state1 state2 lastchildstate =
Map.keys . Map.difference (Map.intersection state2 lastchildstate) $ state1
{- | Returns a list of keys that exist in state1 but in neither
state2 nor lastchildstate -}
findAdded :: (Ord k, Eq k) =>
- SyncCollection k -> SyncCollection k -> SyncCollection k ->
- [k]
+ SyncCollection k v -> SyncCollection k v -> SyncCollection k v ->
+ [(k, v)]
findAdded state1 state2 lastchildstate =
- Map.keys . Map.difference state1 . Map.union state2 $ lastchildstate
-
-{- | Returns a list of keys that exist in the passed state -}
-filterKeys :: (Ord k) =>
- SyncCollection k -> [k] -> [k]
-filterKeys state keylist =
- concatMap keyfunc keylist
- where keyfunc k =
- case Map.lookup k state of
- Nothing -> []
- Just _ -> [k]
+ Map.toList . Map.difference state1 . Map.union state2 $ lastchildstate
+
+
+{- Finds all items that exist in both state1 and lastchildstate in which the payload
+is different in state1 than it was in lastchildstate. Returns the key and new
+payload for each such item found. -}
+findModified :: (Ord k, Eq v) =>
+ SyncCollection k v
+ -> SyncCollection k v
+ -> SyncCollection k v
+ -> SyncCollection k v
+ -> SyncCollection k v
+findModified basestate authoritativestate comparisonstate laststate =
+ Map.mapMaybe id $
+ Map.intersectionWithKey compareFunc comparisonstate laststate
+ where compareFunc k compv lastv =
+ if lastv == compv
+ then Nothing
+ else case (Map.lookup k basestate, Map.lookup k authoritativestate) of
+ (Nothing, _) -> Nothing
+ (Just basev, Nothing) ->
+ if compv /= basev
+ then Just compv
+ else Nothing
+ (Just basev, Just authv) ->
+ if (authv /= lastv) && (authv /= basev)
+ then Just authv
+ else if compv /= basev && (authv /= basev)
+ then Just compv
+ else Nothing
{- | Apply the specified changes to the given SyncCollection. Returns
a new SyncCollection with the changes applied. If changes are specified
that would apply to UIDs that do not exist in the source list, these changes
are silently ignored. -}
-unaryApplyChanges :: (Eq k, Ord k, Show k) =>
- SyncCollection k -> [SyncCommand k] -> SyncCollection k
+unaryApplyChanges :: (Eq k, Ord k, Show k, Show v) =>
+ SyncCollection k v -> [SyncCommand k v] -> SyncCollection k v
unaryApplyChanges collection commands =
let makeChange collection (DeleteItem key) =
Map.delete key collection
- makeChange collection (CopyItem key) =
- Map.insert key () collection
+ makeChange collection (CopyItem key val) =
+ Map.insert key val collection
+ makeChange collection (ModifyContent key val) =
+ Map.adjust (\_ -> val) key collection
in foldl makeChange collection commands