diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index e32fa2b00d..c72eca61ca 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -30,7 +30,10 @@ import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime) import Data.Type.Equality import Data.Typeable (Typeable) import Data.Word (Word32) -import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple (ResultError (..), SQLData (..)) +import Database.SQLite.Simple.FromField (Field, FromField (..), returnError) +import Database.SQLite.Simple.Internal (Field (..)) +import Database.SQLite.Simple.Ok import Database.SQLite.Simple.ToField (ToField (..)) import GHC.Generics (Generic) import Simplex.Chat.Markdown @@ -746,6 +749,7 @@ data CIContent (d :: MsgDirection) where CIRcvGroupFeatureRejected :: GroupFeature -> CIContent 'MDRcv CISndModerated :: CIContent 'MDSnd CIRcvModerated :: CIContent 'MDRcv + CIInvalidJSON :: Text -> CIContent d -- ^ This type is used both in API and in DB, so we use different JSON encodings for the database and for the API -- ! ^ Nested sum types also have to use different encodings for database and API -- ! ^ to avoid breaking cross-platform compatibility, see RcvGroupEvent and SndGroupEvent @@ -790,6 +794,7 @@ ciRequiresAttention content = case msgDirection @d of CIRcvChatFeatureRejected _ -> True CIRcvGroupFeatureRejected _ -> True CIRcvModerated -> True + CIInvalidJSON _ -> False ciCreateStatus :: forall d. MsgDirectionI d => CIContent d -> CIStatus d ciCreateStatus content = case msgDirection @d of @@ -952,6 +957,7 @@ ciContentToText = \case CIRcvGroupFeatureRejected feature -> groupFeatureNameText feature <> ": received, prohibited" CISndModerated -> ciModeratedText CIRcvModerated -> ciModeratedText + CIInvalidJSON _ -> "invalid content JSON" msgIntegrityError :: MsgErrorType -> Text msgIntegrityError = \case @@ -979,11 +985,11 @@ ciModeratedText :: Text ciModeratedText = "moderated" -- platform independent -instance ToField (CIContent d) where +instance MsgDirectionI d => ToField (CIContent d) where toField = toField . encodeJSON . dbJsonCIContent -- platform specific -instance ToJSON (CIContent d) where +instance MsgDirectionI d => ToJSON (CIContent d) where toJSON = J.toJSON . jsonCIContent toEncoding = J.toEncoding . jsonCIContent @@ -991,13 +997,14 @@ data ACIContent = forall d. MsgDirectionI d => ACIContent (SMsgDirection d) (CIC deriving instance Show ACIContent +-- platform independent +dbParseACIContent :: Text -> Either String ACIContent +dbParseACIContent = fmap aciContentDBJSON . J.eitherDecodeStrict' . encodeUtf8 + -- platform specific instance FromJSON ACIContent where parseJSON = fmap aciContentJSON . J.parseJSON --- platform independent -instance FromField ACIContent where fromField = fromTextField_ $ fmap aciContentDBJSON . decodeJSON - -- platform specific data JSONCIContent = JCISndMsgContent {msgContent :: MsgContent} @@ -1024,6 +1031,7 @@ data JSONCIContent | JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature} | JCISndModerated | JCIRcvModerated + | JCIInvalidJSON {direction :: MsgDirection, json :: Text} deriving (Generic) instance FromJSON JSONCIContent where @@ -1033,7 +1041,7 @@ instance ToJSON JSONCIContent where toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCI" toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCI" -jsonCIContent :: CIContent d -> JSONCIContent +jsonCIContent :: forall d. MsgDirectionI d => CIContent d -> JSONCIContent jsonCIContent = \case CISndMsgContent mc -> JCISndMsgContent mc CIRcvMsgContent mc -> JCIRcvMsgContent mc @@ -1059,6 +1067,7 @@ jsonCIContent = \case CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature} CISndModerated -> JCISndModerated CIRcvModerated -> JCISndModerated + CIInvalidJSON json -> JCIInvalidJSON (toMsgDirection $ msgDirection @d) json aciContentJSON :: JSONCIContent -> ACIContent aciContentJSON = \case @@ -1086,6 +1095,8 @@ aciContentJSON = \case JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature JCISndModerated -> ACIContent SMDSnd CISndModerated JCIRcvModerated -> ACIContent SMDRcv CIRcvModerated + JCIInvalidJSON dir json -> case fromMsgDirection dir of + AMsgDirection d -> ACIContent d $ CIInvalidJSON json -- platform independent data DBJSONCIContent @@ -1113,6 +1124,7 @@ data DBJSONCIContent | DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature} | DBJCISndModerated | DBJCIRcvModerated + | DBJCIInvalidJSON {direction :: MsgDirection, json :: Text} deriving (Generic) instance FromJSON DBJSONCIContent where @@ -1122,7 +1134,7 @@ instance ToJSON DBJSONCIContent where toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "DBJCI" toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "DBJCI" -dbJsonCIContent :: CIContent d -> DBJSONCIContent +dbJsonCIContent :: forall d. MsgDirectionI d => CIContent d -> DBJSONCIContent dbJsonCIContent = \case CISndMsgContent mc -> DBJCISndMsgContent mc CIRcvMsgContent mc -> DBJCIRcvMsgContent mc @@ -1148,6 +1160,7 @@ dbJsonCIContent = \case CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature} CISndModerated -> DBJCISndModerated CIRcvModerated -> DBJCIRcvModerated + CIInvalidJSON json -> DBJCIInvalidJSON (toMsgDirection $ msgDirection @d) json aciContentDBJSON :: DBJSONCIContent -> ACIContent aciContentDBJSON = \case @@ -1175,6 +1188,8 @@ aciContentDBJSON = \case DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature DBJCISndModerated -> ACIContent SMDSnd CISndModerated DBJCIRcvModerated -> ACIContent SMDRcv CIRcvModerated + DBJCIInvalidJSON dir json -> case fromMsgDirection dir of + AMsgDirection d -> ACIContent d $ CIInvalidJSON json data CICallStatus = CISCallPending @@ -1267,8 +1282,18 @@ instance ToJSON MsgDirection where toJSON = J.genericToJSON . enumJSON $ dropPrefix "MD" toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MD" +instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgDirection . msgDirectionIntP + instance ToField MsgDirection where toField = toField . msgDirectionInt +fromIntField_ :: (Typeable a) => (Int64 -> Maybe a) -> Field -> Ok a +fromIntField_ fromInt = \case + f@(Field (SQLInteger i) _) -> + case fromInt i of + Just x -> Ok x + _ -> returnError ConversionFailed f ("invalid integer: " <> show i) + f -> returnError ConversionFailed f "expecting SQLInteger column type" + data SMsgDirection (d :: MsgDirection) where SMDRcv :: SMsgDirection 'MDRcv SMDSnd :: SMsgDirection 'MDSnd diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index f494c910ba..44bab60132 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -292,7 +292,7 @@ import qualified Data.Aeson as J import Data.Bifunctor (first) import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) -import Data.Either (rights) +import Data.Either (fromRight, rights) import Data.Functor (($>)) import Data.Int (Int64) import Data.List (sortOn) @@ -3746,7 +3746,7 @@ getDirectChatPreviews_ db user@User {userId} = do -- ChatStats COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), ct.unread_chat, -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, -- DirectQuote @@ -3811,7 +3811,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do -- ChatStats COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), g.unread_chat, -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, -- Maybe GroupMember - sender @@ -3977,7 +3977,7 @@ getDirectChatItemsLast db User {userId} contactId count search = ExceptT $ do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, -- DirectQuote @@ -4008,7 +4008,7 @@ getDirectChatAfter_ db user@User {userId} contactId afterChatItemId count search [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, -- DirectQuote @@ -4040,7 +4040,7 @@ getDirectChatBefore_ db user@User {userId} contactId beforeChatItemId count sear [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, -- DirectQuote @@ -4446,7 +4446,7 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, -- DirectQuote @@ -4589,7 +4589,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, -- GroupMember @@ -4849,9 +4849,9 @@ type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool) -type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, ACIStatus, Maybe SharedMsgId, Bool, Maybe Bool, UTCTime, UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow +type ChatItemRow = (Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId, Bool, Maybe Bool, UTCTime, UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow -type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId, Maybe Bool, Maybe Bool, Maybe UTCTime, Maybe UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow +type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe AMsgDirection, Maybe Text, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId, Maybe Bool, Maybe Bool, Maybe UTCTime, Maybe UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool) @@ -4864,19 +4864,22 @@ toQuote :: QuoteRow -> Maybe (CIQDirection c) -> Maybe (CIQuote c) toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir = CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent) +-- this function can be changed so it never fails, not only avoid failure on invalid json toDirectChatItem :: TimeZone -> UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect) -toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. quoteRow) = - case (itemContent, itemStatus, fileStatus_) of - (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Just (AFS SMDSnd fileStatus)) -> - Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent (maybeCIFile fileStatus) - (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Nothing) -> - Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent Nothing - (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just (AFS SMDRcv fileStatus)) -> - Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent (maybeCIFile fileStatus) - (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Nothing) -> - Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent Nothing - _ -> badItem +toDirectChatItem tz currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. quoteRow) = + chatItem $ fromRight invalid $ dbParseACIContent itemContentText where + invalid = ACIContent msgDir $ CIInvalidJSON itemContentText + chatItem itemContent = case (itemContent, itemStatus, fileStatus_) of + (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Just (AFS SMDSnd fileStatus)) -> + Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent (maybeCIFile fileStatus) + (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Nothing) -> + Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent Nothing + (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just (AFS SMDRcv fileStatus)) -> + Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent (maybeCIFile fileStatus) + (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Nothing) -> + Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent Nothing + _ -> badItem maybeCIFile :: CIFileStatus d -> Maybe (CIFile d) maybeCIFile fileStatus = case (fileId_, fileName_, fileSize_, fileProtocol_) of @@ -4895,8 +4898,8 @@ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStat ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} toDirectChatItemList :: TimeZone -> UTCTime -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect] -toDirectChatItemList tz currentTs (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) = - either (const []) (: []) $ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) +toDirectChatItemList tz currentTs (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) = + either (const []) (: []) $ toDirectChatItem tz currentTs (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) toDirectChatItemList _ _ _ = [] type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow @@ -4911,33 +4914,36 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction direction (Just False) Nothing = Just $ CIQGroupRcv Nothing direction _ _ = Nothing +-- this function can be changed so it never fails, not only avoid failure on invalid json toGroupChatItem :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) -toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do - let member_ = toMaybeGroupMember userContactId memberRow_ - quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_ - deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_ - case (itemContent, itemStatus, member_, fileStatus_) of - (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) -> - Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ (maybeCIFile fileStatus) deletedByGroupMember_ - (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) -> - Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ Nothing deletedByGroupMember_ - (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) -> - Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ (maybeCIFile fileStatus) deletedByGroupMember_ - (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) -> - Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ Nothing deletedByGroupMember_ - _ -> badItem +toGroupChatItem tz currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do + chatItem $ fromRight invalid $ dbParseACIContent itemContentText where + member_ = toMaybeGroupMember userContactId memberRow_ + quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_ + deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_ + invalid = ACIContent msgDir $ CIInvalidJSON itemContentText + chatItem itemContent = case (itemContent, itemStatus, member_, fileStatus_) of + (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) -> + Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent (maybeCIFile fileStatus) + (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) -> + Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent Nothing + (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) -> + Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent (maybeCIFile fileStatus) + (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) -> + Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent Nothing + _ -> badItem maybeCIFile :: CIFileStatus d -> Maybe (CIFile d) maybeCIFile fileStatus = case (fileId_, fileName_, fileSize_, fileProtocol_) of (Just fileId, Just fileName, Just fileSize, Just fileProtocol) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol} _ -> Nothing - cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe GroupMember -> Maybe (CIFile d) -> Maybe GroupMember -> CChatItem 'CTGroup - cItem d chatDir ciStatus content quotedMember_ file deletedByGroupMember_ = - CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus deletedByGroupMember_, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, file} + cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup + cItem d chatDir ciStatus content file = + CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, file} badItem = Left $ SEBadChatItem itemId - ciMeta :: CIContent d -> CIStatus d -> Maybe GroupMember -> CIMeta 'CTGroup d - ciMeta content status deletedByGroupMember_ = + ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d + ciMeta content status = let itemDeleted' = if itemDeleted then Just (maybe (CIDeleted @'CTGroup) CIModerated deletedByGroupMember_) @@ -4948,8 +4954,8 @@ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemT ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} toGroupChatItemList :: TimeZone -> UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] -toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = - either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) +toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = + either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) toGroupChatItemList _ _ _ _ = [] getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p]