dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-26 18:25:49 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into ab/diff-subs

Browse Source
This commit is contained in:
IC Rainbow
2024-05-13 15:56:29 +03:00
parent 6101be5657 06d61ea73e
commit 1a2fad070e
14 changed files with 104 additions and 86 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+5 -5
View File
@@ -3023,7 +3023,7 @@ receiveFile' user ft rcvInline_ filePath_ = do
where
processError = \case
-- TODO AChatItem in Cancelled events
ChatErrorAgent (SMP SMP.AUTH) _ -> pure $ CRRcvFileAcceptedSndCancelled user ft
ChatErrorAgent (SMP _ SMP.AUTH) _ -> pure $ CRRcvFileAcceptedSndCancelled user ft
ChatErrorAgent (CONN DUPLICATE) _ -> pure $ CRRcvFileAcceptedSndCancelled user ft
e -> throwError e
@@ -3360,7 +3360,7 @@ subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do
errorNetworkStatus :: ChatError -> String
errorNetworkStatus = \case
ChatErrorAgent (BROKER _ NETWORK) _ -> "network"
ChatErrorAgent (SMP SMP.AUTH) _ -> "contact deleted"
ChatErrorAgent (SMP _ SMP.AUTH) _ -> "contact deleted"
e -> show e
-- TODO possibly below could be replaced with less noisy events for API
contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> CM ()
@@ -4486,7 +4486,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
MERR _ err -> do
cancelSndFileTransfer user ft True >>= mapM_ (deleteAgentConnectionAsync user)
case err of
SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ do
SMP _ SMP.AUTH -> unless (fileStatus == FSCancelled) $ do
ci <- withStore $ \db -> do
liftIO (lookupChatRefByFileId db user fileId) >>= \case
Just (ChatRef CTDirect _) -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled
@@ -4641,7 +4641,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
incAuthErrCounter :: ConnectionEntity -> Connection -> AgentErrorType -> CM ()
incAuthErrCounter connEntity conn err = do
case err of
SMP SMP.AUTH -> do
SMP _ SMP.AUTH -> do
authErrCounter' <- withStore' $ \db -> incConnectionAuthErrCounter db user conn
when (authErrCounter' >= authErrDisableCount) $ do
toView $ CRConnectionDisabled connEntity
@@ -4693,7 +4693,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
withStore' $ \db -> updateSndMsgDeliveryStatus db connId msgId MDSSndSent
agentErrToItemStatus :: AgentErrorType -> CIStatus 'MDSnd
agentErrToItemStatus (SMP AUTH) = CISSndErrorAuth
agentErrToItemStatus (SMP _ AUTH) = CISSndErrorAuth
agentErrToItemStatus err = CISSndError . T.unpack . safeDecodeUtf8 $ strEncode err
badRcvFileChunk :: RcvFileTransfer -> String -> CM ()
src/Simplex/Chat/AppSettings.hs
+8 -1
View File
@@ -9,6 +9,7 @@ import Control.Applicative ((<|>))
import Data.Aeson (FromJSON (..), (.:?))
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Simplex.Chat.Types.UITheme
@@ -48,7 +49,8 @@ data AppSettings = AppSettings
uiProfileImageCornerRadius :: Maybe Double,
uiColorScheme :: Maybe UIColorScheme,
uiDarkColorScheme :: Maybe DarkColorScheme,
uiThemes :: Maybe UIThemes
uiCurrentThemeIds :: Maybe (Map ThemeColorScheme Text),
uiThemes :: Maybe [UITheme]
}
deriving (Show)
@@ -78,6 +80,7 @@ defaultAppSettings =
uiProfileImageCornerRadius = Just 22.5,
uiColorScheme = Just UCSSystem,
uiDarkColorScheme = Just DCSSimplex,
uiCurrentThemeIds = Nothing,
uiThemes = Nothing
}
@@ -107,6 +110,7 @@ defaultParseAppSettings =
uiProfileImageCornerRadius = Nothing,
uiColorScheme = Nothing,
uiDarkColorScheme = Nothing,
uiCurrentThemeIds = Nothing,
uiThemes = Nothing
}
@@ -136,6 +140,7 @@ combineAppSettings platformDefaults storedSettings =
uiProfileImageCornerRadius = p uiProfileImageCornerRadius,
uiColorScheme = p uiColorScheme,
uiDarkColorScheme = p uiDarkColorScheme,
uiCurrentThemeIds = p uiCurrentThemeIds,
uiThemes = p uiThemes
}
where
@@ -177,6 +182,7 @@ instance FromJSON AppSettings where
uiProfileImageCornerRadius <- p "uiProfileImageCornerRadius"
uiColorScheme <- p "uiColorScheme"
uiDarkColorScheme <- p "uiDarkColorScheme"
uiCurrentThemeIds <- p "uiCurrentThemeIds"
uiThemes <- p "uiThemes"
pure
AppSettings
@@ -203,6 +209,7 @@ instance FromJSON AppSettings where
uiProfileImageCornerRadius,
uiColorScheme,
uiDarkColorScheme,
uiCurrentThemeIds,
uiThemes
}
where
src/Simplex/Chat/Messages.hs
+1
View File
@@ -45,6 +45,7 @@ import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Util (textParseJSON)
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptStatus (..))
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import qualified Simplex.Messaging.Crypto.File as CF
src/Simplex/Chat/Types.hs
-4
View File
@@ -27,7 +27,6 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.TH as JQ
import qualified Data.Aeson.Types as JT
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString, pack, unpack)
import Data.Int (Int64)
@@ -1480,9 +1479,6 @@ serializeIntroStatus = \case
GMIntroToConnected -> "to-con"
GMIntroConnected -> "con"
textParseJSON :: TextEncoding a => String -> J.Value -> JT.Parser a
textParseJSON name = J.withText name $ maybe (fail $ "bad " <> name) pure . textDecode
data NetworkStatus
= NSUnknown
| NSConnected
src/Simplex/Chat/Types/UITheme.hs
+61 -55
View File
@@ -7,26 +7,21 @@ module Simplex.Chat.Types.UITheme where
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.Key as JK
import qualified Data.Aeson.TH as JQ
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import Simplex.Chat.Types.Util
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_)
import Simplex.Messaging.Util ((<$?>))
data UIThemes = UIThemes
{ light :: Maybe UITheme,
dark :: Maybe UITheme,
simplex :: Maybe UITheme
}
deriving (Eq, Show)
data UITheme = UITheme
{ base :: ThemeColorScheme,
{ themeId :: Text,
base :: ThemeColorScheme,
wallpaper :: Maybe ChatWallpaper,
colors :: UIColors
}
@@ -48,40 +43,72 @@ data UIThemeEntityOverride = UIThemeEntityOverride
}
deriving (Eq, Show)
data ThemeColorScheme = TCSLight | TCSDark | TCSSimplex
deriving (Eq, Show)
data DarkColorScheme = DCSDark | DCSBlack | DCSSimplex
deriving (Eq, Ord, Show)
data UIColorScheme
= UCSSystem
| UCSLight
| UCSDark
| UCSSimplex
deriving (Show)
data ThemeColorScheme = TCSLight | TCSDark DarkColorScheme
deriving (Eq, Ord, Show)
data DarkColorScheme = DCSDark | DCSSimplex
deriving (Show)
data UIColorScheme = UCSSystem | UCSFixed ThemeColorScheme
deriving (Eq, Ord, Show)
instance StrEncoding ThemeColorScheme where
strEncode = \case
instance TextEncoding DarkColorScheme where
textEncode = \case
DCSDark -> "DARK"
DCSBlack -> "BLACK"
DCSSimplex -> "SIMPLEX"
textDecode s =
Just $ case s of
"DARK" -> DCSDark
"BLACK" -> DCSBlack
"SIMPLEX" -> DCSSimplex
_ -> DCSDark
instance TextEncoding ThemeColorScheme where
textEncode = \case
TCSLight -> "LIGHT"
TCSDark -> "DARK"
TCSSimplex -> "SIMPLEX"
strDecode = \case
"LIGHT" -> Right TCSLight
"DARK" -> Right TCSDark
"SIMPLEX" -> Right TCSSimplex
_ -> Left "bad ColorScheme"
strP = strDecode <$?> A.takeTill (== ' ')
TCSDark s -> textEncode s
textDecode = \case
"LIGHT" -> Just TCSLight
s -> TCSDark <$> textDecode s
instance TextEncoding UIColorScheme where
textEncode = \case
UCSSystem -> "SYSTEM"
UCSFixed s -> textEncode s
textDecode = \case
"SYSTEM" -> Just UCSSystem
s -> UCSFixed <$> textDecode s
instance FromJSON DarkColorScheme where
parseJSON = textParseJSON "DarkColorScheme"
instance ToJSON DarkColorScheme where
toJSON = J.String . textEncode
toEncoding = JE.text . textEncode
instance FromJSON ThemeColorScheme where
parseJSON = strParseJSON "ThemeColorScheme"
parseJSON = textParseJSON "ThemeColorScheme"
instance ToJSON ThemeColorScheme where
toJSON = strToJSON
toEncoding = strToJEncoding
toJSON = J.String . textEncode
toEncoding = JE.text . textEncode
instance FromJSON UIColorScheme where
parseJSON = textParseJSON "UIColorScheme"
instance ToJSON UIColorScheme where
toJSON = J.String . textEncode
toEncoding = JE.text . textEncode
instance J.FromJSONKey ThemeColorScheme where
fromJSONKey = J.FromJSONKeyText $ fromMaybe (TCSDark DCSDark) . textDecode
instance J.ToJSONKey ThemeColorScheme where
toJSONKey = J.ToJSONKeyText (JK.fromText . textEncode) (JE.text . textEncode)
data ChatWallpaper = ChatWallpaper
{ preset :: Maybe ChatWallpaperPreset,
{ preset :: Maybe Text,
imageFile :: Maybe FilePath,
background :: Maybe UIColor,
tint :: Maybe UIColor,
@@ -109,19 +136,6 @@ data UIColors = UIColors
defaultUIColors :: UIColors
defaultUIColors = UIColors Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
data ChatWallpaperPreset
= CWPKids
| CWPCats
| CWPPets
| CWPFlowers
| CWPHearts
| CWPSocial
| CWPTravel
| CWPInternet
| CWPSpace
| CWPSchool
deriving (Eq, Show)
newtype UIColor = UIColor String
deriving (Eq, Show)
@@ -137,16 +151,10 @@ instance ToJSON UIColor where
toJSON (UIColor t) = J.toJSON t
toEncoding (UIColor t) = J.toEncoding t
$(JQ.deriveJSON (enumJSON $ dropPrefix "DCS") ''DarkColorScheme)
$(JQ.deriveJSON (enumJSON $ dropPrefix "UCM") ''UIColorMode)
$(JQ.deriveJSON (enumJSON $ dropPrefix "UCS") ''UIColorScheme)
$(JQ.deriveJSON (enumJSON $ dropPrefix "CWS") ''ChatWallpaperScale)
$(JQ.deriveJSON (enumJSON $ dropPrefix "CWP") ''ChatWallpaperPreset)
$(JQ.deriveJSON defaultJSON ''ChatWallpaper)
$(JQ.deriveJSON defaultJSON ''UIColors)
@@ -157,8 +165,6 @@ $(JQ.deriveJSON defaultJSON ''UIThemeEntityOverrides)
$(JQ.deriveJSON defaultJSON ''UITheme)
$(JQ.deriveJSON defaultJSON ''UIThemes)
instance ToField UIThemeEntityOverrides where
toField = toField . encodeJSON
src/Simplex/Chat/Types/Util.hs
+5
View File
@@ -4,6 +4,7 @@ module Simplex.Chat.Types.Util where
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as J
import qualified Data.Aeson.Types as JT
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Text (Text)
@@ -13,6 +14,7 @@ import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField (FieldParser, returnError)
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok (Ok (Ok))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Util (safeDecodeUtf8)
encodeJSON :: ToJSON a => a -> Text
@@ -21,6 +23,9 @@ encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode
decodeJSON :: FromJSON a => Text -> Maybe a
decodeJSON = J.decode . LB.fromStrict . encodeUtf8
textParseJSON :: TextEncoding a => String -> J.Value -> JT.Parser a
textParseJSON name = J.withText name $ maybe (fail $ "bad " <> name) pure . textDecode
fromBlobField_ :: Typeable k => (ByteString -> Either String k) -> FieldParser k
fromBlobField_ p = \case
f@(Field (SQLBlob b) _) ->
src/Simplex/Chat/View.hs
+4 -4
View File
@@ -50,7 +50,7 @@ import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.UITheme
import qualified Simplex.FileTransfer.Transport as XFTPTransport
import qualified Simplex.FileTransfer.Transport as XFTP
import Simplex.Messaging.Agent.Client (ActivePendingSubs (..), ProtocolTestFailure (..), ProtocolTestStep (..), SubInfo (..), SubscriptionsInfo (..))
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
import Simplex.Messaging.Agent.Protocol
@@ -1174,8 +1174,8 @@ viewServerTestResult :: AProtoServerWithAuth -> Maybe ProtocolTestFailure -> [St
viewServerTestResult (AProtoServerWithAuth p _) = \case
Just ProtocolTestFailure {testStep, testError} ->
result
<> [pName <> " server requires authorization to create queues, check password" | testStep == TSCreateQueue && testError == SMP SMP.AUTH]
<> [pName <> " server requires authorization to upload files, check password" | testStep == TSCreateFile && testError == XFTP XFTPTransport.AUTH]
<> [pName <> " server requires authorization to create queues, check password" | testStep == TSCreateQueue && (case testError of SMP _ SMP.AUTH -> True; _ -> False)]
<> [pName <> " server requires authorization to upload files, check password" | testStep == TSCreateFile && (case testError of XFTP _ XFTP.AUTH -> True; _ -> False)]
<> ["Possibly, certificate fingerprint in " <> pName <> " server address is incorrect" | testStep == TSConnect && brokerErr]
where
result = [pName <> " server test failed at " <> plain (drop 2 $ show testStep) <> ", error: " <> plain (strEncode testError)]
@@ -2020,7 +2020,7 @@ viewChatError logLevel testView = \case
e -> ["chat database error: " <> sShow e]
ChatErrorAgent err entity_ -> case err of
CMD PROHIBITED -> [withConnEntity <> "error: command is prohibited"]
SMP SMP.AUTH ->
SMP _ SMP.AUTH ->
[ withConnEntity
<> "error: connection authorization failed - this could happen if connection was deleted,\
\ secured with different credentials, or due to a bug - please re-create the connection"