Merge branch 'master' into master-ghc8107

src/Simplex/Chat.hs

@@ -43,7 +43,7 @@ import qualified Data.Map.Strict as M
 import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime)
 import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay, nominalDiffTimeToSeconds)
 import Data.Time.Clock.System (SystemTime, systemToUTCTime)
@@ -52,12 +52,16 @@ import qualified Database.SQLite.Simple as SQL
 import Simplex.Chat.Archive
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
+import Simplex.Chat.Files
 import Simplex.Chat.Markdown
 import Simplex.Chat.Messages
 import Simplex.Chat.Messages.CIContent
+import Simplex.Chat.Messages.CIContent.Events
 import Simplex.Chat.Options
 import Simplex.Chat.ProfileGenerator (generateRandomProfile)
 import Simplex.Chat.Protocol
+import Simplex.Chat.Remote
+import Simplex.Chat.Remote.Types
 import Simplex.Chat.Store
 import Simplex.Chat.Store.Connections
 import Simplex.Chat.Store.Direct
@@ -96,13 +100,14 @@ import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport.Client (defaultSocksProxy)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
-import System.Exit (exitFailure, exitSuccess)
-import System.FilePath (combine, splitExtensions, takeFileName, (</>))
+import System.Exit (ExitCode, exitFailure, exitSuccess)
+import System.FilePath (takeFileName, (</>))
 import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout)
 import System.Random (randomRIO)
 import Text.Read (readMaybe)
 import UnliftIO.Async
 import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay)
+import qualified UnliftIO.Exception as E
 import UnliftIO.Directory
 import UnliftIO.IO (hClose, hSeek, hTell, openFile)
 import UnliftIO.STM
@@ -191,6 +196,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
       config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable}
       firstTime = dbNew chatStore
   currentUser <- newTVarIO user
+  currentRemoteHost <- newTVarIO Nothing
   servers <- agentServers config
   smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore
   agentAsync <- newTVarIO Nothing
@@ -203,6 +209,12 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
   sndFiles <- newTVarIO M.empty
   rcvFiles <- newTVarIO M.empty
   currentCalls <- atomically TM.empty
+  localDeviceName <- newTVarIO "" -- TODO set in config
+  multicastSubscribers <- newTMVarIO 0
+  remoteSessionSeq <- newTVarIO 0
+  remoteHostSessions <- atomically TM.empty
+  remoteHostsFolder <- newTVarIO Nothing
+  remoteCtrlSession <- newTVarIO Nothing
   filesFolder <- newTVarIO optFilesFolder
   chatStoreChanged <- newTVarIO False
   expireCIThreads <- newTVarIO M.empty
@@ -216,8 +228,10 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
   contactMergeEnabled <- newTVarIO True
   pure
     ChatController
-      { firstTime,
+      {
+        firstTime,
         currentUser,
+        currentRemoteHost,
         smpAgent,
         agentAsync,
         chatStore,
@@ -231,6 +245,12 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
         sndFiles,
         rcvFiles,
         currentCalls,
+        localDeviceName,
+        multicastSubscribers,
+        remoteSessionSeq,
+        remoteHostSessions,
+        remoteHostsFolder,
+        remoteCtrlSession,
         config,
         filesFolder,
         expireCIThreads,
@@ -354,7 +374,9 @@ restoreCalls = do
   atomically $ writeTVar calls callsMap
 
 stopChatController :: forall m. MonadUnliftIO m => ChatController -> m ()
-stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags} = do
+stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do
+  readTVarIO remoteHostSessions >>= mapM_ (liftIO . cancelRemoteHost False . snd)
+  atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (liftIO . cancelRemoteCtrl False . snd)
   disconnectAgentClient smpAgent
   readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2)
   closeFiles sndFiles
@@ -370,22 +392,38 @@ stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles,
       mapM_ hClose fs
       atomically $ writeTVar files M.empty
 
-execChatCommand :: ChatMonad' m => ByteString -> m ChatResponse
-execChatCommand s = do
+execChatCommand :: ChatMonad' m => Maybe RemoteHostId -> ByteString -> m ChatResponse
+execChatCommand rh s = do
   u <- readTVarIO =<< asks currentUser
   case parseChatCommand s of
     Left e -> pure $ chatCmdError u e
-    Right cmd -> execChatCommand_ u cmd
+    Right cmd -> case rh of
+      Just rhId
+        | allowRemoteCommand cmd -> execRemoteCommand u rhId cmd s
+        | otherwise -> pure $ CRChatCmdError u $ ChatErrorRemoteHost (RHId rhId) $ RHELocalCommand
+      _ -> execChatCommand_ u cmd
 
 execChatCommand' :: ChatMonad' m => ChatCommand -> m ChatResponse
 execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd)
 
 execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse
-execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd)
+execChatCommand_ u cmd = handleCommandError u $ processChatCommand cmd
+
+execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> ChatCommand -> ByteString -> m ChatResponse
+execRemoteCommand u rhId cmd s = handleCommandError u $ getRemoteHostClient rhId >>= \rh -> processRemoteCommand rhId rh cmd s
+
+handleCommandError :: ChatMonad' m => Maybe User -> ExceptT ChatError m ChatResponse -> m ChatResponse
+handleCommandError u a = either (CRChatCmdError u) id <$> (runExceptT a `E.catches` ioErrors)
+  where
+    ioErrors =
+      [ E.Handler $ \(e :: ExitCode) -> E.throwIO e,
+        E.Handler $ pure . Left . mkChatError
+      ]
 
 parseChatCommand :: ByteString -> Either String ChatCommand
 parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
 
+-- | Chat API commands interpreted in context of a local zone
 processChatCommand :: forall m. ChatMonad m => ChatCommand -> m ChatResponse
 processChatCommand = \case
   ShowActiveUser -> withUser' $ pure . CRActiveUser
@@ -516,6 +554,10 @@ processChatCommand = \case
     createDirectoryIfMissing True ff
     asks filesFolder >>= atomically . (`writeTVar` Just ff)
     ok_
+  SetRemoteHostsFolder rf -> do
+    createDirectoryIfMissing True rf
+    chatWriteVar remoteHostsFolder $ Just rf
+    ok_
   APISetXFTPConfig cfg -> do
     asks userXFTPFileConfig >>= atomically . (`writeTVar` cfg)
     ok_
@@ -1802,15 +1844,15 @@ processChatCommand = \case
     asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_
   SendFile chatName f -> withUser $ \user -> do
     chatRef <- getChatRef user chatName
-    processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCFile "")
-  SendImage chatName f -> withUser $ \user -> do
+    processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCFile "")
+  SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do
     chatRef <- getChatRef user chatName
-    filePath <- toFSFilePath f
-    unless (any (`isSuffixOf` map toLower f) imageExtensions) $ throwChatError CEFileImageType {filePath}
+    filePath <- toFSFilePath fPath
+    unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath}
     fileSize <- getFileSize filePath
     unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
     -- TODO include file description for preview
-    processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCImage "" fixedImagePreview)
+    processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview)
   ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
   ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
   SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO"
@@ -1912,6 +1954,27 @@ processChatCommand = \case
     let pref = uncurry TimedMessagesGroupPreference $ maybe (FEOff, Just 86400) (\ttl -> (FEOn, Just ttl)) ttl_
     updateGroupProfileByName gName $ \p ->
       p {groupPreferences = Just . setGroupPreference' SGFTimedMessages pref $ groupPreferences p}
+  SetLocalDeviceName name -> withUser_ $ chatWriteVar localDeviceName name >> ok_
+  ListRemoteHosts -> withUser_ $ CRRemoteHostList <$> listRemoteHosts
+  SwitchRemoteHost rh_ -> withUser_ $ CRCurrentRemoteHost <$> switchRemoteHost rh_
+  StartRemoteHost rh_ -> withUser_ $ do
+    (remoteHost_, inv) <- startRemoteHost rh_
+    pure CRRemoteHostStarted {remoteHost_, invitation = decodeLatin1 $ strEncode inv}
+  StopRemoteHost rh_ -> withUser_ $ closeRemoteHost rh_ >> ok_
+  DeleteRemoteHost rh -> withUser_ $ deleteRemoteHost rh >> ok_
+  StoreRemoteFile rh encrypted_ localPath -> withUser_ $ CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath
+  GetRemoteFile rh rf -> withUser_ $ getRemoteFile rh rf >> ok_
+  ConnectRemoteCtrl inv -> withUser_ $ do
+    (remoteCtrl_, ctrlAppInfo) <- connectRemoteCtrlURI inv
+    pure CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion = currentAppVersion}
+  FindKnownRemoteCtrl -> withUser_ $ findKnownRemoteCtrl >> ok_
+  ConfirmRemoteCtrl rcId -> withUser_ $ do
+    (rc, ctrlAppInfo) <- confirmRemoteCtrl rcId
+    pure CRRemoteCtrlConnecting {remoteCtrl_ = Just rc, ctrlAppInfo, appVersion = currentAppVersion}
+  VerifyRemoteCtrlSession sessId -> withUser_ $ CRRemoteCtrlConnected <$> verifyRemoteCtrlSession (execChatCommand Nothing) sessId
+  StopRemoteCtrl -> withUser_ $ stopRemoteCtrl >> ok_
+  ListRemoteCtrls -> withUser_ $ CRRemoteCtrlList <$> listRemoteCtrls
+  DeleteRemoteCtrl rc -> withUser_ $ deleteRemoteCtrl rc >> ok_
   QuitChat -> liftIO exitSuccess
   ShowVersion -> do
     let versionInfo = coreVersionInfo $(simplexmqCommitQ)
@@ -2180,14 +2243,14 @@ processChatCommand = \case
     withServerProtocol p action = case userProtocol p of
       Just Dict -> action
       _ -> throwChatError $ CEServerProtocol $ AProtocolType p
-    forwardFile :: ChatName -> FileTransferId -> (ChatName -> FilePath -> ChatCommand) -> m ChatResponse
+    forwardFile :: ChatName -> FileTransferId -> (ChatName -> CryptoFile -> ChatCommand) -> m ChatResponse
     forwardFile chatName fileId sendCommand = withUser $ \user -> do
       withStore (\db -> getFileTransfer db user fileId) >>= \case
-        FTRcv RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}} -> forward filePath
-        FTSnd {fileTransferMeta = FileTransferMeta {filePath}} -> forward filePath
+        FTRcv RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}, cryptoArgs} -> forward filePath cryptoArgs
+        FTSnd {fileTransferMeta = FileTransferMeta {filePath, xftpSndFile}} -> forward filePath $ xftpSndFile >>= \f -> f.cryptoArgs
         _ -> throwChatError CEFileNotReceived {fileId}
       where
-        forward = processChatCommand . sendCommand chatName
+        forward path cfArgs = processChatCommand . sendCommand chatName $ CryptoFile path cfArgs
     getGroupAndMemberId :: User -> GroupName -> ContactName -> m (GroupId, GroupMemberId)
     getGroupAndMemberId user gName groupMemberName =
       withStore $ \db -> do
@@ -2587,10 +2650,9 @@ startReceivingFile user fileId = do
 getRcvFilePath :: forall m. ChatMonad m => FileTransferId -> Maybe FilePath -> String -> Bool -> m FilePath
 getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of
   Nothing ->
-    asks filesFolder >>= readTVarIO >>= \case
-      Nothing -> do
-        dir <- (`combine` "Downloads") <$> getHomeDirectory
-        ifM (doesDirectoryExist dir) (pure dir) getChatTempDirectory
+    chatReadVar filesFolder >>= \case
+      Nothing ->
+        getDefaultFilesFolder
           >>= (`uniqueCombine` fn)
           >>= createEmptyFile
       Just filesFolder ->
@@ -2619,18 +2681,6 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of
     getTmpHandle :: FilePath -> m Handle
     getTmpHandle fPath = openFile fPath AppendMode `catchThrow` (ChatError . CEFileInternal . show)
 
-uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
-uniqueCombine filePath fileName = tryCombine (0 :: Int)
-  where
-    tryCombine n =
-      let (name, ext) = splitExtensions fileName
-          suffix = if n == 0 then "" else "_" <> show n
-          f = filePath `combine` (name <> suffix <> ext)
-       in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f)
-
-getChatTempDirectory :: ChatMonad m => m FilePath
-getChatTempDirectory = chatReadVar tempDirectory >>= maybe getTemporaryDirectory pure
-
 acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> Maybe IncognitoProfile -> m Contact
 acceptContactRequest user UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = cp, userContactLinkId, xContactId} incognitoProfile = do
   subMode <- chatReadVar subscriptionMode
@@ -3195,10 +3245,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
         pure $ updateEntityConnStatus acEntity connStatus
       Nothing -> pure acEntity
 
-    isMember :: MemberId -> GroupInfo -> [GroupMember] -> Bool
-    isMember memId GroupInfo {membership} members =
-      sameMemberId memId membership || isJust (find (sameMemberId memId) members)
-
     agentMsgConnStatus :: ACommand 'Agent e -> Maybe ConnStatus
     agentMsgConnStatus = \case
       CONF {} -> Just ConnRequested
@@ -3476,7 +3522,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
           _ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok"
         pure ()
       CON -> do
-        members <- withStore' $ \db -> getGroupMembers db user gInfo
         withStore' $ \db -> do
           updateGroupMemberStatus db userId m GSMemConnected
           unless (memberActive membership) $
@@ -3496,6 +3541,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
             toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected}
             let Connection {viaUserContactLink} = conn
             when (isJust viaUserContactLink && isNothing (memberContactId m)) sendXGrpLinkMem
+            members <- withStore' $ \db -> getGroupMembers db user gInfo
             intros <- withStore' $ \db -> createIntroductions db members m
             void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m
             forM_ intros $ \intro ->
@@ -4886,11 +4932,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
     xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> RcvMessage -> UTCTime -> m ()
     xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ memberProfile) msg brokerTs = do
       checkHostRole m memRole
-      members <- withStore' $ \db -> getGroupMembers db user gInfo
       unless (sameMemberId memId $ membership gInfo) $
-        if isMember memId gInfo members
-          then messageError "x.grp.mem.new error: member already exists"
-          else do
+        withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case
+          Right _ -> messageError "x.grp.mem.new error: member already exists"
+          Left _ -> do
             newMember@GroupMember {groupMemberId} <- withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced
             ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent $ RGEMemberAdded groupMemberId memberProfile)
             groupMsgToView gInfo ci
@@ -4899,11 +4944,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
     xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> m ()
     xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _) = do
       case memberCategory m of
-        GCHostMember -> do
-          members <- withStore' $ \db -> getGroupMembers db user gInfo
-          if isMember memId gInfo members
-            then messageWarning "x.grp.mem.intro ignored: member already exists"
-            else do
+        GCHostMember ->
+          withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case
+            Right _ -> messageError "x.grp.mem.intro ignored: member already exists"
+            Left _ -> do
               when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c)
               subMode <- chatReadVar subscriptionMode
               -- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second
@@ -4929,11 +4973,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
     xGrpMemInv :: GroupInfo -> GroupMember -> MemberId -> IntroInvitation -> m ()
     xGrpMemInv gInfo@GroupInfo {groupId} m memId introInv = do
       case memberCategory m of
-        GCInviteeMember -> do
-          members <- withStore' $ \db -> getGroupMembers db user gInfo
-          case find (sameMemberId memId) members of
-            Nothing -> messageError "x.grp.mem.inv error: referenced member does not exist"
-            Just reMember -> do
+        GCInviteeMember ->
+          withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case
+            Left _ -> messageError "x.grp.mem.inv error: referenced member does not exist"
+            Right reMember -> do
               GroupMemberIntro {introId} <- withStore $ \db -> saveIntroInvitation db reMember m introInv
               void . sendGroupMessage' user [reMember] (XGrpMemFwd (memberInfo m) introInv) groupId (Just introId) $
                 withStore' $ \db -> updateIntroStatus db introId GMIntroInvForwarded
@@ -4942,14 +4985,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
     xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m ()
     xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
       checkHostRole m memRole
-      members <- withStore' $ \db -> getGroupMembers db user gInfo
-      toMember <- case find (sameMemberId memId) members of
-        -- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent
-        -- the situation when member does not exist is an error
-        -- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that.
-        -- For now, this branch compensates for the lack of delayed message delivery.
-        Nothing -> withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced
-        Just m' -> pure m'
+      toMember <-
+        withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case
+          -- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent
+          -- the situation when member does not exist is an error
+          -- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that.
+          -- For now, this branch compensates for the lack of delayed message delivery.
+          Left _ -> withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced
+          Right m' -> pure m'
       withStore' $ \db -> saveMemberInvitation db toMember introInv
       subMode <- chatReadVar subscriptionMode
       -- [incognito] send membership incognito profile, create direct connection as incognito
@@ -4966,11 +5009,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
       | memberId (membership :: GroupMember) == memId =
         let gInfo' = gInfo {membership = membership {memberRole = memRole}}
          in changeMemberRole gInfo' membership $ RGEUserRole memRole
-      | otherwise = do
-        members <- withStore' $ \db -> getGroupMembers db user gInfo
-        case find (sameMemberId memId) members of
-          Just member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole
-          _ -> messageError "x.grp.mem.role with unknown member ID"
+      | otherwise =
+        withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case
+          Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole
+          Left _ -> messageError "x.grp.mem.role with unknown member ID"
       where
         changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent
           | senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions"
@@ -5024,25 +5066,26 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
 
     xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> m ()
     xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg brokerTs = do
-      members <- withStore' $ \db -> getGroupMembers db user gInfo
       if memberId (membership :: GroupMember) == memId
         then checkRole membership $ do
           deleteGroupLinkIfExists user gInfo
           -- member records are not deleted to keep history
+          members <- withStore' $ \db -> getGroupMembers db user gInfo
           deleteMembersConnections user members
           withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved
           deleteMemberItem RGEUserDeleted
           toView $ CRDeletedMemberUser user gInfo {membership = membership {memberStatus = GSMemRemoved}} m
-        else case find (sameMemberId memId) members of
-          Nothing -> messageError "x.grp.mem.del with unknown member ID"
-          Just member@GroupMember {groupMemberId, memberProfile} ->
-            checkRole member $ do
-              -- ? prohibit deleting member if it's the sender - sender should use x.grp.leave
-              deleteMemberConnection user member
-              -- undeleted "member connected" chat item will prevent deletion of member record
-              deleteOrUpdateMemberRecord user member
-              deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)
-              toView $ CRDeletedMember user gInfo m member {memberStatus = GSMemRemoved}
+        else
+          withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case
+            Left _ -> messageError "x.grp.mem.del with unknown member ID"
+            Right member@GroupMember {groupMemberId, memberProfile} ->
+              checkRole member $ do
+                -- ? prohibit deleting member if it's the sender - sender should use x.grp.leave
+                deleteMemberConnection user member
+                -- undeleted "member connected" chat item will prevent deletion of member record
+                deleteOrUpdateMemberRecord user member
+                deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)
+                toView $ CRDeletedMember user gInfo m member {memberStatus = GSMemRemoved}
       where
         checkRole GroupMember {memberRole} a
           | senderRole < GRAdmin || senderRole < memberRole =
@@ -5411,9 +5454,6 @@ closeFileHandle fileId files = do
   h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m)
   liftIO $ mapM_ hClose h_ `catchAll_` pure ()
 
-throwChatError :: ChatMonad m => ChatErrorType -> m a
-throwChatError = throwError . ChatError
-
 deleteMembersConnections :: ChatMonad m => User -> [GroupMember] -> m ()
 deleteMembersConnections user members = do
   let memberConns =
@@ -5843,6 +5883,9 @@ withUser :: ChatMonad m => (User -> m ChatResponse) -> m ChatResponse
 withUser action = withUser' $ \user ->
   ifM chatStarted (action user) (throwChatError CEChatNotStarted)
 
+withUser_ :: ChatMonad m => m ChatResponse -> m ChatResponse
+withUser_ = withUser . const
+
 withUserId :: ChatMonad m => UserId -> (User -> m ChatResponse) -> m ChatResponse
 withUserId userId action = withUser $ \user -> do
   checkSameUser userId user
@@ -5859,12 +5902,6 @@ waitChatStarted = do
   agentStarted <- asks agentAsync
   atomically $ readTVar agentStarted >>= \a -> unless (isJust a) retry
 
-withAgent :: ChatMonad m => (AgentClient -> ExceptT AgentErrorType m a) -> m a
-withAgent action =
-  asks smpAgent
-    >>= runExceptT . action
-    >>= liftEither . first (`ChatErrorAgent` Nothing)
-
 chatCommandP :: Parser ChatCommand
 chatCommandP =
   choice
@@ -5903,6 +5940,7 @@ chatCommandP =
       "/_resubscribe all" $> ResubscribeAllConnections,
       "/_temp_folder " *> (SetTempFolder <$> filePath),
       ("/_files_folder " <|> "/files_folder ") *> (SetFilesFolder <$> filePath),
+      "/remote_hosts_folder " *> (SetRemoteHostsFolder <$> filePath),
       "/_xftp " *> (APISetXFTPConfig <$> ("on " *> (Just <$> jsonP) <|> ("off" $> Nothing))),
       "/xftp " *> (APISetXFTPConfig <$> ("on" *> (Just <$> xftpCfgP) <|> ("off" $> Nothing))),
       "/_files_encrypt " *> (APISetEncryptLocalFiles <$> onOffP),
@@ -6000,14 +6038,14 @@ chatCommandP =
       "/sync " *> char_ '@' *> (SyncContactRatchet <$> displayName <*> (" force=on" $> True <|> pure False)),
       "/_get code @" *> (APIGetContactCode <$> A.decimal),
       "/_get code #" *> (APIGetGroupMemberCode <$> A.decimal <* A.space <*> A.decimal),
-      "/_verify code @" *> (APIVerifyContact <$> A.decimal <*> optional (A.space *> textP)),
-      "/_verify code #" *> (APIVerifyGroupMember <$> A.decimal <* A.space <*> A.decimal <*> optional (A.space *> textP)),
+      "/_verify code @" *> (APIVerifyContact <$> A.decimal <*> optional (A.space *> verifyCodeP)),
+      "/_verify code #" *> (APIVerifyGroupMember <$> A.decimal <* A.space <*> A.decimal <*> optional (A.space *> verifyCodeP)),
       "/_enable @" *> (APIEnableContact <$> A.decimal),
       "/_enable #" *> (APIEnableGroupMember <$> A.decimal <* A.space <*> A.decimal),
       "/code " *> char_ '@' *> (GetContactCode <$> displayName),
       "/code #" *> (GetGroupMemberCode <$> displayName <* A.space <* char_ '@' <*> displayName),
-      "/verify " *> char_ '@' *> (VerifyContact <$> displayName <*> optional (A.space *> textP)),
-      "/verify #" *> (VerifyGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> optional (A.space *> textP)),
+      "/verify " *> char_ '@' *> (VerifyContact <$> displayName <*> optional (A.space *> verifyCodeP)),
+      "/verify #" *> (VerifyGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> optional (A.space *> verifyCodeP)),
       "/enable " *> char_ '@' *> (EnableContact <$> displayName),
       "/enable #" *> (EnableGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName),
       ("/help files" <|> "/help file" <|> "/hf") $> ChatHelp HSFiles,
@@ -6058,7 +6096,7 @@ chatCommandP =
       "/_connect " *> (APIConnect <$> A.decimal <*> incognitoOnOffP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
       "/_connect " *> (APIAddContact <$> A.decimal <*> incognitoOnOffP),
       "/_set incognito :" *> (APISetConnectionIncognito <$> A.decimal <* A.space <*> onOffP),
-      ("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
+      ("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeTill isSpace $> Nothing)),
       ("/connect" <|> "/c") *> (AddContact <$> incognitoP),
       SendMessage <$> chatNameP <* A.space <*> msgTextP,
       "@#" *> (SendMemberContactMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> msgTextP),
@@ -6077,8 +6115,8 @@ chatCommandP =
       "/show" *> (ShowLiveItems <$> (A.space *> onOffP <|> pure True)),
       "/show " *> (ShowChatItem . Just <$> A.decimal),
       "/item info " *> (ShowChatItemInfo <$> chatNameP <* A.space <*> msgTextP),
-      ("/file " <|> "/f ") *> (SendFile <$> chatNameP' <* A.space <*> filePath),
-      ("/image " <|> "/img ") *> (SendImage <$> chatNameP' <* A.space <*> filePath),
+      ("/file " <|> "/f ") *> (SendFile <$> chatNameP' <* A.space <*> cryptoFileP),
+      ("/image " <|> "/img ") *> (SendImage <$> chatNameP' <* A.space <*> cryptoFileP),
       ("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal),
       ("/image_forward " <|> "/imgf ") *> (ForwardImage <$> chatNameP' <* A.space <*> A.decimal),
       ("/fdescription " <|> "/fd") *> (SendFileDescription <$> chatNameP' <* A.space <*> filePath),
@@ -6121,6 +6159,22 @@ chatCommandP =
       "/set disappear @" *> (SetContactTimedMessages <$> displayName <*> optional (A.space *> timedMessagesEnabledP)),
       "/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))),
       ("/incognito" <* optional (A.space *> onOffP)) $> ChatHelp HSIncognito,
+      "/set device name " *> (SetLocalDeviceName <$> textP),
+      -- "/create remote host" $> CreateRemoteHost,
+      "/list remote hosts" $> ListRemoteHosts,
+      "/switch remote host " *> (SwitchRemoteHost <$> ("local" $> Nothing <|> (Just <$> A.decimal))),
+      "/start remote host " *> (StartRemoteHost <$> ("new" $> Nothing <|> (Just <$> ((,) <$> A.decimal <*> (" multicast=" *> onOffP <|> pure False))))),
+      "/stop remote host " *> (StopRemoteHost <$> ("new" $> RHNew <|> RHId <$> A.decimal)),
+      "/delete remote host " *> (DeleteRemoteHost <$> A.decimal),
+      "/store remote file " *> (StoreRemoteFile <$> A.decimal <*> optional (" encrypt=" *> onOffP) <* A.space <*> filePath),
+      "/get remote file " *> (GetRemoteFile <$> A.decimal <* A.space <*> jsonP),
+      "/connect remote ctrl " *> (ConnectRemoteCtrl <$> strP),
+      "/find remote ctrl" $> FindKnownRemoteCtrl,
+      "/confirm remote ctrl " *> (ConfirmRemoteCtrl <$> A.decimal),
+      "/verify remote ctrl " *> (VerifyRemoteCtrlSession <$> textP),
+      "/list remote ctrls" $> ListRemoteCtrls,
+      "/stop remote ctrl" $> StopRemoteCtrl,
+      "/delete remote ctrl " *> (DeleteRemoteCtrl <$> A.decimal),
       ("/quit" <|> "/q" <|> "/exit") $> QuitChat,
       ("/version" <|> "/v") $> ShowVersion,
       "/debug locks" $> DebugLocks,
@@ -6184,9 +6238,14 @@ chatCommandP =
     fullNameP = A.space *> textP <|> pure ""
     textP = safeDecodeUtf8 <$> A.takeByteString
     pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' '))
+    verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ')
     msgTextP = jsonP <|> textP
     stringP = T.unpack . safeDecodeUtf8 <$> A.takeByteString
     filePath = stringP
+    cryptoFileP = do
+      cfArgs <- optional $ CFArgs <$> (" key=" *> strP <* A.space) <*> (" nonce=" *> strP)
+      path <- filePath
+      pure $ CryptoFile path cfArgs
     memberRole =
       A.choice
         [ " owner" $> GROwner,

src/Simplex/Chat/Archive.hs

@@ -9,6 +9,7 @@ module Simplex.Chat.Archive
     importArchive,
     deleteStorage,
     sqlCipherExport,
+    archiveFilesFolder,
   )
 where
 

src/Simplex/Chat/Bot.hs

@@ -25,7 +25,7 @@ chatBotRepl :: String -> (Contact -> String -> IO String) -> User -> ChatControl
 chatBotRepl welcome answer _user cc = do
   initializeBotAddress cc
   race_ (forever $ void getLine) . forever $ do
-    (_, resp) <- atomically . readTBQueue $ outputQ cc
+    (_, _, resp) <- atomically . readTBQueue $ outputQ cc
     case resp of
       CRContactConnected _ contact _ -> do
         contactConnected contact

src/Simplex/Chat/Call.hs

@@ -1,18 +1,18 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 {-# HLINT ignore "Use newtype instead of data" #-}
 
 module Simplex.Chat.Call where
 
-import Data.Aeson (FromJSON, ToJSON)
-import qualified Data.Aeson as J
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
@@ -20,12 +20,11 @@ import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
-import GHC.Generics (Generic)
 import Simplex.Chat.Types (Contact, ContactId, User)
 import Simplex.Chat.Types.Util (decodeJSON, encodeJSON)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, fstToLower, singleFieldJSON)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, fstToLower, singleFieldJSON)
 
 data Call = Call
   { contactId :: ContactId,
@@ -47,11 +46,7 @@ data CallStateTag
   | CSTCallOfferSent
   | CSTCallOfferReceived
   | CSTCallNegotiated
-  deriving (Show, Generic)
-
-instance ToJSON CallStateTag where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "CSTCall"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CSTCall"
+  deriving (Show)
 
 callStateTag :: CallState -> CallStateTag
 callStateTag = \case
@@ -90,21 +85,7 @@ data CallState
         peerCallSession :: WebRTCSession,
         sharedKey :: Maybe C.Key
       }
-  deriving (Show, Generic)
-
--- database representation
-instance FromJSON CallState where
-  parseJSON = J.genericParseJSON $ singleFieldJSON fstToLower
-
-instance ToJSON CallState where
-  toJSON = J.genericToJSON $ singleFieldJSON fstToLower
-  toEncoding = J.genericToEncoding $ singleFieldJSON fstToLower
-
-instance ToField CallState where
-  toField = toField . encodeJSON
-
-instance FromField CallState where
-  fromField = fromTextField_ decodeJSON
+  deriving (Show)
 
 newtype CallId = CallId ByteString
   deriving (Eq, Show)
@@ -132,17 +113,13 @@ data RcvCallInvitation = RcvCallInvitation
     sharedKey :: Maybe C.Key,
     callTs :: UTCTime
   }
-  deriving (Show, Generic)
-
-instance ToJSON RcvCallInvitation where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Show)
 
 data CallType = CallType
   { media :: CallMedia,
     capabilities :: CallCapabilities
   }
-  deriving (Eq, Show, Generic, FromJSON)
+  deriving (Eq, Show)
 
 defaultCallType :: CallType
 defaultCallType = CallType CMVideo $ CallCapabilities {encryption = True}
@@ -150,104 +127,54 @@ defaultCallType = CallType CMVideo $ CallCapabilities {encryption = True}
 encryptedCall :: CallType -> Bool
 encryptedCall CallType {capabilities = CallCapabilities {encryption}} = encryption
 
-instance ToJSON CallType where toEncoding = J.genericToEncoding J.defaultOptions
-
 -- | * Types for chat protocol
 data CallInvitation = CallInvitation
   { callType :: CallType,
     callDhPubKey :: Maybe C.PublicKeyX25519
   }
-  deriving (Eq, Show, Generic)
-
-instance FromJSON CallInvitation where
-  parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
-
-instance ToJSON CallInvitation where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 data CallMedia = CMAudio | CMVideo
-  deriving (Eq, Show, Generic)
-
-instance FromJSON CallMedia where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CM"
-
-instance ToJSON CallMedia where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "CM"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CM"
+  deriving (Eq, Show)
 
 data CallCapabilities = CallCapabilities
   { encryption :: Bool
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON CallCapabilities where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data CallOffer = CallOffer
   { callType :: CallType,
     rtcSession :: WebRTCSession,
     callDhPubKey :: Maybe C.PublicKeyX25519
   }
-  deriving (Eq, Show, Generic)
-
-instance FromJSON CallOffer where
-  parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
-
-instance ToJSON CallOffer where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 data WebRTCCallOffer = WebRTCCallOffer
   { callType :: CallType,
     rtcSession :: WebRTCSession
   }
-  deriving (Eq, Show, Generic)
-
-instance FromJSON WebRTCCallOffer where
-  parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
-
-instance ToJSON WebRTCCallOffer where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 data CallAnswer = CallAnswer
   { rtcSession :: WebRTCSession
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON CallAnswer where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data CallExtraInfo = CallExtraInfo
   { rtcExtraInfo :: WebRTCExtraInfo
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON CallExtraInfo where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data WebRTCSession = WebRTCSession
   { rtcSession :: Text, -- LZW compressed JSON encoding of offer or answer
     rtcIceCandidates :: Text -- LZW compressed JSON encoding of array of ICE candidates
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON WebRTCSession where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data WebRTCExtraInfo = WebRTCExtraInfo
   { rtcIceCandidates :: Text -- LZW compressed JSON encoding of array of ICE candidates
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON WebRTCExtraInfo where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data WebRTCCallStatus = WCSConnecting | WCSConnected | WCSDisconnected | WCSFailed
   deriving (Show)
@@ -265,3 +192,37 @@ instance StrEncoding WebRTCCallStatus where
       "disconnected" -> pure WCSDisconnected
       "failed" -> pure WCSFailed
       _ -> fail "bad WebRTCCallStatus"
+
+$(J.deriveJSON (enumJSON $ dropPrefix "CSTCall") ''CallStateTag)
+
+$(J.deriveJSON (enumJSON $ dropPrefix "CM") ''CallMedia)
+
+$(J.deriveJSON defaultJSON ''CallCapabilities)
+
+$(J.deriveJSON defaultJSON ''CallType)
+
+$(J.deriveJSON defaultJSON ''CallInvitation)
+
+$(J.deriveJSON defaultJSON ''WebRTCSession)
+
+$(J.deriveJSON defaultJSON ''CallOffer)
+
+$(J.deriveJSON defaultJSON ''WebRTCCallOffer)
+
+$(J.deriveJSON defaultJSON ''CallAnswer)
+
+$(J.deriveJSON defaultJSON ''WebRTCExtraInfo)
+
+$(J.deriveJSON defaultJSON ''CallExtraInfo)
+
+-- database representation
+$(J.deriveJSON (singleFieldJSON fstToLower) ''CallState)
+
+instance ToField CallState where
+  toField = toField . encodeJSON
+
+instance FromField CallState where
+  fromField = fromTextField_ decodeJSON
+
+$(J.deriveJSON defaultJSON ''RcvCallInvitation)
+

src/Simplex/Chat/Controller.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
@@ -12,6 +12,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Simplex.Chat.Controller where
 
@@ -24,11 +25,14 @@ import Control.Monad.Reader
 import Crypto.Random (ChaChaDRG)
 import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?))
 import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
 import qualified Data.Aeson.Types as JT
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (ord)
+import Data.Constraint (Dict (..))
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
@@ -37,7 +41,6 @@ import Data.String
 import Data.Text (Text)
 import Data.Time (NominalDiffTime, UTCTime)
 import Data.Version (showVersion)
-import GHC.Generics (Generic)
 import Language.Haskell.TH (Exp, Q, runIO)
 import Numeric.Natural
 import qualified Paths_simplex_chat as SC
@@ -46,6 +49,8 @@ import Simplex.Chat.Markdown (MarkdownList)
 import Simplex.Chat.Messages
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Protocol
+import Simplex.Chat.Remote.AppVersion
+import Simplex.Chat.Remote.Types
 import Simplex.Chat.Store (AutoAccept, StoreError (..), UserContactLink, UserMsgReceiptSettings)
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
@@ -62,13 +67,16 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import qualified Simplex.Messaging.Crypto.File as CF
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
-import Simplex.Messaging.Parsers (dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
-import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType, CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServerWithAuth)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
+import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServerWithAuth, userProtocol)
 import Simplex.Messaging.TMap (TMap)
-import Simplex.Messaging.Transport (simplexMQVersion)
+import Simplex.Messaging.Transport (TLS, simplexMQVersion)
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (allFinally, catchAllErrors, liftEitherError, tryAllErrors, (<$$>))
 import Simplex.Messaging.Version
+import Simplex.RemoteControl.Client
+import Simplex.RemoteControl.Invitation (RCSignedInvitation, RCVerifiedInvitation)
+import Simplex.RemoteControl.Types
 import System.IO (Handle)
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
@@ -159,6 +167,7 @@ data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLite
 
 data ChatController = ChatController
   { currentUser :: TVar (Maybe User),
+    currentRemoteHost :: TVar (Maybe RemoteHostId),
     firstTime :: Bool,
     smpAgent :: AgentClient,
     agentAsync :: TVar (Maybe (Async (), Maybe (Async ()))),
@@ -166,13 +175,19 @@ data ChatController = ChatController
     chatStoreChanged :: TVar Bool, -- if True, chat should be fully restarted
     idsDrg :: TVar ChaChaDRG,
     inputQ :: TBQueue String,
-    outputQ :: TBQueue (Maybe CorrId, ChatResponse),
+    outputQ :: TBQueue (Maybe CorrId, Maybe RemoteHostId, ChatResponse),
     connNetworkStatuses :: TMap AgentConnId NetworkStatus,
     subscriptionMode :: TVar SubscriptionMode,
     chatLock :: Lock,
     sndFiles :: TVar (Map Int64 Handle),
     rcvFiles :: TVar (Map Int64 Handle),
     currentCalls :: TMap ContactId Call,
+    localDeviceName :: TVar Text,
+    multicastSubscribers :: TMVar Int,
+    remoteSessionSeq :: TVar Int,
+    remoteHostSessions :: TMap RHKey (SessionSeq, RemoteHostSession), -- All the active remote hosts
+    remoteHostsFolder :: TVar (Maybe FilePath), -- folder for remote hosts data
+    remoteCtrlSession :: TVar (Maybe (SessionSeq, RemoteCtrlSession)), -- Supervisor process for hosted controllers
     config :: ChatConfig,
     filesFolder :: TVar (Maybe FilePath), -- path to files folder for mobile apps,
     expireCIThreads :: TMap UserId (Maybe (Async ())),
@@ -188,11 +203,7 @@ data ChatController = ChatController
   }
 
 data HelpSection = HSMain | HSFiles | HSGroups | HSContacts | HSMyAddress | HSIncognito | HSMarkdown | HSMessages | HSSettings | HSDatabase
-  deriving (Show, Generic)
-
-instance ToJSON HelpSection where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "HS"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HS"
+  deriving (Show)
 
 data ChatCommand
   = ShowActiveUser
@@ -222,6 +233,7 @@ data ChatCommand
   | ResubscribeAllConnections
   | SetTempFolder FilePath
   | SetFilesFolder FilePath
+  | SetRemoteHostsFolder FilePath
   | APISetXFTPConfig (Maybe XFTPFileConfig)
   | APISetEncryptLocalFiles Bool
   | SetContactMergeEnabled Bool
@@ -392,8 +404,8 @@ data ChatCommand
   | ShowChatItem (Maybe ChatItemId) -- UserId (not used in UI)
   | ShowChatItemInfo ChatName Text
   | ShowLiveItems Bool
-  | SendFile ChatName FilePath
-  | SendImage ChatName FilePath
+  | SendFile ChatName CryptoFile
+  | SendImage ChatName CryptoFile
   | ForwardFile ChatName FileTransferId
   | ForwardImage ChatName FileTransferId
   | SendFileDescription ChatName FilePath
@@ -411,6 +423,21 @@ data ChatCommand
   | SetUserTimedMessages Bool -- UserId (not used in UI)
   | SetContactTimedMessages ContactName (Maybe TimedMessagesEnabled)
   | SetGroupTimedMessages GroupName (Maybe Int)
+  | SetLocalDeviceName Text
+  | ListRemoteHosts
+  | StartRemoteHost (Maybe (RemoteHostId, Bool)) -- ^ Start new or known remote host with optional multicast for known host
+  | SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host
+  | StopRemoteHost RHKey -- ^ Shut down a running session
+  | DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data
+  | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
+  | GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
+  | ConnectRemoteCtrl RCSignedInvitation -- ^ Connect new or existing controller via OOB data
+  | FindKnownRemoteCtrl -- ^ Start listening for announcements from all existing controllers
+  | ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm the connection with found controller
+  | VerifyRemoteCtrlSession Text -- ^ Verify remote controller session
+  | ListRemoteCtrls
+  | StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session
+  | DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session
   | QuitChat
   | ShowVersion
   | DebugLocks
@@ -420,6 +447,45 @@ data ChatCommand
   | GetAgentSubsDetails
   deriving (Show)
 
+allowRemoteCommand :: ChatCommand -> Bool -- XXX: consider using Relay/Block/ForceLocal
+allowRemoteCommand = \case
+  StartChat {} -> False
+  APIStopChat -> False
+  APIActivateChat -> False
+  APISuspendChat _ -> False
+  QuitChat -> False
+  SetTempFolder _ -> False
+  SetFilesFolder _ -> False
+  SetRemoteHostsFolder _ -> False
+  APISetXFTPConfig _ -> False
+  APISetEncryptLocalFiles _ -> False
+  APIExportArchive _ -> False
+  APIImportArchive _ -> False
+  ExportArchive -> False
+  APIDeleteStorage -> False
+  APIStorageEncryption _ -> False
+  APISetNetworkConfig _ -> False
+  APIGetNetworkConfig -> False
+  SetLocalDeviceName _ -> False
+  ListRemoteHosts -> False
+  StartRemoteHost _ -> False
+  SwitchRemoteHost {} -> False
+  StoreRemoteFile {} -> False
+  GetRemoteFile {} -> False
+  StopRemoteHost _ -> False
+  DeleteRemoteHost _ -> False
+  ConnectRemoteCtrl {} -> False
+  FindKnownRemoteCtrl -> False
+  ConfirmRemoteCtrl _ -> False
+  VerifyRemoteCtrlSession {} -> False
+  ListRemoteCtrls -> False
+  StopRemoteCtrl -> False
+  DeleteRemoteCtrl _ -> False
+  ExecChatStoreSQL _ -> False
+  ExecAgentStoreSQL _ -> False
+  SlowSQLQueries -> False
+  _ -> True
+
 data ChatResponse
   = CRActiveUser {user :: User}
   | CRUsersList {users :: [UserInfo]}
@@ -589,6 +655,20 @@ data ChatResponse
   | CRNtfMessages {user_ :: Maybe User, connEntity :: Maybe ConnectionEntity, msgTs :: Maybe UTCTime, ntfMessages :: [NtfMsgInfo]}
   | CRNewContactConnection {user :: User, connection :: PendingContactConnection}
   | CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection}
+  | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]}
+  | CRCurrentRemoteHost {remoteHost_ :: Maybe RemoteHostInfo}
+  | CRRemoteHostStarted {remoteHost_ :: Maybe RemoteHostInfo, invitation :: Text}
+  | CRRemoteHostSessionCode {remoteHost_ :: Maybe RemoteHostInfo, sessionCode :: Text}
+  | CRNewRemoteHost {remoteHost :: RemoteHostInfo}
+  | CRRemoteHostConnected {remoteHost :: RemoteHostInfo}
+  | CRRemoteHostStopped {remoteHostId_ :: Maybe RemoteHostId}
+  | CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile}
+  | CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]}
+  | CRRemoteCtrlFound {remoteCtrl :: RemoteCtrlInfo} -- registered fingerprint, may connect
+  | CRRemoteCtrlConnecting {remoteCtrl_ :: Maybe RemoteCtrlInfo, ctrlAppInfo :: CtrlAppInfo, appVersion :: AppVersion}
+  | CRRemoteCtrlSessionCode {remoteCtrl_ :: Maybe RemoteCtrlInfo, sessionCode :: Text}
+  | CRRemoteCtrlConnected {remoteCtrl :: RemoteCtrlInfo}
+  | CRRemoteCtrlStopped
   | CRSQLResult {rows :: [Text]}
   | CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]}
   | CRDebugLocks {chatLockName :: Maybe String, agentLocks :: AgentLocks}
