switch to JSON single field encodings for sum types to align with Swi…

…ft enums (#229)

src/Simplex/Chat.hs

@@ -777,7 +777,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
     notifyMemberConnected :: GroupInfo -> GroupMember -> m ()
     notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} = do
       toView $ CRConnectedToGroupMember gInfo m
-      let g = groupName gInfo
+      let g = groupName' gInfo
       setActive $ ActiveG g
       showToast ("#" <> g) $ "member " <> c <> " is connected"
 
@@ -812,7 +812,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
     newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msgId msgMeta = do
       ci <- saveRcvGroupChatItem userId gInfo m msgId msgMeta (CIMsgContent mc)
       toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci
-      let g = groupName gInfo
+      let g = groupName' gInfo
       showToast ("#" <> g <> " " <> c <> "> ") $ msgContentText mc
       setActive $ ActiveG g
 
@@ -834,7 +834,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
       ci <- saveRcvGroupChatItem userId gInfo m msgId msgMeta (CIRcvFileInvitation ft)
       withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId ci
       toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci
-      let g = groupName gInfo
+      let g = groupName' gInfo
       showToast ("#" <> g <> " " <> c <> "> ") "wants to send a file"
       setActive $ ActiveG g
 

src/Simplex/Chat/Controller.hs

@@ -23,11 +23,12 @@ import Numeric.Natural
 import Simplex.Chat.Messages
 import Simplex.Chat.Store (StoreError)
 import Simplex.Chat.Types
+import Simplex.Chat.Util (enumJSON, singleFieldJSON)
 import Simplex.Messaging.Agent (AgentClient)
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig)
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
-import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
+import Simplex.Messaging.Parsers (dropPrefix)
 import Simplex.Messaging.Protocol (CorrId)
 import System.IO (Handle)
 import UnliftIO.STM
@@ -72,8 +73,8 @@ data HelpSection = HSMain | HSFiles | HSGroups | HSMyAddress | HSMarkdown
   deriving (Show, Generic)
 
 instance ToJSON HelpSection where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "HS"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "HS"
+  toJSON = J.genericToJSON . enumJSON $ dropPrefix "HS"
+  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HS"
 
 data ChatCommand
   = ChatHelp HelpSection
@@ -113,8 +114,8 @@ data ChatCommand
 data ChatResponse
   = CRNewChatItem {chatItem :: AChatItem}
   | CRCmdAccepted {corr :: CorrId}
-  | CRChatHelp HelpSection
-  | CRWelcome User
+  | CRChatHelp {helpSection :: HelpSection}
+  | CRWelcome {user :: User}
   | CRGroupCreated {groupInfo :: GroupInfo}
   | CRGroupMembers {group :: Group}
   | CRContactsList {contacts :: [Contact]}
@@ -181,19 +182,19 @@ data ChatResponse
   deriving (Show, Generic)
 
 instance ToJSON ChatResponse where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR"
+  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "CR"
+  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "CR"
 
 data ChatError
-  = ChatError ChatErrorType
-  | ChatErrorMessage String
-  | ChatErrorAgent AgentErrorType
-  | ChatErrorStore StoreError
+  = ChatError {errorType :: ChatErrorType}
+  | ChatErrorMessage {errorMessage :: String}
+  | ChatErrorAgent {agentError :: AgentErrorType}
+  | ChatErrorStore {storeError :: StoreError}
   deriving (Show, Exception, Generic)
 
 instance ToJSON ChatError where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "Chat"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "Chat"
+  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "Chat"
+  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "Chat"
 
 data ChatErrorType
   = CEGroupUserRole
@@ -222,8 +223,8 @@ data ChatErrorType
   deriving (Show, Exception, Generic)
 
 instance ToJSON ChatErrorType where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CE"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CE"
+  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "CE"
+  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "CE"
 
 type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
 

src/Simplex/Chat/Messages.hs

@@ -30,10 +30,11 @@ import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.Generics (Generic)
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
+import Simplex.Chat.Util (enumJSON, singleFieldJSON)
 import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgIntegrity, MsgMeta (..))
 import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
