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
    ]