@@ -604,7 +684,32 @@ data ChatResponse
   | CRChatError {user_ :: Maybe User, chatError :: ChatError}
   | CRArchiveImported {archiveErrors :: [ArchiveError]}
   | CRTimedAction {action :: String, durationMilliseconds :: Int64}
-  deriving (Show, Generic)
+  deriving (Show)
+
+-- some of these can only be used as command responses
+allowRemoteEvent :: ChatResponse -> Bool
+allowRemoteEvent = \case
+  CRChatStarted -> False
+  CRChatRunning -> False
+  CRChatStopped -> False
+  CRChatSuspended -> False
+  CRRemoteHostList _ -> False
+  CRCurrentRemoteHost _ -> False
+  CRRemoteHostStarted {} -> False
+  CRRemoteHostSessionCode {} -> False
+  CRNewRemoteHost _ -> False
+  CRRemoteHostConnected _ -> False
+  CRRemoteHostStopped _ -> False
+  CRRemoteFileStored {} -> False
+  CRRemoteCtrlList _ -> False
+  CRRemoteCtrlFound _ -> False
+  CRRemoteCtrlConnecting {} -> False
+  CRRemoteCtrlSessionCode {} -> False
+  CRRemoteCtrlConnected _ -> False
+  CRRemoteCtrlStopped -> False
+  CRSQLResult _ -> False
+  CRSlowSQLQueries {} -> False
+  _ -> True
 
 logResponseToFile :: ChatResponse -> Bool
 logResponseToFile = \case
@@ -625,30 +730,18 @@ logResponseToFile = \case
   CRMessageError {} -> True
   _ -> False
 
-instance ToJSON ChatResponse where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR"
-
 data ConnectionPlan
   = CPInvitationLink {invitationLinkPlan :: InvitationLinkPlan}
   | CPContactAddress {contactAddressPlan :: ContactAddressPlan}
   | CPGroupLink {groupLinkPlan :: GroupLinkPlan}
-  deriving (Show, Generic)
-
-instance ToJSON ConnectionPlan where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CP"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CP"
+  deriving (Show)
 
 data InvitationLinkPlan
   = ILPOk
   | ILPOwnLink
   | ILPConnecting {contact_ :: Maybe Contact}
   | ILPKnown {contact :: Contact}
-  deriving (Show, Generic)
-
-instance ToJSON InvitationLinkPlan where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "ILP"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "ILP"
+  deriving (Show)
 
 data ContactAddressPlan
   = CAPOk
@@ -657,11 +750,7 @@ data ContactAddressPlan
   | CAPConnectingProhibit {contact :: Contact}
   | CAPKnown {contact :: Contact}
   | CAPContactViaAddress {contact :: Contact}
-  deriving (Show, Generic)
-
-instance ToJSON ContactAddressPlan where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CAP"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CAP"
+  deriving (Show)
 
 data GroupLinkPlan
   = GLPOk
@@ -669,11 +758,7 @@ data GroupLinkPlan
   | GLPConnectingConfirmReconnect
   | GLPConnectingProhibit {groupInfo_ :: Maybe GroupInfo}
   | GLPKnown {groupInfo :: GroupInfo}
-  deriving (Show, Generic)
-
-instance ToJSON GroupLinkPlan where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "GLP"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "GLP"
+  deriving (Show)
 
 connectionPlanProceed :: ConnectionPlan -> Bool
 connectionPlanProceed = \case
@@ -711,12 +796,15 @@ instance StrEncoding AgentQueueId where
   strDecode s = AgentQueueId <$> strDecode s
   strP = AgentQueueId <$> strP
 
+instance FromJSON AgentQueueId where
+  parseJSON = strParseJSON "AgentQueueId"
+
 instance ToJSON AgentQueueId where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
 data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
-  deriving (Show, Generic, FromJSON)
+  deriving (Show)
 
 data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
 
@@ -727,25 +815,17 @@ data UserProtoServers p = UserProtoServers
     protoServers :: NonEmpty (ServerCfg p),
     presetServers :: NonEmpty (ProtoServerWithAuth p)
   }
-  deriving (Show, Generic)
-
-instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
 
-instance ToJSON AUserProtoServers where
-  toJSON (AUPS s) = J.genericToJSON J.defaultOptions s
-  toEncoding (AUPS s) = J.genericToEncoding J.defaultOptions s
-
 deriving instance Show AUserProtoServers
 
 data ArchiveConfig = ArchiveConfig {archivePath :: FilePath, disableCompression :: Maybe Bool, parentTempDirectory :: Maybe FilePath}
-  deriving (Show, Generic, FromJSON)
+  deriving (Show)
 
 data DBEncryptionConfig = DBEncryptionConfig {currentKey :: DBEncryptionKey, newKey :: DBEncryptionKey}
-  deriving (Show, Generic, FromJSON)
+  deriving (Show)
 
 newtype DBEncryptionKey = DBEncryptionKey String
   deriving (Show)
@@ -763,41 +843,25 @@ data ContactSubStatus = ContactSubStatus
   { contact :: Contact,
     contactError :: Maybe ChatError
   }
-  deriving (Show, Generic)
-
-instance ToJSON ContactSubStatus where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Show)
 
 data MemberSubStatus = MemberSubStatus
   { member :: GroupMember,
     memberError :: Maybe ChatError
   }
-  deriving (Show, Generic)
-
-instance ToJSON MemberSubStatus where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Show)
 
 data UserContactSubStatus = UserContactSubStatus
   { userContact :: UserContact,
     userContactError :: Maybe ChatError
   }
-  deriving (Show, Generic)
-
-instance ToJSON UserContactSubStatus where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Show)
 
 data PendingSubStatus = PendingSubStatus
   { connection :: PendingContactConnection,
     connError :: Maybe ChatError
   }
-  deriving (Show, Generic)
-
-instance ToJSON PendingSubStatus where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Show)
 
 data UserProfileUpdateSummary = UserProfileUpdateSummary
   { notChanged :: Int,
@@ -805,16 +869,14 @@ data UserProfileUpdateSummary = UserProfileUpdateSummary
     updateFailures :: Int,
     changedContacts :: [Contact]
   }
-  deriving (Show, Generic)
-
-instance ToJSON UserProfileUpdateSummary where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 data ComposedMessage = ComposedMessage
   { fileSource :: Maybe CryptoFile,
     quotedItemId :: Maybe ChatItemId,
     msgContent :: MsgContent
   }
-  deriving (Show, Generic)
+  deriving (Show)
 
 -- This instance is needed for backward compatibility, can be removed in v6.0
 instance FromJSON ComposedMessage where
@@ -829,26 +891,16 @@ instance FromJSON ComposedMessage where
   parseJSON invalid =
     JT.prependFailure "bad ComposedMessage, " (JT.typeMismatch "Object" invalid)
 
-instance ToJSON ComposedMessage where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-
 data XFTPFileConfig = XFTPFileConfig
   { minFileSize :: Integer
   }
-  deriving (Show, Generic, FromJSON)
+  deriving (Show)
 
 defaultXFTPFileConfig :: XFTPFileConfig
 defaultXFTPFileConfig = XFTPFileConfig {minFileSize = 0}
 
-instance ToJSON XFTPFileConfig where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-
 data NtfMsgInfo = NtfMsgInfo {msgTs :: UTCTime, msgFlags :: MsgFlags}
-  deriving (Show, Generic)
-
-instance ToJSON NtfMsgInfo where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 crNtfToken :: (DeviceToken, NtfTknStatus, NotificationsMode) -> ChatResponse
 crNtfToken (token, status, ntfMode) = CRNtfToken {token, status, ntfMode}
@@ -858,25 +910,19 @@ data SwitchProgress = SwitchProgress
     switchPhase :: SwitchPhase,
     connectionStats :: ConnectionStats
   }
-  deriving (Show, Generic)
-
-instance ToJSON SwitchProgress where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 data RatchetSyncProgress = RatchetSyncProgress
   { ratchetSyncStatus :: RatchetSyncState,
     connectionStats :: ConnectionStats
   }
-  deriving (Show, Generic)
-
-instance ToJSON RatchetSyncProgress where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 data ParsedServerAddress = ParsedServerAddress
   { serverAddress :: Maybe ServerAddress,
     parseError :: String
   }
-  deriving (Show, Generic)
-
-instance ToJSON ParsedServerAddress where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 data ServerAddress = ServerAddress
   { serverProtocol :: AProtocolType,
@@ -885,9 +931,7 @@ data ServerAddress = ServerAddress
     keyHash :: String,
     basicAuth :: String
   }
-  deriving (Show, Generic)
-
-instance ToJSON ServerAddress where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 data TimedMessagesEnabled
   = TMEEnableSetTTL Int
@@ -909,33 +953,27 @@ data CoreVersionInfo = CoreVersionInfo
     simplexmqVersion :: String,
     simplexmqCommit :: String
   }
-  deriving (Show, Generic)
-
-instance ToJSON CoreVersionInfo where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 data SendFileMode
   = SendFileSMP (Maybe InlineFileMode)
   | SendFileXFTP
-  deriving (Show, Generic)
+  deriving (Show)
 
 data SlowSQLQuery = SlowSQLQuery
   { query :: Text,
     queryStats :: SlowQueryStats
   }
-  deriving (Show, Generic)
-
-instance ToJSON SlowSQLQuery where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 data ChatError
   = ChatError {errorType :: ChatErrorType}
   | ChatErrorAgent {agentError :: AgentErrorType, connectionEntity_ :: Maybe ConnectionEntity}
   | ChatErrorStore {storeError :: StoreError}
   | ChatErrorDatabase {databaseError :: DatabaseError}
-  deriving (Show, Exception, Generic)
-
-instance ToJSON ChatError where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "Chat"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "Chat"
+  | ChatErrorRemoteCtrl {remoteCtrlError :: RemoteCtrlError}
+  | ChatErrorRemoteHost {rhKey :: RHKey, remoteHostError :: RemoteHostError}
+  deriving (Show, Exception)
 
 data ChatErrorType
   = CENoActiveUser
@@ -1015,11 +1053,7 @@ data ChatErrorType
   | CEPeerChatVRangeIncompatible
   | CEInternalError {message :: String}
   | CEException {message :: String}
-  deriving (Show, Exception, Generic)
-
-instance ToJSON ChatErrorType where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CE"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CE"
+  deriving (Show, Exception)
 
 data DatabaseError
   = DBErrorEncrypted
@@ -1027,30 +1061,100 @@ data DatabaseError
   | DBErrorNoFile {dbFile :: String}
   | DBErrorExport {sqliteError :: SQLiteError}
   | DBErrorOpen {sqliteError :: SQLiteError}
-  deriving (Show, Exception, Generic)
-
-instance ToJSON DatabaseError where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "DB"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "DB"
+  deriving (Show, Exception)
 
 data SQLiteError = SQLiteErrorNotADatabase | SQLiteError String
-  deriving (Show, Exception, Generic)
-
-instance ToJSON SQLiteError where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SQLite"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SQLite"
+  deriving (Show, Exception)
 
 throwDBError :: ChatMonad m => DatabaseError -> m ()
 throwDBError = throwError . ChatErrorDatabase
 
+-- TODO review errors, some of it can be covered by HTTP2 errors
+data RemoteHostError
+  = RHEMissing -- ^ No remote session matches this identifier
+  | RHEInactive -- ^ A session exists, but not active
+  | RHEBusy -- ^ A session is already running
+  | RHETimeout
+  | RHEBadState -- ^ Illegal state transition
+  | RHEBadVersion {appVersion :: AppVersion}
+  | RHELocalCommand -- ^ Command not allowed for remote execution
+  | RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected?
+  | RHEProtocolError RemoteProtocolError
+  deriving (Show, Exception)
+
+-- TODO review errors, some of it can be covered by HTTP2 errors
+data RemoteCtrlError
+  = RCEInactive -- ^ No session is running
+  | RCEBadState -- ^ A session is in a wrong state for the current operation
+  | RCEBusy -- ^ A session is already running
+  | RCETimeout
+  | RCENoKnownControllers -- ^ No previously-contacted controllers to discover
+  | RCEBadController -- ^ Attempting to confirm a found controller with another ID
+  | RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller
+  | RCEBadInvitation
+  | RCEBadVersion {appVersion :: AppVersion}
+  | RCEHTTP2Error {http2Error :: Text} -- TODO currently not used
+  | RCEProtocolError {protocolError :: RemoteProtocolError}
+  deriving (Show, Exception)
+
 data ArchiveError
   = AEImport {chatError :: ChatError}
   | AEImportFile {file :: String, chatError :: ChatError}
-  deriving (Show, Exception, Generic)
+  deriving (Show, Exception)
 
-instance ToJSON ArchiveError where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "AE"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "AE"
+-- | Host (mobile) side of transport to process remote commands and forward notifications
+data RemoteCtrlSession
+  = RCSessionStarting
+  | RCSessionSearching
+      { action :: Async (),
+        foundCtrl :: TMVar (RemoteCtrl, RCVerifiedInvitation)
+      }
+  | RCSessionConnecting
+      { remoteCtrlId_ :: Maybe RemoteCtrlId,
+        rcsClient :: RCCtrlClient,
+        rcsWaitSession :: Async ()
+      }
+  | RCSessionPendingConfirmation
+      { remoteCtrlId_ :: Maybe RemoteCtrlId,
+        ctrlDeviceName :: Text,
+        rcsClient :: RCCtrlClient,
+        tls :: TLS,
+        sessionCode :: Text,
+        rcsWaitSession :: Async (),
+        rcsWaitConfirmation :: TMVar (Either RCErrorType (RCCtrlSession, RCCtrlPairing))
+      }
+  | RCSessionConnected
+      { remoteCtrlId :: RemoteCtrlId,
+        rcsClient :: RCCtrlClient,
+        tls :: TLS,
+        rcsSession :: RCCtrlSession,
+        http2Server :: Async (),
+        remoteOutputQ :: TBQueue ChatResponse
+      }
+
+data RemoteCtrlSessionState
+  = RCSStarting
+  | RCSSearching
+  | RCSConnecting
+  | RCSPendingConfirmation {sessionCode :: Text}
+  | RCSConnected {sessionCode :: Text}
+  deriving (Show)
+
+rcsSessionState :: RemoteCtrlSession -> RemoteCtrlSessionState
+rcsSessionState = \case
+  RCSessionStarting -> RCSStarting
+  RCSessionSearching {} -> RCSSearching
+  RCSessionConnecting {} -> RCSConnecting
+  RCSessionPendingConfirmation {tls} -> RCSPendingConfirmation {sessionCode = tlsSessionCode tls}
+  RCSessionConnected {tls} -> RCSConnected {sessionCode = tlsSessionCode tls}
+
+-- | UI-accessible remote controller information
+data RemoteCtrlInfo = RemoteCtrlInfo
+  { remoteCtrlId :: RemoteCtrlId,
+    ctrlDeviceName :: Text,
+    sessionState :: Maybe RemoteCtrlSessionState
+  }
+  deriving (Show)
 
 type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m)
 
@@ -1084,6 +1188,10 @@ chatFinally :: ChatMonad m => m a -> m b -> m a
 chatFinally = allFinally mkChatError
 {-# INLINE chatFinally #-}
 
+onChatError :: ChatMonad m => m a -> m b -> m a
+a `onChatError` onErr = a `catchChatError` \e -> onErr >> throwError e
+{-# INLINE onChatError #-}
+
 mkChatError :: SomeException -> ChatError
 mkChatError = ChatError . CEException . show
 {-# INLINE mkChatError #-}
@@ -1091,10 +1199,20 @@ mkChatError = ChatError . CEException . show
 chatCmdError :: Maybe User -> String -> ChatResponse
 chatCmdError user = CRChatCmdError user . ChatError . CECommandError
 
+throwChatError :: ChatMonad m => ChatErrorType -> m a
+throwChatError = throwError . ChatError
+
+-- | Emit local events.
 toView :: ChatMonad' m => ChatResponse -> m ()
 toView event = do
-  q <- asks outputQ
-  atomically $ writeTBQueue q (Nothing, event)
+  localQ <- asks outputQ
+  session <- asks remoteCtrlSession
+  atomically $
+    readTVar session >>= \case
+      Just (_, RCSessionConnected {remoteOutputQ}) | allowRemoteEvent event ->
+        writeTBQueue remoteOutputQ event
+      -- TODO potentially, it should hold some events while connecting
+      _ -> writeTBQueue localQ (Nothing, Nothing, event)
 
 withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a
 withStore' action = withStore $ liftIO . action
@@ -1122,3 +1240,94 @@ withStoreCtx ctx_ action = do
   where
     handleInternal :: String -> SomeException -> IO (Either StoreError a)
     handleInternal ctxStr e = pure . Left . SEInternalError $ show e <> ctxStr
+
+withAgent :: ChatMonad m => (AgentClient -> ExceptT AgentErrorType m a) -> m a
+withAgent action =
+  asks smpAgent
+    >>= runExceptT . action
+    >>= liftEither . first (`ChatErrorAgent` Nothing)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "HS") ''HelpSection)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "ILP") ''InvitationLinkPlan)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CAP") ''ContactAddressPlan)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GLP") ''GroupLinkPlan)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CP") ''ConnectionPlan)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CE") ''ChatErrorType)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RHE") ''RemoteHostError)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RemoteCtrlError)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "SQLite") ''SQLiteError)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "DB") ''DatabaseError)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "Chat") ''ChatError)
+
+$(JQ.deriveJSON defaultJSON ''ContactSubStatus)
+
+$(JQ.deriveJSON defaultJSON ''MemberSubStatus)
+
+$(JQ.deriveJSON defaultJSON ''UserContactSubStatus)
+
+$(JQ.deriveJSON defaultJSON ''PendingSubStatus)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "AE") ''ArchiveError)
+
+$(JQ.deriveJSON defaultJSON ''UserProfileUpdateSummary)
+
+$(JQ.deriveJSON defaultJSON ''NtfMsgInfo)
+
+$(JQ.deriveJSON defaultJSON ''SwitchProgress)
+
+$(JQ.deriveJSON defaultJSON ''RatchetSyncProgress)
+
+$(JQ.deriveJSON defaultJSON ''ServerAddress)
+
+$(JQ.deriveJSON defaultJSON ''ParsedServerAddress)
+
+$(JQ.deriveJSON defaultJSON ''CoreVersionInfo)
+
+$(JQ.deriveJSON defaultJSON ''SlowSQLQuery)
+
+instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
+
+instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
+
+instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
+  toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
+
+instance FromJSON AUserProtoServers where
+  parseJSON v = J.withObject "AUserProtoServers" parse v
+    where
+      parse o = do
+        AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
+        case userProtocol p of
+          Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
+          Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
+
+instance ToJSON AUserProtoServers where
+  toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
+  toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCS") ''RemoteCtrlSessionState)
+
+$(JQ.deriveJSON defaultJSON ''RemoteCtrlInfo)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CR") ''ChatResponse)
+
+$(JQ.deriveFromJSON defaultJSON ''ArchiveConfig)
+
+$(JQ.deriveFromJSON defaultJSON ''DBEncryptionConfig)
+
+$(JQ.deriveJSON defaultJSON ''XFTPFileConfig)
+
+$(JQ.deriveToJSON defaultJSON ''ComposedMessage)

src/Simplex/Chat/Core.hs

@@ -40,7 +40,7 @@ runSimplexChat ChatOpts {maintenance} u cc chat
     waitEither_ a1 a2
 
 sendChatCmdStr :: ChatController -> String -> IO ChatResponse
-sendChatCmdStr cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc
+sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack s) cc
 
 sendChatCmd :: ChatController -> ChatCommand -> IO ChatResponse
 sendChatCmd cc cmd = runReaderT (execChatCommand' cmd) cc

src/Simplex/Chat/Files.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Simplex.Chat.Files where
+
+import Control.Monad.IO.Class
+import Simplex.Chat.Controller
+import Simplex.Messaging.Util (ifM)
+import System.FilePath (splitExtensions, combine)
+import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, getHomeDirectory, doesDirectoryExist)
+
+uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
+uniqueCombine fPath fName = tryCombine (0 :: Int)
+  where
+    tryCombine n =
+      let (name, ext) = splitExtensions fName
+          suffix = if n == 0 then "" else "_" <> show n
+          f = fPath `combine` (name <> suffix <> ext)
+       in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f)
+
+getChatTempDirectory :: ChatMonad m => m FilePath
+getChatTempDirectory = chatReadVar tempDirectory >>= maybe getTemporaryDirectory pure
+
+getDefaultFilesFolder :: ChatMonad m => m FilePath
+getDefaultFilesFolder = do
+  dir <- (`combine` "Downloads") <$> getHomeDirectory
+  ifM (doesDirectoryExist dir) (pure dir) getChatTempDirectory

src/Simplex/Chat/Markdown.hs

@@ -1,8 +1,9 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 {-# HLINT ignore "Use newtype instead of data" #-}
@@ -10,8 +11,9 @@
 module Simplex.Chat.Markdown where
 
 import Control.Applicative (optional, (<|>))
-import Data.Aeson (ToJSON)
+import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
 import Data.Attoparsec.Text (Parser)
 import qualified Data.Attoparsec.Text as A
 import Data.Char (isDigit, isPunctuation)
@@ -26,12 +28,11 @@ import Data.String
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
-import GHC.Generics
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Util
 import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri (..), ConnReqScheme (..), ConnReqUriData (..), ConnectionRequestUri (..), SMPQueue (..))
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fstToLower, sumTypeJSON)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fstToLower, sumTypeJSON)
 import Simplex.Messaging.Protocol (ProtocolServer (..))
 import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.Console.ANSI.Types
@@ -51,14 +52,10 @@ data Format
   | SimplexLink {linkType :: SimplexLinkType, simplexUri :: Text, smpHosts :: NonEmpty Text}
   | Email
   | Phone
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 data SimplexLinkType = XLContact | XLInvitation | XLGroup
-  deriving (Eq, Show, Generic)
-
-instance ToJSON SimplexLinkType where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "XL"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "XL"
+  deriving (Eq, Show)
 
 colored :: Color -> Format
 colored = Colored . FormatColor
@@ -66,10 +63,6 @@ colored = Colored . FormatColor
 markdown :: Format -> Text -> Markdown
 markdown = Markdown . Just
 
-instance ToJSON Format where
-  toJSON = J.genericToJSON $ sumTypeJSON fstToLower
-  toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower
-
 instance Semigroup Markdown where
   m <> (Markdown _ "") = m
   (Markdown _ "") <> m = m
@@ -91,6 +84,18 @@ instance IsString Markdown where fromString = unmarked . T.pack
 newtype FormatColor = FormatColor Color
   deriving (Eq, Show)
 
+instance FromJSON FormatColor where
+  parseJSON = J.withText "FormatColor" $ fmap FormatColor . \case
+    "red" -> pure Red
+    "green" -> pure Green
+    "blue" -> pure Blue
+    "yellow" -> pure Yellow
+    "cyan" -> pure Cyan
+    "magenta" -> pure Magenta
+    "black" -> pure Black
+    "white" -> pure White
+    unexpected -> fail $ "unexpected FormatColor: " <> show unexpected
+
 instance ToJSON FormatColor where
   toJSON (FormatColor c) = case c of
     Red -> "red"
@@ -103,10 +108,7 @@ instance ToJSON FormatColor where
     White -> "white"
 
 data FormattedText = FormattedText {format :: Maybe Format, text :: Text}
-  deriving (Eq, Show, Generic)
-
-instance ToJSON FormattedText where
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 instance IsString FormattedText where
   fromString = FormattedText Nothing . T.pack
@@ -114,11 +116,6 @@ instance IsString FormattedText where
 type MarkdownList = [FormattedText]
 
 data ParsedMarkdown = ParsedMarkdown {formattedText :: Maybe MarkdownList}
-  deriving (Generic)
-
-instance ToJSON ParsedMarkdown where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
 
 unmarked :: Text -> Markdown
 unmarked = Markdown Nothing
@@ -129,7 +126,7 @@ parseMaybeMarkdownList s
   | otherwise = Just . reverse $ foldl' acc [] ml
   where
     ml = intercalate ["\n"] . map (markdownToList . parseMarkdown) $ T.lines s
-    acc [] m = [m] 
+    acc [] m = [m]
     acc ms@(FormattedText f t : ms') ft@(FormattedText f' t')
       | f == f' = FormattedText f (t <> t') : ms'
       | otherwise = ft : ms
@@ -242,3 +239,11 @@ markdownP = mconcat <$> A.many' fragmentP
         linkType' ConnReqUriData {crClientData} = case crClientData >>= decodeJSON of
           Just (CRDataGroup _) -> XLGroup
           Nothing -> XLContact
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "XL") ''SimplexLinkType)
+
+$(JQ.deriveJSON (sumTypeJSON fstToLower) ''Format)
+
+$(JQ.deriveJSON defaultJSON ''FormattedText)
+
+$(JQ.deriveToJSON defaultJSON ''ParsedMarkdown)

src/Simplex/Chat/Messages.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
@@ -9,17 +8,20 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.Chat.Messages where
 
 import Control.Applicative ((<|>))
-import Data.Aeson (FromJSON, ToJSON)
+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.Attoparsec.ByteString.Char8 as A
 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.Maybe (fromMaybe, isJust, isNothing)
 import Data.Text (Text)
@@ -30,7 +32,6 @@ import Data.Type.Equality
 import Data.Typeable (Typeable)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
-import GHC.Generics (Generic)
 import Simplex.Chat.Markdown
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Protocol
@@ -40,19 +41,17 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptSta
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import qualified Simplex.Messaging.Crypto.File as CF
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, enumJSON, sumTypeJSON)
 import Simplex.Messaging.Protocol (MsgBody)
 import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
 
 data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection
-  deriving (Eq, Show, Ord, Generic)
+  deriving (Eq, Show, Ord)
 
 data ChatName = ChatName {chatType :: ChatType, chatName :: Text}
-  deriving (Show, Generic)
+  deriving (Show)
 
-instance ToJSON ChatName where toEncoding = J.genericToEncoding J.defaultOptions
-
-chatTypeStr :: ChatType -> String
+chatTypeStr :: ChatType -> Text
 chatTypeStr = \case
   CTDirect -> "@"
   CTGroup -> "#"
@@ -60,15 +59,11 @@ chatTypeStr = \case
   CTContactConnection -> ":"
 
 chatNameStr :: ChatName -> String
-chatNameStr (ChatName cType name) = chatTypeStr cType <> T.unpack name
+chatNameStr (ChatName cType name) = T.unpack $ chatTypeStr cType <> if T.any isSpace name then "'" <> name <> "'" else name
 
 data ChatRef = ChatRef ChatType Int64
   deriving (Eq, Show, Ord)
 
-instance ToJSON ChatType where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "CT"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CT"
-
 data ChatInfo (c :: ChatType) where
   DirectChat :: Contact -> ChatInfo 'CTDirect
   GroupChat :: GroupInfo -> ChatInfo 'CTGroup
