summaryrefslogtreecommitdiff
path: root/src/Message.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Message.hs')
-rw-r--r--src/Message.hs236
1 files changed, 0 insertions, 236 deletions
diff --git a/src/Message.hs b/src/Message.hs
deleted file mode 100644
index 334cd1e..0000000
--- a/src/Message.hs
+++ /dev/null
@@ -1,236 +0,0 @@
-module Message (
- DirectMessage(..),
- sendDirectMessage,
-
- DirectMessageAttributes(..),
- defaultDirectMessageAttributes,
-
- DirectMessageThreads,
- toThreadList,
-
- DirectMessageThread(..),
- threadToList,
- messageThreadView,
-
- watchReceivedMessages,
- formatMessage,
-) where
-
-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 Identity
-import Network
-import Service
-import State
-import Storage
-import Storage.Merge
-
-data DirectMessage = DirectMessage
- { msgFrom :: ComposedIdentity
- , msgPrev :: [Stored DirectMessage]
- , msgTime :: ZonedTime
- , msgText :: Text
- }
-
-instance Storable DirectMessage where
- store' msg = storeRec $ do
- mapM_ (storeRef "from") $ idExtDataF $ msgFrom msg
- mapM_ (storeRef "PREV") $ msgPrev msg
- storeDate "time" $ msgTime msg
- storeText "text" $ msgText msg
-
- load' = loadRec $ DirectMessage
- <$> loadIdentity "from"
- <*> loadRefs "PREV"
- <*> loadDate "time"
- <*> loadText "text"
-
-data DirectMessageAttributes = DirectMessageAttributes
- { dmOwnerMismatch :: ServiceHandler DirectMessage ()
- }
-
-defaultDirectMessageAttributes :: DirectMessageAttributes
-defaultDirectMessageAttributes = DirectMessageAttributes
- { dmOwnerMismatch = svcPrint "Owner mismatch"
- }
-
-instance Service DirectMessage where
- serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d"
-
- type ServiceAttributes DirectMessage = DirectMessageAttributes
- defaultServiceAttributes _ = defaultDirectMessageAttributes
-
- serviceHandler smsg = do
- let msg = fromStored smsg
- powner <- asks $ finalOwner . svcPeerIdentity
- erb <- svcGetLocal
- st <- getStorage
- let DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb
- sent = findMsgProperty powner msSent prev
- received = findMsgProperty powner msReceived prev
- received' = filterAncestors $ smsg : received
- if powner `sameIdentity` msgFrom msg ||
- filterAncestors sent == filterAncestors (smsg : sent)
- then do
- when (received' /= received) $ do
- next <- wrappedStore st $ MessageState
- { msPrev = prev
- , msPeer = powner
- , msSent = []
- , msReceived = received'
- , msSeen = []
- }
- let threads = DirectMessageThreads [next] (messageThreadView [next])
- shared <- makeSharedStateUpdate st threads (lsShared $ fromStored erb)
- svcSetLocal =<< wrappedStore st (fromStored erb) { lsShared = [shared] }
-
- when (powner `sameIdentity` msgFrom msg) $ do
- replyStoredRef smsg
-
- else join $ asks $ dmOwnerMismatch . svcAttributes
-
- serviceNewPeer = syncDirectMessageToPeer . lookupSharedValue . lsShared . fromStored =<< svcGetLocal
-
- serviceStorageWatchers _ = (:[]) $
- SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncDirectMessageToPeer
-
-
-data MessageState = MessageState
- { msPrev :: [Stored MessageState]
- , msPeer :: ComposedIdentity
- , msSent :: [Stored DirectMessage]
- , msReceived :: [Stored DirectMessage]
- , msSeen :: [Stored DirectMessage]
- }
-
-data DirectMessageThreads = DirectMessageThreads [Stored MessageState] [DirectMessageThread]
-
-instance Eq DirectMessageThreads where
- DirectMessageThreads mss _ == DirectMessageThreads mss' _ = mss == mss'
-
-toThreadList :: DirectMessageThreads -> [DirectMessageThread]
-toThreadList (DirectMessageThreads _ threads) = threads
-
-instance Storable MessageState where
- store' ms = storeRec $ do
- mapM_ (storeRef "PREV") $ msPrev ms
- mapM_ (storeRef "peer") $ idDataF $ msPeer ms
- mapM_ (storeRef "sent") $ msSent ms
- mapM_ (storeRef "received") $ msReceived ms
- mapM_ (storeRef "seen") $ msSeen ms
-
- load' = loadRec $ MessageState
- <$> loadRefs "PREV"
- <*> loadIdentity "peer"
- <*> loadRefs "sent"
- <*> loadRefs "received"
- <*> loadRefs "seen"
-
-instance Mergeable DirectMessageThreads where
- type Component DirectMessageThreads = MessageState
- mergeSorted mss = DirectMessageThreads mss (messageThreadView mss)
- toComponents (DirectMessageThreads mss _) = mss
-
-instance SharedType DirectMessageThreads where
- sharedTypeID _ = mkSharedTypeID "ee793681-5976-466a-b0f0-4e1907d3fade"
-
-findMsgProperty :: Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a]
-findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do
- guard $ msPeer x `sameIdentity` pid
- guard $ not $ null $ sel x
- return $ sel x
-
-
-sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m)
- => Identity f -> Text -> m (Stored DirectMessage)
-sendDirectMessage pid text = updateLocalHead $ \ls -> do
- let self = localIdentity $ fromStored ls
- powner = finalOwner pid
- flip updateSharedState ls $ \(DirectMessageThreads prev _) -> do
- let sent = findMsgProperty powner msSent prev
- received = findMsgProperty powner msReceived prev
-
- time <- liftIO getZonedTime
- smsg <- mstore DirectMessage
- { msgFrom = toComposedIdentity $ finalOwner self
- , msgPrev = filterAncestors $ sent ++ received
- , msgTime = time
- , msgText = text
- }
- next <- mstore MessageState
- { msPrev = prev
- , msPeer = powner
- , msSent = [smsg]
- , msReceived = []
- , msSeen = []
- }
- return (DirectMessageThreads [next] (messageThreadView [next]), smsg)
-
-syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage ()
-syncDirectMessageToPeer (DirectMessageThreads mss _) = do
- pid <- finalOwner <$> asks svcPeerIdentity
- peer <- asks svcPeer
- let thread = messageThreadFor pid mss
- mapM_ (sendToPeerStored peer) $ msgHead thread
-
-data DirectMessageThread = DirectMessageThread
- { msgPeer :: ComposedIdentity
- , msgHead :: [Stored DirectMessage]
- , msgSeen :: [Stored DirectMessage]
- }
-
-threadToList :: DirectMessageThread -> [DirectMessage]
-threadToList thread = helper S.empty $ msgHead thread
- where helper seen msgs
- | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs =
- fromStored msg : helper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg))
- | otherwise = []
- cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg)
-
-messageThreadView :: [Stored MessageState] -> [DirectMessageThread]
-messageThreadView = helper []
- where helper used ms' = case filterAncestors ms' of
- mss@(sms : rest)
- | any (sameIdentity $ msPeer $ fromStored sms) used ->
- helper used $ msPrev (fromStored sms) ++ rest
- | otherwise ->
- let peer = msPeer $ fromStored sms
- in messageThreadFor peer mss : helper (peer : used) (msPrev (fromStored sms) ++ rest)
- _ -> []
-
-messageThreadFor :: ComposedIdentity -> [Stored MessageState] -> DirectMessageThread
-messageThreadFor peer mss =
- let sent = findMsgProperty peer msSent mss
- received = findMsgProperty peer msReceived mss
- seen = findMsgProperty peer msSeen mss
-
- in DirectMessageThread
- { msgPeer = peer
- , msgHead = filterAncestors $ sent ++ received
- , msgSeen = filterAncestors $ sent ++ seen
- }
-
-
-watchReceivedMessages :: Head LocalState -> (Stored DirectMessage -> IO ()) -> IO WatchedHead
-watchReceivedMessages h f = do
- let self = finalOwner $ localIdentity $ headObject h
- watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \(DirectMessageThreads sms _) -> do
- forM_ (map fromStored sms) $ \ms -> do
- mapM_ f $ filter (not . sameIdentity self . msgFrom . fromStored) $ msReceived ms
-
-formatMessage :: TimeZone -> DirectMessage -> String
-formatMessage tzone msg = concat
- [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
- , maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
- , ": "
- , T.unpack $ msgText msg
- ]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 21:19:20 +0000