+import Simplex.Messaging.Parsers (dropPrefix)
 import Simplex.Messaging.Protocol (MsgBody)
 
 data ChatType = CTDirect | CTGroup
@@ -51,8 +52,8 @@ data JSONChatInfo
   deriving (Generic)
 
 instance ToJSON JSONChatInfo where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCInfo"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCInfo"
+  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "JCInfo"
+  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "JCInfo"
 
 instance ToJSON (ChatInfo c) where
   toJSON = J.toJSON . jsonChatInfo
@@ -73,24 +74,26 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) where
 deriving instance Show (ChatItem c d)
 
 data JSONChatItem d
-  = JCItemDirect {meta :: CIMeta d, content :: CIContent d}
-  | JCItemSndGroup {meta :: CIMeta d, content :: CIContent d}
-  | JCItemRcvGroup {member :: GroupMember, meta :: CIMeta d, content :: CIContent d}
+  = JCItemDirect {dir :: MsgDirection, meta :: CIMeta d, content :: CIContent d}
+  | JCItemSndGroup {dir :: MsgDirection, meta :: CIMeta d, content :: CIContent d}
+  | JCItemRcvGroup {dir :: MsgDirection, member :: GroupMember, meta :: CIMeta d, content :: CIContent d}
   deriving (Generic)
 
 instance ToJSON (JSONChatItem d) where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCItem"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCItem"
+  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "JCItem"
+  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "JCItem"
 
-instance ToJSON (ChatItem c d) where
+instance MsgDirectionI d => ToJSON (ChatItem c d) where
   toJSON = J.toJSON . jsonChatItem
   toEncoding = J.toEncoding . jsonChatItem
 
-jsonChatItem :: ChatItem c d -> JSONChatItem d
+jsonChatItem :: forall c d. MsgDirectionI d => ChatItem c d -> JSONChatItem d
 jsonChatItem = \case
-  DirectChatItem meta cic -> JCItemDirect meta cic
-  SndGroupChatItem meta cic -> JCItemSndGroup meta cic
-  RcvGroupChatItem m meta cic -> JCItemRcvGroup m meta cic
+  DirectChatItem meta cic -> JCItemDirect md meta cic
+  SndGroupChatItem meta cic -> JCItemSndGroup md meta cic
+  RcvGroupChatItem m meta cic -> JCItemRcvGroup md m meta cic
+  where
+    md = toMsgDirection $ msgDirection @d
 
 data CChatItem c = forall d. CChatItem (SMsgDirection d) (ChatItem c d)
 