@@ -107,11 +102,11 @@ data JSONChatInfo
   | JCInfoGroup {groupInfo :: GroupInfo}
   | JCInfoContactRequest {contactRequest :: UserContactRequest}
   | JCInfoContactConnection {contactConnection :: PendingContactConnection}
-  deriving (Generic)
 
-instance ToJSON JSONChatInfo where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCInfo"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCInfo"
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCInfo") ''JSONChatInfo)
+
+instance ChatTypeI c => FromJSON (ChatInfo c) where
+  parseJSON v = (\(AChatInfo _ c) -> checkChatType c) <$?> J.parseJSON v
 
 instance ToJSON (ChatInfo c) where
   toJSON = J.toJSON . jsonChatInfo
@@ -124,10 +119,20 @@ jsonChatInfo = \case
   ContactRequest g -> JCInfoContactRequest g
   ContactConnection c -> JCInfoContactConnection c
 
-data AChatInfo = forall c. AChatInfo (SChatType c) (ChatInfo c)
+data AChatInfo = forall c. ChatTypeI c => AChatInfo (SChatType c) (ChatInfo c)
 
 deriving instance Show AChatInfo
 
+jsonAChatInfo :: JSONChatInfo -> AChatInfo
+jsonAChatInfo = \case
+  JCInfoDirect c -> AChatInfo SCTDirect $ DirectChat c
+  JCInfoGroup g -> AChatInfo SCTGroup $ GroupChat g
+  JCInfoContactRequest g -> AChatInfo SCTContactRequest $ ContactRequest g
+  JCInfoContactConnection c -> AChatInfo SCTContactConnection $ ContactConnection c
+
+instance FromJSON AChatInfo where
+  parseJSON v = jsonAChatInfo <$> J.parseJSON v
+
 instance ToJSON AChatInfo where
   toJSON (AChatInfo _ c) = J.toJSON c
   toEncoding (AChatInfo _ c) = J.toEncoding c
@@ -141,11 +146,7 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
     reactions :: [CIReactionCount],
     file :: Maybe (CIFile d)
   }
-  deriving (Show, Generic)
-
-instance MsgDirectionI d => ToJSON (ChatItem c d) where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Show)
 
 isMention :: ChatItem c d -> Bool
 isMention ChatItem {chatDir, quotedItem} = case chatDir of
@@ -168,20 +169,16 @@ data CIDirection (c :: ChatType) (d :: MsgDirection) where
 
 deriving instance Show (CIDirection c d)
 
+data CCIDirection c = forall d. MsgDirectionI d => CCID (SMsgDirection d) (CIDirection c d)
+
+data ACIDirection = forall c d. (ChatTypeI c, MsgDirectionI d) => ACID (SChatType c) (SMsgDirection d) (CIDirection c d)
+
 data JSONCIDirection
   = JCIDirectSnd
   | JCIDirectRcv
   | JCIGroupSnd
   | JCIGroupRcv {groupMember :: GroupMember}
-  deriving (Generic, Show)
-
-instance ToJSON JSONCIDirection where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCI"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCI"
-
-instance ToJSON (CIDirection c d) where
-  toJSON = J.toJSON . jsonCIDirection
-  toEncoding = J.toEncoding . jsonCIDirection
+  deriving (Show)
 
 jsonCIDirection :: CIDirection c d -> JSONCIDirection
 jsonCIDirection = \case
@@ -190,19 +187,20 @@ jsonCIDirection = \case
   CIGroupSnd -> JCIGroupSnd
   CIGroupRcv m -> JCIGroupRcv m
 
-data CIReactionCount = CIReactionCount {reaction :: MsgReaction, userReacted :: Bool, totalReacted :: Int}
-  deriving (Show, Generic)
+jsonACIDirection :: JSONCIDirection -> ACIDirection
+jsonACIDirection = \case
+  JCIDirectSnd -> ACID SCTDirect SMDSnd CIDirectSnd
+  JCIDirectRcv -> ACID SCTDirect SMDRcv CIDirectRcv
+  JCIGroupSnd -> ACID SCTGroup SMDSnd CIGroupSnd
+  JCIGroupRcv m -> ACID SCTGroup SMDRcv $ CIGroupRcv m
 
-instance ToJSON CIReactionCount where toEncoding = J.genericToEncoding J.defaultOptions
+data CIReactionCount = CIReactionCount {reaction :: MsgReaction, userReacted :: Bool, totalReacted :: Int}
+  deriving (Show)
 
 data CChatItem c = forall d. MsgDirectionI d => CChatItem (SMsgDirection d) (ChatItem c d)
 
 deriving instance Show (CChatItem c)
 
-instance ToJSON (CChatItem c) where
-  toJSON (CChatItem _ ci) = J.toJSON ci
-  toEncoding (CChatItem _ ci) = J.toEncoding ci
-
 cchatItemId :: CChatItem c -> ChatItemId
 cchatItemId (CChatItem _ ci) = chatItemId' ci
 
@@ -269,42 +267,25 @@ data Chat c = Chat
     chatItems :: [CChatItem c],
     chatStats :: ChatStats
   }
-  deriving (Show, Generic)
+  deriving (Show)
 
-instance ToJSON (Chat c) where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
-
-data AChat = forall c. AChat (SChatType c) (Chat c)
+data AChat = forall c. ChatTypeI c => AChat (SChatType c) (Chat c)
 
 deriving instance Show AChat
 
-instance ToJSON AChat where
-  toJSON (AChat _ c) = J.toJSON c
-  toEncoding (AChat _ c) = J.toEncoding c
-
 data ChatStats = ChatStats
   { unreadCount :: Int,
     minUnreadItemId :: ChatItemId,
     unreadChat :: Bool
   }
-  deriving (Show, Generic)
-
-instance ToJSON ChatStats where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 -- | type to show a mix of messages from multiple chats
-data AChatItem = forall c d. MsgDirectionI d => AChatItem (SChatType c) (SMsgDirection d) (ChatInfo c) (ChatItem c d)
+data AChatItem = forall c d. (ChatTypeI c, MsgDirectionI d) => AChatItem (SChatType c) (SMsgDirection d) (ChatInfo c) (ChatItem c d)
 
 deriving instance Show AChatItem
 
-instance ToJSON AChatItem where
-  toJSON (AChatItem _ _ chat item) = J.toJSON $ JSONAnyChatItem chat item
-  toEncoding (AChatItem _ _ chat item) = J.toEncoding $ JSONAnyChatItem chat item
-
 data JSONAnyChatItem c d = JSONAnyChatItem {chatInfo :: ChatInfo c, chatItem :: ChatItem c d}
-  deriving (Generic)
 
 aChatItems :: AChat -> [AChatItem]
 aChatItems (AChat ct Chat {chatInfo, chatItems}) = map aChatItem chatItems
@@ -322,10 +303,6 @@ updateFileStatus ci@ChatItem {file} status = case file of
   Just f -> ci {file = Just (f :: CIFile d) {fileStatus = status}}
   Nothing -> ci
 
-instance MsgDirectionI d => ToJSON (JSONAnyChatItem c d) where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
-
 -- This type is not saved to DB, so all JSON encodings are platform-specific
 data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
   { itemId :: ChatItemId,
@@ -342,7 +319,7 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
     createdAt :: UTCTime,
     updatedAt :: UTCTime
   }
-  deriving (Show, Generic)
+  deriving (Show)
 
 mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d
 mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited itemTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt =
@@ -351,15 +328,11 @@ mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted item
         _ -> False
    in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, itemTimed, itemLive, editable, forwardedByMember, createdAt, updatedAt}
 
-instance ToJSON (CIMeta c d) where toEncoding = J.genericToEncoding J.defaultOptions
-
 data CITimed = CITimed
   { ttl :: Int, -- seconds
     deleteAt :: Maybe UTCTime -- this is initially Nothing for received items, the timer starts when they are read
   }
-  deriving (Show, Generic)
-
-instance ToJSON CITimed where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 ttl' :: CITimed -> Int
 ttl' CITimed {ttl} = ttl
@@ -393,11 +366,7 @@ data CIQuote (c :: ChatType) = CIQuote
     content :: MsgContent,
     formattedText :: Maybe MarkdownList
   }
-  deriving (Show, Generic)
-
-instance ToJSON (CIQuote c) where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Show)
 
 data CIReaction (c :: ChatType) (d :: MsgDirection) = CIReaction
   { chatDir :: CIDirection c d,
@@ -405,26 +374,15 @@ data CIReaction (c :: ChatType) (d :: MsgDirection) = CIReaction
     sentAt :: UTCTime,
     reaction :: MsgReaction
   }
-  deriving (Show, Generic)
+  deriving (Show)
 
-instance ToJSON (CIReaction c d) where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+data AnyCIReaction = forall c d. ChatTypeI c => ACIR (SChatType c) (SMsgDirection d) (CIReaction c d)
 
-data ACIReaction = forall c d. ACIReaction (SChatType c) (SMsgDirection d) (ChatInfo c) (CIReaction c d)
+data ACIReaction = forall c d. ChatTypeI c => ACIReaction (SChatType c) (SMsgDirection d) (ChatInfo c) (CIReaction c d)
 
 deriving instance Show ACIReaction
 
-instance ToJSON ACIReaction where
-  toJSON (ACIReaction _ _ chat reaction) = J.toJSON $ JSONCIReaction chat reaction
-  toEncoding (ACIReaction _ _ chat reaction) = J.toEncoding $ JSONCIReaction chat reaction
-
 data JSONCIReaction c d = JSONCIReaction {chatInfo :: ChatInfo c, chatReaction :: CIReaction c d}
-  deriving (Generic)
-
-instance ToJSON (JSONCIReaction c d) where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
 
 data CIQDirection (c :: ChatType) where
   CIQDirectSnd :: CIQDirection 'CTDirect
@@ -434,9 +392,7 @@ data CIQDirection (c :: ChatType) where
 
 deriving instance Show (CIQDirection c)
 
-instance ToJSON (CIQDirection c) where
-  toJSON = J.toJSON . jsonCIQDirection
-  toEncoding = J.toEncoding . jsonCIQDirection
+data ACIQDirection = forall c. ChatTypeI c => ACIQDirection (SChatType c) (CIQDirection c)
 
 jsonCIQDirection :: CIQDirection c -> Maybe JSONCIDirection
 jsonCIQDirection = \case
@@ -446,6 +402,14 @@ jsonCIQDirection = \case
   CIQGroupRcv (Just m) -> Just $ JCIGroupRcv m
   CIQGroupRcv Nothing -> Nothing
 
+jsonACIQDirection :: Maybe JSONCIDirection -> 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)
+  Nothing -> ACIQDirection SCTGroup $ CIQGroupRcv Nothing
+
 quoteMsgDirection :: CIQDirection c -> MsgDirection
 quoteMsgDirection = \case
   CIQDirectSnd -> MDSnd
@@ -461,11 +425,7 @@ data CIFile (d :: MsgDirection) = CIFile
     fileStatus :: CIFileStatus d,
     fileProtocol :: FileProtocol
   }
-  deriving (Show, Generic)
-
-instance MsgDirectionI d => ToJSON (CIFile d) where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Show)
 
 data FileProtocol = FPSMP | FPXFTP
   deriving (Eq, Show, Ord)
@@ -474,6 +434,9 @@ instance FromField FileProtocol where fromField = fromTextField_ textDecode
 
 instance ToField FileProtocol where toField = toField . textEncode
 
+instance FromJSON FileProtocol where
+  parseJSON = textParseJSON "FileProtocol"
+
 instance ToJSON FileProtocol where
   toJSON = J.String . textEncode
   toEncoding = JE.text . textEncode
@@ -520,14 +483,6 @@ ciFileEnded = \case
   CIFSRcvError -> True
   CIFSInvalid {} -> True
 
-instance ToJSON (CIFileStatus d) where
-  toJSON = J.toJSON . jsonCIFileStatus
-  toEncoding = J.toEncoding . jsonCIFileStatus
-
-instance MsgDirectionI d => ToField (CIFileStatus d) where toField = toField . decodeLatin1 . strEncode
-
-instance FromField ACIFileStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
-
 data ACIFileStatus = forall d. MsgDirectionI d => AFS (SMsgDirection d) (CIFileStatus d)
 
 deriving instance Show ACIFileStatus
@@ -585,11 +540,6 @@ data JSONCIFileStatus
   | JCIFSRcvCancelled
   | JCIFSRcvError
   | JCIFSInvalid {text :: Text}
-  deriving (Generic)
-
-instance ToJSON JSONCIFileStatus where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCIFS"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCIFS"
 
 jsonCIFileStatus :: CIFileStatus d -> JSONCIFileStatus
 jsonCIFileStatus = \case
@@ -651,16 +601,6 @@ deriving instance Eq (CIStatus d)
 
 deriving instance Show (CIStatus d)
 
-instance ToJSON (CIStatus d) where
-  toJSON = J.toJSON . jsonCIStatus
-  toEncoding = J.toEncoding . jsonCIStatus
-
-instance MsgDirectionI d => ToField (CIStatus d) where toField = toField . decodeLatin1 . strEncode
-
-instance (Typeable d, MsgDirectionI d) => FromField (CIStatus d) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
-
-instance FromField ACIStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
-
 data ACIStatus = forall d. MsgDirectionI d => ACIStatus (SMsgDirection d) (CIStatus d)
 
 deriving instance Show ACIStatus
@@ -703,11 +643,7 @@ data JSONCIStatus
   | JCISRcvNew
   | JCISRcvRead
   | JCISInvalid {text :: Text}
-  deriving (Show, Generic)
-
-instance ToJSON JSONCIStatus where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCIS"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCIS"
+  deriving (Show)
 
 jsonCIStatus :: CIStatus d -> JSONCIStatus
 jsonCIStatus = \case
@@ -720,6 +656,17 @@ jsonCIStatus = \case
   CISRcvRead -> JCISRcvRead
   CISInvalid text -> JCISInvalid text
 
+jsonACIStatus :: JSONCIStatus -> ACIStatus
+jsonACIStatus = \case
+  JCISSndNew -> ACIStatus SMDSnd CISSndNew
+  JCISSndSent sndProgress -> ACIStatus SMDSnd $ CISSndSent sndProgress
+  JCISSndRcvd msgRcptStatus sndProgress -> ACIStatus SMDSnd $ CISSndRcvd msgRcptStatus sndProgress
+  JCISSndErrorAuth -> ACIStatus SMDSnd CISSndErrorAuth
+  JCISSndError e -> ACIStatus SMDSnd $ CISSndError e
+  JCISRcvNew -> ACIStatus SMDRcv CISRcvNew
+  JCISRcvRead -> ACIStatus SMDRcv CISRcvRead
+  JCISInvalid text -> ACIStatus SMDSnd $ CISInvalid text
+
 ciStatusNew :: forall d. MsgDirectionI d => CIStatus d
 ciStatusNew = case msgDirection @d of
   SMDSnd -> CISSndNew
@@ -748,11 +695,7 @@ membersGroupItemStatus memStatusCounts
 data SndCIStatusProgress
   = SSPPartial
   | SSPComplete
-  deriving (Eq, Show, Generic)
-
-instance ToJSON SndCIStatusProgress where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "SSP"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "SSP"
+  deriving (Eq, Show)
 
 instance StrEncoding SndCIStatusProgress where
   strEncode = \case
@@ -789,6 +732,8 @@ instance TestEquality SChatType where
   testEquality SCTContactConnection SCTContactConnection = Just Refl
   testEquality _ _ = Nothing
 
+data AChatType = forall c. ChatTypeI c => ACT (SChatType c)
+
 class ChatTypeI (c :: ChatType) where
   chatTypeI :: SChatType c
 
@@ -796,6 +741,29 @@ instance ChatTypeI 'CTDirect where chatTypeI = SCTDirect
 
 instance ChatTypeI 'CTGroup where chatTypeI = SCTGroup
 
+instance ChatTypeI 'CTContactRequest where chatTypeI = SCTContactRequest
+
+instance ChatTypeI 'CTContactConnection where chatTypeI = SCTContactConnection
+
+toChatType :: SChatType c -> ChatType
+toChatType = \case
+  SCTDirect -> CTDirect
+  SCTGroup -> CTGroup
+  SCTContactRequest -> CTContactRequest
+  SCTContactConnection -> CTContactConnection
+
+aChatType :: ChatType -> AChatType
+aChatType = \case
+  CTDirect -> ACT SCTDirect
+  CTGroup -> ACT SCTGroup
+  CTContactRequest -> ACT SCTContactRequest
+  CTContactConnection -> ACT SCTContactConnection
+
+checkChatType :: forall t c c'. (ChatTypeI c, ChatTypeI c') => t c' -> Either String (t c)
+checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of
+  Just Refl -> Right x
+  Nothing -> Left "bad chat type"
+
 data NewMessage e = NewMessage
   { chatMsgEvent :: ChatMsgEvent e,
     msgBody :: MsgBody
@@ -850,9 +818,7 @@ data MsgMetaJSON = MsgMetaJSON
     serverTs :: UTCTime,
     sndId :: Int64
   }
-  deriving (Eq, Show, FromJSON, Generic)
-
-instance ToJSON MsgMetaJSON where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 msgMetaToJson :: MsgMeta -> MsgMetaJSON
 msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sndMsgId = sndId} =
@@ -865,9 +831,6 @@ msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId
       sndId
     }
 
-msgMetaJson :: MsgMeta -> Text
-msgMetaJson = decodeLatin1 . LB.toStrict . J.encode . msgMetaToJson
-
 data MsgDeliveryStatus (d :: MsgDirection) where
   MDSRcvAgent :: MsgDeliveryStatus 'MDRcv
   MDSRcvAcknowledged :: MsgDeliveryStatus 'MDRcv
@@ -915,38 +878,33 @@ msgDeliveryStatusT' s =
       Just Refl -> Just st
       _ -> Nothing
 
-checkDirection :: forall t d d'. (MsgDirectionI d, MsgDirectionI d') => t d' -> Either String (t d)
-checkDirection x = case testEquality (msgDirection @d) (msgDirection @d') of
-  Just Refl -> Right x
-  Nothing -> Left "bad direction"
-
 data CIDeleted (c :: ChatType) where
   CIDeleted :: Maybe UTCTime -> CIDeleted c
-  CIBlocked :: Maybe UTCTime -> CIDeleted c
+  CIBlocked :: Maybe UTCTime -> CIDeleted 'CTGroup
   CIModerated :: Maybe UTCTime -> GroupMember -> CIDeleted 'CTGroup
 
 deriving instance Show (CIDeleted c)
 
-instance ToJSON (CIDeleted d) where
-  toJSON = J.toJSON . jsonCIDeleted
-  toEncoding = J.toEncoding . jsonCIDeleted
+data ACIDeleted = forall c. ChatTypeI c => ACIDeleted (SChatType c) (CIDeleted c)
 
 data JSONCIDeleted
-  = JCIDDeleted {deletedTs :: Maybe UTCTime}
+  = JCIDDeleted {deletedTs :: Maybe UTCTime, chatType :: ChatType}
   | JCIDBlocked {deletedTs :: Maybe UTCTime}
   | JCIDModerated {deletedTs :: Maybe UTCTime, byGroupMember :: GroupMember}
-  deriving (Show, Generic)
+  deriving (Show)
 
-instance ToJSON JSONCIDeleted where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCID"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCID"
-
-jsonCIDeleted :: CIDeleted d -> JSONCIDeleted
+jsonCIDeleted :: forall d. ChatTypeI d => CIDeleted d -> JSONCIDeleted
 jsonCIDeleted = \case
-  CIDeleted ts -> JCIDDeleted ts
+  CIDeleted ts -> JCIDDeleted ts (toChatType $ chatTypeI @d)
   CIBlocked ts -> JCIDBlocked ts
   CIModerated ts m -> JCIDModerated ts m
 
+jsonACIDeleted :: JSONCIDeleted -> ACIDeleted
+jsonACIDeleted = \case
+  JCIDDeleted ts cType -> case aChatType cType of ACT c -> ACIDeleted c $ CIDeleted ts
+  JCIDBlocked ts -> ACIDeleted SCTGroup $ CIBlocked ts
+  JCIDModerated ts m -> ACIDeleted SCTGroup (CIModerated ts m)
+
 itemDeletedTs :: CIDeleted d -> Maybe UTCTime
 itemDeletedTs = \case
   CIDeleted ts -> ts
@@ -957,9 +915,7 @@ data ChatItemInfo = ChatItemInfo
   { itemVersions :: [ChatItemVersion],
     memberDeliveryStatuses :: Maybe [MemberDeliveryStatus]
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON ChatItemInfo where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data ChatItemVersion = ChatItemVersion
   { chatItemVersionId :: Int64,
@@ -968,9 +924,7 @@ data ChatItemVersion = ChatItemVersion
     itemVersionTs :: UTCTime,
     createdAt :: UTCTime
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON ChatItemVersion where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 mkItemVersion :: ChatItem c d -> Maybe ChatItemVersion
 mkItemVersion ChatItem {content, meta} = version <$> ciMsgContent content
@@ -989,9 +943,7 @@ data MemberDeliveryStatus = MemberDeliveryStatus
   { groupMemberId :: GroupMemberId,
     memberDeliveryStatus :: CIStatus 'MDSnd
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON MemberDeliveryStatus where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data CIModeration = CIModeration
   { moderationId :: Int64,
@@ -1000,3 +952,187 @@ data CIModeration = CIModeration
     moderatedAt :: UTCTime
   }
   deriving (Show)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "CT") ''ChatType)
+
+instance ChatTypeI c => FromJSON (SChatType c) where
+  parseJSON v = (\(ACT t) -> checkChatType t) . aChatType <$?> J.parseJSON v
+
+instance ToJSON (SChatType c) where
+  toJSON = J.toJSON . toChatType
+  toEncoding = J.toEncoding . toChatType
+
+$(JQ.deriveJSON defaultJSON ''ChatName)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCID") ''JSONCIDeleted)
+
+instance ChatTypeI c => FromJSON (CIDeleted c) where
+  parseJSON v = (\(ACIDeleted _ x) -> checkChatType x) . jsonACIDeleted <$?> J.parseJSON v
+
+instance ChatTypeI c => ToJSON (CIDeleted c) where
+  toJSON = J.toJSON . jsonCIDeleted
+  toEncoding = J.toEncoding . jsonCIDeleted
+
+$(JQ.deriveJSON defaultJSON ''CITimed)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "SSP") ''SndCIStatusProgress)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCIS") ''JSONCIStatus)
+
+instance MsgDirectionI d => FromJSON (CIStatus d) where
+  parseJSON v = (\(ACIStatus _ s) -> checkDirection s) . jsonACIStatus <$?> J.parseJSON v
+
+instance ToJSON (CIStatus d) where
+  toJSON = J.toJSON . jsonCIStatus
+  toEncoding = J.toEncoding . jsonCIStatus
+
+instance MsgDirectionI d => ToField (CIStatus d) where toField = toField . decodeLatin1 . strEncode
+
+instance (Typeable d, MsgDirectionI d) => FromField (CIStatus d) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
+instance FromField ACIStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
+$(JQ.deriveJSON defaultJSON ''MemberDeliveryStatus)
+
+$(JQ.deriveJSON defaultJSON ''ChatItemVersion)
+
+$(JQ.deriveJSON defaultJSON ''ChatItemInfo)
+
+instance (ChatTypeI c, MsgDirectionI d) => FromJSON (CIMeta c d) where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''CIMeta)
+
+instance ChatTypeI c => ToJSON (CIMeta c d) where
+  toJSON = $(JQ.mkToJSON defaultJSON ''CIMeta)
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''CIMeta)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCIFS") ''JSONCIFileStatus)
+
+instance MsgDirectionI d => FromJSON (CIFileStatus d) where
+  parseJSON v = (\(AFS _ s) -> checkDirection s) . aciFileStatusJSON <$?> J.parseJSON v
+
+instance ToJSON (CIFileStatus d) where
+  toJSON = J.toJSON . jsonCIFileStatus
+  toEncoding = J.toEncoding . jsonCIFileStatus
+
+instance MsgDirectionI d => ToField (CIFileStatus d) where toField = toField . decodeLatin1 . strEncode
+
+instance FromField ACIFileStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
+instance MsgDirectionI d => FromJSON (CIFile d) where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''CIFile)
+
+instance MsgDirectionI d => ToJSON (CIFile d) where
+  toJSON = $(JQ.mkToJSON defaultJSON ''CIFile)
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''CIFile)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCI") ''JSONCIDirection)
+
+instance (ChatTypeI c, MsgDirectionI d) => FromJSON (CIDirection c d) where
+  parseJSON v = (\(CCID _ x') -> checkDirection x') <$?> J.parseJSON v
+
+instance ToJSON (CIDirection c d) where
+  toJSON = J.toJSON . jsonCIDirection
+  toEncoding = J.toEncoding . jsonCIDirection
+
+instance ChatTypeI c => FromJSON (CCIDirection c) where
+  parseJSON v = (\(ACID _ d x) -> checkChatType (CCID d x)) <$?> J.parseJSON v
+
+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
+
+instance ToJSON (CIQDirection c) where
+  toJSON = J.toJSON . jsonCIQDirection
+  toEncoding = J.toEncoding . jsonCIQDirection
+
+instance ChatTypeI c => FromJSON (CIQuote c) where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''CIQuote)
+
+$(JQ.deriveToJSON defaultJSON ''CIQuote)
+
+$(JQ.deriveJSON defaultJSON ''CIReactionCount)
+
+instance (ChatTypeI c, MsgDirectionI d) => FromJSON (ChatItem c d) where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''ChatItem)
+
+instance (ChatTypeI c, MsgDirectionI d) => ToJSON (ChatItem c d) where
+  toJSON = $(JQ.mkToJSON defaultJSON ''ChatItem)
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''ChatItem)
+
+instance (ChatTypeI c, MsgDirectionI d) => ToJSON (JSONAnyChatItem c d) where
+  toJSON = $(JQ.mkToJSON defaultJSON ''JSONAnyChatItem)
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''JSONAnyChatItem)
+
+instance FromJSON AChatItem where
+  parseJSON = J.withObject "AChatItem" $ \o -> do
+    AChatInfo c chatInfo <- o .: "chatInfo"
+    CChatItem d chatItem <- o .: "chatItem"
+    pure $ AChatItem c d chatInfo chatItem
+
+instance ToJSON AChatItem where
+  toJSON (AChatItem _ _ chat item) = J.toJSON $ JSONAnyChatItem chat item
+  toEncoding (AChatItem _ _ chat item) = J.toEncoding $ JSONAnyChatItem chat item
+
+instance forall c. ChatTypeI c => FromJSON (CChatItem c) where
+  parseJSON v = J.withObject "CChatItem" parse v
+    where
+      parse o = do
+        CCID d (_ :: CIDirection c d) <- o .: "chatDir"
+        ci <- J.parseJSON @(ChatItem c d) v
+        pure $ CChatItem d ci
+
+instance ChatTypeI c => ToJSON (CChatItem c) where
+  toJSON (CChatItem _ ci) = J.toJSON ci
+  toEncoding (CChatItem _ ci) = J.toEncoding ci
+
+$(JQ.deriveJSON defaultJSON ''ChatStats)
+
+instance ChatTypeI c => ToJSON (Chat c) where
+  toJSON = $(JQ.mkToJSON defaultJSON ''Chat)
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''Chat)
+
+instance FromJSON AChat where
+  parseJSON = J.withObject "AChat" $ \o -> do
+    AChatInfo c chatInfo <- o .: "chatInfo"
+    chatItems <- o .: "chatItems"
+    chatStats <- o .: "chatStats"
+    pure $ AChat c Chat {chatInfo, chatItems, chatStats}
+
+instance ToJSON AChat where
+  toJSON (AChat _ c) = J.toJSON c
+  toEncoding (AChat _ c) = J.toEncoding c
+
+instance (ChatTypeI c, MsgDirectionI d) => FromJSON (CIReaction c d) where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''CIReaction)
+
+instance ChatTypeI c => ToJSON (CIReaction c d) where
+  toJSON = $(JQ.mkToJSON defaultJSON ''CIReaction)
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''CIReaction)
+
+instance FromJSON AnyCIReaction where
+  parseJSON v = J.withObject "AnyCIReaction" parse v
+    where
+      parse o = do
+        ACID c d (_ :: CIDirection c d) <- o .: "chatDir"
+        ACIR c d <$> J.parseJSON @(CIReaction c d) v
+
+instance ChatTypeI c => ToJSON (JSONCIReaction c d) where
+  toJSON = $(JQ.mkToJSON defaultJSON ''JSONCIReaction)
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''JSONCIReaction)
+
+instance FromJSON ACIReaction where
+  parseJSON = J.withObject "ACIReaction" $ \o -> do
+    ACIR c d reaction <- o .: "chatReaction"
+    cInfo <- o .: "chatInfo"
+    pure $ ACIReaction c d cInfo reaction
+
+instance ToJSON ACIReaction where
+  toJSON (ACIReaction _ _ cInfo reaction) = J.toJSON $ JSONCIReaction cInfo reaction
+  toEncoding (ACIReaction _ _ cInfo reaction) = J.toEncoding $ JSONCIReaction cInfo reaction
+
+$(JQ.deriveJSON defaultJSON ''MsgMetaJSON)
+
+msgMetaJson :: MsgMeta -> Text
+msgMetaJson = decodeLatin1 . LB.toStrict . J.encode . msgMetaToJson

src/Simplex/Chat/Messages/CIContent.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
@@ -24,25 +23,20 @@ import Data.Type.Equality
 import Data.Word (Word32)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
-import GHC.Generics (Generic)
+import Simplex.Chat.Messages.CIContent.Events
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
 import Simplex.Chat.Types.Util
 import Simplex.Messaging.Agent.Protocol (MsgErrorType (..), RatchetSyncState (..), SwitchPhase (..))
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fstToLower, singleFieldJSON, sumTypeJSON)
-import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fstToLower, singleFieldJSON, sumTypeJSON)
+import Simplex.Messaging.Util (safeDecodeUtf8, tshow, (<$?>))
 
 data MsgDirection = MDRcv | MDSnd
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
-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"
+$(JQ.deriveJSON (enumJSON $ dropPrefix "MD") ''MsgDirection)
 
 instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgDirection . msgDirectionIntP
 
@@ -59,6 +53,13 @@ instance TestEquality SMsgDirection where
   testEquality SMDSnd SMDSnd = Just Refl
   testEquality _ _ = Nothing
 
+instance MsgDirectionI d => FromJSON (SMsgDirection d) where
+  parseJSON v = (\(AMsgDirection d) -> checkDirection d) . fromMsgDirection <$?> J.parseJSON v
+
+instance ToJSON (SMsgDirection d) where
+  toJSON = J.toJSON . toMsgDirection
+  toEncoding = J.toEncoding . toMsgDirection
+
 instance ToField (SMsgDirection d) where toField = toField . msgDirectionInt . toMsgDirection
 
 data AMsgDirection = forall d. MsgDirectionI d => AMsgDirection (SMsgDirection d)
@@ -82,6 +83,11 @@ instance MsgDirectionI 'MDRcv where msgDirection = SMDRcv
 
 instance MsgDirectionI 'MDSnd where msgDirection = SMDSnd
 
+checkDirection :: forall t d d'. (MsgDirectionI d, MsgDirectionI d') => t d' -> Either String (t d)
+checkDirection x = case testEquality (msgDirection @d) (msgDirection @d') of
+  Just Refl -> Right x
+  Nothing -> Left "bad direction"
+
 msgDirectionInt :: MsgDirection -> Int
 msgDirectionInt = \case
   MDRcv -> 0
@@ -94,14 +100,9 @@ msgDirectionIntP = \case
   _ -> Nothing
 
 data CIDeleteMode = CIDMBroadcast | CIDMInternal
-  deriving (Show, Generic)
+  deriving (Show)
 
-instance ToJSON CIDeleteMode where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "CIDM"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CIDM"
-
-instance FromJSON CIDeleteMode where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CIDM"
+$(JQ.deriveJSON (enumJSON $ dropPrefix "CIDM") ''CIDeleteMode)
 
 ciDeleteModeToText :: CIDeleteMode -> Text
 ciDeleteModeToText = \case
@@ -156,14 +157,7 @@ data MsgDecryptError
   | MDERatchetEarlier
   | MDEOther
   | MDERatchetSync
-  deriving (Eq, Show, Generic)
-
-instance ToJSON MsgDecryptError where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "MDE"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MDE"
-
-instance FromJSON MsgDecryptError where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "MDE"
+  deriving (Eq, Show)
 
 ciRequiresAttention :: forall d. MsgDirectionI d => CIContent d -> Bool
 ciRequiresAttention content = case msgDirection @d of
@@ -197,127 +191,6 @@ ciRequiresAttention content = case msgDirection @d of
     CIRcvModerated -> True
     CIInvalidJSON _ -> False
 
-data RcvGroupEvent
-  = RGEMemberAdded {groupMemberId :: GroupMemberId, profile :: Profile} -- CRJoinedGroupMemberConnecting
-  | RGEMemberConnected -- CRUserJoinedGroup, CRJoinedGroupMember, CRConnectedToGroupMember
-  | RGEMemberLeft -- CRLeftMember
-  | RGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole}
-  | RGEUserRole {role :: GroupMemberRole}
-  | RGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRDeletedMember
-  | RGEUserDeleted -- CRDeletedMemberUser
-  | RGEGroupDeleted -- CRGroupDeleted
-  | RGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated
-  -- RGEInvitedViaGroupLink chat items are not received - they're created when sending group invitations,
-  -- but being RcvGroupEvent allows them to be assigned to the respective member (and so enable "send direct message")
-  -- and be created as unread without adding / working around new status for sent items
-  | RGEInvitedViaGroupLink -- CRSentGroupInvitationViaLink
-  | RGEMemberCreatedContact -- CRNewMemberContactReceivedInv
-  deriving (Show, Generic)
-
-instance FromJSON RcvGroupEvent where
-  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RGE"
-
-instance ToJSON RcvGroupEvent where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RGE"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RGE"
-
-newtype DBRcvGroupEvent = RGE RcvGroupEvent
-
-instance FromJSON DBRcvGroupEvent where
-  parseJSON v = RGE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "RGE") v
-
-instance ToJSON DBRcvGroupEvent where
-  toJSON (RGE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "RGE") v
-  toEncoding (RGE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "RGE") v
-
-data SndGroupEvent
-  = SGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole}
-  | SGEUserRole {role :: GroupMemberRole}
-  | SGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRUserDeletedMember
-  | SGEUserLeft -- CRLeftMemberUser
-  | SGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated
-  deriving (Show, Generic)
-
-instance FromJSON SndGroupEvent where
-  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "SGE"
-
-instance ToJSON SndGroupEvent where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SGE"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SGE"
-
-newtype DBSndGroupEvent = SGE SndGroupEvent
-
-instance FromJSON DBSndGroupEvent where
-  parseJSON v = SGE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "SGE") v
-
-instance ToJSON DBSndGroupEvent where
-  toJSON (SGE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "SGE") v
-  toEncoding (SGE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "SGE") v
-
-data RcvConnEvent
-  = RCESwitchQueue {phase :: SwitchPhase}
-  | RCERatchetSync {syncStatus :: RatchetSyncState}
-  | RCEVerificationCodeReset
-  deriving (Show, Generic)
-
-data SndConnEvent
-  = SCESwitchQueue {phase :: SwitchPhase, member :: Maybe GroupMemberRef}
-  | SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef}
-  deriving (Show, Generic)
-
-instance FromJSON RcvConnEvent where
-  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RCE"
-
-instance ToJSON RcvConnEvent where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RCE"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RCE"
-
-newtype DBRcvConnEvent = RCE RcvConnEvent
-
-instance FromJSON DBRcvConnEvent where
-  parseJSON v = RCE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "RCE") v
-
-instance ToJSON DBRcvConnEvent where
-  toJSON (RCE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "RCE") v
-  toEncoding (RCE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "RCE") v
-
-instance FromJSON SndConnEvent where
-  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "SCE"
-
-instance ToJSON SndConnEvent where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SCE"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SCE"
-
-newtype DBSndConnEvent = SCE SndConnEvent
-
-instance FromJSON DBSndConnEvent where
-  parseJSON v = SCE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "SCE") v
-
-instance ToJSON DBSndConnEvent where
-  toJSON (SCE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "SCE") v
-  toEncoding (SCE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "SCE") v
-
-data RcvDirectEvent =
-  -- RDEProfileChanged {...}
-  RDEContactDeleted
-  deriving (Show, Generic)
-
-instance FromJSON RcvDirectEvent where
-  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RDE"
-
-instance ToJSON RcvDirectEvent where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RDE"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RDE"
-
-newtype DBRcvDirectEvent = RDE RcvDirectEvent
-
-instance FromJSON DBRcvDirectEvent where
-  parseJSON v = RDE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "RDE") v
-
-instance ToJSON DBRcvDirectEvent where
-  toJSON (RDE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "RDE") v
-  toEncoding (RDE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "RDE") v
-
 newtype DBMsgErrorType = DBME MsgErrorType
 
 instance FromJSON DBMsgErrorType where
