From e523506d241dbbbe86741a98a690e9738e413545 Mon Sep 17 00:00:00 2001 From: IC Rainbow Date: Thu, 21 Dec 2023 15:01:42 +0200 Subject: [PATCH] constrain ACIQDirection to exclude CTLocal --- src/Simplex/Chat/Messages.hs | 41 ++++++++++++++++++++---------- src/Simplex/Chat/Store/Messages.hs | 5 ++-- 2 files changed, 30 insertions(+), 16 deletions(-) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 0a0c8f4f37..0e3c86963e 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -11,11 +11,14 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Messages where import Control.Applicative ((<|>)) +import Control.Monad ((>=>)) import Data.Aeson (FromJSON, ToJSON, (.:)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE @@ -25,6 +28,7 @@ import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace) import Data.Int (Int64) +import Data.Kind (Constraint) import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text) import qualified Data.Text as T @@ -34,6 +38,8 @@ import Data.Type.Equality import Data.Typeable (Typeable) import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) +import GHC.TypeLits (ErrorMessage (ShowType, type (:<>:)), TypeError) +import qualified GHC.TypeLits as Type import Simplex.Chat.Markdown import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol @@ -189,7 +195,8 @@ data JSONCIDirection | JCIDirectRcv | JCIGroupSnd | JCIGroupRcv {groupMember :: GroupMember} - | JCINote + | JCILocalSnd + | JCILocalRcv deriving (Show) jsonCIDirection :: CIDirection c d -> JSONCIDirection @@ -198,7 +205,8 @@ jsonCIDirection = \case CIDirectRcv -> JCIDirectRcv CIGroupSnd -> JCIGroupSnd CIGroupRcv m -> JCIGroupRcv m - CINote -> JCINote + CILocalSnd -> JCILocalSnd + CILocalRcv -> JCILocalRcv jsonACIDirection :: JSONCIDirection -> ACIDirection jsonACIDirection = \case @@ -206,7 +214,8 @@ jsonACIDirection = \case JCIDirectRcv -> ACID SCTDirect SMDRcv CIDirectRcv JCIGroupSnd -> ACID SCTGroup SMDSnd CIGroupSnd JCIGroupRcv m -> ACID SCTGroup SMDRcv $ CIGroupRcv m - JCINote -> ACID SCTLocal SMDSnd CINote + JCILocalSnd -> ACID SCTLocal SMDSnd CILocalSnd + JCILocalRcv -> ACID SCTLocal SMDRcv CILocalRcv data CIReactionCount = CIReactionCount {reaction :: MsgReaction, userReacted :: Bool, totalReacted :: Int} deriving (Show) @@ -398,6 +407,12 @@ deriving instance Show ACIReaction data JSONCIReaction c d = JSONCIReaction {chatInfo :: ChatInfo c, chatReaction :: CIReaction c d} +type family ChatTypeQuotable (a :: ChatType) :: Constraint where + ChatTypeQuotable CTDirect = () + ChatTypeQuotable CTGroup = () + ChatTypeQuotable a = + (Int ~ Bool, TypeError (Type.Text "ChatType " :<>: ShowType a :<>: Type.Text " cannot be quoted")) + data CIQDirection (c :: ChatType) where CIQDirectSnd :: CIQDirection 'CTDirect CIQDirectRcv :: CIQDirection 'CTDirect @@ -406,7 +421,7 @@ data CIQDirection (c :: ChatType) where deriving instance Show (CIQDirection c) -data ACIQDirection = forall c. ChatTypeI c => ACIQDirection (SChatType c) (CIQDirection c) +data ACIQDirection = forall c. (ChatTypeI c, ChatTypeQuotable c) => ACIQDirection (SChatType c) (CIQDirection c) jsonCIQDirection :: CIQDirection c -> Maybe JSONCIDirection jsonCIQDirection = \case @@ -416,14 +431,15 @@ jsonCIQDirection = \case CIQGroupRcv (Just m) -> Just $ JCIGroupRcv m CIQGroupRcv Nothing -> Nothing -jsonACIQDirection :: Maybe JSONCIDirection -> ACIQDirection +jsonACIQDirection :: Maybe JSONCIDirection -> Either String ACIQDirection jsonACIQDirection = \case - Just JCIDirectSnd -> ACIQDirection SCTDirect CIQDirectSnd - Just JCIDirectRcv -> ACIQDirection SCTDirect CIQDirectRcv - Just JCIGroupSnd -> ACIQDirection SCTGroup CIQGroupSnd - Just (JCIGroupRcv m) -> ACIQDirection SCTGroup $ CIQGroupRcv (Just m) - Just JCINote -> ACIQDirection SCTLocal CIQNote - Nothing -> ACIQDirection SCTGroup $ CIQGroupRcv Nothing + Just JCIDirectSnd -> Right $ ACIQDirection SCTDirect CIQDirectSnd + Just JCIDirectRcv -> Right $ ACIQDirection SCTDirect CIQDirectRcv + Just JCIGroupSnd -> Right $ ACIQDirection SCTGroup CIQGroupSnd + Just (JCIGroupRcv m) -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv (Just m) + Nothing -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv Nothing + Just JCILocalSnd -> Left "unquotable" + Just JCILocalRcv -> Left "unquotable" quoteMsgDirection :: CIQDirection c -> MsgDirection quoteMsgDirection = \case @@ -431,7 +447,6 @@ quoteMsgDirection = \case CIQDirectRcv -> MDRcv CIQGroupSnd -> MDSnd CIQGroupRcv _ -> MDRcv - CIQNote -> MDSnd data CIFile (d :: MsgDirection) = CIFile { fileId :: Int64, @@ -1057,7 +1072,7 @@ instance FromJSON ACIDirection where parseJSON v = jsonACIDirection <$> J.parseJSON v instance ChatTypeI c => FromJSON (CIQDirection c) where - parseJSON v = (\(ACIQDirection _ x) -> checkChatType x) . jsonACIQDirection <$?> J.parseJSON v + parseJSON v = (jsonACIQDirection >=> \(ACIQDirection _ x) -> checkChatType x) <$?> J.parseJSON v instance ToJSON (CIQDirection c) where toJSON = J.toJSON . jsonCIQDirection diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 8ab339033f..469bc221da 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -366,7 +366,6 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon CIQGroupSnd -> (Just True, Nothing) CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId) CIQGroupRcv Nothing -> (Just False, Nothing) - CIQNote -> (Just True, Nothing) createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c)) createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live itemTs createdAt = do @@ -504,9 +503,9 @@ getChatPreviews db user withPCC pagination query = do ts (ACPD _ cpd) = case cpd of (DirectChatPD t _ _ _) -> t (GroupChatPD t _ _ _) -> t + (LocalChatPD t _) -> t (ContactRequestPD t _) -> t (ContactConnectionPD t _) -> t - (LocalChatPD t _) -> t sortTake = case pagination of PTLast count -> take count . sortBy (comparing $ Down . ts) PTAfter _ count -> reverse . take count . sortBy (comparing ts) @@ -515,9 +514,9 @@ getChatPreviews db user withPCC pagination query = do getChatPreview (ACPD cType cpd) = case cType of SCTDirect -> getDirectChatPreview_ db user cpd SCTGroup -> getGroupChatPreview_ db user cpd + SCTLocal -> let (LocalChatPD _ chat) = cpd in pure chat SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat SCTContactConnection -> let (ContactConnectionPD _ chat) = cpd in pure chat - SCTNotes -> let (LocalChatPD _ chat) = cpd in pure chat data ChatPreviewData (c :: ChatType) where DirectChatPD :: UTCTime -> ContactId -> Maybe ChatItemId -> ChatStats -> ChatPreviewData 'CTDirect