core: save app themes as map with any text key (#4159)

* core: save app themes as map with any text key

* remove theme preset name

* list of themes

* theme id

* theme IDs

* moar

* colors

* default to dark

* fix

src/Simplex/Chat/AppSettings.hs

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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) _) ->