@@ -334,25 +207,14 @@ data CIGroupInvitation = CIGroupInvitation
     groupProfile :: GroupProfile,
     status :: CIGroupInvitationStatus
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON CIGroupInvitation where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 data CIGroupInvitationStatus
   = CIGISPending
   | CIGISAccepted
   | CIGISRejected
   | CIGISExpired
-  deriving (Eq, Show, Generic)
-
-instance FromJSON CIGroupInvitationStatus where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CIGIS"
-
-instance ToJSON CIGroupInvitationStatus where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "CIGIS"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CIGIS"
+  deriving (Eq, Show)
 
 ciContentToText :: CIContent d -> Text
 ciContentToText = \case
@@ -477,27 +339,10 @@ msgDirToModeratedContent_ = \case
 ciModeratedText :: Text
 ciModeratedText = "moderated"
 
--- platform independent
-instance MsgDirectionI d => ToField (CIContent d) where
-  toField = toField . encodeJSON . dbJsonCIContent
-
--- platform specific
-instance MsgDirectionI d => ToJSON (CIContent d) where
-  toJSON = J.toJSON . jsonCIContent
-  toEncoding = J.toEncoding . jsonCIContent
-
 data ACIContent = forall d. MsgDirectionI d => ACIContent (SMsgDirection d) (CIContent d)
 
 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 specific
 data JSONCIContent
   = JCISndMsgContent {msgContent :: MsgContent}
@@ -526,14 +371,6 @@ data JSONCIContent
   | JCISndModerated
   | JCIRcvModerated
   | JCIInvalidJSON {direction :: MsgDirection, json :: Text}
-  deriving (Generic)
-
-instance FromJSON JSONCIContent where
-  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "JCI"
-
-instance ToJSON JSONCIContent where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCI"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCI"
 
 jsonCIContent :: forall d. MsgDirectionI d => CIContent d -> JSONCIContent
 jsonCIContent = \case
@@ -622,14 +459,6 @@ data DBJSONCIContent
   | DBJCISndModerated
   | DBJCIRcvModerated
   | DBJCIInvalidJSON {direction :: MsgDirection, json :: Text}
-  deriving (Generic)
-
-instance FromJSON DBJSONCIContent where
-  parseJSON = J.genericParseJSON . singleFieldJSON $ dropPrefix "DBJCI"
-
-instance ToJSON DBJSONCIContent where
-  toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "DBJCI"
-  toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "DBJCI"
 
 dbJsonCIContent :: forall d. MsgDirectionI d => CIContent d -> DBJSONCIContent
 dbJsonCIContent = \case
@@ -699,14 +528,7 @@ data CICallStatus
   | CISCallProgress
   | CISCallEnded
   | CISCallError
-  deriving (Show, Generic)
-
-instance FromJSON CICallStatus where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CISCall"
-
-instance ToJSON CICallStatus where
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "CISCall"
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CISCall"
+  deriving (Show)
 
 ciCallInfoText :: CICallStatus -> Int -> Text
 ciCallInfoText status duration = case status of
@@ -718,3 +540,37 @@ ciCallInfoText status duration = case status of
   CISCallProgress -> "in progress " <> durationText duration
   CISCallEnded -> "ended " <> durationText duration
   CISCallError -> "error"
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "MDE") ''MsgDecryptError)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "CIGIS") ''CIGroupInvitationStatus)
+
+$(JQ.deriveJSON defaultJSON ''CIGroupInvitation)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "CISCall") ''CICallStatus)
+
+-- platform specific
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCI") ''JSONCIContent)
+
+-- platform independent
+$(JQ.deriveJSON (singleFieldJSON $ dropPrefix "DBJCI") ''DBJSONCIContent)
+
+-- platform independent
+instance MsgDirectionI d => ToField (CIContent d) where
+  toField = toField . encodeJSON . dbJsonCIContent
+
+-- platform specific
+instance MsgDirectionI d => ToJSON (CIContent d) where
+  toJSON = J.toJSON . jsonCIContent
+  toEncoding = J.toEncoding . jsonCIContent
+
+instance MsgDirectionI d => FromJSON (CIContent d) where
+  parseJSON v = (\(ACIContent _ c) -> checkDirection c) <$?> J.parseJSON v
+
+-- platform independent
+dbParseACIContent :: Text -> Either String ACIContent
+dbParseACIContent = fmap aciContentDBJSON . J.eitherDecodeStrict' . encodeUtf8
+
+-- platform specific
+instance FromJSON ACIContent where
+  parseJSON = fmap aciContentJSON . J.parseJSON

src/Simplex/Chat/Messages/CIContent/Events.hs

@@ -0,0 +1,116 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Chat.Messages.CIContent.Events where
+
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson.TH as J
+import Simplex.Chat.Types
+import Simplex.Messaging.Agent.Protocol (RatchetSyncState (..), SwitchPhase (..))
+import Simplex.Messaging.Parsers (dropPrefix, singleFieldJSON, sumTypeJSON)
+
+data RcvGroupEvent
+  = RGEMemberAdded {groupMemberId :: GroupMemberId, profile :: Profile} -- CRJoinedGroupMemberConnecting
+  | RGEMemberConnected -- CRUserJoinedGroup, CRJoinedGroupMember, CRConnectedToGroupMember
+  | RGEMemberLeft -- CRLeftMember
+  | RGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole}
+  | RGEUserRole {role :: GroupMemberRole}
+  | RGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRDeletedMember
+  | RGEUserDeleted -- CRDeletedMemberUser
+  | RGEGroupDeleted -- CRGroupDeleted
+  | RGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated
+  -- RGEInvitedViaGroupLink chat items are not received - they're created when sending group invitations,
+  -- but being RcvGroupEvent allows them to be assigned to the respective member (and so enable "send direct message")
+  -- and be created as unread without adding / working around new status for sent items
+  | RGEInvitedViaGroupLink -- CRSentGroupInvitationViaLink
+  | RGEMemberCreatedContact -- CRNewMemberContactReceivedInv
+  deriving (Show)
+
+data SndGroupEvent
+  = SGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole}
+  | SGEUserRole {role :: GroupMemberRole}
+  | SGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRUserDeletedMember
+  | SGEUserLeft -- CRLeftMemberUser
+  | SGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated
+  deriving (Show)
+
+data RcvConnEvent
+  = RCESwitchQueue {phase :: SwitchPhase}
+  | RCERatchetSync {syncStatus :: RatchetSyncState}
+  | RCEVerificationCodeReset
+  deriving (Show)
+
+data SndConnEvent
+  = SCESwitchQueue {phase :: SwitchPhase, member :: Maybe GroupMemberRef}
+  | SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef}
+  deriving (Show)
+
+data RcvDirectEvent =
+  -- RDEProfileChanged {...}
+  RDEContactDeleted
+  deriving (Show)
+
+-- platform-specific JSON encoding (used in API)
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "RGE") ''RcvGroupEvent)
+
+-- platform-independent JSON encoding (stored in DB)
+newtype DBRcvGroupEvent = RGE RcvGroupEvent
+
+instance FromJSON DBRcvGroupEvent where
+  parseJSON v = RGE <$> $(J.mkParseJSON (singleFieldJSON $ dropPrefix "RGE") ''RcvGroupEvent) v
+
+instance ToJSON DBRcvGroupEvent where
+  toJSON (RGE v) = $(J.mkToJSON (singleFieldJSON $ dropPrefix "RGE") ''RcvGroupEvent) v
+  toEncoding (RGE v) = $(J.mkToEncoding (singleFieldJSON $ dropPrefix "RGE") ''RcvGroupEvent) v
+
+-- platform-specific JSON encoding (used in API)
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "SGE") ''SndGroupEvent)
+
+-- platform-independent JSON encoding (stored in DB)
+newtype DBSndGroupEvent = SGE SndGroupEvent
+
+instance FromJSON DBSndGroupEvent where
+  parseJSON v = SGE <$> $(J.mkParseJSON (singleFieldJSON $ dropPrefix "SGE") ''SndGroupEvent) v
+
+instance ToJSON DBSndGroupEvent where
+  toJSON (SGE v) = $(J.mkToJSON (singleFieldJSON $ dropPrefix "SGE") ''SndGroupEvent) v
+  toEncoding (SGE v) = $(J.mkToEncoding (singleFieldJSON $ dropPrefix "SGE") ''SndGroupEvent) v
+
+-- platform-specific JSON encoding (used in API)
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RcvConnEvent)
+
+-- platform-independent JSON encoding (stored in DB)
+newtype DBRcvConnEvent = RCE RcvConnEvent
+
+instance FromJSON DBRcvConnEvent where
+  parseJSON v = RCE <$> $(J.mkParseJSON (singleFieldJSON $ dropPrefix "RCE") ''RcvConnEvent) v
+
+instance ToJSON DBRcvConnEvent where
+  toJSON (RCE v) = $(J.mkToJSON (singleFieldJSON $ dropPrefix "RCE") ''RcvConnEvent) v
+  toEncoding (RCE v) = $(J.mkToEncoding (singleFieldJSON $ dropPrefix "RCE") ''RcvConnEvent) v
+
+-- platform-specific JSON encoding (used in API)
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "SCE") ''SndConnEvent)
+
+-- platform-independent JSON encoding (stored in DB)
+newtype DBSndConnEvent = SCE SndConnEvent
+
+instance FromJSON DBSndConnEvent where
+  parseJSON v = SCE <$> $(J.mkParseJSON (singleFieldJSON $ dropPrefix "SCE") ''SndConnEvent) v
+
+instance ToJSON DBSndConnEvent where
+  toJSON (SCE v) = $(J.mkToJSON (singleFieldJSON $ dropPrefix "SCE") ''SndConnEvent) v
+  toEncoding (SCE v) = $(J.mkToEncoding (singleFieldJSON $ dropPrefix "SCE") ''SndConnEvent) v
+
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "RDE") ''RcvDirectEvent)
+
+-- platform-independent JSON encoding (stored in DB)
+newtype DBRcvDirectEvent = RDE RcvDirectEvent
+
+instance FromJSON DBRcvDirectEvent where
+  parseJSON v = RDE <$> $(J.mkParseJSON (singleFieldJSON $ dropPrefix "RDE") ''RcvDirectEvent) v
+
+instance ToJSON DBRcvDirectEvent where
+  toJSON (RDE v) = $(J.mkToJSON (singleFieldJSON $ dropPrefix "RDE") ''RcvDirectEvent) v
+  toEncoding (RDE v) = $(J.mkToEncoding (singleFieldJSON $ dropPrefix "RDE") ''RcvDirectEvent) v

src/Simplex/Chat/Migrations/M20231114_remote_control.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Migrations.M20231114_remote_control where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20231114_remote_control :: Query
+m20231114_remote_control =
+  [sql|
+CREATE TABLE remote_hosts ( -- e.g., mobiles known to a desktop app
+  remote_host_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  host_device_name TEXT NOT NULL,
+  store_path TEXT NOT NULL, -- relative folder name for host files
+  ca_key BLOB NOT NULL,
+  ca_cert BLOB NOT NULL,
+  id_key BLOB NOT NULL, -- long-term/identity signing key
+  host_fingerprint BLOB NOT NULL, -- remote host CA cert fingerprint, set when connected
+  host_dh_pub BLOB NOT NULL -- last session DH key
+);
+
+CREATE UNIQUE INDEX idx_remote_hosts_host_fingerprint ON remote_hosts(host_fingerprint);
+
+CREATE TABLE remote_controllers ( -- e.g., desktops known to a mobile app
+  remote_ctrl_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  ctrl_device_name TEXT NOT NULL,
+  ca_key BLOB NOT NULL,
+  ca_cert BLOB NOT NULL,
+  ctrl_fingerprint BLOB NOT NULL, -- remote controller CA cert fingerprint, set when connected
+  id_pub BLOB NOT NULL, -- remote controller long-term/identity key to verify signatures
+  dh_priv_key BLOB NOT NULL, -- last session DH key
+  prev_dh_priv_key BLOB -- previous session DH key
+);
+
+CREATE UNIQUE INDEX idx_remote_controllers_ctrl_fingerprint ON remote_controllers(ctrl_fingerprint);
+|]
+
+down_m20231114_remote_control :: Query
+down_m20231114_remote_control =
+  [sql|
+DROP INDEX idx_remote_hosts_host_fingerprint;
+DROP INDEX idx_remote_controllers_ctrl_fingerprint;
+DROP TABLE remote_hosts;
+DROP TABLE remote_controllers;
+|]

src/Simplex/Chat/Migrations/chat_schema.sql

@@ -527,6 +527,28 @@ CREATE TABLE IF NOT EXISTS "received_probes"(
   created_at TEXT CHECK(created_at NOT NULL),
   updated_at TEXT CHECK(updated_at NOT NULL)
 );
+CREATE TABLE remote_hosts(
+  -- e.g., mobiles known to a desktop app
+  remote_host_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  host_device_name TEXT NOT NULL,
+  store_path TEXT NOT NULL, -- relative folder name for host files
+  ca_key BLOB NOT NULL,
+  ca_cert BLOB NOT NULL,
+  id_key BLOB NOT NULL, -- long-term/identity signing key
+  host_fingerprint BLOB NOT NULL, -- remote host CA cert fingerprint, set when connected
+  host_dh_pub BLOB NOT NULL -- last session DH key
+);
+CREATE TABLE remote_controllers(
+  -- e.g., desktops known to a mobile app
+  remote_ctrl_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  ctrl_device_name TEXT NOT NULL,
+  ca_key BLOB NOT NULL,
+  ca_cert BLOB NOT NULL,
+  ctrl_fingerprint BLOB NOT NULL, -- remote controller CA cert fingerprint, set when connected
+  id_pub BLOB NOT NULL, -- remote controller long-term/identity key to verify signatures
+  dh_priv_key BLOB NOT NULL, -- last session DH key
+  prev_dh_priv_key BLOB -- previous session DH key
+);
 CREATE INDEX contact_profiles_index ON contact_profiles(
   display_name,
   full_name
@@ -778,3 +800,9 @@ CREATE INDEX idx_messages_group_id_shared_msg_id ON messages(
 CREATE INDEX idx_chat_items_forwarded_by_group_member_id ON chat_items(
   forwarded_by_group_member_id
 );
+CREATE UNIQUE INDEX idx_remote_hosts_host_fingerprint ON remote_hosts(
+  host_fingerprint
+);
+CREATE UNIQUE INDEX idx_remote_controllers_ctrl_fingerprint ON remote_controllers(
+  ctrl_fingerprint
+);

src/Simplex/Chat/Mobile.hs

@@ -1,18 +1,20 @@
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 
+{-# OPTIONS_GHC -fobject-code #-}
+
 module Simplex.Chat.Mobile where
 
 import Control.Concurrent.STM
 import Control.Exception (catch, SomeException)
 import Control.Monad.Except
 import Control.Monad.Reader
-import Data.Aeson (ToJSON (..))
 import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
@@ -30,7 +32,6 @@ import Foreign.Ptr
 import Foreign.StablePtr
 import Foreign.Storable (poke)
 import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding)
-import GHC.Generics (Generic)
 import Simplex.Chat
 import Simplex.Chat.Controller
 import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
@@ -38,6 +39,7 @@ import Simplex.Chat.Mobile.File
 import Simplex.Chat.Mobile.Shared
 import Simplex.Chat.Mobile.WebRTC
 import Simplex.Chat.Options
+import Simplex.Chat.Remote.Types
 import Simplex.Chat.Store
 import Simplex.Chat.Store.Profiles
 import Simplex.Chat.Types
@@ -47,18 +49,34 @@ import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), Migrati
 import Simplex.Messaging.Client (defaultNetworkConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), BasicAuth (..), CorrId (..), ProtoServerWithAuth (..), ProtocolServer (..))
 import Simplex.Messaging.Util (catchAll, liftEitherWith, safeDecodeUtf8)
 import System.IO (utf8)
 import System.Timeout (timeout)
 
+data DBMigrationResult
+  = DBMOk
+  | DBMInvalidConfirmation
+  | DBMErrorNotADatabase {dbFile :: String}
+  | DBMErrorMigration {dbFile :: String, migrationError :: MigrationError}
+  | DBMErrorSQL {dbFile :: String, migrationSQLError :: String}
+  deriving (Show)
+
+$(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "DBM") ''DBMigrationResult)
+
+data APIResponse = APIResponse {corr :: Maybe CorrId, remoteHostId :: Maybe RemoteHostId, resp :: ChatResponse}
+
+$(JQ.deriveToJSON defaultJSON ''APIResponse)
+
 foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
 
 foreign export ccall "chat_close_store" cChatCloseStore :: StablePtr ChatController -> IO CString
 
 foreign export ccall "chat_send_cmd" cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
 
+foreign export ccall "chat_send_remote_cmd" cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CJSONString
+
 foreign export ccall "chat_recv_msg" cChatRecvMsg :: StablePtr ChatController -> IO CJSONString
 
 foreign export ccall "chat_recv_msg_wait" cChatRecvMsgWait :: StablePtr ChatController -> CInt -> IO CJSONString
@@ -111,6 +129,14 @@ cChatSendCmd cPtr cCmd = do
   cmd <- B.packCString cCmd
   newCStringFromLazyBS =<< chatSendCmd c cmd
 
+-- | send command to chat (same syntax as in terminal for now)
+cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CJSONString
+cChatSendRemoteCmd cPtr cRemoteHostId cCmd = do
+  c <- deRefStablePtr cPtr
+  cmd <- B.packCString cCmd
+  let rhId = Just $ fromIntegral cRemoteHostId
+  newCStringFromLazyBS =<< chatSendRemoteCmd c rhId cmd
+
 -- | receive message from chat (blocking)
 cChatRecvMsg :: StablePtr ChatController -> IO CJSONString
 cChatRecvMsg cc = deRefStablePtr cc >>= chatRecvMsg >>= newCStringFromLazyBS
@@ -177,18 +203,6 @@ defaultMobileConfig =
 getActiveUser_ :: SQLiteStore -> IO (Maybe User)
 getActiveUser_ st = find activeUser <$> withTransaction st getUsers
 
-data DBMigrationResult
-  = DBMOk
-  | DBMInvalidConfirmation
-  | DBMErrorNotADatabase {dbFile :: String}
-  | DBMErrorMigration {dbFile :: String, migrationError :: MigrationError}
-  | DBMErrorSQL {dbFile :: String, migrationSQLError :: String}
-  deriving (Show, Generic)
-
-instance ToJSON DBMigrationResult where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "DBM"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "DBM"
-
 chatMigrateInit :: String -> String -> String -> IO (Either DBMigrationResult ChatController)
 chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do
   confirmMigrations <- liftEitherWith (const DBMInvalidConfirmation) $ strDecode $ B.pack confirm
@@ -218,13 +232,16 @@ chatCloseStore ChatController {chatStore, smpAgent} = handleErr $ do
 handleErr :: IO () -> IO String
 handleErr a = (a $> "") `catch` (pure . show @SomeException)
   
-chatSendCmd :: ChatController -> ByteString -> IO JSONByteString
-chatSendCmd cc s = J.encode . APIResponse Nothing <$> runReaderT (execChatCommand s) cc
+chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString
+chatSendCmd cc = chatSendRemoteCmd cc Nothing
+
+chatSendRemoteCmd :: ChatController -> Maybe RemoteHostId -> B.ByteString -> IO JSONByteString
+chatSendRemoteCmd cc rh s = J.encode . APIResponse Nothing rh <$> runReaderT (execChatCommand rh s) cc
 
 chatRecvMsg :: ChatController -> IO JSONByteString
 chatRecvMsg ChatController {outputQ} = json <$> atomically (readTBQueue outputQ)
   where
-    json (corr, resp) = J.encode APIResponse {corr, resp}
+    json (corr, remoteHostId, resp) = J.encode APIResponse {corr, remoteHostId, resp}
 
 chatRecvMsgWait :: ChatController -> Int -> IO JSONByteString
 chatRecvMsgWait cc time = fromMaybe "" <$> timeout time (chatRecvMsg cc)
@@ -249,10 +266,3 @@ chatPasswordHash pwd salt = either (const "") passwordHash salt'
   where
     salt' = U.decode salt
     passwordHash = U.encode . C.sha512Hash . (pwd <>)
-
-data APIResponse = APIResponse {corr :: Maybe CorrId, resp :: ChatResponse}
-  deriving (Generic)
-
-instance ToJSON APIResponse where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}

src/Simplex/Chat/Mobile/File.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Chat.Mobile.File
@@ -17,8 +17,9 @@ module Simplex.Chat.Mobile.File
 where
 
 import Control.Monad.Except
-import Data.Aeson (ToJSON)
+import Control.Monad.IO.Class
 import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as LB
@@ -30,7 +31,6 @@ import Foreign.C
 import Foreign.Marshal.Alloc (mallocBytes)
 import Foreign.Ptr
 import Foreign.Storable (poke, pokeByteOff)
-import GHC.Generics (Generic)
 import Simplex.Chat.Mobile.Shared
 import Simplex.Chat.Util (chunkSize, encryptFile)
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..), CryptoFileHandle, FTCryptoError (..))
@@ -43,9 +43,8 @@ import UnliftIO (Handle, IOMode (..), withFile)
 data WriteFileResult
   = WFResult {cryptoArgs :: CryptoFileArgs}
   | WFError {writeError :: String}
-  deriving (Generic)
 
-instance ToJSON WriteFileResult where toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "WF"
+$(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "WF") ''WriteFileResult)
 
 cChatWriteFile :: CString -> Ptr Word8 -> CInt -> IO CJSONString
 cChatWriteFile cPath ptr len = do
@@ -64,9 +63,6 @@ chatWriteFile path s = do
 data ReadFileResult
   = RFResult {fileSize :: Int}
   | RFError {readError :: String}
-  deriving (Generic)
-
-instance ToJSON ReadFileResult where toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RF"
 
 cChatReadFile :: CString -> CString -> CString -> IO (Ptr Word8)
 cChatReadFile cPath cKey cNonce = do
@@ -102,7 +98,7 @@ chatEncryptFile fromPath toPath =
   either WFError WFResult <$> runCatchExceptT encrypt
   where
     encrypt = do
-      cfArgs <- liftIO $ CF.randomArgs
+      cfArgs <- liftIO CF.randomArgs
       encryptFile fromPath toPath cfArgs
       pure cfArgs
 
@@ -139,3 +135,5 @@ chatDecryptFile fromPath keyStr nonceStr toPath = fromLeft "" <$> runCatchExcept
 
 runCatchExceptT :: ExceptT String IO a -> IO (Either String a)
 runCatchExceptT action = runExceptT action `catchAll` (pure . Left . show)
+
+$(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "RF") ''ReadFileResult)

src/Simplex/Chat/Protocol.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -12,6 +11,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.Chat.Protocol where
@@ -22,6 +22,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.KeyMap as JM
+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)
@@ -39,13 +40,12 @@ import Data.Typeable (Typeable)
 import Data.Word (Word32)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
-import GHC.Generics (Generic)
 import Simplex.Chat.Call
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Util
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
 import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
 import Simplex.Messaging.Version hiding (version)
 
@@ -77,11 +77,9 @@ data ConnectionEntity
   | SndFileConnection {entityConnection :: Connection, sndFileTransfer :: SndFileTransfer}
   | RcvFileConnection {entityConnection :: Connection, rcvFileTransfer :: RcvFileTransfer}
   | UserContactConnection {entityConnection :: Connection, userContact :: UserContact}
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
-instance ToJSON ConnectionEntity where
-  toJSON = J.genericToJSON $ sumTypeJSON fstToLower
-  toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower
+$(JQ.deriveJSON (sumTypeJSON fstToLower) ''ConnectionEntity)
 
 updateEntityConnStatus :: ConnectionEntity -> ConnStatus -> ConnectionEntity
 updateEntityConnStatus connEntity connStatus = case connEntity of
@@ -108,8 +106,6 @@ instance MsgEncodingI 'Binary where encoding = SBinary
 
 instance MsgEncodingI 'Json where encoding = SJson
 
-data ACMEventTag = forall e. MsgEncodingI e => ACMEventTag (SMsgEncoding e) (CMEventTag e)
-
 instance TestEquality SMsgEncoding where
   testEquality SBinary SBinary = Just Refl
   testEquality SJson SJson = Just Refl
@@ -131,7 +127,6 @@ data AppMessageJson = AppMessageJson
     event :: Text,
     params :: J.Object
   }
-  deriving (Eq, Show, Generic, FromJSON)
 
 data AppMessageBinary = AppMessageBinary
   { msgId :: Maybe SharedMsgId,
@@ -139,10 +134,6 @@ data AppMessageBinary = AppMessageBinary
     body :: ByteString
   }
 
