Merge branch 'master' into master-ghc8107

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()"