@@ -128,7 +131,7 @@ data AChatPreview = forall c. AChatPreview (SChatType c) (ChatInfo c) (Maybe (CC
 deriving instance Show AChatPreview
 
 -- | type to show a mix of messages from multiple chats
-data AChatItem = forall c d. AChatItem (SChatType c) (SMsgDirection d) (ChatInfo c) (ChatItem c d)
+data AChatItem = forall c d. MsgDirectionI d => AChatItem (SChatType c) (SMsgDirection d) (ChatInfo c) (ChatItem c d)
 
 deriving instance Show AChatItem
 
@@ -139,7 +142,7 @@ instance ToJSON AChatItem where
 data JSONAnyChatItem c d = JSONAnyChatItem {chatInfo :: ChatInfo c, chatItem :: ChatItem c d}
   deriving (Generic)
 
-instance ToJSON (JSONAnyChatItem c d) where
+instance MsgDirectionI d => ToJSON (JSONAnyChatItem c d) where
   toJSON = J.genericToJSON J.defaultOptions
   toEncoding = J.genericToEncoding J.defaultOptions
 
@@ -159,8 +162,8 @@ data JSONCIMeta
   deriving (Generic)
 
 instance ToJSON JSONCIMeta where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCIMeta"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCIMeta"
+  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "JCIMeta"
+  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "JCIMeta"
 
 jsonCIMeta :: CIMeta d -> JSONCIMeta
 jsonCIMeta = \case
@@ -201,8 +204,8 @@ data JSONCIContent
   deriving (Generic)
 
 instance ToJSON JSONCIContent where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCI"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCI"
+  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "JCI"
+  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "JCI"
 
 jsonCIContent :: CIContent d -> JSONCIContent
 jsonCIContent = \case
@@ -251,7 +254,14 @@ data PendingGroupMessage = PendingGroupMessage
 type MessageId = Int64
 
 data MsgDirection = MDRcv | MDSnd
-  deriving (Show)
+  deriving (Show, Generic)
+
+instance FromJSON MsgDirection where
+  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "MD"
+
+instance ToJSON MsgDirection where
+  toJSON = J.genericToJSON . enumJSON $ dropPrefix "MD"
+  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MD"
 
 data SMsgDirection (d :: MsgDirection) where
   SMDRcv :: SMsgDirection 'MDRcv
@@ -271,6 +281,11 @@ instance MsgDirectionI 'MDRcv where msgDirection = SMDRcv
 
 instance MsgDirectionI 'MDSnd where msgDirection = SMDSnd
 
+toMsgDirection :: SMsgDirection d -> MsgDirection
+toMsgDirection = \case
+  SMDRcv -> MDRcv
+  SMDSnd -> MDSnd
+
 instance ToField MsgDirection where toField = toField . msgDirectionInt
 
 msgDirectionInt :: MsgDirection -> Int

src/Simplex/Chat/Store.hs

@@ -138,11 +138,12 @@ import Simplex.Chat.Migrations.M20220122_pending_group_messages
 import Simplex.Chat.Migrations.M20220125_chat_items
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
+import Simplex.Chat.Util (singleFieldJSON)
 import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, InvitationId, MsgMeta (..))
 import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, firstRow, withTransaction)
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
+import Simplex.Messaging.Parsers (dropPrefix)
 import Simplex.Messaging.Util (liftIOEither, (<$$>))
 import System.FilePath (takeFileName)
 import UnliftIO.STM
@@ -1984,28 +1985,28 @@ randomBytes gVar n = B64.encode <$> (atomically . stateTVar gVar $ randomBytesGe
 
 data StoreError
   = SEDuplicateName
-  | SEContactNotFound ContactName
-  | SEContactNotReady ContactName
+  | SEContactNotFound {contactName :: ContactName}
+  | SEContactNotReady {contactName :: ContactName}
   | SEDuplicateContactLink
   | SEUserContactLinkNotFound
-  | SEContactRequestNotFound ContactName
-  | SEGroupNotFound GroupName
+  | SEContactRequestNotFound {contactName :: ContactName}
+  | SEGroupNotFound {groupName :: GroupName}
   | SEGroupWithoutUser
   | SEDuplicateGroupMember
   | SEGroupAlreadyJoined
   | SEGroupInvitationNotFound
-  | SESndFileNotFound Int64
-  | SESndFileInvalid Int64
-  | SERcvFileNotFound Int64
-  | SEFileNotFound Int64
-  | SERcvFileInvalid Int64
-  | SEConnectionNotFound AgentConnId
+  | SESndFileNotFound {fileId :: FileTransferId}
+  | SESndFileInvalid {fileId :: FileTransferId}
+  | SERcvFileNotFound {fileId :: FileTransferId}
+  | SEFileNotFound {fileId :: FileTransferId}
+  | SERcvFileInvalid {fileId :: FileTransferId}
+  | SEConnectionNotFound {agentConnId :: AgentConnId}
   | SEIntroNotFound
   | SEUniqueID
-  | SEInternal String
-  | SENoMsgDelivery Int64 AgentMsgId
+  | SEInternal {message :: String}
+  | SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId}
   deriving (Show, Exception, Generic)
 
 instance ToJSON StoreError where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SE"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SE"
+  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "SE"
+  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "SE"

src/Simplex/Chat/Terminal.hs

@@ -25,12 +25,12 @@ simplexChat cfg opts t
       sendNotification' <- initializeNotifications
       let f = chatStoreFile $ dbFilePrefix opts
       st <- createStore f $ dbPoolSize cfg