-instance ToJSON AppMessageJson where
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-
 instance StrEncoding AppMessageBinary where
   strEncode AppMessageBinary {tag, msgId, body} = smpEncode (tag, msgId', Tail body)
     where
@@ -171,20 +162,42 @@ instance ToJSON SharedMsgId where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+$(JQ.deriveJSON defaultJSON ''AppMessageJson)
+
 data MsgRef = MsgRef
   { msgId :: Maybe SharedMsgId,
     sentAt :: UTCTime,
     sent :: Bool,
     memberId :: Maybe MemberId -- must be present in all group message references, both referencing sent and received
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
-instance FromJSON MsgRef where
-  parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
+$(JQ.deriveJSON defaultJSON ''MsgRef)
 
-instance ToJSON MsgRef where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+data LinkPreview = LinkPreview {uri :: Text, title :: Text, description :: Text, image :: ImageData, content :: Maybe LinkContent}
+  deriving (Eq, Show)
+
+data LinkContent = LCPage | LCImage | LCVideo {duration :: Maybe Int} | LCUnknown {tag :: Text, json :: J.Object}
+  deriving (Eq, Show)
+
+$(pure [])
+
+instance FromJSON LinkContent where
+  parseJSON v@(J.Object j) =
+    $(JQ.mkParseJSON (taggedObjectJSON $ dropPrefix "LC") ''LinkContent) v
+      <|> LCUnknown <$> j .: "type" <*> pure j
+  parseJSON invalid =
+    JT.prependFailure "bad LinkContent, " (JT.typeMismatch "Object" invalid)
+
+instance ToJSON LinkContent where
+  toJSON = \case
+    LCUnknown _ j -> J.Object j
+    v -> $(JQ.mkToJSON (taggedObjectJSON $ dropPrefix "LC") ''LinkContent) v
+  toEncoding = \case
+    LCUnknown _ j -> JE.value $ J.Object j
+    v -> $(JQ.mkToEncoding (taggedObjectJSON $ dropPrefix "LC") ''LinkContent) v
+
+$(JQ.deriveJSON defaultJSON ''LinkPreview)
 
 data ChatMessage e = ChatMessage
   { chatVRange :: VersionRange,
@@ -195,19 +208,6 @@ data ChatMessage e = ChatMessage
 
 data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMessage e)
 
-instance MsgEncodingI e => StrEncoding (ChatMessage e) where
-  strEncode msg = case chatToAppMessage msg of
-    AMJson m -> LB.toStrict $ J.encode m
-    AMBinary m -> strEncode m
-  strP = (\(ACMsg _ m) -> checkEncoding m) <$?> strP
-
-instance StrEncoding AChatMessage where
-  strEncode (ACMsg _ m) = strEncode m
-  strP =
-    A.peekChar' >>= \case
-      '{' -> ACMsg SJson <$> ((appJsonToCM <=< J.eitherDecodeStrict') <$?> A.takeByteString)
-      _ -> ACMsg SBinary <$> (appBinaryToCM <$?> strP)
-
 data ChatMsgEvent (e :: MsgEncoding) where
   XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
   XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
@@ -359,11 +359,7 @@ instance Encoding InlineFileChunk where
         pure FileChunk {chunkNo = fromIntegral $ c2w c, chunkBytes}
 
 data QuotedMsg = QuotedMsg {msgRef :: MsgRef, content :: MsgContent}
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON QuotedMsg where
-  toEncoding = J.genericToEncoding J.defaultOptions
-  toJSON = J.genericToJSON J.defaultOptions
+  deriving (Eq, Show)
 
 cmToQuotedMsg :: AChatMsgEvent -> Maybe QuotedMsg
 cmToQuotedMsg = \case
@@ -416,34 +412,6 @@ isQuote = \case
   MCQuote {} -> True
   _ -> False
 
-data LinkPreview = LinkPreview {uri :: Text, title :: Text, description :: Text, image :: ImageData, content :: Maybe LinkContent}
-  deriving (Eq, Show, Generic)
-
-data LinkContent = LCPage | LCImage | LCVideo {duration :: Maybe Int} | LCUnknown {tag :: Text, json :: J.Object}
-  deriving (Eq, Show, Generic)
-
-instance FromJSON LinkPreview where
-  parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
-
-instance ToJSON LinkPreview where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-
-instance FromJSON LinkContent where
-  parseJSON v@(J.Object j) =
-    J.genericParseJSON (taggedObjectJSON $ dropPrefix "LC") v
-      <|> LCUnknown <$> j .: "type" <*> pure j
-  parseJSON invalid =
-    JT.prependFailure "bad LinkContent, " (JT.typeMismatch "Object" invalid)
-
-instance ToJSON LinkContent where
-  toJSON = \case
-    LCUnknown _ j -> J.Object j
-    v -> J.genericToJSON (taggedObjectJSON $ dropPrefix "LC") v
-  toEncoding = \case
-    LCUnknown _ j -> JE.value $ J.Object j
-    v -> J.genericToEncoding (taggedObjectJSON $ dropPrefix "LC") v
-
 data MsgContent
   = MCText Text
   | MCLink {text :: Text, preview :: LinkPreview}
@@ -496,6 +464,21 @@ msgContentTag = \case
 data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: Maybe FileInvitation, ttl :: Maybe Int, live :: Maybe Bool}
   deriving (Eq, Show)
 
+$(JQ.deriveJSON defaultJSON ''QuotedMsg)
+
+instance MsgEncodingI e => StrEncoding (ChatMessage e) where
+  strEncode msg = case chatToAppMessage msg of
+    AMJson m -> LB.toStrict $ J.encode m
+    AMBinary m -> strEncode m
+  strP = (\(ACMsg _ m) -> checkEncoding m) <$?> strP
+
+instance StrEncoding AChatMessage where
+  strEncode (ACMsg _ m) = strEncode m
+  strP =
+    A.peekChar' >>= \case
+      '{' -> ACMsg SJson <$> ((appJsonToCM <=< J.eitherDecodeStrict') <$?> A.takeByteString)
+      _ -> ACMsg SBinary <$> (appBinaryToCM <$?> strP)
+
 parseMsgContainer :: J.Object -> JT.Parser MsgContainer
 parseMsgContainer v =
   MCQuote <$> v .: "quote" <*> mc
@@ -575,6 +558,8 @@ instance ToField MsgContent where
 instance FromField MsgContent where
   fromField = fromTextField_ decodeJSON
 
+data ACMEventTag = forall e. MsgEncodingI e => ACMEventTag (SMsgEncoding e) (CMEventTag e)
+
 data CMEventTag (e :: MsgEncoding) where
   XMsgNew_ :: CMEventTag 'Json
   XMsgFileDescr_ :: CMEventTag 'Json

src/Simplex/Chat/Remote.hs

@@ -0,0 +1,696 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
+
+module Simplex.Chat.Remote where
+
+import Control.Applicative ((<|>))
+import Control.Logger.Simple
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Crypto.Random (getRandomBytes)
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Types as JT
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64.URL as B64U
+import Data.ByteString.Builder (Builder)
+import qualified Data.ByteString.Char8 as B
+import Data.Functor (($>))
+import Data.List.NonEmpty (nonEmpty)
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe, isJust)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
+import Data.Word (Word32)
+import qualified Network.HTTP.Types as N
+import Network.HTTP2.Server (responseStreaming)
+import qualified Paths_simplex_chat as SC
+import Simplex.Chat.Archive (archiveFilesFolder)
+import Simplex.Chat.Controller
+import Simplex.Chat.Files
+import Simplex.Chat.Messages (chatNameStr)
+import Simplex.Chat.Remote.AppVersion
+import Simplex.Chat.Remote.Protocol
+import Simplex.Chat.Remote.RevHTTP (attachHTTP2Server, attachRevHTTP2Client)
+import Simplex.Chat.Remote.Transport
+import Simplex.Chat.Remote.Types
+import Simplex.Chat.Store.Files
+import Simplex.Chat.Store.Remote
+import Simplex.Chat.Store.Shared
+import Simplex.Chat.Types
+import Simplex.Chat.Util (encryptFile)
+import Simplex.FileTransfer.Description (FileDigest (..))
+import Simplex.Messaging.Agent
+import Simplex.Messaging.Agent.Protocol (AgentErrorType (RCP))
+import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
+import qualified Simplex.Messaging.Crypto.File as CF
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Transport (TLS, closeConnection, tlsUniq)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2ClientError, closeHTTP2Client)
+import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..))
+import Simplex.Messaging.Util
+import Simplex.RemoteControl.Client
+import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..), RCVerifiedInvitation (..), verifySignedInvitation)
+import Simplex.RemoteControl.Types
+import System.FilePath (takeFileName, (</>))
+import UnliftIO
+import UnliftIO.Concurrent (forkIO)
+import UnliftIO.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive, renameFile)
+
+-- when acting as host
+minRemoteCtrlVersion :: AppVersion
+minRemoteCtrlVersion = AppVersion [5, 4, 0, 3]
+
+-- when acting as controller
+minRemoteHostVersion :: AppVersion
+minRemoteHostVersion = AppVersion [5, 4, 0, 3]
+
+currentAppVersion :: AppVersion
+currentAppVersion = AppVersion SC.version
+
+ctrlAppVersionRange :: AppVersionRange
+ctrlAppVersionRange = mkAppVersionRange minRemoteHostVersion currentAppVersion
+
+hostAppVersionRange :: AppVersionRange
+hostAppVersionRange = mkAppVersionRange minRemoteCtrlVersion currentAppVersion
+
+networkIOTimeout :: Int
+networkIOTimeout = 15000000
+
+discoveryTimeout :: Int
+discoveryTimeout = 60000000
+
+-- * Desktop side
+
+getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient
+getRemoteHostClient rhId = do
+  sessions <- asks remoteHostSessions
+  liftIOEither . atomically $ TM.lookup rhKey sessions >>= \case
+    Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient
+    Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
+    Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
+  where
+    rhKey = RHId rhId
+
+withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a
+withRemoteHostSession rhKey sseq f = do
+  sessions <- asks remoteHostSessions
+  r <- atomically $
+    TM.lookup rhKey sessions >>= \case
+      Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
+      Just (stateSeq, state)
+        | stateSeq /= sseq -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
+        | otherwise -> case f state of
+            Right (r, newState) -> Right r <$ TM.insert rhKey (sseq, newState) sessions
+            Left ce -> pure $ Left ce
+  liftEither r
+
+-- | Transition session state with a 'RHNew' ID to an assigned 'RemoteHostId'
+setNewRemoteHostId :: ChatMonad m => SessionSeq -> RemoteHostId -> m ()
+setNewRemoteHostId sseq rhId = do
+  sessions <- asks remoteHostSessions
+  liftIOEither . atomically $ do
+    TM.lookup RHNew sessions >>= \case
+      Nothing -> err RHEMissing
+      Just sess@(stateSeq, _)
+        | stateSeq /= sseq -> err RHEBadState
+        | otherwise -> do
+            TM.delete RHNew sessions
+            TM.insert (RHId rhId) sess sessions
+            pure $ Right ()
+  where
+    err = pure . Left . ChatErrorRemoteHost RHNew
+
+startRemoteHost :: ChatMonad m => Maybe (RemoteHostId, Bool) -> m (Maybe RemoteHostInfo, RCSignedInvitation)
+startRemoteHost rh_ = do
+  (rhKey, multicast, remoteHost_, pairing) <- case rh_ of
+    Just (rhId, multicast) -> do
+      rh@RemoteHost {hostPairing} <- withStore $ \db -> getRemoteHost db rhId
+      pure (RHId rhId, multicast, Just $ remoteHostInfo rh $ Just RHSStarting, hostPairing) -- get from the database, start multicast if requested
+    Nothing -> (RHNew,False,Nothing,) <$> rcNewHostPairing
+  sseq <- startRemoteHostSession rhKey
+  ctrlAppInfo <- mkCtrlAppInfo
+  (invitation, rchClient, vars) <- handleConnectError rhKey sseq . withAgent $ \a -> rcConnectHost a pairing (J.toJSON ctrlAppInfo) multicast
+  cmdOk <- newEmptyTMVarIO
+  rhsWaitSession <- async $ do
+    rhKeyVar <- newTVarIO rhKey
+    atomically $ takeTMVar cmdOk
+    handleHostError sseq rhKeyVar $ waitForHostSession remoteHost_ rhKey sseq rhKeyVar vars
+  let rhs = RHPendingSession {rhKey, rchClient, rhsWaitSession, remoteHost_}
+  withRemoteHostSession rhKey sseq $ \case
+    RHSessionStarting ->
+      let inv = decodeLatin1 $ strEncode invitation
+       in Right ((), RHSessionConnecting inv rhs)
+    _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
+  (remoteHost_, invitation) <$ atomically (putTMVar cmdOk ())
+  where
+    mkCtrlAppInfo = do
+      deviceName <- chatReadVar localDeviceName
+      pure CtrlAppInfo {appVersionRange = ctrlAppVersionRange, deviceName}
+    parseHostAppInfo :: RCHostHello -> ExceptT RemoteHostError IO HostAppInfo
+    parseHostAppInfo RCHostHello {app = hostAppInfo} = do
+      hostInfo@HostAppInfo {appVersion, encoding} <-
+        liftEitherWith (RHEProtocolError . RPEInvalidJSON) $ JT.parseEither J.parseJSON hostAppInfo
+      unless (isAppCompatible appVersion ctrlAppVersionRange) $ throwError $ RHEBadVersion appVersion
+      when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding
+      pure hostInfo
+    handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a
+    handleConnectError rhKey sessSeq action = action `catchChatError` \err -> do
+      logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err
+      cancelRemoteHostSession (Just sessSeq) rhKey
+      throwError err
+    handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m ()
+    handleHostError sessSeq rhKeyVar action = action `catchChatError` \err -> do
+      logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
+      readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just sessSeq)
+    waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
+    waitForHostSession remoteHost_ rhKey sseq rhKeyVar vars = do
+      (sessId, tls, vars') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars
+      let sessionCode = verificationCode sessId
+      withRemoteHostSession rhKey sseq $ \case
+        RHSessionConnecting _inv rhs' -> Right ((), RHSessionPendingConfirmation sessionCode tls rhs')
+        _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
+      let rh_' = (\rh -> (rh :: RemoteHostInfo) {sessionState = Just RHSPendingConfirmation {sessionCode}}) <$> remoteHost_
+      toView $ CRRemoteHostSessionCode {remoteHost_ = rh_', sessionCode}
+      (RCHostSession {sessionKeys}, rhHello, pairing') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars'
+      hostInfo@HostAppInfo {deviceName = hostDeviceName} <-
+        liftError (ChatErrorRemoteHost rhKey) $ parseHostAppInfo rhHello
+      withRemoteHostSession rhKey sseq $ \case
+        RHSessionPendingConfirmation _ tls' rhs' -> Right ((), RHSessionConfirmed tls' rhs')
+        _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
+      rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' rh_' hostDeviceName sseq RHSConfirmed {sessionCode}
+      let rhKey' = RHId remoteHostId -- rhKey may be invalid after upserting on RHNew
+      when (rhKey' /= rhKey) $ do
+        atomically $ writeTVar rhKeyVar rhKey'
+        toView $ CRNewRemoteHost rhi
+      -- set up HTTP transport and remote profile protocol
+      disconnected <- toIO $ onDisconnected rhKey' sseq
+      httpClient <- liftEitherError (httpError remoteHostId) $ attachRevHTTP2Client disconnected tls
+      rhClient <- mkRemoteHostClient httpClient sessionKeys sessId storePath hostInfo
+      pollAction <- async $ pollEvents remoteHostId rhClient
+      withRemoteHostSession rhKey' sseq $ \case
+        RHSessionConfirmed _ RHPendingSession {rchClient} -> Right ((), RHSessionConnected {rchClient, tls, rhClient, pollAction, storePath})
+        _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
+      chatWriteVar currentRemoteHost $ Just remoteHostId -- this is required for commands to be passed to remote host
+      toView $ CRRemoteHostConnected rhi {sessionState = Just RHSConnected {sessionCode}}
+    upsertRemoteHost :: ChatMonad m => RCHostPairing -> Maybe RemoteHostInfo -> Text -> SessionSeq -> RemoteHostSessionState -> m RemoteHostInfo
+    upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ hostDeviceName sseq state = do
+      KnownHostPairing {hostDhPubKey = hostDhPubKey'} <- maybe (throwError . ChatError $ CEInternalError "KnownHost is known after verification") pure kh_
+      case rhi_ of
+        Nothing -> do
+          storePath <- liftIO randomStorePath
+          rh@RemoteHost {remoteHostId} <- withStore $ \db -> insertRemoteHost db hostDeviceName storePath pairing' >>= getRemoteHost db
+          setNewRemoteHostId sseq remoteHostId
+          pure $ remoteHostInfo rh $ Just state
+        Just rhi@RemoteHostInfo {remoteHostId} -> do
+          withStore' $ \db -> updateHostPairing db remoteHostId hostDeviceName hostDhPubKey'
+          pure (rhi :: RemoteHostInfo) {sessionState = Just state}
+    onDisconnected :: ChatMonad m => RHKey -> SessionSeq -> m ()
+    onDisconnected rhKey sseq = do
+      logDebug $ "HTTP2 client disconnected: " <> tshow (rhKey, sseq)
+      cancelRemoteHostSession (Just sseq) rhKey
+    pollEvents :: ChatMonad m => RemoteHostId -> RemoteHostClient -> m ()
+    pollEvents rhId rhClient = do
+      oq <- asks outputQ
+      forever $ do
+        r_ <- liftRH rhId $ remoteRecv rhClient 10000000
+        forM r_ $ \r -> atomically $ writeTBQueue oq (Nothing, Just rhId, r)
+    httpError :: RemoteHostId -> HTTP2ClientError -> ChatError
+    httpError rhId = ChatErrorRemoteHost (RHId rhId) . RHEProtocolError . RPEHTTP2 . tshow
+
+startRemoteHostSession :: ChatMonad m => RHKey -> m SessionSeq
+startRemoteHostSession rhKey = do
+  sessions <- asks remoteHostSessions
+  nextSessionSeq <- asks remoteSessionSeq
+  liftIOEither . atomically $
+    TM.lookup rhKey sessions >>= \case
+      Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBusy
+      Nothing -> do
+        sessionSeq <- stateTVar nextSessionSeq $ \s -> (s, s + 1)
+        Right sessionSeq <$ TM.insert rhKey (sessionSeq, RHSessionStarting) sessions
+
+closeRemoteHost :: ChatMonad m => RHKey -> m ()
+closeRemoteHost rhKey = do
+  logNote $ "Closing remote host session for " <> tshow rhKey
+  cancelRemoteHostSession Nothing rhKey
+
+cancelRemoteHostSession :: ChatMonad m => Maybe SessionSeq -> RHKey -> m ()
+cancelRemoteHostSession sseq_ rhKey = do
+  sessions <- asks remoteHostSessions
+  crh <- asks currentRemoteHost
+  deregistered <- atomically $
+    TM.lookup rhKey sessions >>= \case
+      Nothing -> pure Nothing
+      Just (sessSeq, _) | maybe False (/= sessSeq) sseq_ -> pure Nothing -- ignore cancel from a ghost session handler
+      Just (_, rhs) -> do
+        TM.delete rhKey sessions
+        modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH
+        pure $ Just rhs
+  forM_ deregistered $ \session -> do
+    liftIO $ cancelRemoteHost handlingError session `catchAny` (logError . tshow)
+    when handlingError $ toView $ CRRemoteHostStopped rhId_
+  where
+    handlingError = isJust sseq_
+    rhId_ = case rhKey of
+      RHNew -> Nothing
+      RHId rhId -> Just rhId
+
+cancelRemoteHost :: Bool -> RemoteHostSession -> IO ()
+cancelRemoteHost handlingError = \case
+  RHSessionStarting -> pure ()
+  RHSessionConnecting _inv rhs -> cancelPendingSession rhs
+  RHSessionPendingConfirmation _sessCode tls rhs -> do
+    cancelPendingSession rhs
+    closeConnection tls
+  RHSessionConfirmed tls rhs -> do
+    cancelPendingSession rhs
+    closeConnection tls
+  RHSessionConnected {rchClient, tls, rhClient = RemoteHostClient {httpClient}, pollAction} -> do
+    uninterruptibleCancel pollAction
+    cancelHostClient rchClient `catchAny` (logError . tshow)
+    closeConnection tls `catchAny` (logError . tshow)
+    unless handlingError $ closeHTTP2Client httpClient `catchAny` (logError . tshow)
+  where
+    cancelPendingSession RHPendingSession {rchClient, rhsWaitSession} = do
+      unless handlingError $ uninterruptibleCancel rhsWaitSession `catchAny` (logError . tshow)
+      cancelHostClient rchClient `catchAny` (logError . tshow)
+
+-- | Generate a random 16-char filepath without / in it by using base64url encoding.
+randomStorePath :: IO FilePath
+randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12
+
+listRemoteHosts :: ChatMonad m => m [RemoteHostInfo]
+listRemoteHosts = do
+  sessions <- chatReadVar remoteHostSessions
+  map (rhInfo sessions) <$> withStore' getRemoteHosts
+  where
+    rhInfo sessions rh@RemoteHost {remoteHostId} =
+      remoteHostInfo rh $ rhsSessionState . snd <$> M.lookup (RHId remoteHostId) sessions
+
+switchRemoteHost :: ChatMonad m => Maybe RemoteHostId -> m (Maybe RemoteHostInfo)
+switchRemoteHost rhId_ = do
+  rhi_ <- forM rhId_ $ \rhId -> do
+    let rhKey = RHId rhId
+    rh <- withStore (`getRemoteHost` rhId)
+    sessions <- chatReadVar remoteHostSessions
+    case M.lookup rhKey sessions of
+      Just (_, RHSessionConnected {tls}) -> pure $ remoteHostInfo rh $ Just RHSConnected {sessionCode = tlsSessionCode tls}
+      _ -> throwError $ ChatErrorRemoteHost rhKey RHEInactive
+  rhi_ <$ chatWriteVar currentRemoteHost rhId_
+
+remoteHostInfo :: RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo
+remoteHostInfo RemoteHost {remoteHostId, storePath, hostDeviceName} sessionState =
+  RemoteHostInfo {remoteHostId, storePath, hostDeviceName, sessionState}
+
+deleteRemoteHost :: ChatMonad m => RemoteHostId -> m ()
+deleteRemoteHost rhId = do
+  RemoteHost {storePath} <- withStore (`getRemoteHost` rhId)
+  chatReadVar remoteHostsFolder >>= \case
+    Just baseDir -> do
+      let hostStore = baseDir </> storePath
+      logInfo $ "removing host store at " <> tshow hostStore
+      whenM (doesDirectoryExist hostStore) $ removeDirectoryRecursive hostStore
+    Nothing -> logWarn "Local file store not available while deleting remote host"
+  withStore' (`deleteRemoteHostRecord` rhId)
+
+storeRemoteFile :: forall m. ChatMonad m => RemoteHostId -> Maybe Bool -> FilePath -> m CryptoFile
+storeRemoteFile rhId encrypted_ localPath = do
+  c@RemoteHostClient {encryptHostFiles, storePath} <- getRemoteHostClient rhId
+  let encrypt = fromMaybe encryptHostFiles encrypted_
+  cf@CryptoFile {filePath} <- if encrypt then encryptLocalFile else pure $ CF.plain localPath
+  filePath' <- liftRH rhId $ remoteStoreFile c filePath (takeFileName localPath)
+  hf_ <- chatReadVar remoteHostsFolder
+  forM_ hf_ $ \hf -> do
+    let rhf = hf </> storePath </> archiveFilesFolder
+        hPath = rhf </> takeFileName filePath'
+    createDirectoryIfMissing True rhf
+    (if encrypt then renameFile else copyFile) filePath hPath
+  pure (cf :: CryptoFile) {filePath = filePath'}
+  where
+    encryptLocalFile :: m CryptoFile
+    encryptLocalFile = do
+      tmpDir <- getChatTempDirectory
+      createDirectoryIfMissing True tmpDir
+      tmpFile <- tmpDir `uniqueCombine` takeFileName localPath
+      cfArgs <- liftIO CF.randomArgs
+      liftError (ChatError . CEFileWrite tmpFile) $ encryptFile localPath tmpFile cfArgs
+      pure $ CryptoFile tmpFile $ Just cfArgs
+
+getRemoteFile :: ChatMonad m => RemoteHostId -> RemoteFile -> m ()
+getRemoteFile rhId rf = do
+  c@RemoteHostClient {storePath} <- getRemoteHostClient rhId
+  dir <- (</> storePath </> archiveFilesFolder) <$> (maybe getDefaultFilesFolder pure =<< chatReadVar remoteHostsFolder)
+  createDirectoryIfMissing True dir
+  liftRH rhId $ remoteGetFile c dir rf
+
+processRemoteCommand :: ChatMonad m => RemoteHostId -> RemoteHostClient -> ChatCommand -> ByteString -> m ChatResponse
+processRemoteCommand remoteHostId c cmd s = case cmd of
+  SendFile chatName f -> sendFile "/f" chatName f
+  SendImage chatName f -> sendFile "/img" chatName f
+  _ -> liftRH remoteHostId $ remoteSend c s
+  where
+    sendFile cmdName chatName (CryptoFile path cfArgs) = do
+      -- don't encrypt in host if already encrypted locally
+      CryptoFile path' cfArgs' <- storeRemoteFile remoteHostId (cfArgs $> False) path
+      let f = CryptoFile path' (cfArgs <|> cfArgs') -- use local or host encryption
+      liftRH remoteHostId $ remoteSend c $ B.unwords [cmdName, B.pack (chatNameStr chatName), cryptoFileStr f]
+    cryptoFileStr CryptoFile {filePath, cryptoArgs} =
+      maybe "" (\(CFArgs key nonce) -> "key=" <> strEncode key <> " nonce=" <> strEncode nonce <> " ") cryptoArgs
+        <> encodeUtf8 (T.pack filePath)
+
+liftRH :: ChatMonad m => RemoteHostId -> ExceptT RemoteProtocolError IO a -> m a
+liftRH rhId = liftError (ChatErrorRemoteHost (RHId rhId) . RHEProtocolError)
+
+-- * Mobile side
+
+-- ** QR/link
+
+-- | Use provided OOB link as an annouce
+connectRemoteCtrlURI :: ChatMonad m => RCSignedInvitation -> m (Maybe RemoteCtrlInfo, CtrlAppInfo)
+connectRemoteCtrlURI signedInv = do
+  verifiedInv <- maybe (throwError $ ChatErrorRemoteCtrl RCEBadInvitation) pure $ verifySignedInvitation signedInv
+  sseq <- startRemoteCtrlSession
+  connectRemoteCtrl verifiedInv sseq
+
+-- ** Multicast
+
+findKnownRemoteCtrl :: ChatMonad m => m ()
+findKnownRemoteCtrl = do
+  knownCtrls <- withStore' getRemoteCtrls
+  pairings <- case nonEmpty knownCtrls of
+    Nothing -> throwError $ ChatErrorRemoteCtrl RCENoKnownControllers
+    Just ne -> pure $ fmap (\RemoteCtrl {ctrlPairing} -> ctrlPairing) ne
+  sseq <- startRemoteCtrlSession
+  foundCtrl <- newEmptyTMVarIO
+  cmdOk <- newEmptyTMVarIO
+  action <- async $ handleCtrlError sseq "findKnownRemoteCtrl.discover" $ do
+    atomically $ takeTMVar cmdOk
+    (RCCtrlPairing {ctrlFingerprint}, inv) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings
+    rc <- withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case
+      Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl"
+      Just rc  -> pure rc
+    atomically $ putTMVar foundCtrl (rc, inv)
+    toView CRRemoteCtrlFound {remoteCtrl = remoteCtrlInfo rc (Just RCSSearching)}
+  updateRemoteCtrlSession sseq $ \case
+    RCSessionStarting -> Right RCSessionSearching {action, foundCtrl}
+    _ -> Left $ ChatErrorRemoteCtrl RCEBadState
+  atomically $ putTMVar cmdOk ()
+
+confirmRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m (RemoteCtrlInfo, CtrlAppInfo)
+confirmRemoteCtrl rcId = do
+  session <- asks remoteCtrlSession
+  (sseq, listener, found) <- liftIOEither $ atomically $ do
+    readTVar session >>= \case
+      Just (sseq, RCSessionSearching {action, foundCtrl}) -> do
+        writeTVar session $ Just (sseq, RCSessionStarting) -- drop intermediate "Searching" state so connectRemoteCtrl can proceed
+        pure $ Right (sseq, action, foundCtrl)
+      _ -> pure . Left $ ChatErrorRemoteCtrl RCEBadState
+  uninterruptibleCancel listener
+  (RemoteCtrl{remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found
+  unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController
+  connectRemoteCtrl verifiedInv sseq >>= \case
+    (Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl"
+    (Just rci, appInfo) -> pure (rci, appInfo)
+
+-- ** Common
+
+startRemoteCtrlSession :: ChatMonad m => m SessionSeq
+startRemoteCtrlSession = do
+  session <- asks remoteCtrlSession
+  nextSessionSeq <- asks remoteSessionSeq
+  liftIOEither . atomically $
+    readTVar session >>= \case
+      Just _ -> pure . Left $ ChatErrorRemoteCtrl RCEBusy
+      Nothing -> do
+        sseq <- stateTVar nextSessionSeq $ \s -> (s, s + 1)
+        Right sseq <$ writeTVar session (Just (sseq, RCSessionStarting))
+
+connectRemoteCtrl :: ChatMonad m => RCVerifiedInvitation -> SessionSeq -> m (Maybe RemoteCtrlInfo, CtrlAppInfo)
+connectRemoteCtrl verifiedInv@(RCVerifiedInvitation inv@RCInvitation {ca, app}) sseq = handleCtrlError sseq "connectRemoteCtrl" $ do
+  (ctrlInfo@CtrlAppInfo {deviceName = ctrlDeviceName}, v) <- parseCtrlAppInfo app
+  rc_ <- withStore' $ \db -> getRemoteCtrlByFingerprint db ca
+  mapM_ (validateRemoteCtrl inv) rc_
+  hostAppInfo <- getHostAppInfo v
+  (rcsClient, vars) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout . withAgent $ \a ->
+    rcConnectCtrl a verifiedInv (ctrlPairing <$> rc_) (J.toJSON hostAppInfo)
+  cmdOk <- newEmptyTMVarIO
+  rcsWaitSession <- async $ do
+    atomically $ takeTMVar cmdOk
+    handleCtrlError sseq "waitForCtrlSession" $ waitForCtrlSession rc_ ctrlDeviceName rcsClient vars
+  updateRemoteCtrlSession sseq $ \case
+    RCSessionStarting -> Right RCSessionConnecting {remoteCtrlId_ = remoteCtrlId' <$> rc_, rcsClient, rcsWaitSession}
+    _ -> Left $ ChatErrorRemoteCtrl RCEBadState
+  atomically $ putTMVar cmdOk ()
+  pure ((`remoteCtrlInfo` Just RCSConnecting) <$> rc_, ctrlInfo)
+  where
+    validateRemoteCtrl RCInvitation {idkey} RemoteCtrl {ctrlPairing = RCCtrlPairing {idPubKey}} =
+      unless (idkey == idPubKey) $ throwError $ ChatErrorRemoteCtrl $ RCEProtocolError $ PRERemoteControl RCEIdentity
+    waitForCtrlSession :: ChatMonad m => Maybe RemoteCtrl -> Text -> RCCtrlClient -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> m ()
+    waitForCtrlSession rc_ ctrlName rcsClient vars = do
+      (uniq, tls, rcsWaitConfirmation) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout $ takeRCStep vars
+      let sessionCode = verificationCode uniq
+      updateRemoteCtrlSession sseq $ \case
+        RCSessionConnecting {rcsWaitSession} ->
+          let remoteCtrlId_ = remoteCtrlId' <$> rc_
+           in Right RCSessionPendingConfirmation {remoteCtrlId_, ctrlDeviceName = ctrlName, rcsClient, tls, sessionCode, rcsWaitSession, rcsWaitConfirmation}
+        _ -> Left $ ChatErrorRemoteCtrl RCEBadState
+      toView CRRemoteCtrlSessionCode {remoteCtrl_ = (`remoteCtrlInfo` Just RCSPendingConfirmation {sessionCode}) <$> rc_, sessionCode}
+    parseCtrlAppInfo ctrlAppInfo = do
+      ctrlInfo@CtrlAppInfo {appVersionRange} <-
+        liftEitherWith (const $ ChatErrorRemoteCtrl RCEBadInvitation) $ JT.parseEither J.parseJSON ctrlAppInfo
+      v <- case compatibleAppVersion hostAppVersionRange appVersionRange of
+        Just (AppCompatible v) -> pure v
+        Nothing -> throwError $ ChatErrorRemoteCtrl $ RCEBadVersion $ maxVersion appVersionRange
+      pure (ctrlInfo, v)
+    getHostAppInfo appVersion = do
+      hostDeviceName <- chatReadVar localDeviceName
+      encryptFiles <- chatReadVar encryptLocalFiles
+      pure HostAppInfo {appVersion, deviceName = hostDeviceName, encoding = localEncoding, encryptFiles}
+
+handleRemoteCommand :: forall m. ChatMonad m => (ByteString -> m ChatResponse) -> RemoteCrypto -> TBQueue ChatResponse -> HTTP2Request -> m ()
+handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do
+  logDebug "handleRemoteCommand"
+  liftRC (tryRemoteError parseRequest) >>= \case
+    Right (getNext, rc) -> do
+      chatReadVar currentUser >>= \case
+        Nothing -> replyError $ ChatError CENoActiveUser
+        Just user -> processCommand user getNext rc `catchChatError` replyError
+    Left e -> reply $ RRProtocolError e
+  where
+    parseRequest :: ExceptT RemoteProtocolError IO (GetChunk, RemoteCommand)
+    parseRequest = do
+      (header, getNext) <- parseDecryptHTTP2Body encryption request reqBody
+      (getNext,) <$> liftEitherWith RPEInvalidJSON (J.eitherDecode header)
+    replyError = reply . RRChatResponse . CRChatCmdError Nothing
+    processCommand :: User -> GetChunk -> RemoteCommand -> m ()
+    processCommand user getNext = \case
+      RCSend {command} -> handleSend execChatCommand command >>= reply
+      RCRecv {wait = time} -> handleRecv time remoteOutputQ >>= reply
+      RCStoreFile {fileName, fileSize, fileDigest} -> handleStoreFile encryption fileName fileSize fileDigest getNext >>= reply
+      RCGetFile {file} -> handleGetFile encryption user file replyWith
+    reply :: RemoteResponse -> m ()
+    reply = (`replyWith` \_ -> pure ())
+    replyWith :: Respond m
+    replyWith rr attach = do
+      resp <- liftRC $ encryptEncodeHTTP2Body encryption $ J.encode rr
+      liftIO . sendResponse . responseStreaming N.status200 [] $ \send flush -> do
+        send resp
+        attach send
+        flush
+
+takeRCStep :: ChatMonad m => RCStepTMVar a -> m a
+takeRCStep = liftEitherError (\e -> ChatErrorAgent {agentError = RCP e, connectionEntity_ = Nothing}) . atomically . takeTMVar
+
+type GetChunk = Int -> IO ByteString
+
+type SendChunk = Builder -> IO ()
+
+type Respond m = RemoteResponse -> (SendChunk -> IO ()) -> m ()
+
+liftRC :: ChatMonad m => ExceptT RemoteProtocolError IO a -> m a
+liftRC = liftError (ChatErrorRemoteCtrl . RCEProtocolError)
+
+tryRemoteError :: ExceptT RemoteProtocolError IO a -> ExceptT RemoteProtocolError IO (Either RemoteProtocolError a)
+tryRemoteError = tryAllErrors (RPEException . tshow)
+{-# INLINE tryRemoteError #-}
+
+handleSend :: ChatMonad m => (ByteString -> m ChatResponse) -> Text -> m RemoteResponse
+handleSend execChatCommand command = do
+  logDebug $ "Send: " <> tshow command
+  -- execChatCommand checks for remote-allowed commands
+  -- convert errors thrown in ChatMonad into error responses to prevent aborting the protocol wrapper
+  RRChatResponse <$> execChatCommand (encodeUtf8 command) `catchError` (pure . CRChatError Nothing)
+
+handleRecv :: MonadUnliftIO m => Int -> TBQueue ChatResponse -> m RemoteResponse
+handleRecv time events = do
+  logDebug $ "Recv: " <> tshow time
+  RRChatEvent <$> (timeout time . atomically $ readTBQueue events)
+
+-- TODO this command could remember stored files and return IDs to allow removing files that are not needed.
+-- Also, there should be some process removing unused files uploaded to remote host (possibly, all unused files).
+handleStoreFile :: forall m. ChatMonad m => RemoteCrypto -> FilePath -> Word32 -> FileDigest -> GetChunk -> m RemoteResponse
+handleStoreFile encryption fileName fileSize fileDigest getChunk =
+  either RRProtocolError RRFileStored <$> (chatReadVar filesFolder >>= storeFile)
+  where
+    storeFile :: Maybe FilePath -> m (Either RemoteProtocolError FilePath)
+    storeFile = \case
+      Just ff -> takeFileName <$$> storeFileTo ff
+      Nothing -> storeFileTo =<< getDefaultFilesFolder
+    storeFileTo :: FilePath -> m (Either RemoteProtocolError FilePath)
+    storeFileTo dir = liftRC . tryRemoteError $ do
+      filePath <- dir `uniqueCombine` fileName
+      receiveEncryptedFile encryption getChunk fileSize fileDigest filePath
+      pure filePath
+
+handleGetFile :: ChatMonad m => RemoteCrypto -> User -> RemoteFile -> Respond m -> m ()
+handleGetFile encryption User {userId} RemoteFile {userId = commandUserId, fileId, sent, fileSource = cf'@CryptoFile {filePath}} reply = do
+  logDebug $ "GetFile: " <> tshow filePath
+  unless (userId == commandUserId) $ throwChatError $ CEDifferentActiveUser {commandUserId, activeUserId = userId}
+  path <- maybe filePath (</> filePath) <$> chatReadVar filesFolder
+  withStore $ \db -> do
+    cf <- getLocalCryptoFile db commandUserId fileId sent
+    unless (cf == cf') $ throwError $ SEFileNotFound fileId
+  liftRC (tryRemoteError $ getFileInfo path) >>= \case
+    Left e -> reply (RRProtocolError e) $ \_ -> pure ()
+    Right (fileSize, fileDigest) ->
+      withFile path ReadMode $ \h -> do
+        encFile <- liftRC $ prepareEncryptedFile encryption (h, fileSize)
+        reply RRFile {fileSize, fileDigest} $ sendEncryptedFile encFile
+
+listRemoteCtrls :: ChatMonad m => m [RemoteCtrlInfo]
+listRemoteCtrls = do
+  session <- snd <$$> chatReadVar remoteCtrlSession
+  let rcId = sessionRcId =<< session
+      sessState = rcsSessionState <$> session
+  map (rcInfo rcId sessState) <$> withStore' getRemoteCtrls
+  where
+    rcInfo :: Maybe RemoteCtrlId -> Maybe RemoteCtrlSessionState -> RemoteCtrl -> RemoteCtrlInfo
+    rcInfo rcId sessState rc@RemoteCtrl {remoteCtrlId} =
+      remoteCtrlInfo rc $ if rcId == Just remoteCtrlId then sessState else Nothing
+    sessionRcId = \case
+      RCSessionConnecting {remoteCtrlId_} -> remoteCtrlId_
+      RCSessionPendingConfirmation {remoteCtrlId_} -> remoteCtrlId_
+      RCSessionConnected {remoteCtrlId} -> Just remoteCtrlId
+      _ -> Nothing
+
+remoteCtrlInfo :: RemoteCtrl -> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo
+remoteCtrlInfo RemoteCtrl {remoteCtrlId, ctrlDeviceName} sessionState =
+  RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionState}
+
+-- | Take a look at emoji of tlsunique, commit pairing, and start session server
+verifyRemoteCtrlSession :: ChatMonad m => (ByteString -> m ChatResponse) -> Text -> m RemoteCtrlInfo
+verifyRemoteCtrlSession execChatCommand sessCode' = do
+  (sseq, client, ctrlName, sessionCode, vars) <-
+    chatReadVar remoteCtrlSession >>= \case
+      Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive
+      Just (sseq, RCSessionPendingConfirmation {rcsClient, ctrlDeviceName = ctrlName, sessionCode, rcsWaitConfirmation}) -> pure (sseq, rcsClient, ctrlName, sessionCode, rcsWaitConfirmation)
+      _ -> throwError $ ChatErrorRemoteCtrl RCEBadState
+  handleCtrlError sseq "verifyRemoteCtrlSession" $ do
+    let verified = sameVerificationCode sessCode' sessionCode
+    timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout . liftIO $ confirmCtrlSession client verified -- signal verification result before crashing
+    unless verified $ throwError $ ChatErrorRemoteCtrl $ RCEProtocolError PRESessionCode
+    (rcsSession@RCCtrlSession {tls, sessionKeys}, rcCtrlPairing) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout $ takeRCStep vars
+    rc@RemoteCtrl {remoteCtrlId} <- upsertRemoteCtrl ctrlName rcCtrlPairing
+    remoteOutputQ <- asks (tbqSize . config) >>= newTBQueueIO
+    encryption <- mkCtrlRemoteCrypto sessionKeys $ tlsUniq tls
+    http2Server <- async $ attachHTTP2Server tls $ handleRemoteCommand execChatCommand encryption remoteOutputQ
+    void . forkIO $ monitor sseq http2Server
+    updateRemoteCtrlSession sseq $ \case
+      RCSessionPendingConfirmation {} -> Right RCSessionConnected {remoteCtrlId, rcsClient = client, rcsSession, tls, http2Server, remoteOutputQ}
+      _ -> Left $ ChatErrorRemoteCtrl RCEBadState
+    pure $ remoteCtrlInfo rc $ Just RCSConnected {sessionCode = tlsSessionCode tls}
+  where
+    upsertRemoteCtrl :: ChatMonad m => Text -> RCCtrlPairing -> m RemoteCtrl
+    upsertRemoteCtrl ctrlName rcCtrlPairing = withStore $ \db -> do
+      rc_ <- liftIO $ getRemoteCtrlByFingerprint db (ctrlFingerprint rcCtrlPairing)
+      case rc_ of
+        Nothing -> insertRemoteCtrl db ctrlName rcCtrlPairing >>= getRemoteCtrl db
+        Just rc@RemoteCtrl {ctrlPairing} -> do
+          let dhPrivKey' = dhPrivKey rcCtrlPairing
+          liftIO $ updateRemoteCtrl db rc ctrlName dhPrivKey'
+          pure rc {ctrlDeviceName = ctrlName, ctrlPairing = ctrlPairing {dhPrivKey = dhPrivKey'}}
+    monitor :: ChatMonad m => SessionSeq -> Async () -> m ()
+    monitor sseq server = do
+      res <- waitCatch server
+      logInfo $ "HTTP2 server stopped: " <> tshow res
+      cancelActiveRemoteCtrl (Just sseq)
+
+stopRemoteCtrl :: ChatMonad m => m ()
+stopRemoteCtrl = cancelActiveRemoteCtrl Nothing
+
+handleCtrlError :: ChatMonad m => SessionSeq -> Text -> m a -> m a
+handleCtrlError sseq name action =
+  action `catchChatError` \e -> do
+    logError $ name <> " remote ctrl error: " <> tshow e
+    cancelActiveRemoteCtrl (Just sseq)
+    throwError e
+
+-- | Stop session controller, unless session update key is present but stale
+cancelActiveRemoteCtrl :: ChatMonad m => Maybe SessionSeq -> m ()
+cancelActiveRemoteCtrl sseq_ = handleAny (logError . tshow) $ do
+  var <- asks remoteCtrlSession
+  session_ <- atomically $ readTVar var >>= \case
+    Nothing -> pure Nothing
+    Just (oldSeq, _) | maybe False (/= oldSeq) sseq_ -> pure Nothing
+    Just (_, s) -> Just s <$ writeTVar var Nothing
+  forM_ session_ $ \session -> do
+    liftIO $ cancelRemoteCtrl handlingError session
+    when handlingError $ toView CRRemoteCtrlStopped
+  where
+    handlingError = isJust sseq_
+
+cancelRemoteCtrl :: Bool -> RemoteCtrlSession -> IO ()
+cancelRemoteCtrl handlingError = \case
+  RCSessionStarting -> pure ()
+  RCSessionSearching {action} -> uninterruptibleCancel action
+  RCSessionConnecting {rcsClient, rcsWaitSession} -> do
+    unless handlingError $ uninterruptibleCancel rcsWaitSession
+    cancelCtrlClient rcsClient
+  RCSessionPendingConfirmation {rcsClient, tls, rcsWaitSession} -> do
+    unless handlingError $ uninterruptibleCancel rcsWaitSession
+    cancelCtrlClient rcsClient
+    closeConnection tls
+  RCSessionConnected {rcsClient, tls, http2Server} -> do
+    unless handlingError $ uninterruptibleCancel http2Server
+    cancelCtrlClient rcsClient
+    closeConnection tls
+
+deleteRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
+deleteRemoteCtrl rcId = do
+  checkNoRemoteCtrlSession
+  -- TODO check it exists
+  withStore' (`deleteRemoteCtrlRecord` rcId)
+
+checkNoRemoteCtrlSession :: ChatMonad m => m ()
+checkNoRemoteCtrlSession =
+  chatReadVar remoteCtrlSession >>= maybe (pure ()) (\_ -> throwError $ ChatErrorRemoteCtrl RCEBusy)
+
+-- | Transition controller to a new state, unless session update key is stale
+updateRemoteCtrlSession :: ChatMonad m => SessionSeq -> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession) -> m ()
+updateRemoteCtrlSession sseq state = do
+  session <- asks remoteCtrlSession
+  r <- atomically $ do
+    readTVar session >>= \case
+      Nothing -> pure . Left $ ChatErrorRemoteCtrl RCEInactive
+      Just (oldSeq, st)
+        | oldSeq /= sseq -> pure . Left $ ChatErrorRemoteCtrl RCEBadState
+        | otherwise -> case state st of
+            Left ce -> pure $ Left ce
+            Right st' -> Right () <$ writeTVar session (Just (sseq, st'))
+  liftEither r
+
+utf8String :: [Char] -> ByteString
+utf8String = encodeUtf8 . T.pack
+{-# INLINE utf8String #-}

src/Simplex/Chat/Remote/AppVersion.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Chat.Remote.AppVersion
+  ( AppVersionRange (minVersion, maxVersion),
+    pattern AppVersionRange,
+    AppVersion (..),
+    pattern AppCompatible,
+    mkAppVersionRange,
+    compatibleAppVersion,
+    isAppCompatible,
+  )
+  where
+
+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.Text as T
+import Data.Version (parseVersion, showVersion)
+import qualified Data.Version as V
+import Simplex.Messaging.Parsers (defaultJSON)
+import Text.ParserCombinators.ReadP (readP_to_S)
+
+newtype AppVersion = AppVersion {appVersion :: V.Version}
+  deriving (Eq, Ord, Show)
+
+instance ToJSON AppVersion where
+  toJSON (AppVersion v) = J.String . T.pack $ showVersion v
+  toEncoding (AppVersion v) = JE.text . T.pack $ showVersion v
+
+instance FromJSON AppVersion where
+  parseJSON = J.withText "AppVersion" $ parse . T.unpack
+    where
+      parse s = case filter (null . snd) $ readP_to_S parseVersion s of
+        (v, _) : _ -> pure $ AppVersion v
+        _ -> fail $ "bad AppVersion: " <> s
+
+data AppVersionRange = AppVRange
+  { minVersion :: AppVersion,
+    maxVersion :: AppVersion
+  }
+  deriving (Show)
+
+pattern AppVersionRange :: AppVersion -> AppVersion -> AppVersionRange
+pattern AppVersionRange v1 v2 <- AppVRange v1 v2
+
+{-# COMPLETE AppVersionRange #-}
+
+mkAppVersionRange :: AppVersion -> AppVersion -> AppVersionRange
+mkAppVersionRange v1 v2
+  | v1 <= v2 = AppVRange v1 v2
+  | otherwise = error "invalid version range"
+
+newtype AppCompatible a = AppCompatible_ a
+
+pattern AppCompatible :: a -> AppCompatible a
+pattern AppCompatible a <- AppCompatible_ a
+
+{-# COMPLETE AppCompatible #-}
+
+isAppCompatible :: AppVersion -> AppVersionRange -> Bool
+isAppCompatible v (AppVRange v1 v2) = v1 <= v && v <= v2
+
+isCompatibleAppRange :: AppVersionRange -> AppVersionRange -> Bool
+isCompatibleAppRange (AppVRange min1 max1) (AppVRange min2 max2) = min1 <= max2 && min2 <= max1
+
+compatibleAppVersion :: AppVersionRange -> AppVersionRange -> Maybe (AppCompatible AppVersion)
+compatibleAppVersion vr1 vr2 =
+  min (maxVersion vr1) (maxVersion vr2) `mkCompatibleIf` isCompatibleAppRange vr1 vr2
+
+mkCompatibleIf :: AppVersion -> Bool -> Maybe (AppCompatible AppVersion)
+v `mkCompatibleIf` cond = if cond then Just $ AppCompatible_ v else Nothing
+
+$(JQ.deriveJSON defaultJSON ''AppVersionRange)

src/Simplex/Chat/Remote/Multicast.hsc

@@ -0,0 +1,46 @@
+module Simplex.Chat.Remote.Multicast (setMembership) where
+
+import Foreign (Ptr, allocaBytes, castPtr, pokeByteOff)
+import Foreign.C.Types (CInt (..))
+import Network.Socket
+
+#include <HsNet.h>
+
+{- | Toggle multicast group membership.
+
+NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
+-}
+setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ())
+setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do
+  #{poke struct ip_mreq, imr_multiaddr} mReqPtr group
+  #{poke struct ip_mreq, imr_interface} mReqPtr (0 :: HostAddress) -- attempt to contact the group on ANY interface
+  withFdSocket sock $ \fd -> do
+    rc <- c_setsockopt fd c_IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq})
+    if rc == 0
+      then pure $ Right ()
+      else pure $ Left rc
+  where
+    flag = if membership then c_IP_ADD_MEMBERSHIP else c_IP_DROP_MEMBERSHIP
+
+#ifdef mingw32_HOST_OS
+
+foreign import stdcall unsafe "setsockopt"
+    c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
+
+c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt
+c_IP_ADD_MEMBERSHIP  = 12
+c_IP_DROP_MEMBERSHIP = 13
+
+#else
+
+foreign import ccall unsafe "setsockopt"
+    c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
+
+c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt
+c_IP_ADD_MEMBERSHIP  = #const IP_ADD_MEMBERSHIP
+c_IP_DROP_MEMBERSHIP = #const IP_DROP_MEMBERSHIP
+
+#endif
+
+c_IPPROTO_IP :: CInt
+c_IPPROTO_IP = #const IPPROTO_IP

src/Simplex/Chat/Remote/Protocol.hs

@@ -0,0 +1,292 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Chat.Remote.Protocol where
+
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+import Crypto.Hash (SHA512)
+import qualified Crypto.Hash as CH
+import Data.Aeson ((.=))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Key as JK
+import qualified Data.Aeson.KeyMap as JM
+import Data.Aeson.TH (deriveJSON)
+import qualified Data.Aeson.Types as JT
+import qualified Data.ByteArray as BA
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import Data.ByteString.Builder (Builder, byteString, lazyByteString)
+import qualified Data.ByteString.Lazy as LB
+import Data.String (fromString)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Data.Word (Word32)
+import qualified Network.HTTP.Types as N
+import qualified Network.HTTP2.Client as H
+import Network.Transport.Internal (decodeWord32, encodeWord32)
+import Simplex.Chat.Controller
+import Simplex.Chat.Remote.Transport
+import Simplex.Chat.Remote.Types
+import Simplex.FileTransfer.Description (FileDigest (..))
+import Simplex.Messaging.Agent.Client (agentDRG)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.File (CryptoFile (..))
+import Simplex.Messaging.Crypto.Lazy  (LazyByteString)
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
+import Simplex.Messaging.Transport.Buffer (getBuffered)
+import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
+import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow)
+import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
+import Simplex.RemoteControl.Client (xrcpBlockSize)
+import qualified Simplex.RemoteControl.Client as RC
+import System.FilePath (takeFileName, (</>))
+import UnliftIO
+
+data RemoteCommand
+  = RCSend {command :: Text} -- TODO maybe ChatCommand here?
+  | RCRecv {wait :: Int} -- this wait should be less than HTTP timeout
+  | -- local file encryption is determined by the host, but can be overridden for videos
+    RCStoreFile {fileName :: String, fileSize :: Word32, fileDigest :: FileDigest} -- requires attachment
+  | RCGetFile {file :: RemoteFile}
+  deriving (Show)
+
+data RemoteResponse
+  = RRChatResponse {chatResponse :: ChatResponse}
+  | RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout
+  | RRFileStored {filePath :: String}
+  | RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest
+  | RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- ^ The protocol error happened on the server side
+  deriving (Show)
+
+-- Force platform-independent encoding as the types aren't UI-visible
+$(deriveJSON (taggedObjectJSON $ dropPrefix "RC") ''RemoteCommand)
+$(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse)
+
+-- * Client side / desktop
+
+mkRemoteHostClient :: ChatMonad m => HTTP2Client -> HostSessKeys -> SessionCode -> FilePath -> HostAppInfo -> m RemoteHostClient
+mkRemoteHostClient httpClient sessionKeys sessionCode storePath HostAppInfo {encoding, deviceName, encryptFiles} = do
+  drg <- asks $ agentDRG . smpAgent
+  counter <- newTVarIO 1
+  let HostSessKeys {hybridKey, idPrivKey, sessPrivKey} = sessionKeys
+      signatures = RSSign {idPrivKey, sessPrivKey}
+      encryption = RemoteCrypto {drg, counter, sessionCode, hybridKey, signatures}
+  pure
+    RemoteHostClient
+      { hostEncoding = encoding,
+        hostDeviceName = deviceName,
+        httpClient,
+        encryption,
+        encryptHostFiles = encryptFiles,
+        storePath
+      }
+
+mkCtrlRemoteCrypto :: ChatMonad m => CtrlSessKeys -> SessionCode -> m RemoteCrypto
+mkCtrlRemoteCrypto CtrlSessKeys {hybridKey, idPubKey, sessPubKey} sessionCode = do
+  drg <- asks $ agentDRG . smpAgent
+  counter <- newTVarIO 1
+  let signatures = RSVerify {idPubKey, sessPubKey}
+  pure RemoteCrypto {drg, counter, sessionCode, hybridKey, signatures}
+
+closeRemoteHostClient :: MonadIO m => RemoteHostClient -> m ()
+closeRemoteHostClient RemoteHostClient {httpClient} = liftIO $ closeHTTP2Client httpClient
+
+-- ** Commands
+
+remoteSend :: RemoteHostClient -> ByteString -> ExceptT RemoteProtocolError IO ChatResponse
+remoteSend c cmd =
+  sendRemoteCommand' c Nothing RCSend {command = decodeUtf8 cmd} >>= \case
+    RRChatResponse cr -> pure cr
+    r -> badResponse r
+
+remoteRecv :: RemoteHostClient -> Int -> ExceptT RemoteProtocolError IO (Maybe ChatResponse)
+remoteRecv c ms =
+  sendRemoteCommand' c Nothing RCRecv {wait = ms} >>= \case
+    RRChatEvent cr_ -> pure cr_
+    r -> badResponse r
+
+remoteStoreFile :: RemoteHostClient -> FilePath -> FilePath -> ExceptT RemoteProtocolError IO FilePath
+remoteStoreFile c localPath fileName = do
+  (fileSize, fileDigest) <- getFileInfo localPath
+  let send h = sendRemoteCommand' c (Just (h, fileSize)) RCStoreFile {fileName, fileSize, fileDigest}
+  withFile localPath ReadMode send >>= \case
+    RRFileStored {filePath = filePath'} -> pure filePath'
+    r -> badResponse r
+
+remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO ()
+remoteGetFile c@RemoteHostClient{encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} =
+  sendRemoteCommand c Nothing RCGetFile {file = rf} >>= \case
+    (getChunk, RRFile {fileSize, fileDigest}) -> do
+      -- TODO we could optimize by checking size and hash before receiving the file
+      let localPath = destDir </> takeFileName filePath
+      receiveEncryptedFile encryption getChunk fileSize fileDigest localPath
+    (_, r) -> badResponse r
+
+-- TODO validate there is no attachment in response
+sendRemoteCommand' :: RemoteHostClient -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO RemoteResponse
+sendRemoteCommand' c attachment_ rc = snd <$> sendRemoteCommand c attachment_ rc
+
+sendRemoteCommand :: RemoteHostClient -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO (Int -> IO ByteString, RemoteResponse)
+sendRemoteCommand RemoteHostClient {httpClient, hostEncoding, encryption} file_ cmd = do
+  encFile_ <- mapM (prepareEncryptedFile encryption) file_ 
+  req <- httpRequest encFile_ <$> encryptEncodeHTTP2Body encryption (J.encode cmd)
+  HTTP2Response {response, respBody} <- liftEitherError (RPEHTTP2 . tshow) $ sendRequestDirect httpClient req Nothing
+  (header, getNext) <- parseDecryptHTTP2Body encryption response respBody
+  rr <- liftEitherWith (RPEInvalidJSON . fromString) $ J.eitherDecode header >>= JT.parseEither J.parseJSON . convertJSON hostEncoding localEncoding
+  pure (getNext, rr)
+  where
+    httpRequest encFile_ cmdBld = H.requestStreaming N.methodPost "/" mempty $ \send flush -> do
+      send cmdBld
+      forM_ encFile_ (`sendEncryptedFile` send)
+      flush
+
+badResponse :: RemoteResponse -> ExceptT RemoteProtocolError IO a
+badResponse = \case
+  RRProtocolError e -> throwError e
+  -- TODO handle chat errors?
+  r -> throwError $ RPEUnexpectedResponse $ tshow r
+
+-- * Transport-level wrappers
+
+convertJSON :: PlatformEncoding -> PlatformEncoding -> J.Value -> J.Value
+convertJSON _remote@PEKotlin _local@PEKotlin = id
+convertJSON PESwift PESwift = id
+convertJSON PESwift PEKotlin = owsf2tagged
+convertJSON PEKotlin PESwift = error "unsupported convertJSON: K/S" -- guarded by handshake
+
+-- | Convert swift single-field sum encoding into tagged/discriminator-field
+owsf2tagged :: J.Value -> J.Value
+owsf2tagged = fst . convert
+  where
+    convert val = case val of
+      J.Object o
+        | JM.size o == 2 ->
+            case JM.toList o of
+              [OwsfTag, o'] -> tagged o'
+              [o', OwsfTag] -> tagged o'
+              _ -> props
+        | otherwise -> props
+        where
+          props = (J.Object $ fmap owsf2tagged o, False)
+      J.Array a -> (J.Array $ fmap owsf2tagged a, False)
+      _ -> (val, False)
+    -- `tagged` converts the pair of single-field object encoding to tagged encoding.
+    -- It sets innerTag returned by `convert` to True to prevent the tag being overwritten.
+    tagged (k, v) = (J.Object pairs, True)
+      where
+        (v', innerTag) = convert v
+        pairs = case v' of
+          -- `innerTag` indicates that internal object already has tag,
+          -- so the current tag cannot be inserted into it.
+          J.Object o
+            | innerTag -> pair
+            | otherwise -> JM.insert TaggedObjectJSONTag tag o
+          _ -> pair
+        tag = J.String $ JK.toText k
+        pair = JM.fromList [TaggedObjectJSONTag .= tag, TaggedObjectJSONData .= v']
+
+pattern OwsfTag :: (JK.Key, J.Value)
+pattern OwsfTag = (SingleFieldJSONTag, J.Bool True)
+
+-- ```
+-- commandBody = encBody sessSignature idSignature (attachment / noAttachment)
+-- responseBody = encBody attachment; should match counter in the command
+-- encBody = nonce encLength32 encrypted(tlsunique counter body)
+-- attachment = %x01 nonce encLength32 encrypted(attachment)
+-- noAttachment = %x00
+-- tlsunique = length 1*OCTET
+-- nonce = 24*24 OCTET
+-- counter = 8*8 OCTET ; int64
+-- encLength32 = 4*4 OCTET ; uint32, includes authTag
+-- ```
+
+-- See https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2023-10-25-remote-control.md for encoding
+
+encryptEncodeHTTP2Body :: RemoteCrypto -> LazyByteString -> ExceptT RemoteProtocolError IO Builder
+encryptEncodeHTTP2Body RemoteCrypto {drg, counter, sessionCode, hybridKey, signatures} s = do
+  corrId <- atomically $ stateTVar counter $ \c -> (c, c + 1)
+  let pfx = smpEncode (sessionCode, corrId)
+  (nonce, ct) <- liftError PRERemoteControl $ RC.rcEncryptBody drg hybridKey $ LB.fromStrict pfx <> s
+  let ctLen = encodeWord32 (fromIntegral $ LB.length ct)
+      signed = LB.fromStrict (smpEncode nonce <> ctLen) <> ct
+  sigs <- bodySignatures signed
+  pure $ lazyByteString signed <> sigs
+  where
+    bodySignatures :: LazyByteString -> ExceptT RemoteProtocolError IO Builder
+    bodySignatures signed = case signatures of
+      RSSign {idPrivKey, sessPrivKey} -> do
+        let hc = CH.hashUpdates (CH.hashInit @SHA512) (LB.toChunks signed)
+            ssig = sign sessPrivKey hc
+            idsig = sign idPrivKey $ CH.hashUpdate hc ssig
+        pure $ byteString $ smpEncode (ssig, idsig)
+      _ -> pure mempty
+    sign :: C.PrivateKeyEd25519 -> CH.Context SHA512 -> ByteString
+    sign k = C.signatureBytes . C.sign' k . BA.convert . CH.hashFinalize
+
+-- | Parse and decrypt HTTP2 request/response
+parseDecryptHTTP2Body :: HTTP2BodyChunk a => RemoteCrypto -> a -> HTTP2Body -> ExceptT RemoteProtocolError IO (LazyByteString, Int -> IO ByteString)
+parseDecryptHTTP2Body RemoteCrypto {hybridKey, sessionCode, signatures} hr HTTP2Body {bodyBuffer} = do
+  (nonce, ct) <- getBody
+  s <- liftError PRERemoteControl $ RC.rcDecryptBody hybridKey nonce ct
+  (,getNext) <$> parseBody s
+  where
+    getBody :: ExceptT RemoteProtocolError IO (C.CbNonce, LazyByteString)
+    getBody = do
+      nonceStr <- liftIO $ getNext 24
+      nonce <- liftEitherWith RPEInvalidBody $ smpDecode nonceStr
+      ctLenStr <- liftIO $ getNext 4
+      let ctLen = decodeWord32 ctLenStr
+      when (ctLen > fromIntegral (maxBound :: Int)) $ throwError RPEInvalidSize
+      chunks <- liftIO $ getLazy $ fromIntegral ctLen
+      let hc = CH.hashUpdates (CH.hashInit @SHA512) [nonceStr, ctLenStr]
+          hc' = CH.hashUpdates hc chunks
+      verifySignatures hc'
+      pure (nonce, LB.fromChunks chunks)
+    getLazy :: Int -> IO [ByteString]
+    getLazy 0 = pure []
+    getLazy n = do
+      let sz = min n xrcpBlockSize
+      bs <- getNext sz
+      let n' = if B.length bs < sz then 0 else max 0 (n - xrcpBlockSize)
+      (bs :) <$> getLazy n'
+    verifySignatures :: CH.Context SHA512 -> ExceptT RemoteProtocolError IO ()
+    verifySignatures hc = case signatures of
+      RSVerify {sessPubKey, idPubKey} -> do
+        ssig <- getSig
+        idsig <- getSig
+        verifySig sessPubKey ssig hc
+        verifySig idPubKey idsig $ CH.hashUpdate hc $ C.signatureBytes ssig
+      _ -> pure ()
+      where
+        getSig = do
+          len <- liftIO $ B.head <$> getNext 1
+          liftEitherError RPEInvalidBody $ C.decodeSignature <$> getNext (fromIntegral len)
+        verifySig key sig hc' = do
+          let signed = BA.convert $ CH.hashFinalize hc'
+          unless (C.verify' key sig signed) $ throwError $ PRERemoteControl RCECtrlAuth
+    parseBody :: LazyByteString -> ExceptT RemoteProtocolError IO LazyByteString
+    parseBody s = case LB.uncons s of
+      Nothing -> throwError $ RPEInvalidBody "empty body"
+      Just (scLen, rest) -> do
+        (sessCode', rest') <- takeBytes (fromIntegral scLen) rest
+        unless (sessCode' == sessionCode) $ throwError PRESessionCode
+        (_corrId, s') <- takeBytes 8 rest'
+        pure s'
+      where
+        takeBytes n s' = do
+          let (bs, rest) = LB.splitAt n s'
+          unless (LB.length bs == n) $ throwError PRESessionCode
+          pure (LB.toStrict bs, rest)
+    getNext sz = getBuffered bodyBuffer sz Nothing $ getBodyChunk hr

src/Simplex/Chat/Remote/RevHTTP.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.Remote.RevHTTP where
+
+import Simplex.Messaging.Transport (TLS)
+import Simplex.Messaging.Transport.HTTP2 (defaultHTTP2BufferSize, getHTTP2Body)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError (..), attachHTTP2Client, bodyHeadSize, connTimeout, defaultHTTP2ClientConfig)
+import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith)
+import Simplex.RemoteControl.Discovery
+import UnliftIO
+
+attachRevHTTP2Client :: IO () -> TLS -> IO (Either HTTP2ClientError HTTP2Client)
+attachRevHTTP2Client disconnected = attachHTTP2Client config ANY_ADDR_V4 "0" disconnected defaultHTTP2BufferSize
+  where
+    config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound}
+
+attachHTTP2Server :: MonadUnliftIO m => TLS -> (HTTP2Request -> m ()) -> m ()
+attachHTTP2Server tls processRequest = do
+  withRunInIO $ \unlift ->
+    runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do
+      reqBody <- getHTTP2Body r doNotPrefetchHead
+      unlift $ processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse}
+
+-- | Suppress storing initial chunk in bodyHead, forcing clients and servers to stream chunks
+doNotPrefetchHead :: Int
+doNotPrefetchHead = 0

src/Simplex/Chat/Remote/Transport.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.Remote.Transport where
+
+import Control.Monad
+import Control.Monad.Except
+import Data.ByteString.Builder (Builder, byteString)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LB
+import Data.Word (Word32)
+import Simplex.FileTransfer.Description (FileDigest (..))
+import Simplex.Chat.Remote.Types
+import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Util (liftEitherError, liftEitherWith)
+import Simplex.RemoteControl.Types (RCErrorType (..))
+import UnliftIO
+import UnliftIO.Directory (getFileSize)
+
+type EncryptedFile = ((Handle, Word32), C.CbNonce, LC.SbState)
+
+prepareEncryptedFile :: RemoteCrypto -> (Handle, Word32) -> ExceptT RemoteProtocolError IO EncryptedFile
+prepareEncryptedFile RemoteCrypto {drg, hybridKey} f = do
+  nonce <- atomically $ C.pseudoRandomCbNonce drg
+  sbState <- liftEitherWith (const $ PRERemoteControl RCEEncrypt) $ LC.kcbInit hybridKey nonce
+  pure (f, nonce, sbState)
+
+sendEncryptedFile :: EncryptedFile -> (Builder -> IO ()) -> IO ()
+sendEncryptedFile ((h, sz), nonce, sbState) send = do
+  send $ byteString $ smpEncode ('\x01', nonce, sz + fromIntegral C.authTagSize)
+  sendEncFile h send sbState sz
+
+receiveEncryptedFile :: RemoteCrypto -> (Int -> IO ByteString) -> Word32 -> FileDigest -> FilePath -> ExceptT RemoteProtocolError IO ()
+receiveEncryptedFile RemoteCrypto {hybridKey} getChunk fileSize fileDigest toPath = do
+  c <- liftIO $ getChunk 1
+  unless (c == "\x01") $ throwError RPENoFile
+  nonce <- liftEitherError RPEInvalidBody $ smpDecode <$> getChunk 24
+  size <- liftEitherError RPEInvalidBody $ smpDecode <$> getChunk 4
+  unless (size == fileSize + fromIntegral C.authTagSize) $ throwError RPEFileSize
+  sbState <- liftEitherWith (const $ PRERemoteControl RCEDecrypt) $ LC.kcbInit hybridKey nonce
+  liftEitherError fErr $ withFile toPath WriteMode $ \h -> receiveSbFile getChunk h sbState fileSize
+  digest <- liftIO $ LC.sha512Hash <$> LB.readFile toPath
+  unless (FileDigest digest == fileDigest) $ throwError RPEFileDigest
+  where
+    fErr RFESize = RPEFileSize
+    fErr RFECrypto = PRERemoteControl RCEDecrypt
+
+getFileInfo :: FilePath -> ExceptT RemoteProtocolError IO (Word32, FileDigest)
+getFileInfo filePath = do
+  fileDigest <- liftIO $ FileDigest . LC.sha512Hash <$> LB.readFile filePath
+  fileSize' <- getFileSize filePath
+  when (fileSize' > toInteger (maxBound :: Word32)) $ throwError RPEFileSize
+  pure (fromInteger fileSize', fileDigest)

src/Simplex/Chat/Remote/Types.hs

@@ -0,0 +1,202 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Chat.Remote.Types where
+
+import Control.Concurrent.Async (Async)
+import Control.Concurrent.STM (TVar)
+import Control.Exception (Exception)
+import Crypto.Random (ChaChaDRG)
+import qualified Data.Aeson.TH as J
+import Data.ByteString (ByteString)
+import Data.Int (Int64)
+import Data.Text (Text)
+import Simplex.Chat.Remote.AppVersion
+import Simplex.Chat.Types (verificationCode)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
+import Simplex.RemoteControl.Client
+import Simplex.RemoteControl.Types
+import Simplex.Messaging.Crypto.File (CryptoFile)
+import Simplex.Messaging.Transport (TLS (..))
+
+data RemoteHostClient = RemoteHostClient
+  { hostEncoding :: PlatformEncoding,
+    hostDeviceName :: Text,
+    httpClient :: HTTP2Client,
+    encryption :: RemoteCrypto,
+    encryptHostFiles :: Bool,
+    storePath :: FilePath
+  }
+
+data RemoteCrypto = RemoteCrypto
+  { drg :: TVar ChaChaDRG,
+    counter :: TVar Int64,
+    sessionCode :: ByteString,
+    hybridKey :: KEMHybridSecret,
+    signatures :: RemoteSignatures
+  }
+
+data RemoteSignatures
+  = RSSign
+    { idPrivKey :: C.PrivateKeyEd25519,
+      sessPrivKey :: C.PrivateKeyEd25519
+    }
+  | RSVerify
+    { idPubKey :: C.PublicKeyEd25519,
+      sessPubKey :: C.PublicKeyEd25519
+    }
+
+type SessionSeq = Int
+
+data RHPendingSession = RHPendingSession
+  { rhKey :: RHKey,
+    rchClient :: RCHostClient,
+    rhsWaitSession :: Async (),
+    remoteHost_ :: Maybe RemoteHostInfo
+  }
+
+data RemoteHostSession
+  = RHSessionStarting
+  | RHSessionConnecting {invitation :: Text, rhPendingSession :: RHPendingSession}
+  | RHSessionPendingConfirmation {sessionCode :: Text, tls :: TLS, rhPendingSession :: RHPendingSession}
+  | RHSessionConfirmed {tls :: TLS, rhPendingSession :: RHPendingSession}
+  | RHSessionConnected
+    { rchClient :: RCHostClient,
+      tls :: TLS,
+      rhClient :: RemoteHostClient,
+      pollAction :: Async (),
+      storePath :: FilePath
+    }
+
+data RemoteHostSessionState
+  = RHSStarting
+  | RHSConnecting {invitation :: Text}
+  | RHSPendingConfirmation {sessionCode :: Text}
+  | RHSConfirmed {sessionCode :: Text}
+  | RHSConnected {sessionCode :: Text}
+  deriving (Show)
+
+rhsSessionState :: RemoteHostSession -> RemoteHostSessionState
+rhsSessionState = \case
+  RHSessionStarting -> RHSStarting
+  RHSessionConnecting {invitation} -> RHSConnecting {invitation}
+  RHSessionPendingConfirmation {tls} -> RHSPendingConfirmation {sessionCode = tlsSessionCode tls}
+  RHSessionConfirmed {tls} -> RHSConfirmed {sessionCode = tlsSessionCode tls}
+  RHSessionConnected {tls} -> RHSConnected {sessionCode = tlsSessionCode tls}
+
+tlsSessionCode :: TLS -> Text
+tlsSessionCode = verificationCode . tlsUniq
+
+data RemoteProtocolError
+  = -- | size prefix is malformed
+    RPEInvalidSize
+  | -- | failed to parse RemoteCommand or RemoteResponse
+    RPEInvalidJSON {invalidJSON :: String}
+  | RPEInvalidBody {invalidBody :: String}
+  | PRESessionCode
+  | RPEIncompatibleEncoding
+  | RPEUnexpectedFile
+  | RPENoFile
+  | RPEFileSize
+  | RPEFileDigest
+  | -- | Wrong response received for the command sent
+    RPEUnexpectedResponse {response :: Text}
+  | -- | A file already exists in the destination position
+    RPEStoredFileExists
+  | PRERemoteControl {rcError :: RCErrorType}
+  | RPEHTTP2 {http2Error :: Text}
+  | RPEException {someException :: Text}
+  deriving (Show, Exception)
+
+type RemoteHostId = Int64
+
+data RHKey = RHNew | RHId {remoteHostId :: RemoteHostId}
+  deriving (Eq, Ord, Show)
+
+-- | Storable/internal remote host data
+data RemoteHost = RemoteHost
+  { remoteHostId :: RemoteHostId,
+    hostDeviceName :: Text,
+    storePath :: FilePath,
+    hostPairing :: RCHostPairing
+  }
+
+-- | UI-accessible remote host information
+data RemoteHostInfo = RemoteHostInfo
+  { remoteHostId :: RemoteHostId,
+    hostDeviceName :: Text,
+    storePath :: FilePath,
+    sessionState :: Maybe RemoteHostSessionState
+  }
+  deriving (Show)
+
+type RemoteCtrlId = Int64
+
+-- | Storable/internal remote controller data
+data RemoteCtrl = RemoteCtrl
+  { remoteCtrlId :: RemoteCtrlId,
+    ctrlDeviceName :: Text,
+    ctrlPairing :: RCCtrlPairing
+  }
+
+remoteCtrlId' :: RemoteCtrl -> RemoteCtrlId
+remoteCtrlId' = remoteCtrlId
+
+data PlatformEncoding
+  = PESwift
+  | PEKotlin
+  deriving (Show, Eq)
+
+localEncoding :: PlatformEncoding
+#if defined(darwin_HOST_OS) && defined(swiftJSON)
+localEncoding = PESwift
+#else
+localEncoding = PEKotlin
+#endif
+
+data RemoteFile = RemoteFile
+  { userId :: Int64,
+    fileId :: Int64,
+    sent :: Bool,
+    fileSource :: CryptoFile
+  }
+  deriving (Show)
+
+data CtrlAppInfo = CtrlAppInfo
+  { appVersionRange :: AppVersionRange,
+    deviceName :: Text
+  }
+  deriving (Show)
+
+data HostAppInfo = HostAppInfo
+  { appVersion :: AppVersion,
+    deviceName :: Text,
+    encoding :: PlatformEncoding,
+    encryptFiles :: Bool -- if the host encrypts files in app storage
+  }
+
+$(J.deriveJSON defaultJSON ''RemoteFile)
+
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "RPE") ''RemoteProtocolError)
+
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "RH") ''RHKey)
+
+$(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding)
+
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "RHS") ''RemoteHostSessionState)
+
+$(J.deriveJSON defaultJSON ''RemoteHostInfo)
+
+$(J.deriveJSON defaultJSON ''CtrlAppInfo)
+
+$(J.deriveJSON defaultJSON ''HostAppInfo)

src/Simplex/Chat/Store/Files.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -71,6 +72,7 @@ module Simplex.Chat.Store.Files
     getSndFileTransfer,
     getSndFileTransfers,
     getContactFileInfo,
+    getLocalCryptoFile,
     updateDirectCIFileStatus,
   )
 where
@@ -602,7 +604,10 @@ getRcvFileTransferById db fileId = do
   (user,) <$> getRcvFileTransfer db user fileId
 
 getRcvFileTransfer :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO RcvFileTransfer
-getRcvFileTransfer db User {userId} fileId = do
+getRcvFileTransfer db User {userId} = getRcvFileTransfer_ db userId
+
+getRcvFileTransfer_ :: DB.Connection -> UserId -> FileTransferId -> ExceptT StoreError IO RcvFileTransfer
+getRcvFileTransfer_ db userId fileId = do
   rftRow <-
     ExceptT . firstRow id (SERcvFileNotFound fileId) $
       DB.query
@@ -808,25 +813,26 @@ getFileTransferProgress db user fileId = do
 
 getFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransfer
 getFileTransfer db user@User {userId} fileId =
-  fileTransfer =<< liftIO getFileTransferRow
+  fileTransfer =<< liftIO (getFileTransferRow_ db userId fileId)
   where
     fileTransfer :: [(Maybe Int64, Maybe Int64)] -> ExceptT StoreError IO FileTransfer
     fileTransfer [(Nothing, Just _)] = FTRcv <$> getRcvFileTransfer db user fileId
     fileTransfer _ = do
       (ftm, fts) <- getSndFileTransfer db user fileId
       pure $ FTSnd {fileTransferMeta = ftm, sndFileTransfers = fts}
-    getFileTransferRow :: IO [(Maybe Int64, Maybe Int64)]
-    getFileTransferRow =
-      DB.query
-        db
-        [sql|
-          SELECT s.file_id, r.file_id
-          FROM files f
-          LEFT JOIN snd_files s ON s.file_id = f.file_id
-          LEFT JOIN rcv_files r ON r.file_id = f.file_id
-          WHERE user_id = ? AND f.file_id = ?
-        |]
-        (userId, fileId)
+
+getFileTransferRow_ :: DB.Connection -> UserId -> Int64 -> IO [(Maybe Int64, Maybe Int64)]
+getFileTransferRow_ db userId fileId =
+  DB.query
+    db
+    [sql|
+      SELECT s.file_id, r.file_id
+      FROM files f
+      LEFT JOIN snd_files s ON s.file_id = f.file_id
+      LEFT JOIN rcv_files r ON r.file_id = f.file_id
+      WHERE user_id = ? AND f.file_id = ?
+    |]
+    (userId, fileId)
 
 getSndFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer])
 getSndFileTransfer db user fileId = do
@@ -861,7 +867,10 @@ getSndFileTransfers_ db userId fileId =
         Nothing -> Left $ SESndFileInvalid fileId
 
 getFileTransferMeta :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransferMeta
-getFileTransferMeta db User {userId} fileId =
+getFileTransferMeta db User {userId} = getFileTransferMeta_ db userId
+
+getFileTransferMeta_ :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO FileTransferMeta
+getFileTransferMeta_ db userId fileId =
   ExceptT . firstRow fileTransferMeta (SEFileNotFound fileId) $
     DB.query
       db
@@ -883,6 +892,20 @@ getContactFileInfo db User {userId} Contact {contactId} =
   map toFileInfo
     <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ?") (userId, contactId)
 
+getLocalCryptoFile :: DB.Connection -> UserId -> Int64 -> Bool -> ExceptT StoreError IO CryptoFile
+getLocalCryptoFile db userId fileId sent =
+  liftIO (getFileTransferRow_ db userId fileId) >>= \case
+    [(Nothing, Just _)] -> do
+      when sent $ throwError $ SEFileNotFound fileId
+      RcvFileTransfer {fileStatus, cryptoArgs} <- getRcvFileTransfer_ db userId fileId
+      case fileStatus of
+        RFSComplete RcvFileInfo {filePath} -> pure $ CryptoFile filePath cryptoArgs
+        _ -> throwError $ SEFileNotFound fileId
+    _ -> do
+      unless sent $ throwError $ SEFileNotFound fileId
+      FileTransferMeta {filePath, xftpSndFile} <- getFileTransferMeta_ db userId fileId
+      pure $ CryptoFile filePath $ xftpSndFile >>= \f -> f.cryptoArgs
+
 updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
 updateDirectCIFileStatus db user fileId fileStatus = do
   aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId

src/Simplex/Chat/Store/Messages.hs

@@ -1103,7 +1103,7 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
     ciMeta content status =
       let itemDeleted' = case itemDeleted of
             DBCINotDeleted -> Nothing
-            DBCIBlocked -> Just (CIBlocked @'CTGroup deletedTs)
+            DBCIBlocked -> Just (CIBlocked deletedTs)
             _ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
           itemEdited' = fromMaybe False itemEdited
        in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt

src/Simplex/Chat/Store/Migrations.hs

@@ -89,6 +89,7 @@ import Simplex.Chat.Migrations.M20231019_indexes
 import Simplex.Chat.Migrations.M20231030_xgrplinkmem_received
 import Simplex.Chat.Migrations.M20231107_indexes
 import Simplex.Chat.Migrations.M20231113_group_forward
+import Simplex.Chat.Migrations.M20231114_remote_control
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
 
 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -177,7 +178,8 @@ schemaMigrations =
     ("20231019_indexes", m20231019_indexes, Just down_m20231019_indexes),
     ("20231030_xgrplinkmem_received", m20231030_xgrplinkmem_received, Just down_m20231030_xgrplinkmem_received),
     ("20231107_indexes", m20231107_indexes, Just down_m20231107_indexes),
-    ("20231113_group_forward", m20231113_group_forward, Just down_m20231113_group_forward)
+    ("20231113_group_forward", m20231113_group_forward, Just down_m20231113_group_forward),
+    ("20231114_remote_control", m20231114_remote_control, Just down_m20231114_remote_control)
   ]
 
 -- | The list of migrations in ascending order by date

src/Simplex/Chat/Store/Profiles.hs

@@ -1,9 +1,10 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
@@ -58,8 +59,8 @@ module Simplex.Chat.Store.Profiles
 where
 
 import Control.Monad.Except
-import Data.Aeson (ToJSON)
-import qualified Data.Aeson as J
+import Control.Monad.IO.Class
+import qualified Data.Aeson.TH as J
 import Data.Functor (($>))
 import Data.Int (Int64)
 import qualified Data.List.NonEmpty as L
@@ -70,7 +71,6 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock (UTCTime (..), getCurrentTime)
 import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..))
 import Database.SQLite.Simple.QQ (sql)
-import GHC.Generics (Generic)
 import Simplex.Chat.Call
 import Simplex.Chat.Messages
 import Simplex.Chat.Protocol
@@ -83,6 +83,7 @@ import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (defaultJSON)
 import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (safeDecodeUtf8, eitherToMaybe)
@@ -397,17 +398,17 @@ data UserContactLink = UserContactLink
   { connReqContact :: ConnReqContact,
     autoAccept :: Maybe AutoAccept
   }
-  deriving (Show, Generic)
-
-instance ToJSON UserContactLink where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 data AutoAccept = AutoAccept
   { acceptIncognito :: IncognitoEnabled,
     autoReply :: Maybe MsgContent
   }
-  deriving (Show, Generic)
+  deriving (Show)
 
-instance ToJSON AutoAccept where toEncoding = J.genericToEncoding J.defaultOptions
+$(J.deriveJSON defaultJSON ''AutoAccept)
+
+$(J.deriveJSON defaultJSON ''UserContactLink)
 
 toUserContactLink :: (ConnReqContact, Bool, IncognitoEnabled, Maybe MsgContent) -> UserContactLink
 toUserContactLink (connReq, autoAccept, acceptIncognito, autoReply) =

src/Simplex/Chat/Store/Remote.hs

@@ -0,0 +1,143 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Store.Remote where
+
+import Control.Monad.Except
+import Data.Int (Int64)
+import Data.Text (Text)
+import Database.SQLite.Simple (Only (..))
+import qualified Database.SQLite.Simple as SQL
+import Database.SQLite.Simple.QQ (sql)
+import Simplex.Chat.Remote.Types
+import Simplex.Chat.Store.Shared
+import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
+import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.RemoteControl.Types
+import UnliftIO
+
+insertRemoteHost :: DB.Connection -> Text -> FilePath -> RCHostPairing -> ExceptT StoreError IO RemoteHostId
+insertRemoteHost db hostDeviceName storePath RCHostPairing {caKey, caCert, idPrivKey, knownHost = kh_} = do
+  KnownHostPairing {hostFingerprint, hostDhPubKey} <-
+    maybe (throwError SERemoteHostUnknown) pure kh_
+  checkConstraint SERemoteHostDuplicateCA . liftIO $
+    DB.execute
+      db
+      [sql|
+        INSERT INTO remote_hosts
+          (host_device_name, store_path, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub)
+        VALUES
+          (?, ?, ?, ?, ?, ?, ?)
+      |]
+      (hostDeviceName, storePath, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey)
+  liftIO $ insertedRowId db
+
+getRemoteHosts :: DB.Connection -> IO [RemoteHost]
+getRemoteHosts db =
+  map toRemoteHost <$> DB.query_ db remoteHostQuery
+
+getRemoteHost :: DB.Connection -> RemoteHostId -> ExceptT StoreError IO RemoteHost
+getRemoteHost db remoteHostId =
+  ExceptT . firstRow toRemoteHost (SERemoteHostNotFound remoteHostId) $
+    DB.query db (remoteHostQuery <> " WHERE remote_host_id = ?") (Only remoteHostId)
+
+getRemoteHostByFingerprint :: DB.Connection -> C.KeyHash -> IO (Maybe RemoteHost)
+getRemoteHostByFingerprint db fingerprint =
+  maybeFirstRow toRemoteHost $
+    DB.query db (remoteHostQuery <> " WHERE host_fingerprint = ?") (Only fingerprint)
+
+remoteHostQuery :: SQL.Query
+remoteHostQuery =
+  [sql|
+    SELECT remote_host_id, host_device_name, store_path, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub
+    FROM remote_hosts
+  |]
+
+toRemoteHost :: (Int64, Text, FilePath, C.APrivateSignKey, C.SignedObject C.Certificate, C.PrivateKeyEd25519, C.KeyHash, C.PublicKeyX25519) -> RemoteHost
+toRemoteHost (remoteHostId, hostDeviceName, storePath, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey) =
+  RemoteHost {remoteHostId, hostDeviceName, storePath, hostPairing}
+  where
+    hostPairing = RCHostPairing {caKey, caCert, idPrivKey, knownHost = Just knownHost}
+    knownHost = KnownHostPairing {hostFingerprint, hostDhPubKey}
+
+updateHostPairing :: DB.Connection -> RemoteHostId -> Text -> C.PublicKeyX25519 -> IO ()
+updateHostPairing db rhId hostDeviceName hostDhPubKey =
+  DB.execute
+    db
+    [sql|
+      UPDATE remote_hosts
+      SET host_device_name = ?, host_dh_pub = ?
+      WHERE remote_host_id = ?
+    |]
+    (hostDeviceName, hostDhPubKey, rhId)
+
+deleteRemoteHostRecord :: DB.Connection -> RemoteHostId -> IO ()
+deleteRemoteHostRecord db remoteHostId = DB.execute db "DELETE FROM remote_hosts WHERE remote_host_id = ?" (Only remoteHostId)
+
+insertRemoteCtrl :: DB.Connection -> Text -> RCCtrlPairing -> ExceptT StoreError IO RemoteCtrlId
+insertRemoteCtrl db ctrlDeviceName RCCtrlPairing {caKey, caCert, ctrlFingerprint, idPubKey, dhPrivKey, prevDhPrivKey} = do
+  checkConstraint SERemoteCtrlDuplicateCA . liftIO $
+    DB.execute
+      db
+      [sql|
+      INSERT INTO remote_controllers
+        (ctrl_device_name, ca_key, ca_cert, ctrl_fingerprint, id_pub, dh_priv_key, prev_dh_priv_key)
+      VALUES
+        (?, ?, ?, ?, ?, ?, ?)
+    |]
+      (ctrlDeviceName, caKey, C.SignedObject caCert, ctrlFingerprint, idPubKey, dhPrivKey, prevDhPrivKey)
+  liftIO $ insertedRowId db
+
+getRemoteCtrls :: DB.Connection -> IO [RemoteCtrl]
+getRemoteCtrls db =
+  map toRemoteCtrl <$> DB.query_ db remoteCtrlQuery
+
+getRemoteCtrl :: DB.Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteCtrl
+getRemoteCtrl db remoteCtrlId =
+  ExceptT . firstRow toRemoteCtrl (SERemoteCtrlNotFound remoteCtrlId) $
+    DB.query db (remoteCtrlQuery <> " WHERE remote_ctrl_id = ?") (Only remoteCtrlId)
+
+getRemoteCtrlByFingerprint :: DB.Connection -> C.KeyHash -> IO (Maybe RemoteCtrl)
+getRemoteCtrlByFingerprint db fingerprint =
+  maybeFirstRow toRemoteCtrl $
+    DB.query db (remoteCtrlQuery <> " WHERE ctrl_fingerprint = ?") (Only fingerprint)
+
+remoteCtrlQuery :: SQL.Query
+remoteCtrlQuery =
+  [sql|
+    SELECT remote_ctrl_id, ctrl_device_name, ca_key, ca_cert, ctrl_fingerprint, id_pub, dh_priv_key, prev_dh_priv_key
+    FROM remote_controllers
+  |]
+
+toRemoteCtrl ::
+  ( RemoteCtrlId,
+    Text,
+    C.APrivateSignKey,
+    C.SignedObject C.Certificate,
+    C.KeyHash,
+    C.PublicKeyEd25519,
+    C.PrivateKeyX25519,
+    Maybe C.PrivateKeyX25519
+  ) ->
+  RemoteCtrl
+toRemoteCtrl (remoteCtrlId, ctrlDeviceName, caKey, C.SignedObject caCert, ctrlFingerprint, idPubKey, dhPrivKey, prevDhPrivKey) =
+  let ctrlPairing = RCCtrlPairing {caKey, caCert, ctrlFingerprint, idPubKey, dhPrivKey, prevDhPrivKey}
+   in RemoteCtrl {remoteCtrlId, ctrlDeviceName, ctrlPairing}
+
+updateRemoteCtrl :: DB.Connection -> RemoteCtrl -> Text -> C.PrivateKeyX25519 -> IO ()
+updateRemoteCtrl db RemoteCtrl {remoteCtrlId} ctrlDeviceName dhPrivKey =
+  DB.execute
+    db
+    [sql|
+      UPDATE remote_controllers
+      SET ctrl_device_name = ?, dh_priv_key = ?, prev_dh_priv_key = dh_priv_key
+      WHERE remote_ctrl_id = ?
+    |]
+    (ctrlDeviceName, dhPrivKey, remoteCtrlId)
+
+deleteRemoteCtrlRecord :: DB.Connection -> RemoteCtrlId -> IO ()
+deleteRemoteCtrlRecord db remoteCtrlId =
+  DB.execute db "DELETE FROM remote_controllers WHERE remote_ctrl_id = ?" (Only remoteCtrlId)

src/Simplex/Chat/Store/Shared.hs

@@ -1,11 +1,11 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeOperators #-}
 
 module Simplex.Chat.Store.Shared where
@@ -14,8 +14,7 @@ import Control.Exception (Exception)
 import qualified Control.Exception as E
 import Control.Monad.Except
 import Crypto.Random (ChaChaDRG, randomBytesGenerate)
-import Data.Aeson (ToJSON)
-import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as J
 import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
@@ -26,9 +25,9 @@ import Data.Time.Clock (UTCTime (..), getCurrentTime)
 import Database.SQLite.Simple (NamedParam (..), Only (..), Query, SQLError, (:.) (..))
 import qualified Database.SQLite.Simple as SQL
 import Database.SQLite.Simple.QQ (sql)
-import GHC.Generics (Generic)
 import Simplex.Chat.Messages
 import Simplex.Chat.Protocol
+import Simplex.Chat.Remote.Types
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
 import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
@@ -99,11 +98,14 @@ data StoreError
   | SEContactNotFoundByFileId {fileId :: FileTransferId}
   | SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
   | SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId}
-  deriving (Show, Exception, Generic)
+  | SERemoteHostNotFound {remoteHostId :: RemoteHostId}
+  | SERemoteHostUnknown -- ^ attempting to store KnownHost without a known fingerprint
+  | SERemoteHostDuplicateCA
+  | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
+  | SERemoteCtrlDuplicateCA
+  deriving (Show, Exception)
 
-instance ToJSON StoreError where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SE"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SE"
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError)
 
 insertedRowId :: DB.Connection -> IO Int64
 insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"

src/Simplex/Chat/Terminal/Input.hs

@@ -52,12 +52,14 @@ getKey =
 runInputLoop :: ChatTerminal -> ChatController -> IO ()
 runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
   s <- atomically . readTBQueue $ inputQ cc
+  rh <- readTVarIO $ currentRemoteHost cc
   let bs = encodeUtf8 $ T.pack s
       cmd = parseChatCommand bs
+      rh' = if either (const False) allowRemoteCommand cmd then rh else Nothing
   unless (isMessage cmd) $ echo s
-  r <- runReaderT (execChatCommand bs) cc
+  r <- runReaderT (execChatCommand rh' bs) cc
   processResp s cmd r
-  printRespToTerminal ct cc False r
+  printRespToTerminal ct cc False rh r
   startLiveMessage cmd r
   where
     echo s = printToTerminal ct [plain s]
@@ -145,7 +147,7 @@ runTerminalInput ct cc = withChatTerm ct $ do
   receiveFromTTY cc ct
 
 receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m ()
-receiveFromTTY cc@ChatController {inputQ, currentUser, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState, activeTo} =
+receiveFromTTY cc@ChatController {inputQ, currentUser, currentRemoteHost, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState, activeTo} =
   forever $ getKey >>= liftIO . processKey >> withTermLock ct (updateInput ct)
   where
     processKey :: (Key, Modifiers) -> IO ()
@@ -177,7 +179,8 @@ receiveFromTTY cc@ChatController {inputQ, currentUser, chatStore} ct@ChatTermina
       kill promptThreadId
       atomically $ writeTVar liveMessageState Nothing
       r <- sendUpdatedLiveMessage cc sentMsg lm False
-      printRespToTerminal ct cc False r
+      rh <- readTVarIO currentRemoteHost -- XXX: should be inherited from live message state
+      printRespToTerminal ct cc False rh r
       where
         kill sel = deRefWeak (sel lm) >>= mapM_ killThread
 

src/Simplex/Chat/Terminal/Output.hs

@@ -25,6 +25,7 @@ import Simplex.Chat.Messages
 import Simplex.Chat.Messages.CIContent (CIContent(..), SMsgDirection (..))
 import Simplex.Chat.Options
 import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
+import Simplex.Chat.Remote.Types (RemoteHostId)
 import Simplex.Chat.Styled
 import Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications)
 import Simplex.Chat.Types
@@ -137,7 +138,7 @@ withTermLock ChatTerminal {termLock} action = do
 runTerminalOutput :: ChatTerminal -> ChatController -> IO ()
 runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = do
   forever $ do
-    (_, r) <- atomically $ readTBQueue outputQ
+    (_, outputRH, r) <- atomically $ readTBQueue outputQ
     case r of
       CRNewChatItem u ci -> markChatItemRead u ci
       CRChatItemUpdated u ci -> markChatItemRead u ci
@@ -146,7 +147,7 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
           Just path -> if logResponseToFile r then logResponse path else printToTerminal ct
           _ -> printToTerminal ct
     liveItems <- readTVarIO showLiveItems
-    responseString cc liveItems r >>= printResp
+    responseString cc liveItems outputRH r >>= printResp
     responseNotification ct cc r
   where
     markChatItemRead u (AChatItem _ _ chat ci@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
@@ -252,15 +253,16 @@ whenCurrUser cc u a = do
   where
     sameUser User {userId = uId} = maybe False $ \User {userId} -> userId == uId
 
-printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> ChatResponse -> IO ()
-printRespToTerminal ct cc liveItems r = responseString cc liveItems r >>= printToTerminal ct
+printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> Maybe RemoteHostId -> ChatResponse -> IO ()
+printRespToTerminal ct cc liveItems outputRH r = responseString cc liveItems outputRH r >>= printToTerminal ct
 
-responseString :: ChatController -> Bool -> ChatResponse -> IO [StyledString]
-responseString cc liveItems r = do
-  user <- readTVarIO $ currentUser cc
+responseString :: ChatController -> Bool -> Maybe RemoteHostId -> ChatResponse -> IO [StyledString]
+responseString cc liveItems outputRH r = do
+  currentRH <- readTVarIO $ currentRemoteHost cc
+  user <- readTVarIO $ currentUser cc -- XXX: local user, should be subsumed by remote when connected
   ts <- getCurrentTime
   tz <- getCurrentTimeZone
-  pure $ responseToView user (config cc) liveItems ts tz r
+  pure $ responseToView (currentRH, user) (config cc) liveItems ts tz outputRH r
 
 printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
 printToTerminal ct s =

src/Simplex/Chat/Types.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -10,10 +9,12 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
@@ -23,9 +24,10 @@
 module Simplex.Chat.Types where
 
 import Crypto.Number.Serialize (os2ip)
-import Data.Aeson (FromJSON (..), ToJSON (..), (.=))
+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)
@@ -41,14 +43,13 @@ import Database.SQLite.Simple.FromField (returnError, FromField(..))
 import Database.SQLite.Simple.Internal (Field (..))
 import Database.SQLite.Simple.Ok
 import Database.SQLite.Simple.ToField (ToField (..))
-import GHC.Generics (Generic)
 import Simplex.Chat.Types.Preferences
 import Simplex.Chat.Types.Util
 import Simplex.FileTransfer.Description (FileDigest)
 import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
 import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON)
 import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
 import Simplex.Messaging.Util ((<$?>))
 import Simplex.Messaging.Version
