{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Mergeful.Persistent
(
clientMakeSyncRequestQuery,
clientMergeSyncResponseQuery,
clientSyncProcessor,
ItemMergeStrategy (..),
mergeFromServerStrategy,
mergeFromClientStrategy,
mergeUsingCRDTStrategy,
serverProcessSyncQuery,
serverProcessSyncWithCustomIdQuery,
serverSyncProcessor,
serverSyncWithCustomIdProcessor,
setupClientQuery,
clientGetStoreQuery,
setupServerQuery,
serverGetStoreQuery,
)
where
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe
import Data.Mergeful
import Data.Set (Set)
import qualified Data.Set as S
import Database.Persist
import Database.Persist.Sql
deriving instance PersistField ServerTime
deriving instance PersistFieldSql ServerTime
clientMakeSyncRequestQuery ::
forall record sid a m.
( Ord sid,
PersistEntity record,
PersistField sid,
PersistEntityBackend record ~ SqlBackend,
ToBackendKey SqlBackend record,
MonadIO m
) =>
EntityField record (Maybe sid) ->
EntityField record (Maybe ServerTime) ->
EntityField record Bool ->
EntityField record Bool ->
(record -> a) ->
(record -> (sid, Timed a)) ->
(record -> (sid, ServerTime)) ->
SqlPersistT m (SyncRequest (Key record) sid a)
clientMakeSyncRequestQuery
serverIdField
serverTimeField
changedField
deletedField
unmakeUnsyncedClientThing
unmakeSyncedClientThing
unmakeDeletedClientThing = do
syncRequestNewItems <-
M.fromList . map (\(Entity cid r) -> (cid, unmakeUnsyncedClientThing r))
<$> selectList
[ serverIdField ==. Nothing,
serverTimeField ==. Nothing
]
[]
syncRequestKnownItems <-
M.fromList . map (unmakeDeletedClientThing . entityVal)
<$> selectList
[ serverIdField !=. Nothing,
serverTimeField !=. Nothing,
changedField ==. False,
deletedField ==. False
]
[]
syncRequestKnownButChangedItems <-
M.fromList . map (unmakeSyncedClientThing . entityVal)
<$> selectList
[ serverIdField !=. Nothing,
serverTimeField !=. Nothing,
changedField ==. True,
deletedField ==. False
]
[]
syncRequestDeletedItems <-
M.fromList . map (unmakeDeletedClientThing . entityVal)
<$> selectList
[ deletedField ==. True
]
[]
pure SyncRequest {..}
clientMergeSyncResponseQuery ::
forall record sid a m.
( Ord sid,
PersistField sid,
PersistEntityBackend record ~ SqlBackend,
ToBackendKey SqlBackend record,
MonadIO m
) =>
EntityField record (Maybe sid) ->
EntityField record (Maybe ServerTime) ->
EntityField record Bool ->
EntityField record Bool ->
(sid -> Timed a -> record) ->
(record -> (sid, Timed a)) ->
(a -> [Update record]) ->
ItemMergeStrategy a ->
SyncResponse (Key record) sid a ->
SqlPersistT m ()
clientMergeSyncResponseQuery
serverIdField
serverTimeField
changedField
deletedField
makeSyncedClientThing
unmakeSyncedClientThing
recordUpdates
strat =
mergeSyncResponseCustom strat $
clientSyncProcessor
serverIdField
serverTimeField
changedField
deletedField
makeSyncedClientThing
unmakeSyncedClientThing
recordUpdates
clientSyncProcessor ::
forall record sid a m.
( Ord sid,
PersistField sid,
PersistEntityBackend record ~ SqlBackend,
ToBackendKey SqlBackend record,
MonadIO m
) =>
EntityField record (Maybe sid) ->
EntityField record (Maybe ServerTime) ->
EntityField record Bool ->
EntityField record Bool ->
(sid -> Timed a -> record) ->
(record -> (sid, Timed a)) ->
(a -> [Update record]) ->
ClientSyncProcessor (Key record) sid a (SqlPersistT m)
clientSyncProcessor
serverIdField
serverTimeField
changedField
deletedField
makeSyncedClientThing
unmakeSyncedClientThing
recordUpdates = ClientSyncProcessor {..}
where
clientSyncProcessorQuerySyncedButChangedValues :: Set sid -> SqlPersistT m (Map sid (Timed a))
clientSyncProcessorQuerySyncedButChangedValues si = fmap (M.fromList . map (\(Entity _ r) -> unmakeSyncedClientThing r) . catMaybes) $ forM (S.toList si) $ \sid ->
selectFirst
[ serverIdField ==. Just sid,
serverTimeField !=. Nothing,
changedField ==. True,
deletedField ==. False
]
[]
clientSyncProcessorSyncClientAdded :: Map (Key record) (ClientAddition sid) -> SqlPersistT m ()
clientSyncProcessorSyncClientAdded m = forM_ (M.toList m) $ \(cid, ClientAddition {..}) ->
update
cid
[ serverIdField =. Just clientAdditionId,
serverTimeField =. Just clientAdditionServerTime
]
clientSyncProcessorSyncClientChanged :: Map sid ServerTime -> SqlPersistT m ()
clientSyncProcessorSyncClientChanged m = forM_ (M.toList m) $ \(sid, st) ->
updateWhere
[serverIdField ==. Just sid]
[ serverTimeField =. Just st,
changedField =. False
]
clientSyncProcessorSyncClientDeleted :: Set sid -> SqlPersistT m ()
clientSyncProcessorSyncClientDeleted s = forM_ (S.toList s) $ \sid ->
deleteWhere [serverIdField ==. Just sid]
clientSyncProcessorSyncMergedConflict :: Map sid (Timed a) -> SqlPersistT m ()
clientSyncProcessorSyncMergedConflict m = forM_ (M.toList m) $ \(sid, Timed a st) ->
updateWhere
[serverIdField ==. Just sid]
$ [ serverTimeField =. Just st,
changedField =. True
]
++ recordUpdates a
clientSyncProcessorSyncServerAdded :: Map sid (Timed a) -> SqlPersistT m ()
clientSyncProcessorSyncServerAdded m =
insertMany_ $ map (uncurry makeSyncedClientThing) (M.toList m)
clientSyncProcessorSyncServerChanged :: Map sid (Timed a) -> SqlPersistT m ()
clientSyncProcessorSyncServerChanged m = forM_ (M.toList m) $ \(sid, Timed a st) -> do
updateWhere
[serverIdField ==. Just sid]
$ [ serverTimeField =. Just st,
changedField =. False
]
++ recordUpdates a
clientSyncProcessorSyncServerDeleted :: Set sid -> SqlPersistT m ()
clientSyncProcessorSyncServerDeleted s = forM_ (S.toList s) $ \sid ->
deleteWhere [serverIdField ==. Just sid]
setupClientQuery ::
forall record sid a m.
( PersistEntityBackend record ~ SqlBackend,
ToBackendKey SqlBackend record,
MonadIO m
) =>
(a -> record) ->
(sid -> Timed a -> record) ->
(sid -> Timed a -> record) ->
(sid -> ServerTime -> record) ->
ClientStore (Key record) sid a ->
SqlPersistT m ()
setupClientQuery makeUnsyncedClientThing makeSyncedClientThing makeSyncedButChangedClientThing makeDeletedClientThing ClientStore {..} = do
forM_ (M.toList clientStoreAddedItems) $ \(cid, t) ->
insertKey cid $ makeUnsyncedClientThing t
forM_ (M.toList clientStoreSyncedItems) $ \(sid, tt) ->
insert_ $ makeSyncedClientThing sid tt
forM_ (M.toList clientStoreSyncedButChangedItems) $ \(sid, tt) ->
insert_ $ makeSyncedButChangedClientThing sid tt
forM_ (M.toList clientStoreDeletedItems) $ \(sid, st) -> insert_ $ makeDeletedClientThing sid st
clientGetStoreQuery ::
forall record sid a m.
( Ord sid,
PersistEntity record,
PersistField sid,
PersistEntityBackend record ~ SqlBackend,
ToBackendKey SqlBackend record,
MonadIO m
) =>
EntityField record (Maybe sid) ->
EntityField record (Maybe ServerTime) ->
EntityField record Bool ->
EntityField record Bool ->
(record -> a) ->
(record -> (sid, Timed a)) ->
(record -> (sid, ServerTime)) ->
SqlPersistT m (ClientStore (Key record) sid a)
clientGetStoreQuery
serverIdField
serverTimeField
changedField
deletedField
unmakeUnsyncedClientThing
unmakeSyncedClientThing
unmakeDeletedClientThing = do
clientStoreAddedItems <-
M.fromList . map (\(Entity cid cr) -> (cid, unmakeUnsyncedClientThing cr))
<$> selectList
[ serverIdField ==. Nothing,
serverTimeField ==. Nothing
]
[]
clientStoreSyncedItems <-
M.fromList . map (unmakeSyncedClientThing . entityVal)
<$> selectList
[ serverIdField !=. Nothing,
serverTimeField !=. Nothing,
changedField ==. False,
deletedField ==. False
]
[]
clientStoreSyncedButChangedItems <-
M.fromList . map (unmakeSyncedClientThing . entityVal)
<$> selectList
[ serverIdField !=. Nothing,
serverTimeField !=. Nothing,
changedField ==. True,
deletedField ==. False
]
[]
clientStoreDeletedItems <-
M.fromList . map (unmakeDeletedClientThing . entityVal)
<$> selectList
[ deletedField ==. True
]
[]
pure ClientStore {..}
serverProcessSyncQuery ::
forall cid record a m.
( PersistEntity record,
PersistEntityBackend record ~ SqlBackend,
ToBackendKey SqlBackend record,
MonadIO m
) =>
EntityField record ServerTime ->
[Filter record] ->
(record -> Timed a) ->
(a -> record) ->
(a -> [Update record]) ->
SyncRequest cid (Key record) a ->
SqlPersistT m (SyncResponse cid (Key record) a)
serverProcessSyncQuery
serverTimeField
filters
unmakeFunc
makeFunc
recordUpdates =
processServerSyncCustom $
serverSyncProcessor
serverTimeField
filters
unmakeFunc
makeFunc
recordUpdates
serverSyncProcessor ::
forall cid record a m.
( PersistEntity record,
PersistEntityBackend record ~ SqlBackend,
ToBackendKey SqlBackend record,
MonadIO m
) =>
EntityField record ServerTime ->
[Filter record] ->
(record -> Timed a) ->
(a -> record) ->
(a -> [Update record]) ->
ServerSyncProcessor cid (Key record) a (SqlPersistT m)
serverSyncProcessor
serverTimeField
filters
unmakeFunc
makeFunc
recordUpdates =
ServerSyncProcessor {..} :: ServerSyncProcessor cid (Key record) a (SqlPersistT m)
where
serverSyncProcessorRead = M.fromList . map (\(Entity i r) -> (i, unmakeFunc r)) <$> selectList filters []
serverSyncProcessorAddItem = insert . makeFunc
serverSyncProcessorChangeItem si st a = update si $ (serverTimeField =. st) : recordUpdates a
serverSyncProcessorDeleteItem = delete
serverProcessSyncWithCustomIdQuery ::
forall cid sid record a m.
( Ord sid,
PersistField sid,
PersistEntityBackend record ~ SqlBackend,
ToBackendKey SqlBackend record,
MonadIO m
) =>
EntityField record sid ->
SqlPersistT m sid ->
EntityField record ServerTime ->
[Filter record] ->
(record -> (sid, Timed a)) ->
(sid -> a -> record) ->
(a -> [Update record]) ->
SyncRequest cid sid a ->
SqlPersistT m (SyncResponse cid sid a)
serverProcessSyncWithCustomIdQuery
idField
uuidGen
serverTimeField
filters
unmakeFunc
makeFunc
recordUpdates =
processServerSyncCustom $
serverSyncWithCustomIdProcessor
idField
uuidGen
serverTimeField
filters
unmakeFunc
makeFunc
recordUpdates
serverSyncWithCustomIdProcessor ::
forall cid sid record a m.
( Ord sid,
PersistField sid,
PersistEntityBackend record ~ SqlBackend,
ToBackendKey SqlBackend record,
MonadIO m
) =>
EntityField record sid ->
SqlPersistT m sid ->
EntityField record ServerTime ->
[Filter record] ->
(record -> (sid, Timed a)) ->
(sid -> a -> record) ->
(a -> [Update record]) ->
ServerSyncProcessor cid sid a (SqlPersistT m)
serverSyncWithCustomIdProcessor
idField
uuidGen
serverTimeField
filters
unmakeFunc
makeFunc
recordUpdates = ServerSyncProcessor {..} :: ServerSyncProcessor cid sid a (SqlPersistT m)
where
serverSyncProcessorRead = M.fromList . map (\(Entity _ record) -> unmakeFunc record) <$> selectList filters []
serverSyncProcessorAddItem a = do
uuid <- uuidGen
insert_ $ makeFunc uuid a
pure uuid
serverSyncProcessorChangeItem si st a = updateWhere [idField ==. si] $ (serverTimeField =. st) : recordUpdates a
serverSyncProcessorDeleteItem si = deleteWhere [idField ==. si]
setupServerQuery ::
forall sid record a.
( PersistEntity record,
PersistEntityBackend record ~ SqlBackend
) =>
(sid -> Timed a -> Entity record) ->
ServerStore sid a ->
SqlPersistT IO ()
setupServerQuery func ServerStore {..} =
forM_ (M.toList serverStoreItems) $ \(sid, tt) ->
let (Entity k r) = func sid tt
in insertKey k r
serverGetStoreQuery ::
( Ord sid,
PersistEntity record,
PersistEntityBackend record ~ SqlBackend
) =>
(Entity record -> (sid, Timed a)) ->
SqlPersistT IO (ServerStore sid a)
serverGetStoreQuery func = ServerStore . M.fromList . map func <$> selectList [] []