-      user <- getCreateActiveUser st
+      u <- getCreateActiveUser st
       ct <- newChatTerminal t
-      cc <- newChatController st user cfg opts sendNotification'
-      runSimplexChat user ct cc
+      cc <- newChatController st u cfg opts sendNotification'
+      runSimplexChat u ct cc
 
 runSimplexChat :: User -> ChatTerminal -> ChatController -> IO ()
-runSimplexChat user ct = runReaderT $ do
-  whenM (asks firstTime) . liftIO . printToTerminal ct $ chatWelcome user
+runSimplexChat u ct = runReaderT $ do
+  whenM (asks firstTime) . liftIO . printToTerminal ct $ chatWelcome u
   raceAny_ [runTerminalInput ct, runTerminalOutput ct, runInputLoop ct, runChatController]

src/Simplex/Chat/Types.hs

@@ -32,10 +32,11 @@ import Database.SQLite.Simple.Internal (Field (..))
 import Database.SQLite.Simple.Ok (Ok (Ok))
 import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.Generics (Generic)
+import Simplex.Chat.Util (singleFieldJSON)
 import Simplex.Messaging.Agent.Protocol (ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId)
 import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
+import Simplex.Messaging.Parsers (dropPrefix)
 import Simplex.Messaging.Util ((<$?>))
 
 class IsContact a where
@@ -120,8 +121,8 @@ data GroupInfo = GroupInfo
 
 instance ToJSON GroupInfo where toEncoding = J.genericToEncoding J.defaultOptions
 
-groupName :: GroupInfo -> GroupName
-groupName GroupInfo {localDisplayName = g} = g
+groupName' :: GroupInfo -> GroupName
+groupName' GroupInfo {localDisplayName = g} = g
 
 data Profile = Profile
   { displayName :: ContactName,
@@ -243,11 +244,11 @@ data InvitedBy = IBContact {byContactId :: Int64} | IBUser | IBUnknown
   deriving (Eq, Show, Generic)
 
 instance FromJSON InvitedBy where
-  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "IB"
+  parseJSON = J.genericParseJSON . singleFieldJSON $ dropPrefix "IB"
 
 instance ToJSON InvitedBy where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "IB"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "IB"
+  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "IB"
+  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "IB"
 
 toInvitedBy :: Int64 -> Maybe Int64 -> InvitedBy
 toInvitedBy userCtId (Just ctId)
@@ -483,11 +484,11 @@ data RcvFileStatus
   deriving (Eq, Show, Generic)
 
 instance FromJSON RcvFileStatus where
-  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RFS"
+  parseJSON = J.genericParseJSON . singleFieldJSON $ dropPrefix "RFS"
 
 instance ToJSON RcvFileStatus where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RFS"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RFS"
+  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "RFS"
+  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "RFS"
 
 data RcvFileInfo = RcvFileInfo
   { filePath :: FilePath,
@@ -521,8 +522,8 @@ data FileTransfer = FTSnd {sndFileTransfers :: [SndFileTransfer]} | FTRcv RcvFil
   deriving (Show, Generic)
 
 instance ToJSON FileTransfer where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "FT"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "FT"
+  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "FT"
+  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "FT"
 
 data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Ord, Show)
 

src/Simplex/Chat/Util.hs

@@ -1,6 +1,7 @@
 module Simplex.Chat.Util where
 
 import Control.Monad (when)
+import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8With)
@@ -18,3 +19,18 @@ whenM ba a = ba >>= (`when` a)
 
 unlessM :: Monad m => m Bool -> m () -> m ()
 unlessM b = ifM b $ pure ()
+
+enumJSON :: (String -> String) -> J.Options
+enumJSON tagModifier =
+  J.defaultOptions
+    { J.constructorTagModifier = tagModifier,
+      J.allNullaryToStringTag = True
+    }
+
+singleFieldJSON :: (String -> String) -> J.Options
+singleFieldJSON tagModifier =
+  J.defaultOptions
+    { J.constructorTagModifier = tagModifier,
+      J.sumEncoding = J.ObjectWithSingleField,
+      J.omitNothingFields = True
+    }