@@ -114,18 +115,14 @@ data User = User
     sendRcptsContacts :: Bool,
     sendRcptsSmallGroups :: Bool
   }
-  deriving (Show, Generic, FromJSON)
-
-instance ToJSON User where
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
+  deriving (Show)
 
 data NewUser = NewUser
   { profile :: Maybe Profile,
     sameServers :: Bool,
     pastTimestamp :: Bool
   }
-  deriving (Show, Generic, FromJSON)
+  deriving (Show)
 
 newtype B64UrlByteString = B64UrlByteString ByteString
   deriving (Eq, Show)
@@ -146,19 +143,13 @@ instance ToJSON B64UrlByteString where
   toEncoding = strToJEncoding
 
 data UserPwdHash = UserPwdHash {hash :: B64UrlByteString, salt :: B64UrlByteString}
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON UserPwdHash where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data UserInfo = UserInfo
   { user :: User,
     unreadCount :: Int
   }
-  deriving (Show, Generic, FromJSON)
-
-instance ToJSON UserInfo where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 type ContactId = Int64
 
@@ -181,11 +172,7 @@ data Contact = Contact
     contactGroupMemberId :: Maybe GroupMemberId,
     contactGrpInvSent :: Bool
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON Contact where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 contactConn :: Contact -> Maybe Connection
 contactConn Contact {activeConn} = activeConn
