module Erebos.Message ( DirectMessage(..), sendDirectMessage, DirectMessageAttributes(..), defaultDirectMessageAttributes, DirectMessageThreads, toThreadList, DirectMessageThread(..), threadToList, messageThreadView, watchReceivedMessages, formatMessage, ) where import Control.Monad import Control.Monad.Except import Control.Monad.Reader import Data.List import Data.Ord import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Time.Format import Data.Time.LocalTime import Erebos.Identity import Erebos.Network import Erebos.Service import Erebos.State import Erebos.Storage import Erebos.Storage.Merge data DirectMessage = DirectMessage { DirectMessage -> ComposedIdentity msgFrom :: ComposedIdentity , DirectMessage -> [Stored DirectMessage] msgPrev :: [Stored DirectMessage] , DirectMessage -> ZonedTime msgTime :: ZonedTime , DirectMessage -> Text msgText :: Text } instance Storable DirectMessage where store' :: DirectMessage -> Store store' DirectMessage msg = (forall (c :: * -> *). StorageCompleteness c => StoreRec c) -> Store storeRec ((forall (c :: * -> *). StorageCompleteness c => StoreRec c) -> Store) -> (forall (c :: * -> *). StorageCompleteness c => StoreRec c) -> Store forall a b. (a -> b) -> a -> b $ do (Stored (Signed ExtendedIdentityData) -> StoreRec c) -> [Stored (Signed ExtendedIdentityData)] -> StoreRec c forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> Stored (Signed ExtendedIdentityData) -> StoreRec c forall a (c :: * -> *). (Storable a, StorageCompleteness c) => String -> a -> StoreRec c storeRef String "from") ([Stored (Signed ExtendedIdentityData)] -> StoreRec c) -> [Stored (Signed ExtendedIdentityData)] -> StoreRec c forall a b. (a -> b) -> a -> b $ ComposedIdentity -> [Stored (Signed ExtendedIdentityData)] forall (m :: * -> *). Identity m -> m (Stored (Signed ExtendedIdentityData)) idExtDataF (ComposedIdentity -> [Stored (Signed ExtendedIdentityData)]) -> ComposedIdentity -> [Stored (Signed ExtendedIdentityData)] forall a b. (a -> b) -> a -> b $ DirectMessage -> ComposedIdentity msgFrom DirectMessage msg (Stored DirectMessage -> StoreRec c) -> [Stored DirectMessage] -> StoreRec c forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> Stored DirectMessage -> StoreRec c forall a (c :: * -> *). (Storable a, StorageCompleteness c) => String -> a -> StoreRec c storeRef String "PREV") ([Stored DirectMessage] -> StoreRec c) -> [Stored DirectMessage] -> StoreRec c forall a b. (a -> b) -> a -> b $ DirectMessage -> [Stored DirectMessage] msgPrev DirectMessage msg String -> ZonedTime -> StoreRec c forall a (c :: * -> *). StorableDate a => String -> a -> StoreRec c storeDate String "time" (ZonedTime -> StoreRec c) -> ZonedTime -> StoreRec c forall a b. (a -> b) -> a -> b $ DirectMessage -> ZonedTime msgTime DirectMessage msg String -> Text -> StoreRec c forall a (c :: * -> *). StorableText a => String -> a -> StoreRec c storeText String "text" (Text -> StoreRec c) -> Text -> StoreRec c forall a b. (a -> b) -> a -> b $ DirectMessage -> Text msgText DirectMessage msg load' :: Load DirectMessage load' = LoadRec DirectMessage -> Load DirectMessage forall a. LoadRec a -> Load a loadRec (LoadRec DirectMessage -> Load DirectMessage) -> LoadRec DirectMessage -> Load DirectMessage forall a b. (a -> b) -> a -> b $ ComposedIdentity -> [Stored DirectMessage] -> ZonedTime -> Text -> DirectMessage DirectMessage (ComposedIdentity -> [Stored DirectMessage] -> ZonedTime -> Text -> DirectMessage) -> LoadRec ComposedIdentity -> LoadRec ([Stored DirectMessage] -> ZonedTime -> Text -> DirectMessage) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> LoadRec ComposedIdentity loadIdentity String "from" LoadRec ([Stored DirectMessage] -> ZonedTime -> Text -> DirectMessage) -> LoadRec [Stored DirectMessage] -> LoadRec (ZonedTime -> Text -> DirectMessage) forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> String -> LoadRec [Stored DirectMessage] forall a. Storable a => String -> LoadRec [a] loadRefs String "PREV" LoadRec (ZonedTime -> Text -> DirectMessage) -> LoadRec ZonedTime -> LoadRec (Text -> DirectMessage) forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> String -> LoadRec ZonedTime forall a. StorableDate a => String -> LoadRec a loadDate String "time" LoadRec (Text -> DirectMessage) -> LoadRec Text -> LoadRec DirectMessage forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> String -> LoadRec Text forall a. StorableText a => String -> LoadRec a loadText String "text" data DirectMessageAttributes = DirectMessageAttributes { DirectMessageAttributes -> ServiceHandler DirectMessage () dmOwnerMismatch :: ServiceHandler DirectMessage () } defaultDirectMessageAttributes :: DirectMessageAttributes defaultDirectMessageAttributes :: DirectMessageAttributes defaultDirectMessageAttributes = DirectMessageAttributes { dmOwnerMismatch :: ServiceHandler DirectMessage () dmOwnerMismatch = String -> ServiceHandler DirectMessage () forall s. String -> ServiceHandler s () svcPrint String "Owner mismatch" } instance Service DirectMessage where serviceID :: forall (proxy :: * -> *). proxy DirectMessage -> ServiceID serviceID proxy DirectMessage _ = String -> ServiceID mkServiceID String "c702076c-4928-4415-8b6b-3e839eafcb0d" type ServiceAttributes DirectMessage = DirectMessageAttributes defaultServiceAttributes :: forall (proxy :: * -> *). proxy DirectMessage -> ServiceAttributes DirectMessage defaultServiceAttributes proxy DirectMessage _ = ServiceAttributes DirectMessage DirectMessageAttributes defaultDirectMessageAttributes serviceHandler :: Stored DirectMessage -> ServiceHandler DirectMessage () serviceHandler Stored DirectMessage smsg = do let msg :: DirectMessage msg = Stored DirectMessage -> DirectMessage forall a. Stored a -> a fromStored Stored DirectMessage smsg ComposedIdentity powner <- (ServiceInput DirectMessage -> ComposedIdentity) -> ServiceHandler DirectMessage ComposedIdentity forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks ((ServiceInput DirectMessage -> ComposedIdentity) -> ServiceHandler DirectMessage ComposedIdentity) -> (ServiceInput DirectMessage -> ComposedIdentity) -> ServiceHandler DirectMessage ComposedIdentity forall a b. (a -> b) -> a -> b $ Identity Identity -> ComposedIdentity forall (m :: * -> *). (Foldable m, Applicative m) => Identity m -> ComposedIdentity finalOwner (Identity Identity -> ComposedIdentity) -> (ServiceInput DirectMessage -> Identity Identity) -> ServiceInput DirectMessage -> ComposedIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c . ServiceInput DirectMessage -> Identity Identity forall s. ServiceInput s -> Identity Identity svcPeerIdentity Stored LocalState erb <- ServiceHandler DirectMessage (Stored LocalState) forall s. ServiceHandler s (Stored LocalState) svcGetLocal Storage st <- ServiceHandler DirectMessage Storage forall (m :: * -> *). MonadStorage m => m Storage getStorage let DirectMessageThreads [Stored MessageState] prev [DirectMessageThread] _ = [Stored SharedState] -> DirectMessageThreads forall a. SharedType a => [Stored SharedState] -> a lookupSharedValue ([Stored SharedState] -> DirectMessageThreads) -> [Stored SharedState] -> DirectMessageThreads forall a b. (a -> b) -> a -> b $ LocalState -> [Stored SharedState] lsShared (LocalState -> [Stored SharedState]) -> LocalState -> [Stored SharedState] forall a b. (a -> b) -> a -> b $ Stored LocalState -> LocalState forall a. Stored a -> a fromStored Stored LocalState erb sent :: [Stored DirectMessage] sent = ComposedIdentity -> (MessageState -> [Stored DirectMessage]) -> [Stored MessageState] -> [Stored DirectMessage] forall (m :: * -> *) a. Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty ComposedIdentity powner MessageState -> [Stored DirectMessage] msSent [Stored MessageState] prev received :: [Stored DirectMessage] received = ComposedIdentity -> (MessageState -> [Stored DirectMessage]) -> [Stored MessageState] -> [Stored DirectMessage] forall (m :: * -> *) a. Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty ComposedIdentity powner MessageState -> [Stored DirectMessage] msReceived [Stored MessageState] prev received' :: [Stored DirectMessage] received' = [Stored DirectMessage] -> [Stored DirectMessage] forall a. Storable a => [Stored a] -> [Stored a] filterAncestors ([Stored DirectMessage] -> [Stored DirectMessage]) -> [Stored DirectMessage] -> [Stored DirectMessage] forall a b. (a -> b) -> a -> b $ Stored DirectMessage smsg Stored DirectMessage -> [Stored DirectMessage] -> [Stored DirectMessage] forall a. a -> [a] -> [a] : [Stored DirectMessage] received if ComposedIdentity powner ComposedIdentity -> ComposedIdentity -> Bool forall (m :: * -> *) (m' :: * -> *). (Foldable m, Foldable m') => Identity m -> Identity m' -> Bool `sameIdentity` DirectMessage -> ComposedIdentity msgFrom DirectMessage msg Bool -> Bool -> Bool || [Stored DirectMessage] -> [Stored DirectMessage] forall a. Storable a => [Stored a] -> [Stored a] filterAncestors [Stored DirectMessage] sent [Stored DirectMessage] -> [Stored DirectMessage] -> Bool forall a. Eq a => a -> a -> Bool == [Stored DirectMessage] -> [Stored DirectMessage] forall a. Storable a => [Stored a] -> [Stored a] filterAncestors (Stored DirectMessage smsg Stored DirectMessage -> [Stored DirectMessage] -> [Stored DirectMessage] forall a. a -> [a] -> [a] : [Stored DirectMessage] sent) then do Bool -> ServiceHandler DirectMessage () -> ServiceHandler DirectMessage () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when ([Stored DirectMessage] received' [Stored DirectMessage] -> [Stored DirectMessage] -> Bool forall a. Eq a => a -> a -> Bool /= [Stored DirectMessage] received) (ServiceHandler DirectMessage () -> ServiceHandler DirectMessage ()) -> ServiceHandler DirectMessage () -> ServiceHandler DirectMessage () forall a b. (a -> b) -> a -> b $ do Stored MessageState next <- Storage -> MessageState -> ServiceHandler DirectMessage (Stored MessageState) forall (m :: * -> *) a. (MonadIO m, Storable a) => Storage -> a -> m (Stored a) wrappedStore Storage st (MessageState -> ServiceHandler DirectMessage (Stored MessageState)) -> MessageState -> ServiceHandler DirectMessage (Stored MessageState) forall a b. (a -> b) -> a -> b $ MessageState { msPrev :: [Stored MessageState] msPrev = [Stored MessageState] prev , msPeer :: ComposedIdentity msPeer = ComposedIdentity powner , msReady :: [Stored DirectMessage] msReady = [] , msSent :: [Stored DirectMessage] msSent = [] , msReceived :: [Stored DirectMessage] msReceived = [Stored DirectMessage] received' , msSeen :: [Stored DirectMessage] msSeen = [] } let threads :: DirectMessageThreads threads = [Stored MessageState] -> [DirectMessageThread] -> DirectMessageThreads DirectMessageThreads [Stored MessageState next] ([Stored MessageState] -> [DirectMessageThread] messageThreadView [Stored MessageState next]) Stored SharedState shared <- Storage -> DirectMessageThreads -> [Stored SharedState] -> ServiceHandler DirectMessage (Stored SharedState) forall a (m :: * -> *). (MonadIO m, SharedType a) => Storage -> a -> [Stored SharedState] -> m (Stored SharedState) makeSharedStateUpdate Storage st DirectMessageThreads threads (LocalState -> [Stored SharedState] lsShared (LocalState -> [Stored SharedState]) -> LocalState -> [Stored SharedState] forall a b. (a -> b) -> a -> b $ Stored LocalState -> LocalState forall a. Stored a -> a fromStored Stored LocalState erb) Stored LocalState -> ServiceHandler DirectMessage () forall s. Stored LocalState -> ServiceHandler s () svcSetLocal (Stored LocalState -> ServiceHandler DirectMessage ()) -> ServiceHandler DirectMessage (Stored LocalState) -> ServiceHandler DirectMessage () forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Storage -> LocalState -> ServiceHandler DirectMessage (Stored LocalState) forall (m :: * -> *) a. (MonadIO m, Storable a) => Storage -> a -> m (Stored a) wrappedStore Storage st (Stored LocalState -> LocalState forall a. Stored a -> a fromStored Stored LocalState erb) { lsShared = [shared] } Bool -> ServiceHandler DirectMessage () -> ServiceHandler DirectMessage () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (ComposedIdentity powner ComposedIdentity -> ComposedIdentity -> Bool forall (m :: * -> *) (m' :: * -> *). (Foldable m, Foldable m') => Identity m -> Identity m' -> Bool `sameIdentity` DirectMessage -> ComposedIdentity msgFrom DirectMessage msg) (ServiceHandler DirectMessage () -> ServiceHandler DirectMessage ()) -> ServiceHandler DirectMessage () -> ServiceHandler DirectMessage () forall a b. (a -> b) -> a -> b $ do Stored DirectMessage -> ServiceHandler DirectMessage () forall s. Service s => Stored s -> ServiceHandler s () replyStoredRef Stored DirectMessage smsg else ServiceHandler DirectMessage (ServiceHandler DirectMessage ()) -> ServiceHandler DirectMessage () forall (m :: * -> *) a. Monad m => m (m a) -> m a join (ServiceHandler DirectMessage (ServiceHandler DirectMessage ()) -> ServiceHandler DirectMessage ()) -> ServiceHandler DirectMessage (ServiceHandler DirectMessage ()) -> ServiceHandler DirectMessage () forall a b. (a -> b) -> a -> b $ (ServiceInput DirectMessage -> ServiceHandler DirectMessage ()) -> ServiceHandler DirectMessage (ServiceHandler DirectMessage ()) forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks ((ServiceInput DirectMessage -> ServiceHandler DirectMessage ()) -> ServiceHandler DirectMessage (ServiceHandler DirectMessage ())) -> (ServiceInput DirectMessage -> ServiceHandler DirectMessage ()) -> ServiceHandler DirectMessage (ServiceHandler DirectMessage ()) forall a b. (a -> b) -> a -> b $ DirectMessageAttributes -> ServiceHandler DirectMessage () dmOwnerMismatch (DirectMessageAttributes -> ServiceHandler DirectMessage ()) -> (ServiceInput DirectMessage -> DirectMessageAttributes) -> ServiceInput DirectMessage -> ServiceHandler DirectMessage () forall b c a. (b -> c) -> (a -> b) -> a -> c . ServiceInput DirectMessage -> ServiceAttributes DirectMessage ServiceInput DirectMessage -> DirectMessageAttributes forall s. ServiceInput s -> ServiceAttributes s svcAttributes serviceNewPeer :: ServiceHandler DirectMessage () serviceNewPeer = DirectMessageThreads -> ServiceHandler DirectMessage () syncDirectMessageToPeer (DirectMessageThreads -> ServiceHandler DirectMessage ()) -> (Stored LocalState -> DirectMessageThreads) -> Stored LocalState -> ServiceHandler DirectMessage () forall b c a. (b -> c) -> (a -> b) -> a -> c . [Stored SharedState] -> DirectMessageThreads forall a. SharedType a => [Stored SharedState] -> a lookupSharedValue ([Stored SharedState] -> DirectMessageThreads) -> (Stored LocalState -> [Stored SharedState]) -> Stored LocalState -> DirectMessageThreads forall b c a. (b -> c) -> (a -> b) -> a -> c . LocalState -> [Stored SharedState] lsShared (LocalState -> [Stored SharedState]) -> (Stored LocalState -> LocalState) -> Stored LocalState -> [Stored SharedState] forall b c a. (b -> c) -> (a -> b) -> a -> c . Stored LocalState -> LocalState forall a. Stored a -> a fromStored (Stored LocalState -> ServiceHandler DirectMessage ()) -> ServiceHandler DirectMessage (Stored LocalState) -> ServiceHandler DirectMessage () forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< ServiceHandler DirectMessage (Stored LocalState) forall s. ServiceHandler s (Stored LocalState) svcGetLocal serviceStorageWatchers :: forall (proxy :: * -> *). proxy DirectMessage -> [SomeStorageWatcher DirectMessage] serviceStorageWatchers proxy DirectMessage _ = (SomeStorageWatcher DirectMessage -> [SomeStorageWatcher DirectMessage] -> [SomeStorageWatcher DirectMessage] forall a. a -> [a] -> [a] :[]) (SomeStorageWatcher DirectMessage -> [SomeStorageWatcher DirectMessage]) -> SomeStorageWatcher DirectMessage -> [SomeStorageWatcher DirectMessage] forall a b. (a -> b) -> a -> b $ (Stored LocalState -> DirectMessageThreads) -> (DirectMessageThreads -> ServiceHandler DirectMessage ()) -> SomeStorageWatcher DirectMessage forall s a. Eq a => (Stored LocalState -> a) -> (a -> ServiceHandler s ()) -> SomeStorageWatcher s SomeStorageWatcher ([Stored SharedState] -> DirectMessageThreads forall a. SharedType a => [Stored SharedState] -> a lookupSharedValue ([Stored SharedState] -> DirectMessageThreads) -> (Stored LocalState -> [Stored SharedState]) -> Stored LocalState -> DirectMessageThreads forall b c a. (b -> c) -> (a -> b) -> a -> c . LocalState -> [Stored SharedState] lsShared (LocalState -> [Stored SharedState]) -> (Stored LocalState -> LocalState) -> Stored LocalState -> [Stored SharedState] forall b c a. (b -> c) -> (a -> b) -> a -> c . Stored LocalState -> LocalState forall a. Stored a -> a fromStored) DirectMessageThreads -> ServiceHandler DirectMessage () syncDirectMessageToPeer data MessageState = MessageState { MessageState -> [Stored MessageState] msPrev :: [Stored MessageState] , MessageState -> ComposedIdentity msPeer :: ComposedIdentity , MessageState -> [Stored DirectMessage] msReady :: [Stored DirectMessage] , MessageState -> [Stored DirectMessage] msSent :: [Stored DirectMessage] , MessageState -> [Stored DirectMessage] msReceived :: [Stored DirectMessage] , MessageState -> [Stored DirectMessage] msSeen :: [Stored DirectMessage] } data DirectMessageThreads = DirectMessageThreads [Stored MessageState] [DirectMessageThread] instance Eq DirectMessageThreads where DirectMessageThreads [Stored MessageState] mss [DirectMessageThread] _ == :: DirectMessageThreads -> DirectMessageThreads -> Bool == DirectMessageThreads [Stored MessageState] mss' [DirectMessageThread] _ = [Stored MessageState] mss [Stored MessageState] -> [Stored MessageState] -> Bool forall a. Eq a => a -> a -> Bool == [Stored MessageState] mss' toThreadList :: DirectMessageThreads -> [DirectMessageThread] toThreadList :: DirectMessageThreads -> [DirectMessageThread] toThreadList (DirectMessageThreads [Stored MessageState] _ [DirectMessageThread] threads) = [DirectMessageThread] threads instance Storable MessageState where store' :: MessageState -> Store store' MessageState {[Stored MessageState] [Stored DirectMessage] ComposedIdentity msSent :: MessageState -> [Stored DirectMessage] msReceived :: MessageState -> [Stored DirectMessage] msPrev :: MessageState -> [Stored MessageState] msPeer :: MessageState -> ComposedIdentity msReady :: MessageState -> [Stored DirectMessage] msSeen :: MessageState -> [Stored DirectMessage] msPrev :: [Stored MessageState] msPeer :: ComposedIdentity msReady :: [Stored DirectMessage] msSent :: [Stored DirectMessage] msReceived :: [Stored DirectMessage] msSeen :: [Stored DirectMessage] ..} = (forall (c :: * -> *). StorageCompleteness c => StoreRec c) -> Store storeRec ((forall (c :: * -> *). StorageCompleteness c => StoreRec c) -> Store) -> (forall (c :: * -> *). StorageCompleteness c => StoreRec c) -> Store forall a b. (a -> b) -> a -> b $ do (Stored MessageState -> StoreRec c) -> [Stored MessageState] -> StoreRec c forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> Stored MessageState -> StoreRec c forall a (c :: * -> *). (Storable a, StorageCompleteness c) => String -> a -> StoreRec c storeRef String "PREV") [Stored MessageState] msPrev (Stored (Signed IdentityData) -> StoreRec c) -> [Stored (Signed IdentityData)] -> StoreRec c forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> Stored (Signed IdentityData) -> StoreRec c forall a (c :: * -> *). (Storable a, StorageCompleteness c) => String -> a -> StoreRec c storeRef String "peer") ([Stored (Signed IdentityData)] -> StoreRec c) -> [Stored (Signed IdentityData)] -> StoreRec c forall a b. (a -> b) -> a -> b $ ComposedIdentity -> [Stored (Signed IdentityData)] forall (m :: * -> *). Identity m -> m (Stored (Signed IdentityData)) idDataF ComposedIdentity msPeer (Stored DirectMessage -> StoreRec c) -> [Stored DirectMessage] -> StoreRec c forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> Stored DirectMessage -> StoreRec c forall a (c :: * -> *). (Storable a, StorageCompleteness c) => String -> a -> StoreRec c storeRef String "ready") [Stored DirectMessage] msReady (Stored DirectMessage -> StoreRec c) -> [Stored DirectMessage] -> StoreRec c forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> Stored DirectMessage -> StoreRec c forall a (c :: * -> *). (Storable a, StorageCompleteness c) => String -> a -> StoreRec c storeRef String "sent") [Stored DirectMessage] msSent (Stored DirectMessage -> StoreRec c) -> [Stored DirectMessage] -> StoreRec c forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> Stored DirectMessage -> StoreRec c forall a (c :: * -> *). (Storable a, StorageCompleteness c) => String -> a -> StoreRec c storeRef String "received") [Stored DirectMessage] msReceived (Stored DirectMessage -> StoreRec c) -> [Stored DirectMessage] -> StoreRec c forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> Stored DirectMessage -> StoreRec c forall a (c :: * -> *). (Storable a, StorageCompleteness c) => String -> a -> StoreRec c storeRef String "seen") [Stored DirectMessage] msSeen load' :: Load MessageState load' = LoadRec MessageState -> Load MessageState forall a. LoadRec a -> Load a loadRec (LoadRec MessageState -> Load MessageState) -> LoadRec MessageState -> Load MessageState forall a b. (a -> b) -> a -> b $ do [Stored MessageState] msPrev <- String -> LoadRec [Stored MessageState] forall a. Storable a => String -> LoadRec [a] loadRefs String "PREV" ComposedIdentity msPeer <- String -> LoadRec ComposedIdentity loadIdentity String "peer" [Stored DirectMessage] msReady <- String -> LoadRec [Stored DirectMessage] forall a. Storable a => String -> LoadRec [a] loadRefs String "ready" [Stored DirectMessage] msSent <- String -> LoadRec [Stored DirectMessage] forall a. Storable a => String -> LoadRec [a] loadRefs String "sent" [Stored DirectMessage] msReceived <- String -> LoadRec [Stored DirectMessage] forall a. Storable a => String -> LoadRec [a] loadRefs String "received" [Stored DirectMessage] msSeen <- String -> LoadRec [Stored DirectMessage] forall a. Storable a => String -> LoadRec [a] loadRefs String "seen" MessageState -> LoadRec MessageState forall a. a -> LoadRec a forall (m :: * -> *) a. Monad m => a -> m a return MessageState {[Stored MessageState] [Stored DirectMessage] ComposedIdentity msSent :: [Stored DirectMessage] msReceived :: [Stored DirectMessage] msPrev :: [Stored MessageState] msPeer :: ComposedIdentity msReady :: [Stored DirectMessage] msSeen :: [Stored DirectMessage] msPrev :: [Stored MessageState] msPeer :: ComposedIdentity msReady :: [Stored DirectMessage] msSent :: [Stored DirectMessage] msReceived :: [Stored DirectMessage] msSeen :: [Stored DirectMessage] ..} instance Mergeable DirectMessageThreads where type Component DirectMessageThreads = MessageState mergeSorted :: [Stored (Component DirectMessageThreads)] -> DirectMessageThreads mergeSorted [Stored (Component DirectMessageThreads)] mss = [Stored MessageState] -> [DirectMessageThread] -> DirectMessageThreads DirectMessageThreads [Stored (Component DirectMessageThreads)] [Stored MessageState] mss ([Stored MessageState] -> [DirectMessageThread] messageThreadView [Stored (Component DirectMessageThreads)] [Stored MessageState] mss) toComponents :: DirectMessageThreads -> [Stored (Component DirectMessageThreads)] toComponents (DirectMessageThreads [Stored MessageState] mss [DirectMessageThread] _) = [Stored (Component DirectMessageThreads)] [Stored MessageState] mss instance SharedType DirectMessageThreads where sharedTypeID :: forall (proxy :: * -> *). proxy DirectMessageThreads -> SharedTypeID sharedTypeID proxy DirectMessageThreads _ = String -> SharedTypeID mkSharedTypeID String "ee793681-5976-466a-b0f0-4e1907d3fade" findMsgProperty :: Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty :: forall (m :: * -> *) a. Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty Identity m pid MessageState -> [a] sel [Stored MessageState] mss = [[a]] -> [a] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat ([[a]] -> [a]) -> [[a]] -> [a] forall a b. (a -> b) -> a -> b $ ((MessageState -> Maybe [a]) -> [Stored MessageState] -> [[a]]) -> [Stored MessageState] -> (MessageState -> Maybe [a]) -> [[a]] forall a b c. (a -> b -> c) -> b -> a -> c flip (MessageState -> Maybe [a]) -> [Stored MessageState] -> [[a]] forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> [b] findProperty [Stored MessageState] mss ((MessageState -> Maybe [a]) -> [[a]]) -> (MessageState -> Maybe [a]) -> [[a]] forall a b. (a -> b) -> a -> b $ \MessageState x -> do Bool -> Maybe () forall (f :: * -> *). Alternative f => Bool -> f () guard (Bool -> Maybe ()) -> Bool -> Maybe () forall a b. (a -> b) -> a -> b $ MessageState -> ComposedIdentity msPeer MessageState x ComposedIdentity -> Identity m -> Bool forall (m :: * -> *) (m' :: * -> *). (Foldable m, Foldable m') => Identity m -> Identity m' -> Bool `sameIdentity` Identity m pid Bool -> Maybe () forall (f :: * -> *). Alternative f => Bool -> f () guard (Bool -> Maybe ()) -> Bool -> Maybe () forall a b. (a -> b) -> a -> b $ Bool -> Bool not (Bool -> Bool) -> Bool -> Bool forall a b. (a -> b) -> a -> b $ [a] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null ([a] -> Bool) -> [a] -> Bool forall a b. (a -> b) -> a -> b $ MessageState -> [a] sel MessageState x [a] -> Maybe [a] forall a. a -> Maybe a forall (m :: * -> *) a. Monad m => a -> m a return ([a] -> Maybe [a]) -> [a] -> Maybe [a] forall a b. (a -> b) -> a -> b $ MessageState -> [a] sel MessageState x sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m) => Identity f -> Text -> m (Stored DirectMessage) sendDirectMessage :: forall (f :: * -> *) (m :: * -> *). (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m) => Identity f -> Text -> m (Stored DirectMessage) sendDirectMessage Identity f pid Text text = (Stored LocalState -> m (Stored LocalState, Stored DirectMessage)) -> m (Stored DirectMessage) forall b. (Stored LocalState -> m (Stored LocalState, b)) -> m b forall a (m :: * -> *) b. MonadHead a m => (Stored a -> m (Stored a, b)) -> m b updateLocalHead ((Stored LocalState -> m (Stored LocalState, Stored DirectMessage)) -> m (Stored DirectMessage)) -> (Stored LocalState -> m (Stored LocalState, Stored DirectMessage)) -> m (Stored DirectMessage) forall a b. (a -> b) -> a -> b $ \Stored LocalState ls -> do let self :: Identity Identity self = LocalState -> Identity Identity localIdentity (LocalState -> Identity Identity) -> LocalState -> Identity Identity forall a b. (a -> b) -> a -> b $ Stored LocalState -> LocalState forall a. Stored a -> a fromStored Stored LocalState ls powner :: ComposedIdentity powner = Identity f -> ComposedIdentity forall (m :: * -> *). (Foldable m, Applicative m) => Identity m -> ComposedIdentity finalOwner Identity f pid ((DirectMessageThreads -> m (DirectMessageThreads, Stored DirectMessage)) -> Stored LocalState -> m (Stored LocalState, Stored DirectMessage)) -> Stored LocalState -> (DirectMessageThreads -> m (DirectMessageThreads, Stored DirectMessage)) -> m (Stored LocalState, Stored DirectMessage) forall a b c. (a -> b -> c) -> b -> a -> c flip (DirectMessageThreads -> m (DirectMessageThreads, Stored DirectMessage)) -> Stored LocalState -> m (Stored LocalState, Stored DirectMessage) forall a b (m :: * -> *). (SharedType a, MonadHead LocalState m) => (a -> m (a, b)) -> Stored LocalState -> m (Stored LocalState, b) updateSharedState Stored LocalState ls ((DirectMessageThreads -> m (DirectMessageThreads, Stored DirectMessage)) -> m (Stored LocalState, Stored DirectMessage)) -> (DirectMessageThreads -> m (DirectMessageThreads, Stored DirectMessage)) -> m (Stored LocalState, Stored DirectMessage) forall a b. (a -> b) -> a -> b $ \(DirectMessageThreads [Stored MessageState] prev [DirectMessageThread] _) -> do let ready :: [Stored DirectMessage] ready = ComposedIdentity -> (MessageState -> [Stored DirectMessage]) -> [Stored MessageState] -> [Stored DirectMessage] forall (m :: * -> *) a. Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty ComposedIdentity powner MessageState -> [Stored DirectMessage] msReady [Stored MessageState] prev received :: [Stored DirectMessage] received = ComposedIdentity -> (MessageState -> [Stored DirectMessage]) -> [Stored MessageState] -> [Stored DirectMessage] forall (m :: * -> *) a. Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty ComposedIdentity powner MessageState -> [Stored DirectMessage] msReceived [Stored MessageState] prev ZonedTime time <- IO ZonedTime -> m ZonedTime forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO IO ZonedTime getZonedTime Stored DirectMessage smsg <- DirectMessage -> m (Stored DirectMessage) forall a. Storable a => a -> m (Stored a) forall (m :: * -> *) a. (MonadStorage m, Storable a) => a -> m (Stored a) mstore DirectMessage { msgFrom :: ComposedIdentity msgFrom = ComposedIdentity -> ComposedIdentity forall (m :: * -> *). Identity m -> ComposedIdentity toComposedIdentity (ComposedIdentity -> ComposedIdentity) -> ComposedIdentity -> ComposedIdentity forall a b. (a -> b) -> a -> b $ Identity Identity -> ComposedIdentity forall (m :: * -> *). (Foldable m, Applicative m) => Identity m -> ComposedIdentity finalOwner Identity Identity self , msgPrev :: [Stored DirectMessage] msgPrev = [Stored DirectMessage] -> [Stored DirectMessage] forall a. Storable a => [Stored a] -> [Stored a] filterAncestors ([Stored DirectMessage] -> [Stored DirectMessage]) -> [Stored DirectMessage] -> [Stored DirectMessage] forall a b. (a -> b) -> a -> b $ [Stored DirectMessage] ready [Stored DirectMessage] -> [Stored DirectMessage] -> [Stored DirectMessage] forall a. [a] -> [a] -> [a] ++ [Stored DirectMessage] received , msgTime :: ZonedTime msgTime = ZonedTime time , msgText :: Text msgText = Text text } Stored MessageState next <- MessageState -> m (Stored MessageState) forall a. Storable a => a -> m (Stored a) forall (m :: * -> *) a. (MonadStorage m, Storable a) => a -> m (Stored a) mstore MessageState { msPrev :: [Stored MessageState] msPrev = [Stored MessageState] prev , msPeer :: ComposedIdentity msPeer = ComposedIdentity powner , msReady :: [Stored DirectMessage] msReady = [Stored DirectMessage smsg] , msSent :: [Stored DirectMessage] msSent = [] , msReceived :: [Stored DirectMessage] msReceived = [] , msSeen :: [Stored DirectMessage] msSeen = [] } (DirectMessageThreads, Stored DirectMessage) -> m (DirectMessageThreads, Stored DirectMessage) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return ([Stored MessageState] -> [DirectMessageThread] -> DirectMessageThreads DirectMessageThreads [Stored MessageState next] ([Stored MessageState] -> [DirectMessageThread] messageThreadView [Stored MessageState next]), Stored DirectMessage smsg) syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage () syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage () syncDirectMessageToPeer (DirectMessageThreads [Stored MessageState] mss [DirectMessageThread] _) = do ComposedIdentity pid <- Identity Identity -> ComposedIdentity forall (m :: * -> *). (Foldable m, Applicative m) => Identity m -> ComposedIdentity finalOwner (Identity Identity -> ComposedIdentity) -> ServiceHandler DirectMessage (Identity Identity) -> ServiceHandler DirectMessage ComposedIdentity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (ServiceInput DirectMessage -> Identity Identity) -> ServiceHandler DirectMessage (Identity Identity) forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks ServiceInput DirectMessage -> Identity Identity forall s. ServiceInput s -> Identity Identity svcPeerIdentity Peer peer <- (ServiceInput DirectMessage -> Peer) -> ServiceHandler DirectMessage Peer forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks ServiceInput DirectMessage -> Peer forall s. ServiceInput s -> Peer svcPeer let thread :: DirectMessageThread thread = ComposedIdentity -> [Stored MessageState] -> DirectMessageThread messageThreadFor ComposedIdentity pid [Stored MessageState] mss (Stored DirectMessage -> ServiceHandler DirectMessage ()) -> [Stored DirectMessage] -> ServiceHandler DirectMessage () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (Peer -> Stored DirectMessage -> ServiceHandler DirectMessage () forall s (m :: * -> *). (Service s, MonadIO m) => Peer -> Stored s -> m () sendToPeerStored Peer peer) ([Stored DirectMessage] -> ServiceHandler DirectMessage ()) -> [Stored DirectMessage] -> ServiceHandler DirectMessage () forall a b. (a -> b) -> a -> b $ DirectMessageThread -> [Stored DirectMessage] msgHead DirectMessageThread thread (Stored LocalState -> ServiceHandler DirectMessage (Stored LocalState)) -> ServiceHandler DirectMessage () forall a (m :: * -> *). MonadHead a m => (Stored a -> m (Stored a)) -> m () updateLocalHead_ ((Stored LocalState -> ServiceHandler DirectMessage (Stored LocalState)) -> ServiceHandler DirectMessage ()) -> (Stored LocalState -> ServiceHandler DirectMessage (Stored LocalState)) -> ServiceHandler DirectMessage () forall a b. (a -> b) -> a -> b $ \Stored LocalState ls -> do let powner :: ComposedIdentity powner = ComposedIdentity -> ComposedIdentity forall (m :: * -> *). (Foldable m, Applicative m) => Identity m -> ComposedIdentity finalOwner ComposedIdentity pid ((DirectMessageThreads -> ServiceHandler DirectMessage DirectMessageThreads) -> Stored LocalState -> ServiceHandler DirectMessage (Stored LocalState)) -> Stored LocalState -> (DirectMessageThreads -> ServiceHandler DirectMessage DirectMessageThreads) -> ServiceHandler DirectMessage (Stored LocalState) forall a b c. (a -> b -> c) -> b -> a -> c flip (DirectMessageThreads -> ServiceHandler DirectMessage DirectMessageThreads) -> Stored LocalState -> ServiceHandler DirectMessage (Stored LocalState) forall a (m :: * -> *). (SharedType a, MonadHead LocalState m) => (a -> m a) -> Stored LocalState -> m (Stored LocalState) updateSharedState_ Stored LocalState ls ((DirectMessageThreads -> ServiceHandler DirectMessage DirectMessageThreads) -> ServiceHandler DirectMessage (Stored LocalState)) -> (DirectMessageThreads -> ServiceHandler DirectMessage DirectMessageThreads) -> ServiceHandler DirectMessage (Stored LocalState) forall a b. (a -> b) -> a -> b $ \unchanged :: DirectMessageThreads unchanged@(DirectMessageThreads [Stored MessageState] prev [DirectMessageThread] _) -> do let ready :: [Stored DirectMessage] ready = ComposedIdentity -> (MessageState -> [Stored DirectMessage]) -> [Stored MessageState] -> [Stored DirectMessage] forall (m :: * -> *) a. Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty ComposedIdentity powner MessageState -> [Stored DirectMessage] msReady [Stored MessageState] prev sent :: [Stored DirectMessage] sent = ComposedIdentity -> (MessageState -> [Stored DirectMessage]) -> [Stored MessageState] -> [Stored DirectMessage] forall (m :: * -> *) a. Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty ComposedIdentity powner MessageState -> [Stored DirectMessage] msSent [Stored MessageState] prev sent' :: [Stored DirectMessage] sent' = [Stored DirectMessage] -> [Stored DirectMessage] forall a. Storable a => [Stored a] -> [Stored a] filterAncestors ([Stored DirectMessage] ready [Stored DirectMessage] -> [Stored DirectMessage] -> [Stored DirectMessage] forall a. [a] -> [a] -> [a] ++ [Stored DirectMessage] sent) if [Stored DirectMessage] sent' [Stored DirectMessage] -> [Stored DirectMessage] -> Bool forall a. Eq a => a -> a -> Bool /= [Stored DirectMessage] sent then do Stored MessageState next <- MessageState -> ServiceHandler DirectMessage (Stored MessageState) forall a. Storable a => a -> ServiceHandler DirectMessage (Stored a) forall (m :: * -> *) a. (MonadStorage m, Storable a) => a -> m (Stored a) mstore MessageState { msPrev :: [Stored MessageState] msPrev = [Stored MessageState] prev , msPeer :: ComposedIdentity msPeer = ComposedIdentity powner , msReady :: [Stored DirectMessage] msReady = [] , msSent :: [Stored DirectMessage] msSent = [Stored DirectMessage] sent' , msReceived :: [Stored DirectMessage] msReceived = [] , msSeen :: [Stored DirectMessage] msSeen = [] } DirectMessageThreads -> ServiceHandler DirectMessage DirectMessageThreads forall a. a -> ServiceHandler DirectMessage a forall (m :: * -> *) a. Monad m => a -> m a return (DirectMessageThreads -> ServiceHandler DirectMessage DirectMessageThreads) -> DirectMessageThreads -> ServiceHandler DirectMessage DirectMessageThreads forall a b. (a -> b) -> a -> b $ [Stored MessageState] -> [DirectMessageThread] -> DirectMessageThreads DirectMessageThreads [Stored MessageState next] ([Stored MessageState] -> [DirectMessageThread] messageThreadView [Stored MessageState next]) else do DirectMessageThreads -> ServiceHandler DirectMessage DirectMessageThreads forall a. a -> ServiceHandler DirectMessage a forall (m :: * -> *) a. Monad m => a -> m a return DirectMessageThreads unchanged data DirectMessageThread = DirectMessageThread { DirectMessageThread -> ComposedIdentity msgPeer :: ComposedIdentity , DirectMessageThread -> [Stored DirectMessage] msgHead :: [Stored DirectMessage] , DirectMessageThread -> [Stored DirectMessage] msgSent :: [Stored DirectMessage] , DirectMessageThread -> [Stored DirectMessage] msgSeen :: [Stored DirectMessage] } threadToList :: DirectMessageThread -> [DirectMessage] threadToList :: DirectMessageThread -> [DirectMessage] threadToList DirectMessageThread thread = Set (Stored DirectMessage) -> [Stored DirectMessage] -> [DirectMessage] helper Set (Stored DirectMessage) forall a. Set a S.empty ([Stored DirectMessage] -> [DirectMessage]) -> [Stored DirectMessage] -> [DirectMessage] forall a b. (a -> b) -> a -> b $ DirectMessageThread -> [Stored DirectMessage] msgHead DirectMessageThread thread where helper :: Set (Stored DirectMessage) -> [Stored DirectMessage] -> [DirectMessage] helper Set (Stored DirectMessage) seen [Stored DirectMessage] msgs | Stored DirectMessage msg : [Stored DirectMessage] msgs' <- (Stored DirectMessage -> Bool) -> [Stored DirectMessage] -> [Stored DirectMessage] forall a. (a -> Bool) -> [a] -> [a] filter (Stored DirectMessage -> Set (Stored DirectMessage) -> Bool forall a. Ord a => a -> Set a -> Bool `S.notMember` Set (Stored DirectMessage) seen) ([Stored DirectMessage] -> [Stored DirectMessage]) -> [Stored DirectMessage] -> [Stored DirectMessage] forall a b. (a -> b) -> a -> b $ [Stored DirectMessage] -> [Stored DirectMessage] forall a. [a] -> [a] reverse ([Stored DirectMessage] -> [Stored DirectMessage]) -> [Stored DirectMessage] -> [Stored DirectMessage] forall a b. (a -> b) -> a -> b $ (Stored DirectMessage -> Stored DirectMessage -> Ordering) -> [Stored DirectMessage] -> [Stored DirectMessage] forall a. (a -> a -> Ordering) -> [a] -> [a] sortBy ((Stored DirectMessage -> (UTCTime, Stored DirectMessage)) -> Stored DirectMessage -> Stored DirectMessage -> Ordering forall a b. Ord a => (b -> a) -> b -> b -> Ordering comparing Stored DirectMessage -> (UTCTime, Stored DirectMessage) cmpView) [Stored DirectMessage] msgs = Stored DirectMessage -> DirectMessage forall a. Stored a -> a fromStored Stored DirectMessage msg DirectMessage -> [DirectMessage] -> [DirectMessage] forall a. a -> [a] -> [a] : Set (Stored DirectMessage) -> [Stored DirectMessage] -> [DirectMessage] helper (Stored DirectMessage -> Set (Stored DirectMessage) -> Set (Stored DirectMessage) forall a. Ord a => a -> Set a -> Set a S.insert Stored DirectMessage msg Set (Stored DirectMessage) seen) ([Stored DirectMessage] msgs' [Stored DirectMessage] -> [Stored DirectMessage] -> [Stored DirectMessage] forall a. [a] -> [a] -> [a] ++ DirectMessage -> [Stored DirectMessage] msgPrev (Stored DirectMessage -> DirectMessage forall a. Stored a -> a fromStored Stored DirectMessage msg)) | Bool otherwise = [] cmpView :: Stored DirectMessage -> (UTCTime, Stored DirectMessage) cmpView Stored DirectMessage msg = (ZonedTime -> UTCTime zonedTimeToUTC (ZonedTime -> UTCTime) -> ZonedTime -> UTCTime forall a b. (a -> b) -> a -> b $ DirectMessage -> ZonedTime msgTime (DirectMessage -> ZonedTime) -> DirectMessage -> ZonedTime forall a b. (a -> b) -> a -> b $ Stored DirectMessage -> DirectMessage forall a. Stored a -> a fromStored Stored DirectMessage msg, Stored DirectMessage msg) messageThreadView :: [Stored MessageState] -> [DirectMessageThread] messageThreadView :: [Stored MessageState] -> [DirectMessageThread] messageThreadView = [ComposedIdentity] -> [Stored MessageState] -> [DirectMessageThread] helper [] where helper :: [ComposedIdentity] -> [Stored MessageState] -> [DirectMessageThread] helper [ComposedIdentity] used [Stored MessageState] ms' = case [Stored MessageState] -> [Stored MessageState] forall a. Storable a => [Stored a] -> [Stored a] filterAncestors [Stored MessageState] ms' of mss :: [Stored MessageState] mss@(Stored MessageState sms : [Stored MessageState] rest) | (ComposedIdentity -> Bool) -> [ComposedIdentity] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any (ComposedIdentity -> ComposedIdentity -> Bool forall (m :: * -> *) (m' :: * -> *). (Foldable m, Foldable m') => Identity m -> Identity m' -> Bool sameIdentity (ComposedIdentity -> ComposedIdentity -> Bool) -> ComposedIdentity -> ComposedIdentity -> Bool forall a b. (a -> b) -> a -> b $ MessageState -> ComposedIdentity msPeer (MessageState -> ComposedIdentity) -> MessageState -> ComposedIdentity forall a b. (a -> b) -> a -> b $ Stored MessageState -> MessageState forall a. Stored a -> a fromStored Stored MessageState sms) [ComposedIdentity] used -> [ComposedIdentity] -> [Stored MessageState] -> [DirectMessageThread] helper [ComposedIdentity] used ([Stored MessageState] -> [DirectMessageThread]) -> [Stored MessageState] -> [DirectMessageThread] forall a b. (a -> b) -> a -> b $ MessageState -> [Stored MessageState] msPrev (Stored MessageState -> MessageState forall a. Stored a -> a fromStored Stored MessageState sms) [Stored MessageState] -> [Stored MessageState] -> [Stored MessageState] forall a. [a] -> [a] -> [a] ++ [Stored MessageState] rest | Bool otherwise -> let peer :: ComposedIdentity peer = MessageState -> ComposedIdentity msPeer (MessageState -> ComposedIdentity) -> MessageState -> ComposedIdentity forall a b. (a -> b) -> a -> b $ Stored MessageState -> MessageState forall a. Stored a -> a fromStored Stored MessageState sms in ComposedIdentity -> [Stored MessageState] -> DirectMessageThread messageThreadFor ComposedIdentity peer [Stored MessageState] mss DirectMessageThread -> [DirectMessageThread] -> [DirectMessageThread] forall a. a -> [a] -> [a] : [ComposedIdentity] -> [Stored MessageState] -> [DirectMessageThread] helper (ComposedIdentity peer ComposedIdentity -> [ComposedIdentity] -> [ComposedIdentity] forall a. a -> [a] -> [a] : [ComposedIdentity] used) (MessageState -> [Stored MessageState] msPrev (Stored MessageState -> MessageState forall a. Stored a -> a fromStored Stored MessageState sms) [Stored MessageState] -> [Stored MessageState] -> [Stored MessageState] forall a. [a] -> [a] -> [a] ++ [Stored MessageState] rest) [Stored MessageState] _ -> [] messageThreadFor :: ComposedIdentity -> [Stored MessageState] -> DirectMessageThread messageThreadFor :: ComposedIdentity -> [Stored MessageState] -> DirectMessageThread messageThreadFor ComposedIdentity peer [Stored MessageState] mss = let ready :: [Stored DirectMessage] ready = ComposedIdentity -> (MessageState -> [Stored DirectMessage]) -> [Stored MessageState] -> [Stored DirectMessage] forall (m :: * -> *) a. Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty ComposedIdentity peer MessageState -> [Stored DirectMessage] msReady [Stored MessageState] mss sent :: [Stored DirectMessage] sent = ComposedIdentity -> (MessageState -> [Stored DirectMessage]) -> [Stored MessageState] -> [Stored DirectMessage] forall (m :: * -> *) a. Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty ComposedIdentity peer MessageState -> [Stored DirectMessage] msSent [Stored MessageState] mss received :: [Stored DirectMessage] received = ComposedIdentity -> (MessageState -> [Stored DirectMessage]) -> [Stored MessageState] -> [Stored DirectMessage] forall (m :: * -> *) a. Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty ComposedIdentity peer MessageState -> [Stored DirectMessage] msReceived [Stored MessageState] mss seen :: [Stored DirectMessage] seen = ComposedIdentity -> (MessageState -> [Stored DirectMessage]) -> [Stored MessageState] -> [Stored DirectMessage] forall (m :: * -> *) a. Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] findMsgProperty ComposedIdentity peer MessageState -> [Stored DirectMessage] msSeen [Stored MessageState] mss in DirectMessageThread { msgPeer :: ComposedIdentity msgPeer = ComposedIdentity peer , msgHead :: [Stored DirectMessage] msgHead = [Stored DirectMessage] -> [Stored DirectMessage] forall a. Storable a => [Stored a] -> [Stored a] filterAncestors ([Stored DirectMessage] -> [Stored DirectMessage]) -> [Stored DirectMessage] -> [Stored DirectMessage] forall a b. (a -> b) -> a -> b $ [Stored DirectMessage] ready [Stored DirectMessage] -> [Stored DirectMessage] -> [Stored DirectMessage] forall a. [a] -> [a] -> [a] ++ [Stored DirectMessage] received , msgSent :: [Stored DirectMessage] msgSent = [Stored DirectMessage] -> [Stored DirectMessage] forall a. Storable a => [Stored a] -> [Stored a] filterAncestors ([Stored DirectMessage] -> [Stored DirectMessage]) -> [Stored DirectMessage] -> [Stored DirectMessage] forall a b. (a -> b) -> a -> b $ [Stored DirectMessage] sent [Stored DirectMessage] -> [Stored DirectMessage] -> [Stored DirectMessage] forall a. [a] -> [a] -> [a] ++ [Stored DirectMessage] received , msgSeen :: [Stored DirectMessage] msgSeen = [Stored DirectMessage] -> [Stored DirectMessage] forall a. Storable a => [Stored a] -> [Stored a] filterAncestors ([Stored DirectMessage] -> [Stored DirectMessage]) -> [Stored DirectMessage] -> [Stored DirectMessage] forall a b. (a -> b) -> a -> b $ [Stored DirectMessage] ready [Stored DirectMessage] -> [Stored DirectMessage] -> [Stored DirectMessage] forall a. [a] -> [a] -> [a] ++ [Stored DirectMessage] seen } watchReceivedMessages :: Head LocalState -> (Stored DirectMessage -> IO ()) -> IO WatchedHead watchReceivedMessages :: Head LocalState -> (Stored DirectMessage -> IO ()) -> IO WatchedHead watchReceivedMessages Head LocalState h Stored DirectMessage -> IO () f = do let self :: ComposedIdentity self = Identity Identity -> ComposedIdentity forall (m :: * -> *). (Foldable m, Applicative m) => Identity m -> ComposedIdentity finalOwner (Identity Identity -> ComposedIdentity) -> Identity Identity -> ComposedIdentity forall a b. (a -> b) -> a -> b $ LocalState -> Identity Identity localIdentity (LocalState -> Identity Identity) -> LocalState -> Identity Identity forall a b. (a -> b) -> a -> b $ Head LocalState -> LocalState forall a. Head a -> a headObject Head LocalState h Head LocalState -> (Head LocalState -> DirectMessageThreads) -> (DirectMessageThreads -> IO ()) -> IO WatchedHead forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead watchHeadWith Head LocalState h ([Stored SharedState] -> DirectMessageThreads forall a. SharedType a => [Stored SharedState] -> a lookupSharedValue ([Stored SharedState] -> DirectMessageThreads) -> (Head LocalState -> [Stored SharedState]) -> Head LocalState -> DirectMessageThreads forall b c a. (b -> c) -> (a -> b) -> a -> c . LocalState -> [Stored SharedState] lsShared (LocalState -> [Stored SharedState]) -> (Head LocalState -> LocalState) -> Head LocalState -> [Stored SharedState] forall b c a. (b -> c) -> (a -> b) -> a -> c . Head LocalState -> LocalState forall a. Head a -> a headObject) ((DirectMessageThreads -> IO ()) -> IO WatchedHead) -> (DirectMessageThreads -> IO ()) -> IO WatchedHead forall a b. (a -> b) -> a -> b $ \(DirectMessageThreads [Stored MessageState] sms [DirectMessageThread] _) -> do [MessageState] -> (MessageState -> IO ()) -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ ((Stored MessageState -> MessageState) -> [Stored MessageState] -> [MessageState] forall a b. (a -> b) -> [a] -> [b] map Stored MessageState -> MessageState forall a. Stored a -> a fromStored [Stored MessageState] sms) ((MessageState -> IO ()) -> IO ()) -> (MessageState -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ \MessageState ms -> do (Stored DirectMessage -> IO ()) -> [Stored DirectMessage] -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ Stored DirectMessage -> IO () f ([Stored DirectMessage] -> IO ()) -> [Stored DirectMessage] -> IO () forall a b. (a -> b) -> a -> b $ (Stored DirectMessage -> Bool) -> [Stored DirectMessage] -> [Stored DirectMessage] forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not (Bool -> Bool) -> (Stored DirectMessage -> Bool) -> Stored DirectMessage -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . ComposedIdentity -> ComposedIdentity -> Bool forall (m :: * -> *) (m' :: * -> *). (Foldable m, Foldable m') => Identity m -> Identity m' -> Bool sameIdentity ComposedIdentity self (ComposedIdentity -> Bool) -> (Stored DirectMessage -> ComposedIdentity) -> Stored DirectMessage -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . DirectMessage -> ComposedIdentity msgFrom (DirectMessage -> ComposedIdentity) -> (Stored DirectMessage -> DirectMessage) -> Stored DirectMessage -> ComposedIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c . Stored DirectMessage -> DirectMessage forall a. Stored a -> a fromStored) ([Stored DirectMessage] -> [Stored DirectMessage]) -> [Stored DirectMessage] -> [Stored DirectMessage] forall a b. (a -> b) -> a -> b $ MessageState -> [Stored DirectMessage] msReceived MessageState ms formatMessage :: TimeZone -> DirectMessage -> String formatMessage :: TimeZone -> DirectMessage -> String formatMessage TimeZone tzone DirectMessage msg = [String] -> String forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ TimeLocale -> String -> LocalTime -> String forall t. FormatTime t => TimeLocale -> String -> t -> String formatTime TimeLocale defaultTimeLocale String "[%H:%M] " (LocalTime -> String) -> LocalTime -> String forall a b. (a -> b) -> a -> b $ TimeZone -> UTCTime -> LocalTime utcToLocalTime TimeZone tzone (UTCTime -> LocalTime) -> UTCTime -> LocalTime forall a b. (a -> b) -> a -> b $ ZonedTime -> UTCTime zonedTimeToUTC (ZonedTime -> UTCTime) -> ZonedTime -> UTCTime forall a b. (a -> b) -> a -> b $ DirectMessage -> ZonedTime msgTime DirectMessage msg , String -> (Text -> String) -> Maybe Text -> String forall b a. b -> (a -> b) -> Maybe a -> b maybe String "<unnamed>" Text -> String T.unpack (Maybe Text -> String) -> Maybe Text -> String forall a b. (a -> b) -> a -> b $ ComposedIdentity -> Maybe Text forall (m :: * -> *). Identity m -> Maybe Text idName (ComposedIdentity -> Maybe Text) -> ComposedIdentity -> Maybe Text forall a b. (a -> b) -> a -> b $ DirectMessage -> ComposedIdentity msgFrom DirectMessage msg , String ": " , Text -> String T.unpack (Text -> String) -> Text -> String forall a b. (a -> b) -> a -> b $ DirectMessage -> Text msgText DirectMessage msg ]