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)
-syncThem :: (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], [SyncCommand k]) -- ^ Changes to make to (master, child, child state repo)
-syncThem masterstate childstate lastchildstate =
- (masterchanges, childchanges, statuschanges)
- where masterchanges = []
- childchanges = map DeleteItem masterToChildDeletes
- statuschanges = map DeleteItem masterToStatusDeletes
+pairToFunc :: (a -> b -> c) -> (a, b) -> c
+pairToFunc func (a, b) = func a b
-{-
- # Delete local copies of remote messages. This way,
- # if a message's flag is modified locally but it has been
- # deleted remotely, we'll delete it locally. Otherwise, we
- # try to modify a deleted message's flags! This step
- # need only be taken if a statusfolder is present; otherwise,
- # there is no action taken *to* the remote repository.
+{- | 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:
- FIXME: validate logic in situation of new folder here -}
-
- masterToChildDeletes = syncToDelete masterstate childstate
- masterToStatusDeletes = filterKeys lastchildstate masterToChildDeletes
-
-
-{- | Returns a list of keys that exist in masterstate but not in childstate -}
-syncToDelete :: (Ord k) =>
- SyncCollection k -> SyncCollection k -> [k]
-syncToDelete masterstate childstate =
- concatMap keyfunc (Map.keys masterstate)
- where keyfunc k =
- case Map.lookup k childstate of
- Nothing -> [k]
- Just _ -> []
-
-{- | 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]
+>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 (pairToFunc CopyItem) .
+ findAdded childstate masterstate $ lastchildstate)
+ ++ (map (pairToFunc ModifyContent) . Map.toList $ masterPayloadChanges)
+ childchanges = (map DeleteItem .
+ findDeleted masterstate childstate $ lastchildstate)
+ ++
+ (map (pairToFunc CopyItem) .
+ findAdded masterstate childstate $ lastchildstate)
+ ++ (map (pairToFunc ModifyContent) . Map.toList $ childPayloadChanges)
+ masterPayloadChanges =
+ Map.union (findModified masterstate childstate lastchildstate)
+ (findModified masterstate childstate masterstate)
+
+ -- 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 lastchildstate)
+ (findModified masterstate 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 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 v -> SyncCollection k v -> SyncCollection k v ->
+ [(k, v)]
+findAdded state1 state2 lastchildstate =
+ 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
+findModified basestate state1 lastchildstate =
+ Map.mapMaybe id .
+ Map.intersectionWithKey comparefunc state1 $ lastchildstate
+ where comparefunc k v1 v2 =
+ if v1 /= v2
+ then case Map.lookup k basestate of
+ Nothing -> Nothing
+ Just baseval ->
+ if baseval == v1
+ then Nothing
+ else Just v1
+ 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, 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 val) =
+ Map.insert key val collection
+ makeChange collection (ModifyContent key val) =
+ Map.adjust (\_ -> val) key collection
+ in foldl makeChange collection commands