@@ -231,6 +218,9 @@ instance FromField ContactStatus where fromField = fromTextField_ textDecode
 
 instance ToField ContactStatus where toField = toField . textEncode
 
+instance FromJSON ContactStatus where
+  parseJSON = textParseJSON "ContactStatus"
+
 instance ToJSON ContactStatus where
   toJSON = J.String . textEncode
   toEncoding = JE.text . textEncode
@@ -250,9 +240,7 @@ data ContactRef = ContactRef
     agentConnId :: AgentConnId,
     localDisplayName :: ContactName
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON ContactRef where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data ContactOrMember = COMContact Contact | COMGroupMember GroupMember
   deriving (Show)
@@ -272,15 +260,11 @@ data UserContact = UserContact
     connReqContact :: ConnReqContact,
     groupId :: Maybe GroupId
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 userContactGroupId :: UserContact -> Maybe GroupId
 userContactGroupId UserContact {groupId} = groupId
 
-instance ToJSON UserContact where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
-
 data UserContactRequest = UserContactRequest
   { contactRequestId :: Int64,
     agentInvitationId :: AgentInvId,
@@ -294,10 +278,7 @@ data UserContactRequest = UserContactRequest
     updatedAt :: UTCTime,
     xContactId :: Maybe XContactId
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON UserContactRequest where
-  toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 newtype XContactId = XContactId ByteString
   deriving (Eq, Show)
@@ -351,9 +332,7 @@ optionalFullName displayName fullName
   | otherwise = " (" <> fullName <> ")"
 
 data Group = Group {groupInfo :: GroupInfo, members :: [GroupMember]}
-  deriving (Eq, Show, Generic)
-
-instance ToJSON Group where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 type GroupId = Int64
 
@@ -369,9 +348,7 @@ data GroupInfo = GroupInfo
     updatedAt :: UTCTime,
     chatTs :: Maybe UTCTime
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON GroupInfo where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 groupName' :: GroupInfo -> GroupName
 groupName' GroupInfo {localDisplayName = g} = g
@@ -379,9 +356,7 @@ groupName' GroupInfo {localDisplayName = g} = g
 data GroupSummary = GroupSummary
   { currentMembers :: Int
   }
-  deriving (Show, Generic)
-
-instance ToJSON GroupSummary where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 data ContactOrGroup = CGContact Contact | CGGroup Group
 
@@ -396,9 +371,7 @@ data ChatSettings = ChatSettings
     sendRcpts :: Maybe Bool,
     favorite :: Bool
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 defaultChatSettings :: ChatSettings
 defaultChatSettings =
@@ -412,18 +385,7 @@ chatHasNtfs :: ChatSettings -> Bool
 chatHasNtfs ChatSettings {enableNtfs} = enableNtfs /= MFNone
 
 data MsgFilter = MFNone | MFAll | MFMentions
-  deriving (Eq, Show, Generic)
-
-instance FromJSON MsgFilter where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "MF"
-
-instance ToJSON MsgFilter where
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MF"
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "MF"
-
-instance FromField MsgFilter where fromField = fromIntField_ msgFilterIntP
-
-instance ToField MsgFilter where toField = toField . msgFilterInt
+  deriving (Eq, Show)
 
 msgFilterInt :: MsgFilter -> Int
 msgFilterInt = \case
@@ -506,11 +468,7 @@ data Profile = Profile
     -- - incognito
     -- - local_alias
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON Profile where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 profileFromName :: ContactName -> Profile
 profileFromName displayName =
@@ -536,11 +494,7 @@ data LocalProfile = LocalProfile
     preferences :: Maybe Preferences,
     localAlias :: LocalAlias
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON LocalProfile where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 localProfileId :: LocalProfile -> ProfileId
 localProfileId = profileId
@@ -560,11 +514,7 @@ data GroupProfile = GroupProfile
     image :: Maybe ImageData,
     groupPreferences :: Maybe GroupPreferences
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON GroupProfile where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 newtype ImageData = ImageData Text
   deriving (Eq, Show)
@@ -581,14 +531,6 @@ instance ToField ImageData where toField (ImageData t) = toField t
 instance FromField ImageData where fromField = fmap ImageData . fromField
 
 data CReqClientData = CRDataGroup {groupLinkId :: GroupLinkId}
-  deriving (Generic)
-
-instance ToJSON CReqClientData where
-  toJSON = J.genericToJSON . taggedObjectJSON $ dropPrefix "CRData"
-  toEncoding = J.genericToEncoding . taggedObjectJSON $ dropPrefix "CRData"
-
-instance FromJSON CReqClientData where
-  parseJSON = J.genericParseJSON . taggedObjectJSON $ dropPrefix "CRData"
 
 newtype GroupLinkId = GroupLinkId {unGroupLinkId :: ByteString} -- used to identify invitation via group link
   deriving (Eq, Show)
@@ -616,11 +558,7 @@ data GroupInvitation = GroupInvitation
     groupProfile :: GroupProfile,
     groupLinkId :: Maybe GroupLinkId
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON GroupInvitation where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 data GroupLinkInvitation = GroupLinkInvitation
   { fromMember :: MemberIdRole,
@@ -628,29 +566,19 @@ data GroupLinkInvitation = GroupLinkInvitation
     invitedMember :: MemberIdRole,
     groupProfile :: GroupProfile
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON GroupLinkInvitation where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data MemberIdRole = MemberIdRole
   { memberId :: MemberId,
     memberRole :: GroupMemberRole
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON MemberIdRole where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data IntroInvitation = IntroInvitation
   { groupConnReq :: ConnReqInvitation,
     directConnReq :: Maybe ConnReqInvitation
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON IntroInvitation where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 data MemberInfo = MemberInfo
   { memberId :: MemberId,
@@ -658,11 +586,7 @@ data MemberInfo = MemberInfo
     v :: Maybe ChatVersionRange,
     profile :: Profile
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON MemberInfo where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 memberInfo :: GroupMember -> MemberInfo
 memberInfo GroupMember {memberId, memberRole, memberProfile, activeConn} =
@@ -705,16 +629,10 @@ data GroupMember = GroupMember
     -- for membership current supportedChatVRange is set, it's not updated on protocol version increase
     memberChatVRange :: JVersionRange
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON GroupMember where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 data GroupMemberRef = GroupMemberRef {groupMemberId :: Int64, profile :: Profile}
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON GroupMemberRef where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 groupMemberRef :: GroupMember -> GroupMemberRef
 groupMemberRef GroupMember {groupMemberId, memberProfile = p} =
@@ -781,11 +699,7 @@ instance ToJSON MemberId where
   toEncoding = strToJEncoding
 
 data InvitedBy = IBContact {byContactId :: Int64} | IBUser | IBUnknown
-  deriving (Eq, Show, Generic)
-
-instance ToJSON InvitedBy where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "IB"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "IB"
+  deriving (Eq, Show)
 
 toInvitedBy :: Int64 -> Maybe Int64 -> InvitedBy
 toInvitedBy userCtId (Just ctId)
@@ -837,9 +751,7 @@ instance ToJSON GroupMemberRole where
 data GroupMemberSettings = GroupMemberSettings
   { showMessages :: Bool
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON GroupMemberSettings where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 defaultMemberSettings :: GroupMemberSettings
 defaultMemberSettings = GroupMemberSettings {showMessages = True}
@@ -886,6 +798,9 @@ instance FromField GroupMemberCategory where fromField = fromTextField_ textDeco
 
 instance ToField GroupMemberCategory where toField = toField . textEncode
 
+instance FromJSON GroupMemberCategory where
+  parseJSON = textParseJSON "GroupMemberCategory"
+
 instance ToJSON GroupMemberCategory where
   toJSON = J.String . textEncode
   toEncoding = JE.text . textEncode
@@ -923,6 +838,9 @@ instance FromField GroupMemberStatus where fromField = fromTextField_ textDecode
 
 instance ToField GroupMemberStatus where toField = toField . textEncode
 
+instance FromJSON GroupMemberStatus where
+  parseJSON = textParseJSON "GroupMemberStatus"
+
 instance ToJSON GroupMemberStatus where
   toJSON = J.String . textEncode
   toEncoding = JE.text . textEncode
@@ -1014,9 +932,7 @@ data SndFileTransfer = SndFileTransfer
     fileDescrId :: Maybe Int64,
     fileInline :: Maybe InlineFileMode
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON SndFileTransfer where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 sndFileTransferConnId :: SndFileTransfer -> ConnId
 sndFileTransferConnId SndFileTransfer {agentConnId = AgentConnId acId} = acId
@@ -1031,24 +947,10 @@ data FileInvitation = FileInvitation
     fileInline :: Maybe InlineFileMode,
     fileDescr :: Maybe FileDescr
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON FileInvitation where
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-
-instance FromJSON FileInvitation where
-  parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 data FileDescr = FileDescr {fileDescrText :: Text, fileDescrPartNo :: Int, fileDescrComplete :: Bool}
-  deriving (Eq, Show, Generic)
-
-instance ToJSON FileDescr where
-  toEncoding = J.genericToEncoding J.defaultOptions
-  toJSON = J.genericToJSON J.defaultOptions
-
-instance FromJSON FileDescr where
-  parseJSON = J.genericParseJSON J.defaultOptions
+  deriving (Eq, Show)
 
 xftpFileInvitation :: FilePath -> Integer -> FileDescr -> FileInvitation
 xftpFileInvitation fileName fileSize fileDescr =
@@ -1064,7 +966,7 @@ xftpFileInvitation fileName fileSize fileDescr =
 data InlineFileMode
   = IFMOffer -- file will be sent inline once accepted
   | IFMSent -- file is sent inline without acceptance
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 instance TextEncoding InlineFileMode where
   textEncode = \case
@@ -1080,7 +982,7 @@ instance FromField InlineFileMode where fromField = fromTextField_ textDecode
 instance ToField InlineFileMode where toField = toField . textEncode
 
 instance FromJSON InlineFileMode where
-  parseJSON = J.withText "InlineFileMode" $ maybe (fail "bad InlineFileMode") pure . textDecode
+  parseJSON = textParseJSON "InlineFileMode"
 
 instance ToJSON InlineFileMode where
   toJSON = J.String . textEncode
@@ -1100,18 +1002,14 @@ data RcvFileTransfer = RcvFileTransfer
     -- SMP files are encrypted after all chunks are received
     cryptoArgs :: Maybe CryptoFileArgs
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON RcvFileTransfer where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data XFTPRcvFile = XFTPRcvFile
   { rcvFileDescription :: RcvFileDescr,
     agentRcvFileId :: Maybe AgentRcvFileId,
     agentRcvFileDeleted :: Bool
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON XFTPRcvFile where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data RcvFileDescr = RcvFileDescr
   { fileDescrId :: Int64,
@@ -1119,9 +1017,7 @@ data RcvFileDescr = RcvFileDescr
     fileDescrPartNo :: Int,
     fileDescrComplete :: Bool
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON RcvFileDescr where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data RcvFileStatus
   = RFSNew
@@ -1129,11 +1025,7 @@ data RcvFileStatus
   | RFSConnected RcvFileInfo
   | RFSComplete RcvFileInfo
   | RFSCancelled (Maybe RcvFileInfo)
-  deriving (Eq, Show, Generic)
-
-instance ToJSON RcvFileStatus where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RFS"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RFS"
+  deriving (Eq, Show)
 
 rcvFileComplete :: RcvFileStatus -> Bool
 rcvFileComplete = \case
@@ -1148,9 +1040,7 @@ data RcvFileInfo = RcvFileInfo
     connId :: Maybe Int64,
     agentConnId :: Maybe AgentConnId
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON RcvFileInfo where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 liveRcvFileTransferInfo :: RcvFileTransfer -> Maybe RcvFileInfo
 liveRcvFileTransferInfo RcvFileTransfer {fileStatus} = case fileStatus of
@@ -1196,6 +1086,9 @@ instance StrEncoding AgentSndFileId where
   strDecode s = AgentSndFileId <$> strDecode s
   strP = AgentSndFileId <$> strP
 
+instance FromJSON AgentSndFileId where
+  parseJSON = strParseJSON "AgentSndFileId"
+
 instance ToJSON AgentSndFileId where
   toJSON = strToJSON
   toEncoding = strToJEncoding
@@ -1212,6 +1105,9 @@ instance StrEncoding AgentRcvFileId where
   strDecode s = AgentRcvFileId <$> strDecode s
   strP = AgentRcvFileId <$> strP
 
+instance FromJSON AgentRcvFileId where
+  parseJSON = strParseJSON "AgentRcvFileId"
+
 instance ToJSON AgentRcvFileId where
   toJSON = strToJSON
   toEncoding = strToJEncoding
@@ -1228,6 +1124,9 @@ instance StrEncoding AgentInvId where
   strDecode s = AgentInvId <$> strDecode s
   strP = AgentInvId <$> strP
 
+instance FromJSON AgentInvId where
+  parseJSON = strParseJSON "AgentInvId"
+
 instance ToJSON AgentInvId where
   toJSON = strToJSON
   toEncoding = strToJEncoding
@@ -1242,11 +1141,7 @@ data FileTransfer
         sndFileTransfers :: [SndFileTransfer]
       }
   | FTRcv {rcvFileTransfer :: RcvFileTransfer}
-  deriving (Show, Generic)
-
-instance ToJSON FileTransfer where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "FT"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "FT"
+  deriving (Show)
 
 data FileTransferMeta = FileTransferMeta
   { fileId :: FileTransferId,
@@ -1258,9 +1153,7 @@ data FileTransferMeta = FileTransferMeta
     chunkSize :: Integer,
     cancelled :: Bool
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON FileTransferMeta where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data XFTPSndFile = XFTPSndFile
   { agentSndFileId :: AgentSndFileId,
@@ -1268,9 +1161,7 @@ data XFTPSndFile = XFTPSndFile
     agentSndFileDeleted :: Bool,
     cryptoArgs :: Maybe CryptoFileArgs
   }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON XFTPSndFile where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 fileTransferCancelled :: FileTransfer -> Bool
 fileTransferCancelled (FTSnd FileTransferMeta {cancelled} _) = cancelled
@@ -1283,6 +1174,9 @@ instance FromField FileStatus where fromField = fromTextField_ textDecode
 
 instance ToField FileStatus where toField = toField . textEncode
 
+instance FromJSON FileStatus where
+  parseJSON = textParseJSON "FileStatus"
+
 instance ToJSON FileStatus where
   toJSON = J.String . textEncode
   toEncoding = JE.text . textEncode
@@ -1328,7 +1222,7 @@ data Connection = Connection
     authErrCounter :: Int,
     createdAt :: UTCTime
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 connReady :: Connection -> Bool
 connReady Connection {connStatus} = connStatus == ConnReady || connStatus == ConnSndReady
@@ -1340,11 +1234,7 @@ connDisabled :: Connection -> Bool
 connDisabled Connection {authErrCounter} = authErrCounter >= authErrDisableCount
 
 data SecurityCode = SecurityCode {securityCode :: Text, verifiedAt :: UTCTime}
-  deriving (Eq, Show, Generic)
-
-instance ToJSON SecurityCode where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 verificationCode :: ByteString -> Text
 verificationCode = T.pack . unwords . chunks 5 . show . os2ip
@@ -1363,10 +1253,6 @@ aConnId Connection {agentConnId = AgentConnId cId} = cId
 connIncognito :: Connection -> Bool
 connIncognito Connection {customUserProfileId} = isJust customUserProfileId
 
-instance ToJSON Connection where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-
 data PendingContactConnection = PendingContactConnection
   { pccConnId :: Int64,
     pccAgentConnId :: AgentConnId,
@@ -1380,13 +1266,11 @@ data PendingContactConnection = PendingContactConnection
     createdAt :: UTCTime,
     updatedAt :: UTCTime
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 aConnId' :: PendingContactConnection -> ConnId
 aConnId' PendingContactConnection {pccAgentConnId = AgentConnId cId} = cId
 
-instance ToJSON PendingContactConnection where toEncoding = J.genericToEncoding J.defaultOptions
-
 data ConnStatus
   = -- | connection is created by initiating party with agent NEW command (createConnection)
     ConnNew
@@ -1408,6 +1292,9 @@ instance FromField ConnStatus where fromField = fromTextField_ textDecode
 
 instance ToField ConnStatus where toField = toField . textEncode
 
+instance FromJSON ConnStatus where
+  parseJSON = textParseJSON "ConnStatus"
+
 instance ToJSON ConnStatus where
   toJSON = J.String . textEncode
   toEncoding = JE.text . textEncode
@@ -1438,6 +1325,9 @@ instance FromField ConnType where fromField = fromTextField_ textDecode
 
 instance ToField ConnType where toField = toField . textEncode
 
+instance FromJSON ConnType where
+  parseJSON = textParseJSON "ConnType"
+
 instance ToJSON ConnType where
   toJSON = J.String . textEncode
   toEncoding = JE.text . textEncode
@@ -1515,7 +1405,7 @@ data NetworkStatus
   | NSConnected
   | NSDisconnected
   | NSError {connectionError :: String}
-  deriving (Eq, Ord, Show, Generic)
+  deriving (Eq, Ord, Show)
 
 netStatusStr :: NetworkStatus -> String
 netStatusStr = \case
@@ -1524,20 +1414,11 @@ netStatusStr = \case
   NSDisconnected -> "disconnected"
   NSError e -> "error: " <> e
 
-instance FromJSON NetworkStatus where
-  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "NS"
-
-instance ToJSON NetworkStatus where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "NS"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "NS"
-
 data ConnNetworkStatus = ConnNetworkStatus
   { agentConnId :: AgentConnId,
     networkStatus :: NetworkStatus
   }
-  deriving (Show, Generic, FromJSON)
-
-instance ToJSON ConnNetworkStatus where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Show)
 
 type CommandId = Int64
 
@@ -1551,7 +1432,7 @@ data CommandStatus
   = CSCreated
   | CSCompleted -- unused - was replaced with deleteCommand
   | CSError -- internal command error, e.g. not matching connection id or unexpected response, not related to agent message ERR
-  deriving (Show, Generic)
+  deriving (Show)
 
 instance FromField CommandStatus where fromField = fromTextField_ textDecode
 
@@ -1578,7 +1459,7 @@ data CommandFunction
   | CFAcceptContact
   | CFAckMessage
   | CFDeleteConn -- not used
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 instance FromField CommandFunction where fromField = fromTextField_ textDecode
 
@@ -1644,14 +1525,7 @@ data ServerCfg p = ServerCfg
     tested :: Maybe Bool,
     enabled :: Bool
   }
-  deriving (Show, Generic)
-
-instance ProtocolTypeI p => ToJSON (ServerCfg p) where
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-
-instance ProtocolTypeI p => FromJSON (ServerCfg p) where
-  parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
+  deriving (Show)
 
 newtype ChatVersionRange = ChatVersionRange {fromChatVRange :: VersionRange} deriving (Eq, Show)
 
@@ -1667,6 +1541,107 @@ instance ToJSON ChatVersionRange where
 
 newtype JVersionRange = JVersionRange {fromJVersionRange :: VersionRange} deriving (Eq, Show)
 
+instance FromJSON JVersionRange where
+  parseJSON = J.withObject "JVersionRange" $ \o -> do
+    minv <- o .: "minVersion"
+    maxv <- o .: "maxVersion"
+    maybe (fail "bad version range") (pure . JVersionRange) $ safeVersionRange minv maxv
+
 instance ToJSON JVersionRange where
   toJSON (JVersionRange (VersionRange minV maxV)) = J.object ["minVersion" .= minV, "maxVersion" .= maxV]
   toEncoding (JVersionRange (VersionRange minV maxV)) = J.pairs $ "minVersion" .= minV <> "maxVersion" .= maxV
+
+$(JQ.deriveJSON defaultJSON ''UserContact)
+
+$(JQ.deriveJSON defaultJSON ''Profile)
+
+$(JQ.deriveJSON defaultJSON ''LocalProfile)
+
+$(JQ.deriveJSON defaultJSON ''UserContactRequest)
+
+$(JQ.deriveJSON defaultJSON ''GroupProfile)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "IB") ''InvitedBy)
+
+$(JQ.deriveJSON defaultJSON ''GroupMemberSettings)
+
+$(JQ.deriveJSON defaultJSON ''SecurityCode)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "NS") ''NetworkStatus)
+
+$(JQ.deriveJSON defaultJSON ''ConnNetworkStatus)
+
+$(JQ.deriveJSON defaultJSON ''Connection)
+
+$(JQ.deriveJSON defaultJSON ''PendingContactConnection)
+
+$(JQ.deriveJSON defaultJSON ''GroupMember)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "MF") ''MsgFilter)
+
+$(JQ.deriveJSON defaultJSON ''ChatSettings)
+
+$(JQ.deriveJSON defaultJSON ''GroupInfo)
+
+$(JQ.deriveJSON defaultJSON ''Group)
+
+$(JQ.deriveJSON defaultJSON ''GroupSummary)
+
+instance FromField MsgFilter where fromField = fromIntField_ msgFilterIntP
+
+instance ToField MsgFilter where toField = toField . msgFilterInt
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "CRData") ''CReqClientData)
+
+$(JQ.deriveJSON defaultJSON ''MemberIdRole)
+
+$(JQ.deriveJSON defaultJSON ''GroupInvitation)
+
+$(JQ.deriveJSON defaultJSON ''GroupLinkInvitation)
+
+$(JQ.deriveJSON defaultJSON ''IntroInvitation)
+
+$(JQ.deriveJSON defaultJSON ''MemberInfo)
+
+$(JQ.deriveJSON defaultJSON ''GroupMemberRef)
+
+$(JQ.deriveJSON defaultJSON ''FileDescr)
+
+$(JQ.deriveJSON defaultJSON ''FileInvitation)
+
+$(JQ.deriveJSON defaultJSON ''SndFileTransfer)
+
+$(JQ.deriveJSON defaultJSON ''RcvFileDescr)
+
+$(JQ.deriveJSON defaultJSON ''XFTPRcvFile)
+
+$(JQ.deriveJSON defaultJSON ''RcvFileInfo)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RFS") ''RcvFileStatus)
+
+$(JQ.deriveJSON defaultJSON ''RcvFileTransfer)
+
+$(JQ.deriveJSON defaultJSON ''XFTPSndFile)
+
+$(JQ.deriveJSON defaultJSON ''FileTransferMeta)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "FT") ''FileTransfer)
+
+$(JQ.deriveJSON defaultJSON ''UserPwdHash)
+
+$(JQ.deriveJSON defaultJSON ''User)
+
+$(JQ.deriveJSON defaultJSON ''NewUser)
+
+$(JQ.deriveJSON defaultJSON ''UserInfo)
+
+$(JQ.deriveJSON defaultJSON ''Contact)
+
+$(JQ.deriveJSON defaultJSON ''ContactRef)
+
+instance ProtocolTypeI p => ToJSON (ServerCfg p) where
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerCfg)
+  toJSON = $(JQ.mkToJSON defaultJSON ''ServerCfg)
+
+instance ProtocolTypeI p => FromJSON (ServerCfg p) where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerCfg)

src/Simplex/Chat/Types/Preferences.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -11,6 +10,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
@@ -21,7 +21,7 @@ module Simplex.Chat.Types.Preferences where
 
 import Control.Applicative ((<|>))
 import Data.Aeson (FromJSON (..), ToJSON (..))
-import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import Data.Maybe (fromMaybe, isJust)
@@ -29,11 +29,10 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
-import GHC.Generics (Generic)
 import GHC.Records.Compat
 import Simplex.Chat.Types.Util
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, sumTypeJSON)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON)
 import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>))
 
 data ChatFeature
@@ -42,7 +41,7 @@ data ChatFeature
   | CFReactions
   | CFVoice
   | CFCalls
-  deriving (Show, Generic)
+  deriving (Show)
 
 data SChatFeature (f :: ChatFeature) where
   SCFTimedMessages :: SChatFeature 'CFTimedMessages
@@ -68,13 +67,6 @@ chatFeatureNameText = \case
 chatFeatureNameText' :: SChatFeature f -> Text
 chatFeatureNameText' = chatFeatureNameText . chatFeature
 
-instance ToJSON ChatFeature where
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CF"
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "CF"
-
-instance FromJSON ChatFeature where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CF"
-
 allChatFeatures :: [AChatFeature]
 allChatFeatures =
   [ ACF SCFTimedMessages,
@@ -146,17 +138,7 @@ data Preferences = Preferences
     voice :: Maybe VoicePreference,
     calls :: Maybe CallsPreference
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON Preferences where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-
-instance ToField Preferences where
-  toField = toField . encodeJSON
-
-instance FromField Preferences where
-  fromField = fromTextField_ decodeJSON
+  deriving (Eq, Show)
 
 data GroupFeature
   = GFTimedMessages
@@ -165,7 +147,7 @@ data GroupFeature
   | GFReactions
   | GFVoice
   | GFFiles
-  deriving (Show, Generic)
+  deriving (Show)
 
 data SGroupFeature (f :: GroupFeature) where
   SGFTimedMessages :: SGroupFeature 'GFTimedMessages
@@ -197,13 +179,6 @@ groupFeatureAllowed' :: GroupFeatureI f => SGroupFeature f -> FullGroupPreferenc
 groupFeatureAllowed' feature prefs =
   getField @"enable" (getGroupPreference feature prefs) == FEOn
 
-instance ToJSON GroupFeature where
-  toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "GF"
-  toJSON = J.genericToJSON . enumJSON $ dropPrefix "GF"
-
-instance FromJSON GroupFeature where
-  parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "GF"
-
 allGroupFeatures :: [AGroupFeature]
 allGroupFeatures =
   [ AGF SGFTimedMessages,
@@ -260,17 +235,7 @@ data GroupPreferences = GroupPreferences
     voice :: Maybe VoiceGroupPreference,
     files :: Maybe FilesGroupPreference
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON GroupPreferences where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-
-instance ToField GroupPreferences where
-  toField = toField . encodeJSON
-
-instance FromField GroupPreferences where
-  fromField = fromTextField_ decodeJSON
+  deriving (Eq, Show)
 
 setGroupPreference :: forall f. GroupFeatureI f => SGroupFeature f -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences
 setGroupPreference f enable prefs_ = setGroupPreference_ f pref prefs
@@ -309,9 +274,7 @@ data FullPreferences = FullPreferences
     voice :: VoicePreference,
     calls :: CallsPreference
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON FullPreferences where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 -- full collection of group preferences defined in the app - it is used to ensure we include all preferences and to simplify processing
 -- if some of the preferences are not defined in GroupPreferences, defaults from defaultGroupPrefs are used here.
@@ -323,9 +286,7 @@ data FullGroupPreferences = FullGroupPreferences
     voice :: VoiceGroupPreference,
     files :: FilesGroupPreference
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON FullGroupPreferences where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 -- merged preferences of user for a given contact - they differentiate between specific preferences for the contact and global user preferences
 data ContactUserPreferences = ContactUserPreferences
@@ -335,25 +296,17 @@ data ContactUserPreferences = ContactUserPreferences
     voice :: ContactUserPreference VoicePreference,
     calls :: ContactUserPreference CallsPreference
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 data ContactUserPreference p = ContactUserPreference
   { enabled :: PrefEnabled,
     userPreference :: ContactUserPref p,
     contactPreference :: p
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 data ContactUserPref p = CUPContact {preference :: p} | CUPUser {preference :: p}
-  deriving (Eq, Show, Generic)
-
-instance ToJSON ContactUserPreferences where toEncoding = J.genericToEncoding J.defaultOptions
-
-instance ToJSON p => ToJSON (ContactUserPreference p) where toEncoding = J.genericToEncoding J.defaultOptions
-
-instance ToJSON p => ToJSON (ContactUserPref p) where
-  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CUP"
-  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CUP"
+  deriving (Eq, Show)
 
 toChatPrefs :: FullPreferences -> Preferences
 toChatPrefs FullPreferences {timedMessages, fullDelete, reactions, voice, calls} =
@@ -396,31 +349,19 @@ data TimedMessagesPreference = TimedMessagesPreference
   { allow :: FeatureAllowed,
     ttl :: Maybe Int
   }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON TimedMessagesPreference where
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  deriving (Eq, Show)
 
 data FullDeletePreference = FullDeletePreference {allow :: FeatureAllowed}
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON FullDeletePreference where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data ReactionsPreference = ReactionsPreference {allow :: FeatureAllowed}
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON ReactionsPreference where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data VoicePreference = VoicePreference {allow :: FeatureAllowed}
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON VoicePreference where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 data CallsPreference = CallsPreference {allow :: FeatureAllowed}
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON CallsPreference where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 class (Eq (FeaturePreference f), HasField "allow" (FeaturePreference f) FeatureAllowed) => FeatureI f where
   type FeaturePreference (f :: ChatFeature) = p | p -> f
@@ -469,47 +410,33 @@ instance FeatureI 'CFCalls where
 
 data GroupPreference = GroupPreference
   {enable :: GroupFeatureEnabled}
-  deriving (Eq, Show, Generic, FromJSON)
+  deriving (Eq, Show)
 
 data TimedMessagesGroupPreference = TimedMessagesGroupPreference
   { enable :: GroupFeatureEnabled,
     ttl :: Maybe Int
   }
-  deriving (Eq, Show, Generic, FromJSON)
+  deriving (Eq, Show)
 
 data DirectMessagesGroupPreference = DirectMessagesGroupPreference
   {enable :: GroupFeatureEnabled}
-  deriving (Eq, Show, Generic, FromJSON)
+  deriving (Eq, Show)
 
 data FullDeleteGroupPreference = FullDeleteGroupPreference
   {enable :: GroupFeatureEnabled}
-  deriving (Eq, Show, Generic, FromJSON)
+  deriving (Eq, Show)
 
 data ReactionsGroupPreference = ReactionsGroupPreference
   {enable :: GroupFeatureEnabled}
-  deriving (Eq, Show, Generic, FromJSON)
+  deriving (Eq, Show)
 
 data VoiceGroupPreference = VoiceGroupPreference
   {enable :: GroupFeatureEnabled}
-  deriving (Eq, Show, Generic, FromJSON)
+  deriving (Eq, Show)
 
 data FilesGroupPreference = FilesGroupPreference
   {enable :: GroupFeatureEnabled}
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON GroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
-
-instance ToJSON TimedMessagesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
-
-instance ToJSON DirectMessagesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
-
-instance ToJSON ReactionsGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
-
-instance ToJSON FullDeleteGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
-
-instance ToJSON VoiceGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
-
-instance ToJSON FilesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference f) GroupFeatureEnabled) => GroupFeatureI f where
   type GroupFeaturePreference (f :: GroupFeature) = p | p -> f
@@ -611,7 +538,7 @@ data FeatureAllowed
   = FAAlways -- allow unconditionally
   | FAYes -- allow, if peer allows it
   | FANo -- do not allow
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 instance FromField FeatureAllowed where fromField = fromBlobField_ strDecode
 
@@ -637,7 +564,7 @@ instance ToJSON FeatureAllowed where
   toEncoding = strToJEncoding
 
 data GroupFeatureEnabled = FEOn | FEOff
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 instance FromField GroupFeatureEnabled where fromField = fromBlobField_ strDecode
 
@@ -710,11 +637,7 @@ toGroupPreferences groupPreferences =
     pref f = Just $ getGroupPreference f groupPreferences
 
 data PrefEnabled = PrefEnabled {forUser :: Bool, forContact :: Bool}
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON PrefEnabled where
-  toJSON = J.genericToJSON J.defaultOptions
-  toEncoding = J.genericToEncoding J.defaultOptions
+  deriving (Eq, Show)
 
 prefEnabled :: FeatureI f => Bool -> FeaturePreference f -> FeaturePreference f -> PrefEnabled
 prefEnabled asymmetric user contact = case (getField @"allow" user, getField @"allow" contact) of
@@ -776,3 +699,69 @@ getContactUserPreference = \case
   SCFReactions -> reactions
   SCFVoice -> voice
   SCFCalls -> calls
+
+$(J.deriveJSON (enumJSON $ dropPrefix "CF") ''ChatFeature)
+
+$(J.deriveJSON (enumJSON $ dropPrefix "GF") ''GroupFeature)
+
+$(J.deriveJSON defaultJSON ''TimedMessagesPreference)
+
+$(J.deriveJSON defaultJSON ''FullDeletePreference)
+
+$(J.deriveJSON defaultJSON ''ReactionsPreference)
+
+$(J.deriveJSON defaultJSON ''VoicePreference)
+
+$(J.deriveJSON defaultJSON ''CallsPreference)
+
+$(J.deriveJSON defaultJSON ''Preferences)
+
+instance ToField Preferences where
+  toField = toField . encodeJSON
+
+instance FromField Preferences where
+  fromField = fromTextField_ decodeJSON
+
+$(J.deriveJSON defaultJSON ''GroupPreference)
+
+$(J.deriveJSON defaultJSON ''TimedMessagesGroupPreference)
+
+$(J.deriveJSON defaultJSON ''DirectMessagesGroupPreference)
+
+$(J.deriveJSON defaultJSON ''ReactionsGroupPreference)
+
+$(J.deriveJSON defaultJSON ''FullDeleteGroupPreference)
+
+$(J.deriveJSON defaultJSON ''VoiceGroupPreference)
+
+$(J.deriveJSON defaultJSON ''FilesGroupPreference)
+
+$(J.deriveJSON defaultJSON ''GroupPreferences)
+
+instance ToField GroupPreferences where
+  toField = toField . encodeJSON
+
+instance FromField GroupPreferences where
+  fromField = fromTextField_ decodeJSON
+
+$(J.deriveJSON defaultJSON ''FullPreferences)
+
+$(J.deriveJSON defaultJSON ''FullGroupPreferences)
+
+$(J.deriveJSON defaultJSON ''PrefEnabled)
+
+instance FromJSON p => FromJSON (ContactUserPref p) where
+  parseJSON = $(J.mkParseJSON (sumTypeJSON $ dropPrefix "CUP") ''ContactUserPref)
+
+instance ToJSON p => ToJSON (ContactUserPref p) where
+  toJSON = $(J.mkToJSON (sumTypeJSON $ dropPrefix "CUP") ''ContactUserPref)
+  toEncoding = $(J.mkToEncoding (sumTypeJSON $ dropPrefix "CUP") ''ContactUserPref)
+
+instance FromJSON p => FromJSON (ContactUserPreference p) where
+  parseJSON = $(J.mkParseJSON defaultJSON ''ContactUserPreference)
+
+instance ToJSON p => ToJSON (ContactUserPreference p) where
+  toJSON = $(J.mkToJSON defaultJSON ''ContactUserPreference)
+  toEncoding = $(J.mkToEncoding defaultJSON ''ContactUserPreference)
+
+$(J.deriveJSON defaultJSON ''ContactUserPreferences)

src/Simplex/Chat/View.hs

@@ -1,18 +1,20 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.Chat.View where
 
-import Data.Aeson (ToJSON)
 import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
 import qualified Data.ByteString.Char8 as B
+import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char (isSpace, toUpper)
 import Data.Function (on)
@@ -30,7 +32,7 @@ import Data.Time (LocalTime (..), TimeOfDay (..), TimeZone (..), utcToLocalTime)
 import Data.Time.Calendar (addDays)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Format (defaultTimeLocale, formatTime)
-import GHC.Generics (Generic)
+import qualified Data.Version as V
 import qualified Network.HTTP.Types as Q
 import Numeric (showFFloat)
 import Simplex.Chat (defaultChatConfig, maxImageSize)
@@ -41,6 +43,8 @@ import Simplex.Chat.Markdown
 import Simplex.Chat.Messages hiding (NewChatItem (..))
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Protocol
+import Simplex.Chat.Remote.Types
+import Simplex.Chat.Remote.AppVersion (pattern AppVersionRange, AppVersion (..))
 import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
 import Simplex.Chat.Styled
 import Simplex.Chat.Types
@@ -64,11 +68,18 @@ import System.Console.ANSI.Types
 
 type CurrentTime = UTCTime
 
-serializeChatResponse :: Maybe User -> CurrentTime -> TimeZone -> ChatResponse -> String
-serializeChatResponse user_ ts tz = unlines . map unStyle . responseToView user_ defaultChatConfig False ts tz
+data WCallCommand
+  = WCCallStart {media :: CallMedia, aesKey :: Maybe String, useWorker :: Bool}
+  | WCCallOffer {offer :: Text, iceCandidates :: Text, media :: CallMedia, aesKey :: Maybe String, useWorker :: Bool}
+  | WCCallAnswer {answer :: Text, iceCandidates :: Text}
 
-responseToView :: Maybe User -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> ChatResponse -> [StyledString]
-responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView} liveItems ts tz = \case
+$(JQ.deriveToJSON (taggedObjectJSON $ dropPrefix "WCCall") ''WCallCommand)
+
+serializeChatResponse :: (Maybe RemoteHostId, Maybe User) -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> String
+serializeChatResponse user_ ts tz remoteHost_ = unlines . map unStyle . responseToView user_ defaultChatConfig False ts tz remoteHost_
+
+responseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> [StyledString]
+responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showReceipts, testView} liveItems ts tz outputRH = \case
   CRActiveUser User {profile} -> viewUserProfile $ fromLocalProfile profile
   CRUsersList users -> viewUsersList users
   CRChatStarted -> ["chat started"]
@@ -182,10 +193,10 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
   CRGroupMemberUpdated {} -> []
   CRContactsMerged u intoCt mergedCt ct' -> ttyUser u $ viewContactsMerged intoCt mergedCt ct'
   CRReceivedContactRequest u UserContactRequest {localDisplayName = c, profile} -> ttyUser u $ viewReceivedContactRequest c profile
-  CRRcvFileStart u ci -> ttyUser u $ receivingFile_' testView "started" ci
-  CRRcvFileComplete u ci -> ttyUser u $ receivingFile_' testView "completed" ci
+  CRRcvFileStart u ci -> ttyUser u $ receivingFile_' hu testView "started" ci
+  CRRcvFileComplete u ci -> ttyUser u $ receivingFile_' hu testView "completed" ci
   CRRcvFileSndCancelled u _ ft -> ttyUser u $ viewRcvFileSndCancelled ft
-  CRRcvFileError u ci e -> ttyUser u $ receivingFile_' testView "error" ci <> [sShow e]
+  CRRcvFileError u ci e -> ttyUser u $ receivingFile_' hu testView "error" ci <> [sShow e]
   CRSndFileStart u _ ft -> ttyUser u $ sendingFile_ "started" ft
   CRSndFileComplete u _ ft -> ttyUser u $ sendingFile_ "completed" ft
   CRSndFileStartXFTP {} -> []
@@ -266,6 +277,52 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
   CRNtfTokenStatus status -> ["device token status: " <> plain (smpEncode status)]
   CRNtfToken _ status mode -> ["device token status: " <> plain (smpEncode status) <> ", notifications mode: " <> plain (strEncode mode)]
   CRNtfMessages {} -> []
+  CRCurrentRemoteHost rhi_ ->
+    [ maybe
+        "Using local profile"
+        (\RemoteHostInfo {remoteHostId = rhId, hostDeviceName} -> "Using remote host " <> sShow rhId <> " (" <> plain hostDeviceName <> ")")
+        rhi_
+    ]
+  CRRemoteHostList hs -> viewRemoteHosts hs
+  CRRemoteHostStarted {remoteHost_, invitation} ->
+    [ maybe "new remote host started" (\RemoteHostInfo {remoteHostId = rhId} -> "remote host " <> sShow rhId <> " started") remoteHost_,
+      "Remote session invitation:",
+      plain invitation
+    ]
+  CRRemoteHostSessionCode {remoteHost_, sessionCode} ->
+    [ maybe "new remote host connecting" (\RemoteHostInfo {remoteHostId = rhId} -> "remote host " <> sShow rhId <> " connecting") remoteHost_,
+      "Compare session code with host:",
+      plain sessionCode
+    ]
+  CRNewRemoteHost RemoteHostInfo {remoteHostId = rhId, hostDeviceName} -> ["new remote host " <> sShow rhId <> " added: " <> plain hostDeviceName]
+  CRRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"]
+  CRRemoteHostStopped rhId_ ->
+    [ maybe "new remote host" (mappend "remote host " . sShow) rhId_ <> " stopped"
+    ]
+  CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) ->
+    [plain $ "file " <> filePath <> " stored on remote host " <> show rhId]
+      <> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_
+  CRRemoteCtrlList cs -> viewRemoteCtrls cs
+  CRRemoteCtrlFound rc ->
+    ["remote controller found:", viewRemoteCtrl rc]
+  CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo = CtrlAppInfo {deviceName, appVersionRange = AppVersionRange _ (AppVersion ctrlVersion)}, appVersion = AppVersion v} ->
+    [ (maybe "connecting new remote controller" (\RemoteCtrlInfo {remoteCtrlId} -> "connecting remote controller " <> sShow remoteCtrlId) remoteCtrl_ <> ": ")
+        <> (if T.null deviceName then "" else plain deviceName <> ", ")
+        <> ("v" <> plain (V.showVersion ctrlVersion) <> ctrlVersionInfo)
+    ]
+    where
+      ctrlVersionInfo
+        | ctrlVersion < v = " (older than this app - upgrade controller)"
+        | ctrlVersion > v = " (newer than this app - upgrade it)"
+        | otherwise = ""
+  CRRemoteCtrlSessionCode {remoteCtrl_, sessionCode} ->
+    [ maybe "new remote controller connected" (\RemoteCtrlInfo {remoteCtrlId} -> "remote controller " <> sShow remoteCtrlId <> " connected") remoteCtrl_,
+      "Compare session code with controller and use:",
+      "/verify remote ctrl " <> plain sessionCode -- TODO maybe pass rcId
+    ]
+  CRRemoteCtrlConnected RemoteCtrlInfo {remoteCtrlId = rcId, ctrlDeviceName} ->
+    ["remote controller " <> sShow rcId <> " session started with " <> plain ctrlDeviceName]
+  CRRemoteCtrlStopped -> ["remote controller stopped"]
   CRSQLResult rows -> map plain rows
   CRSlowSQLQueries {chatQueries, agentQueries} ->
     let viewQuery SlowSQLQuery {query, queryStats = SlowQueryStats {count, timeMax, timeAvg}} =
@@ -313,12 +370,14 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
       | otherwise = []
     ttyUserPrefix :: User -> [StyledString] -> [StyledString]
     ttyUserPrefix _ [] = []
-    ttyUserPrefix User {userId, localDisplayName = u} ss = prependFirst userPrefix ss
+    ttyUserPrefix User {userId, localDisplayName = u} ss
+      | null prefix = ss
+      | otherwise = prependFirst ("[" <> mconcat prefix <> "] ") ss
       where
-        userPrefix = case user_ of
-          Just User {userId = activeUserId} -> if userId /= activeUserId then prefix else ""
-          _ -> prefix
-        prefix = "[user: " <> highlight u <> "] "
+        prefix = intersperse ", " $ remotePrefix <> userPrefix
+        remotePrefix = [maybe "local" (("remote: " <>) . highlight . show) outputRH | outputRH /= currentRH]
+        userPrefix = ["user: " <> highlight u | Just userId /= currentUserId]
+        currentUserId = (\User {userId = uId} -> uId) <$> user_
     ttyUser' :: Maybe User -> [StyledString] -> [StyledString]
     ttyUser' = maybe id ttyUser
     ttyUserPrefix' :: Maybe User -> [StyledString] -> [StyledString]
@@ -428,7 +487,7 @@ viewGroupSubscribed :: GroupInfo -> [StyledString]
 viewGroupSubscribed g = [membershipIncognito g <> ttyFullGroup g <> ": connected to server(s)"]
 
 showSMPServer :: SMPServer -> String
-showSMPServer = B.unpack . strEncode . host
+showSMPServer srv = B.unpack $ strEncode srv.host
 
 viewHostEvent :: AProtocolType -> TransportHost -> String
 viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h)
@@ -1480,18 +1539,25 @@ savingFile' (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource
   ["saving file " <> sShow fileId <> fileFrom chat chatDir <> " to " <> plain filePath]
 savingFile' _ = ["saving file"] -- shouldn't happen
 
-receivingFile_' :: Bool -> String -> AChatItem -> [StyledString]
-receivingFile_' testView status (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileName, fileSource = Just (CryptoFile _ cfArgs_)}, chatDir}) =
-  [plain status <> " receiving " <> fileTransferStr fileId fileName <> fileFrom chat chatDir] <> cfArgsStr cfArgs_
+receivingFile_' :: (Maybe RemoteHostId, Maybe User) -> Bool -> String -> AChatItem -> [StyledString]
+receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileName, fileSource = Just f@(CryptoFile _ cfArgs_)}, chatDir}) =
+  [plain status <> " receiving " <> fileTransferStr fileId fileName <> fileFrom chat chatDir] <> cfArgsStr cfArgs_ <> getRemoteFileStr
   where
-    cfArgsStr (Just cfArgs@(CFArgs key nonce)) = [plain s | status == "completed"]
-      where
-      s =
-        if testView
-          then LB.toStrict $ J.encode cfArgs
-          else "encryption key: " <> strEncode key <> ", nonce: " <> strEncode nonce
+    cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"]
     cfArgsStr _ = []
-receivingFile_' _ status _ = [plain status <> " receiving file"] -- shouldn't happen
+    getRemoteFileStr = case hu of
+      (Just rhId, Just User {userId}) | status == "completed" ->
+        [ "File received to connected remote host " <> sShow rhId,
+          "To download to this device use:",
+          highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
+        ]
+      _ -> []
+receivingFile_' _ _ status _ = [plain status <> " receiving file"] -- shouldn't happen
+
+cryptoFileArgsStr :: Bool -> CryptoFileArgs -> ByteString
+cryptoFileArgsStr testView cfArgs@(CFArgs key nonce)
+  | testView = LB.toStrict $ J.encode cfArgs
+  | otherwise = "encryption key: " <> strEncode key <> ", nonce: " <> strEncode nonce
 
 fileFrom :: ChatInfo c -> CIDirection c d -> StyledString
 fileFrom (DirectChat ct) CIDirectRcv = " from " <> ttyContact' ct
@@ -1625,16 +1691,6 @@ supporedBrowsers callType
   | encryptedCall callType = " (only Chrome and Safari support e2e encryption for WebRTC, Safari may require enabling WebRTC insertable streams)"
   | otherwise = ""
 
-data WCallCommand
-  = WCCallStart {media :: CallMedia, aesKey :: Maybe String, useWorker :: Bool}
-  | WCCallOffer {offer :: Text, iceCandidates :: Text, media :: CallMedia, aesKey :: Maybe String, useWorker :: Bool}
-  | WCCallAnswer {answer :: Text, iceCandidates :: Text}
-  deriving (Generic)
-
-instance ToJSON WCallCommand where
-  toEncoding = J.genericToEncoding . taggedObjectJSON $ dropPrefix "WCCall"
-  toJSON = J.genericToJSON . taggedObjectJSON $ dropPrefix "WCCall"
-
 viewVersionInfo :: ChatLogLevel -> CoreVersionInfo -> [StyledString]
 viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCommit} =
   map plain $
@@ -1644,6 +1700,39 @@ viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCo
   where
     parens s = " (" <> s <> ")"
 
+viewRemoteHosts :: [RemoteHostInfo] -> [StyledString]
+viewRemoteHosts = \case
+  [] -> ["No remote hosts"]
+  hs -> "Remote hosts: " : map viewRemoteHostInfo hs
+  where
+    viewRemoteHostInfo RemoteHostInfo {remoteHostId, hostDeviceName, sessionState} =
+      plain $ tshow remoteHostId <> ". " <> hostDeviceName <> maybe "" viewSessionState sessionState
+    viewSessionState = \case
+      RHSStarting -> " (starting)"
+      RHSConnecting _ -> " (connecting)"
+      RHSPendingConfirmation {sessionCode} -> " (pending confirmation, code: " <> sessionCode <> ")"
+      RHSConfirmed _ -> " (confirmed)"
+      RHSConnected _ -> " (connected)"
+
+viewRemoteCtrls :: [RemoteCtrlInfo] -> [StyledString]
+viewRemoteCtrls = \case
+  [] -> ["No remote controllers"]
+  hs -> "Remote controllers: " : map viewRemoteCtrlInfo hs
+  where
+    viewRemoteCtrlInfo RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionState} =
+      plain $ tshow remoteCtrlId <> ". " <> ctrlDeviceName <> maybe "" viewSessionState sessionState
+    viewSessionState = \case
+      RCSStarting -> " (starting)"
+      RCSSearching -> " (searching)"
+      RCSConnecting -> " (connecting)"
+      RCSPendingConfirmation {sessionCode} -> " (pending confirmation, code: " <> sessionCode <> ")"
+      RCSConnected _ -> " (connected)"
+
+-- TODO fingerprint, accepted?
+viewRemoteCtrl :: RemoteCtrlInfo -> StyledString
+viewRemoteCtrl RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName} =
+  plain $ tshow remoteCtrlId <> ". " <> ctrlDeviceName
+
 viewChatError :: ChatLogLevel -> ChatError -> [StyledString]
 viewChatError logLevel = \case
   ChatError err -> case err of
@@ -1753,6 +1842,8 @@ viewChatError logLevel = \case
     SEChatItemNotFoundByText text -> ["message not found by text: " <> plain text]
     SEDuplicateGroupLink g -> ["you already have link for this group, to show: " <> highlight ("/show link #" <> viewGroupName g)]
     SEGroupLinkNotFound g -> ["no group link, to create: " <> highlight ("/create link #" <> viewGroupName g)]
+    SERemoteCtrlNotFound rcId -> ["no remote controller " <> sShow rcId]
+    SERemoteHostNotFound rhId -> ["no remote host " <> sShow rhId]
     e -> ["chat db error: " <> sShow e]
   ChatErrorDatabase err -> case err of
     DBErrorEncrypted -> ["error: chat database is already encrypted"]
@@ -1787,7 +1878,11 @@ viewChatError logLevel = \case
         Just entity@(UserContactConnection conn UserContact {userContactLinkId}) ->
           "[" <> connEntityLabel entity <> ", userContactLinkId: " <> sShow userContactLinkId <> ", connId: " <> cId conn <> "] "
         Nothing -> ""
+      cId :: Connection -> StyledString
       cId conn = sShow (connId (conn :: Connection))
+  ChatErrorRemoteCtrl e -> [plain $ "remote controller error: " <> show e]
+  ChatErrorRemoteHost RHNew e -> [plain $ "new remote host error: " <> show e]
+  ChatErrorRemoteHost (RHId rhId) e -> [plain $ "remote host " <> show rhId <> " error: " <> show e]
   where
     fileNotFound fileId = ["file " <> sShow fileId <> " not found"]
     sqliteError' = \case