From 58889be83d7ac0cfe8b7859fb0d187441584d03d Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 5 Jul 2021 19:54:44 +0100 Subject: [PATCH] establish connection using user profiles (#69) * establish connection using user profiles (TODO: delete contact and send message) * delete contact and send message with the updated schema * comment * refactor, remove old code --- apps/simplex-chat/ChatOptions.hs | 2 +- apps/simplex-chat/Main.hs | 3 +- apps/simplex-chat/Simplex/Chat.hs | 137 +++++++--- apps/simplex-chat/Simplex/Chat/Controller.hs | 14 +- apps/simplex-chat/Simplex/Store.hs | 252 +++++++++++++------ apps/simplex-chat/Simplex/View.hs | 24 +- migrations/20210612_initial.sql | 87 +++---- package.yaml | 2 + src/Simplex/Chat/Types.hs | 71 ++++-- 9 files changed, 400 insertions(+), 192 deletions(-) diff --git a/apps/simplex-chat/ChatOptions.hs b/apps/simplex-chat/ChatOptions.hs index 11ececded6..b646d66d02 100644 --- a/apps/simplex-chat/ChatOptions.hs +++ b/apps/simplex-chat/ChatOptions.hs @@ -35,7 +35,7 @@ chatOpts appDir = <> value (L.fromList ["smp1.simplex.im#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA="]) ) where - defaultDbFilePath = combine appDir "smp-chat.db" + defaultDbFilePath = combine appDir "simplex" parseSMPServer :: ReadM (NonEmpty SMPServer) parseSMPServer = eitherReader $ parseAll servers . B.pack diff --git a/apps/simplex-chat/Main.hs b/apps/simplex-chat/Main.hs index 041ba7d721..8d24c0d4d2 100644 --- a/apps/simplex-chat/Main.hs +++ b/apps/simplex-chat/Main.hs @@ -42,10 +42,11 @@ main :: IO () main = do ChatOpts {dbFile, smpServers} <- welcomeGetOpts st <- createStore (dbFile <> ".chat.db") 4 + user <- getCreateActiveUser st ct <- newChatTerminal a <- getSMPAgentClient cfg {dbFile = dbFile <> ".agent.db", smpServers} notify <- initializeNotifications - cc <- atomically $ newChatController a ct st notify $ tbqSize cfg + cc <- atomically $ newChatController a ct st user notify $ tbqSize cfg -- setLogLevel LogInfo -- LogError -- withGlobalLogging logCfg $ do runReaderT simplexChat cc diff --git a/apps/simplex-chat/Simplex/Chat.hs b/apps/simplex-chat/Simplex/Chat.hs index fa7ebfc1fe..25a3b340d8 100644 --- a/apps/simplex-chat/Simplex/Chat.hs +++ b/apps/simplex-chat/Simplex/Chat.hs @@ -9,18 +9,20 @@ module Simplex.Chat where -import Control.Applicative (optional, (<|>)) +import Control.Applicative ((<|>)) import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader +import qualified Data.Aeson as J import Data.Attoparsec.ByteString.Char8 (Parser) 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 qualified Data.ByteString.Lazy.Char8 as LB import Data.Functor (($>)) import Data.List (find) -import Data.Maybe (fromMaybe) +import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -37,14 +39,17 @@ import Simplex.Notification import Simplex.Store import Simplex.Terminal import Simplex.View +import System.Exit (exitFailure) +import System.IO (hFlush, stdout) +import Text.Read (readMaybe) import qualified UnliftIO.Exception as E import UnliftIO.STM data ChatCommand = ChatHelp | MarkdownHelp - | AddContact (Maybe ContactRef) - | Connect (Maybe ContactRef) SMPQueueInfo + | AddContact + | Connect SMPQueueInfo | DeleteContact ContactRef | SendMessage ContactRef ByteString deriving (Show) @@ -71,38 +76,35 @@ inputSubscriber = do case cmd of SendMessage c msg -> showSentMessage c msg _ -> printToView [plain s] - runExceptT (processChatCommand cmd) >>= \case + user <- asks currentUser + runExceptT (processChatCommand user cmd) >>= \case Left e -> showChatError e _ -> pure () -processChatCommand :: ChatMonad m => ChatCommand -> m () -processChatCommand = \case +processChatCommand :: ChatMonad m => User -> ChatCommand -> m () +processChatCommand User {userId, profile} = \case ChatHelp -> printToView chatHelpInfo MarkdownHelp -> printToView markdownInfo - AddContact cRef -> do - (connId, qInfo) <- withAgent (fromMaybe "" cRef) createConnection - userId <- asks currentUserId - contact <- withStore $ \st -> createDirectContact st userId connId cRef - showInvitation (localContactRef contact) qInfo - Connect cRef qInfo -> do - userId <- asks currentUserId - connId <- withAgent (fromMaybe "" cRef) $ \agent -> joinConnection agent qInfo "user profile here" - void $ withStore $ \st -> createDirectContact st userId connId cRef + AddContact -> do + (connId, qInfo) <- withAgent createConnection + withStore $ \st -> createDirectConnection st userId connId + showInvitation qInfo + Connect qInfo -> do + connId <- withAgent $ \agent -> joinConnection agent qInfo $ LB.toStrict (J.encode profile) + withStore $ \st -> createDirectConnection st userId connId DeleteContact cRef -> do - userId <- asks currentUserId conns <- withStore $ \st -> getContactConnections st userId cRef - withAgent cRef $ \smp -> forM_ conns $ \Connection {agentConnId} -> + withAgent $ \smp -> forM_ conns $ \Connection {agentConnId} -> deleteConnection smp agentConnId `catchError` \(_ :: AgentErrorType) -> pure () - void $ withStore $ \st -> deleteContact st userId cRef + withStore $ \st -> deleteContact st userId cRef unsetActive $ ActiveC cRef when (null conns) . throwError . ChatErrorContact $ CENotFound cRef showContactDeleted cRef SendMessage cRef msg -> do - userId <- asks currentUserId Connection {agentConnId} <- withStore $ \st -> getContactConnection st userId cRef let body = MsgBodyContent {contentType = SimplexContentType XCText, contentHash = Nothing, contentData = MBFull $ MsgData msg} rawMsg = rawChatMessage ChatMessage {chatMsgId = Nothing, chatMsgEvent = XMsgNew MTText, chatMsgBody = [body], chatDAGIdx = Nothing} - void . withAgent cRef $ \smp -> sendMessage smp agentConnId $ serializeRawChatMessage rawMsg + void . withAgent $ \smp -> sendMessage smp agentConnId $ serializeRawChatMessage rawMsg setActive $ ActiveC cRef agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m () @@ -111,7 +113,7 @@ agentSubscriber = do cQ <- asks chatQ forever $ do (_, agentConnId, resp) <- atomically (readTBQueue aQ) - userId <- asks currentUserId + User {userId} <- asks currentUser runExceptT (withStore $ \st -> getConnectionChatDirection st userId agentConnId) >>= \case -- TODO handle errors Left e -> liftIO $ print e @@ -128,7 +130,8 @@ agentSubscriber = do chatSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m () chatSubscriber = do cQ <- asks chatQ - forever $ + forever $ do + User {userId, profile} <- asks currentUser atomically (readTBQueue cQ) >>= \case ChatTransmission { agentMsgMeta = meta, @@ -145,12 +148,19 @@ chatSubscriber = do setActive $ ActiveC c _ -> pure () _ -> pure () - AgentTransmission {agentConnId, chatDirection = ReceivedDirectMessage Contact {localContactRef = c}, agentMessage} -> + AgentTransmission {agentConnId, chatDirection = ReceivedDirectMessage NewContact {activeConn}, agentMessage} -> + void . runExceptT $ case agentMessage of + CONF confId connInfo -> do + -- TODO update connection status + saveContact userId activeConn connInfo + withAgent $ \a -> allowConnection a agentConnId confId $ LB.toStrict (J.encode profile) + INFO connInfo -> + saveContact userId activeConn connInfo + _ -> pure () + AgentTransmission {chatDirection = ReceivedDirectMessage Contact {localContactRef = c}, agentMessage} -> case agentMessage of - CONF confId _ -> - -- TODO save profile? Show confirmation? - void . runExceptT . withAgent c $ \a -> allowConnection a agentConnId confId "user profile here" CON -> do + -- TODO update connection status showContactConnected c showToast ("@" <> c) "connected" setActive $ ActiveC c @@ -160,6 +170,68 @@ chatSubscriber = do unsetActive $ ActiveC c _ -> pure () _ -> pure () + where + saveContact userId activeConn connInfo = do + p <- liftEither . first (ChatErrorContact . CEProfile) $ J.eitherDecodeStrict' connInfo + withStore $ \st -> createDirectContact st userId activeConn p + +getCreateActiveUser :: SQLiteStore -> IO User +getCreateActiveUser st = do + user <- + getUsers st >>= \case + [] -> newUser + users -> maybe (selectUser users) pure (find activeUser users) + putStrLn $ "Current user: " <> userStr user + pure user + where + newUser :: IO User + newUser = do + putStrLn + "No user profiles found, it will be created now.\n\ + \Please choose your alias and your profile name.\n\ + \They will be sent to your contacts when you connect.\n\ + \They are only stored on your device and you can change them later." + loop + where + loop = do + contactRef <- getContactRef + displayName <- T.pack <$> getWithPrompt "profile name (optional)" + liftIO (runExceptT $ createUser st Profile {contactRef, displayName} True) >>= \case + Left SEDuplicateContactRef -> do + putStrLn "chosen alias already used by another profile on this device, choose another one" + loop + Left e -> putStrLn ("database error " <> show e) >> exitFailure + Right user -> pure user + selectUser :: [User] -> IO User + selectUser [user] = do + liftIO $ setActiveUser st (userId user) + pure user + selectUser users = do + putStrLn "Select user profile: " + forM_ (zip [1 ..] users) $ \(n :: Int, user) -> putStrLn $ show n <> " - " <> userStr user + loop + where + loop = do + nStr <- getWithPrompt $ "user profile number (1 .. " <> show (length users) <> ")" + case readMaybe nStr :: Maybe Int of + Nothing -> putStrLn "invalid user number" >> loop + Just n + | n <= 0 || n > length users -> putStrLn "invalid user number" >> loop + | otherwise -> do + let user = users !! (n - 1) + liftIO $ setActiveUser st (userId user) + pure user + userStr :: User -> String + userStr User {localContactRef, profile = Profile {displayName}} = + T.unpack $ localContactRef <> if T.null displayName then "" else " (" <> displayName <> ")" + getContactRef :: IO ContactRef + getContactRef = do + contactRef <- getWithPrompt "alias (no spaces)" + if null contactRef || isJust (find (== ' ') contactRef) + then putStrLn "alias has space(s), choose another one" >> getContactRef + else pure $ T.pack contactRef + getWithPrompt :: String -> IO String + getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine showToast :: (MonadUnliftIO m, MonadReader ChatController m) => Text -> Text -> m () showToast title text = atomically . (`writeTBQueue` Notification {title, text}) =<< asks notifyQ @@ -169,11 +241,11 @@ notificationSubscriber = do ChatController {notifyQ, sendNotification} <- ask forever $ atomically (readTBQueue notifyQ) >>= liftIO . sendNotification -withAgent :: ChatMonad m => ContactRef -> (AgentClient -> ExceptT AgentErrorType m a) -> m a -withAgent c action = +withAgent :: ChatMonad m => (AgentClient -> ExceptT AgentErrorType m a) -> m a +withAgent action = asks smpAgent >>= runExceptT . action - >>= liftEither . first (ChatErrorAgent c) + >>= liftEither . first ChatErrorAgent withStore :: ChatMonad m => @@ -197,11 +269,10 @@ withStore action = do chatCommandP :: Parser ChatCommand chatCommandP = ("/help" <|> "/h") $> ChatHelp - <|> ("/add" <|> "/a") *> (AddContact <$> optional (A.space *> contactRef)) - <|> ("/connect" <|> "/c") *> ((Connect <$> optional (A.space *> contactRef) <*> qInfo) <|> (Connect Nothing <$> qInfo)) + <|> ("/add" <|> "/a") $> AddContact + <|> ("/connect " <|> "/c ") *> (Connect <$> smpQueueInfoP) <|> ("/delete " <|> "/d ") *> (DeleteContact <$> contactRef) <|> A.char '@' *> (SendMessage <$> contactRef <*> (A.space *> A.takeByteString)) <|> ("/markdown" <|> "/m") $> MarkdownHelp where contactRef = safeDecodeUtf8 <$> A.takeTill (== ' ') - qInfo = A.space *> smpQueueInfoP diff --git a/apps/simplex-chat/Simplex/Chat/Controller.hs b/apps/simplex-chat/Simplex/Chat/Controller.hs index 43d9e5e780..ddd0850bc3 100644 --- a/apps/simplex-chat/Simplex/Chat/Controller.hs +++ b/apps/simplex-chat/Simplex/Chat/Controller.hs @@ -1,7 +1,9 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Simplex.Chat.Controller where @@ -21,7 +23,7 @@ import Simplex.Terminal import UnliftIO.STM data ChatController = ChatController - { currentUserId :: UserId, + { currentUser :: User, smpAgent :: AgentClient, chatTerminal :: ChatTerminal, chatStore :: SQLiteStore, @@ -35,21 +37,21 @@ data InputEvent = InputCommand String | InputControl Char data ChatError = ChatErrorContact ContactError - | ChatErrorAgent ContactRef AgentErrorType + | ChatErrorAgent AgentErrorType | ChatErrorStore StoreError deriving (Show, Exception) -newtype ContactError = CENotFound ContactRef +data ContactError = CENotFound ContactRef | CEProfile String deriving (Show, Exception) type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m) -newChatController :: AgentClient -> ChatTerminal -> SQLiteStore -> (Notification -> IO ()) -> Natural -> STM ChatController -newChatController smpAgent chatTerminal chatStore sendNotification qSize = do +newChatController :: AgentClient -> ChatTerminal -> SQLiteStore -> User -> (Notification -> IO ()) -> Natural -> STM ChatController +newChatController smpAgent chatTerminal chatStore currentUser sendNotification qSize = do inputQ <- newTBQueue qSize notifyQ <- newTBQueue qSize chatQ <- newTBQueue qSize - pure ChatController {currentUserId = 1, smpAgent, chatTerminal, chatStore, chatQ, inputQ, notifyQ, sendNotification} + pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, chatQ, inputQ, notifyQ, sendNotification} setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m () setActive to = asks (activeTo . chatTerminal) >>= atomically . (`writeTVar` to) diff --git a/apps/simplex-chat/Simplex/Store.hs b/apps/simplex-chat/Simplex/Store.hs index 37a54c85ae..16ee8a874e 100644 --- a/apps/simplex-chat/Simplex/Store.hs +++ b/apps/simplex-chat/Simplex/Store.hs @@ -13,6 +13,10 @@ module Simplex.Store ( SQLiteStore, StoreError (..), createStore, + createUser, + getUsers, + setActiveUser, + createDirectConnection, createDirectContact, deleteContact, getContactConnection, @@ -21,7 +25,8 @@ module Simplex.Store ) where -import Control.Exception +import Control.Exception (Exception) +import qualified Control.Exception as E import Control.Monad.Except import Control.Monad.IO.Unlift import Data.ByteString.Char8 (ByteString) @@ -29,10 +34,12 @@ import Data.FileEmbed (embedDir, makeRelativeToProject) import Data.Function (on) import Data.Int (Int64) import Data.List (sortBy) -import Data.Maybe (fromMaybe) +import Data.Maybe (listToMaybe) import Data.Text (Text) +import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) -import Database.SQLite.Simple (NamedParam (..), Only (..)) +import Data.Time.Clock (UTCTime) +import Database.SQLite.Simple (NamedParam (..), Only (..), SQLError) import qualified Database.SQLite.Simple as DB import Database.SQLite.Simple.QQ (sql) import Simplex.Chat.Protocol @@ -40,7 +47,7 @@ import Simplex.Chat.Types import Simplex.Messaging.Agent.Protocol (AParty (..), ConnId) import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, withTransaction) import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) -import Simplex.Messaging.Util (liftIOEither) +import Simplex.Messaging.Util (bshow, liftIOEither, (<$$>)) import System.FilePath (takeBaseName, takeExtension) -- | The list of migrations in ascending order by date @@ -55,33 +62,122 @@ migrations = createStore :: FilePath -> Int -> IO SQLiteStore createStore dbFilePath poolSize = createSQLiteStore dbFilePath poolSize migrations +checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a) +checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err) + +handleSQLError :: StoreError -> SQLError -> StoreError +handleSQLError err e + | DB.sqlError e == DB.ErrorConstraint = err + | otherwise = SEInternal $ bshow e + insertedRowId :: DB.Connection -> IO Int64 insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid();" -createDirectContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> Maybe Text -> m Contact -createDirectContact st userId agentConnId contactRef = - liftIO . withTransaction st $ \db -> do - DB.execute db "INSERT INTO connections (user_id, agent_conn_id, conn_status) VALUES (?,?,?);" (userId, agentConnId, ConnNew) - connId <- insertedRowId db - let activeConn = Connection {connId, agentConnId, connLevel = 0, viaContact = Nothing, connStatus = ConnNew} - -- TODO support undefined localContactRef (Nothing) - currently it would fail - let localContactRef = fromMaybe "" contactRef - DB.execute db "INSERT INTO contacts (user_id, local_contact_ref) VALUES (?,?);" (userId, localContactRef) +createUser :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> Profile -> Bool -> m User +createUser st Profile {contactRef, displayName} activeUser = + liftIOEither . checkConstraint SEDuplicateContactRef . withTransaction st $ \db -> do + DB.execute db "INSERT INTO contact_profiles (contact_ref, display_name) VALUES (?, ?);" (contactRef, displayName) + profileId <- insertedRowId db + DB.execute db "INSERT INTO users (contact_id, active_user) VALUES (0, ?);" (Only activeUser) + userId <- insertedRowId db + DB.execute + db + "INSERT INTO contacts (contact_profile_id, local_contact_ref, lcr_base, user_id, user) VALUES (?, ?, ?, ?, 1);" + (profileId, contactRef, contactRef, userId) contactId <- insertedRowId db - DB.execute db "INSERT INTO contact_connections (connection_id, contact_id, active) VALUES (?,?,1);" (connId, contactId) - pure Contact {contactId, localContactRef, profile = Nothing, activeConn} + DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?;" (contactId, userId) + pure . Right $ toUser (userId, activeUser, contactRef, displayName) + +getUsers :: SQLiteStore -> IO [User] +getUsers st = + withTransaction st $ \db -> + map toUser + <$> DB.query_ + db + [sql| + SELECT u.user_id, u.active_user, c.local_contact_ref, p.display_name + FROM users u + JOIN contacts c ON u.contact_id = c.contact_id + JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id + |] + +toUser :: (UserId, Bool, ContactRef, Text) -> User +toUser (userId, activeUser, contactRef, displayName) = + let profile = Profile {contactRef, displayName} + in User {userId, localContactRef = contactRef, profile, activeUser} + +setActiveUser :: MonadUnliftIO m => SQLiteStore -> UserId -> m () +setActiveUser st userId = do + liftIO . withTransaction st $ \db -> do + DB.execute_ db "UPDATE users SET active_user = 0;" + DB.execute db "UPDATE users SET active_user = 1 WHERE user_id = ?;" (Only userId) + +createDirectConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> m () +createDirectConnection st userId agentConnId = + liftIO . withTransaction st $ \db -> + DB.execute + db + [sql| + INSERT INTO connections + (user_id, agent_conn_id, conn_status, conn_type) VALUES (?,?,?,?); + |] + (userId, agentConnId, ConnNew, ConnContact) + +createDirectContact :: + (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> Connection -> Profile -> m () +createDirectContact st userId Connection {connId} Profile {contactRef, displayName} = + liftIOEither . withTransaction st $ \db -> do + DB.execute db "INSERT INTO contact_profiles (contact_ref, display_name) VALUES (?, ?);" (contactRef, displayName) + profileId <- insertedRowId db + lcrSuffix <- getLcrSuffix db + create db profileId lcrSuffix 20 + where + getLcrSuffix :: DB.Connection -> IO Int + getLcrSuffix db = + maybe 0 ((+ 1) . fromOnly) . listToMaybe + <$> DB.queryNamed + db + [sql| + SELECT lcr_suffix FROM contacts + WHERE user_id = :user_id AND lcr_base = :contact_ref + ORDER BY lcr_suffix DESC + LIMIT 1; + |] + [":user_id" := userId, ":contact_ref" := contactRef] + create :: DB.Connection -> Int64 -> Int -> Int -> IO (Either StoreError ()) + create _ _ _ 0 = pure $ Left SEDuplicateContactRef + create db profileId lcrSuffix attempts = do + let lcr = localContactRef' lcrSuffix + E.try (insertUser lcr) >>= \case + Right () -> do + contactId <- insertedRowId db + DB.execute db "UPDATE connections SET contact_id = ? WHERE connection_id = ?" (contactId, connId) + pure $ Right () + Left e + | DB.sqlError e == DB.ErrorConstraint -> create db profileId (lcrSuffix + 1) (attempts - 1) + | otherwise -> E.throwIO e + where + localContactRef' 0 = contactRef + localContactRef' n = contactRef <> T.pack ('_' : show n) + insertUser lcr = + DB.execute + db + [sql| + INSERT INTO contacts + (contact_profile_id, local_contact_ref, lcr_base, lcr_suffix, user_id) VALUES (?, ?, ?, ?, ?) + |] + (profileId, lcr, contactRef, lcrSuffix, userId) deleteContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactRef -> m () deleteContact st userId contactRef = liftIO . withTransaction st $ \db -> forM_ [ [sql| - DELETE FROM connections - WHERE user_id = :user_id AND connection_id IN ( - SELECT cc.connection_id - FROM contact_connections AS cc - JOIN contacts AS cs ON cs.contact_id = cc.contact_id - WHERE local_contact_ref = :contact_ref + DELETE FROM connections WHERE connection_id IN ( + SELECT connection_id + FROM connections c + JOIN contacts cs ON c.contact_id = cs.contact_id + WHERE cs.user_id = :user_id AND cs.local_contact_ref = :contact_ref ); |], [sql| @@ -91,21 +187,25 @@ deleteContact st userId contactRef = ] $ \q -> DB.executeNamed db q [":user_id" := userId, ":contact_ref" := contactRef] -getContactConnection :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactRef -> m Connection +-- TODO return the last connection that is ready, not any last connection +-- requires updating connection status +getContactConnection :: + (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactRef -> m Connection getContactConnection st userId contactRef = liftIOEither . withTransaction st $ \db -> connection <$> DB.queryNamed db [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.conn_status - FROM connections AS c - JOIN contact_connections AS cc ON cc.connection_id == c.connection_id - JOIN contacts AS cs ON cc.contact_id == cs.contact_id + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, + c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.created_at + FROM connections c + JOIN contacts cs ON c.contact_id == cs.contact_id WHERE c.user_id = :user_id AND cs.user_id = :user_id AND cs.local_contact_ref == :contact_ref - AND cc.active == 1; + ORDER BY c.connection_id DESC + LIMIT 1; |] [":user_id" := userId, ":contact_ref" := contactRef] where @@ -119,61 +219,71 @@ getContactConnections st userId contactRef = <$> DB.queryNamed db [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.conn_status - FROM connections AS c - JOIN contact_connections AS cc ON cc.connection_id == c.connection_id - JOIN contacts AS cs ON cc.contact_id == cs.contact_id + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, + c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.created_at + FROM connections c + JOIN contacts cs ON c.contact_id == cs.contact_id WHERE c.user_id = :user_id AND cs.user_id = :user_id - AND cs.local_contact_ref == :contact_ref - AND cc.active == 1; + AND cs.local_contact_ref == :contact_ref; |] [":user_id" := userId, ":contact_ref" := contactRef] -toConnection :: (Int64, ConnId, Int, Maybe Int64, ConnStatus) -> Connection -toConnection (connId, agentConnId, connLevel, viaContact, connStatus) = - Connection {connId, agentConnId, connLevel, viaContact, connStatus} +toConnection :: + (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, UTCTime) -> Connection +toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, createdAt) = + let entityId = entityId_ connType + in Connection {connId, agentConnId, connLevel, viaContact, connStatus, connType, entityId, createdAt} + where + entityId_ :: ConnType -> Maybe Int64 + entityId_ ConnContact = contactId + entityId_ ConnMember = groupMemberId getConnectionChatDirection :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ConnId -> m (ChatDirection 'Agent) getConnectionChatDirection st userId agentConnId = - liftIOEither . withTransaction st $ \db -> - chatDirection - <$> DB.queryNamed - db - [sql| - SELECT - cs.contact_id, cs.local_contact_ref, - a.connection_id, a.conn_level, a.via_contact, a.conn_status, - p.contact_profile_id, p.contact_ref, p.display_name - FROM contacts AS cs - JOIN contact_connections AS cc ON cs.contact_id = cc.contact_id - JOIN contact_connections AS ac ON cs.contact_id = ac.contact_id - JOIN connections AS c ON c.connection_id = cc.connection_id - JOIN connections AS a ON a.connection_id = ac.connection_id - LEFT JOIN contact_profiles AS p ON p.contact_profile_id = cs.contact_profile_id - WHERE cs.user_id = :user_id - AND c.agent_conn_id = :agent_conn_id - AND ac.active = 1 - |] - [":user_id" := userId, ":agent_conn_id" := agentConnId] + liftIOEither . withTransaction st $ \db -> do + getConnection db >>= \case + Left e -> pure $ Left e + Right c@Connection {connType, entityId} -> case connType of + ConnMember -> pure . Left $ SEInternal "group members not supported yet" + ConnContact -> + ReceivedDirectMessage <$$> case entityId of + Nothing -> pure $ Right NewContact {activeConn = c} + Just cId -> getContact db cId c where - chatDirection :: [ChatDirRow] -> Either StoreError (ChatDirection 'Agent) - chatDirection [d] = Right $ toChatDirection agentConnId d - chatDirection _ = Left SEConnectionNotFound - -type ChatDirRow = (Int64, Text, Int64, Int, Maybe Int64, ConnStatus, Maybe Int64, Maybe ContactRef, Maybe Text) - -toChatDirection :: ConnId -> ChatDirRow -> ChatDirection 'Agent -toChatDirection - agentConnId - (contactId, localContactRef, connId, connLevel, viaContact, connStatus, profileId, contactRef, displayName) = - let profile = Profile <$> profileId <*> contactRef <*> displayName - activeConn = Connection {connId, agentConnId, connLevel, viaContact, connStatus} - in ReceivedDirectMessage $ Contact {contactId, localContactRef, profile, activeConn} + getConnection db = + connection + <$> DB.query + db + [sql| + SELECT connection_id, agent_conn_id, conn_level, via_contact, + conn_status, conn_type, contact_id, group_member_id, created_at + FROM connections + WHERE user_id = ? AND agent_conn_id = ?; + |] + (userId, agentConnId) + connection (connRow : _) = Right $ toConnection connRow + connection _ = Left $ SEConnectionNotFound agentConnId + getContact db contactId c = + toContact contactId c + <$> DB.query + db + [sql| + SELECT c.local_contact_ref, p.contact_ref, p.display_name + FROM contacts c + JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id + WHERE c.user_id = ? AND c.contact_id = ? + |] + (userId, contactId) + toContact contactId c [(localContactRef, contactRef, displayName)] = + let profile = Profile {contactRef, displayName} + in Right Contact {contactId, localContactRef, profile, activeConn = c} + toContact _ _ _ = Left $ SEInternal "referenced contact not found" data StoreError - = SEContactNotFound ContactRef - | SEConnectionNotFound + = SEDuplicateContactRef + | SEContactNotFound ContactRef + | SEConnectionNotFound ConnId | SEInternal ByteString deriving (Show, Exception) diff --git a/apps/simplex-chat/Simplex/View.hs b/apps/simplex-chat/Simplex/View.hs index ab3c980de1..26579c7be7 100644 --- a/apps/simplex-chat/Simplex/View.hs +++ b/apps/simplex-chat/Simplex/View.hs @@ -19,7 +19,6 @@ where import Control.Monad.IO.Unlift import Control.Monad.Reader import Data.ByteString.Char8 (ByteString) -import Data.Composition ((.:)) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (DiffTime, UTCTime) @@ -36,8 +35,8 @@ import System.Console.ANSI.Types type ChatReader m = (MonadUnliftIO m, MonadReader ChatController m) -showInvitation :: ChatReader m => ContactRef -> SMPQueueInfo -> m () -showInvitation = printToView .: invitation +showInvitation :: ChatReader m => SMPQueueInfo -> m () +showInvitation = printToView . invitation showChatError :: ChatReader m => ChatError -> m () showChatError = printToView . chatError @@ -57,9 +56,9 @@ showReceivedMessage c utcTime msg mOk = printToView =<< liftIO (receivedMessage showSentMessage :: ChatReader m => ContactRef -> ByteString -> m () showSentMessage c msg = printToView =<< liftIO (sentMessage c msg) -invitation :: ContactRef -> SMPQueueInfo -> [StyledString] -invitation c qInfo = - [ "pass this invitation to your contact " <> ttyContact c <> " (via any channel): ", +invitation :: SMPQueueInfo -> [StyledString] +invitation qInfo = + [ "pass this invitation to your contact (via another channel): ", "", (bPlain . serializeSmpQueueInfo) qInfo, "", @@ -117,12 +116,13 @@ chatError :: ChatError -> [StyledString] chatError = \case ChatErrorContact e -> case e of CENotFound c -> ["no contact " <> ttyContact c] - ChatErrorAgent c err -> case err of - CONN e -> case e of - -- TODO replace with ChatErrorContact errors, these errors should never happen - NOT_FOUND -> ["no contact " <> ttyContact c] - DUPLICATE -> ["contact " <> ttyContact c <> " already exists"] - SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"] + CEProfile s -> ["invalid profile: " <> plain s] + ChatErrorAgent err -> case err of + -- CONN e -> case e of + -- -- TODO replace with ChatErrorContact errors, these errors should never happen + -- NOT_FOUND -> ["no contact " <> ttyContact c] + -- DUPLICATE -> ["contact " <> ttyContact c <> " already exists"] + -- SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"] e -> ["smp agent error: " <> plain (show e)] e -> ["chat error: " <> plain (show e)] diff --git a/migrations/20210612_initial.sql b/migrations/20210612_initial.sql index 22fcae5b22..aa35c77b01 100644 --- a/migrations/20210612_initial.sql +++ b/migrations/20210612_initial.sql @@ -1,21 +1,29 @@ CREATE TABLE contact_profiles ( -- remote user profile contact_profile_id INTEGER PRIMARY KEY, contact_ref TEXT NOT NULL, -- contact name set by remote user (not unique), this name must not contain spaces - display_name TEXT NOT NULL DEFAULT '', + display_name TEXT NOT NULL, properties TEXT NOT NULL DEFAULT '{}' -- JSON with contact profile properties ); --- the first record (id = 1) is reserved for the first local user -INSERT INTO contact_profiles (contact_profile_id, contact_ref) VALUES (1, ''); - - CREATE TABLE users ( user_id INTEGER PRIMARY KEY, - contact_profile_id INTEGER NOT NULL UNIQUE REFERENCES contact_profiles -- user's profile + contact_id INTEGER NOT NULL UNIQUE REFERENCES contacts ON DELETE CASCADE + DEFERRABLE INITIALLY DEFERRED, + active_user INTEGER -- 1 for active user ); --- the first record (id = 1) is reserved for the first local user -INSERT INTO users (user_id, contact_profile_id) VALUES (1, 1); +CREATE TABLE contacts ( + contact_id INTEGER PRIMARY KEY, + contact_profile_id INTEGER UNIQUE REFERENCES contact_profiles, -- NULL if it's an incognito profile + local_contact_ref TEXT NOT NULL, + lcr_base TEXT NOT NULL, + lcr_suffix INTEGER NOT NULL DEFAULT 0, + user_id INTEGER NOT NULL REFERENCES users, + user INTEGER, -- 1 if this contact is a user + created_at TEXT NOT NULL DEFAULT (datetime('now')), + UNIQUE (user_id, local_contact_ref) ON CONFLICT FAIL, + UNIQUE (user_id, lcr_base, lcr_suffix) ON CONFLICT FAIL +); CREATE TABLE known_servers( server_id INTEGER PRIMARY KEY, @@ -26,36 +34,13 @@ CREATE TABLE known_servers( UNIQUE (user_id, host, port) ) WITHOUT ROWID; -CREATE TABLE contacts ( - contact_id INTEGER PRIMARY KEY, - local_contact_ref TEXT NOT NULL UNIQUE, -- contact name set by local user - must be unique - local_properties TEXT NOT NULL DEFAULT '{}', -- JSON set by local user - contact_profile_id INTEGER UNIQUE REFERENCES contact_profiles, -- profile sent by remote contact, NULL for incognito contacts - user_id INTEGER NOT NULL REFERENCES users -); - -CREATE TABLE connections ( -- all SMP agent connections - connection_id INTEGER PRIMARY KEY, - agent_conn_id BLOB NOT NULL UNIQUE, - conn_level INTEGER NOT NULL DEFAULT 0, - via_contact INTEGER REFERENCES contacts (contact_id), - conn_status TEXT NOT NULL, - user_id INTEGER NOT NULL REFERENCES users -); - -CREATE TABLE contact_connections ( -- connections only for direct messages, many per contact - connection_id INTEGER NOT NULL UNIQUE REFERENCES connections ON DELETE CASCADE, - contact_id INTEGER REFERENCES contacts ON DELETE RESTRICT, -- connection must be removed first via the agent - active INTEGER NOT NULL DEFAULT 0 -); - -CREATE TABLE contact_invitations ( - invitation_id INTEGER PRIMARY KEY, - agent_inv_id BLOB UNIQUE, - invitation TEXT, - contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE RESTRICT, - invitation_status TEXT NOT NULL DEFAULT '' -); +-- CREATE TABLE contact_invitations ( +-- invitation_id INTEGER PRIMARY KEY, +-- agent_inv_id BLOB UNIQUE, +-- invitation TEXT, +-- contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE RESTRICT, +-- invitation_status TEXT NOT NULL DEFAULT '' +-- ); CREATE TABLE group_profiles ( -- shared group profiles group_profile_id INTEGER PRIMARY KEY, @@ -71,8 +56,6 @@ CREATE TABLE groups ( local_group_ref TEXT NOT NULL UNIQUE, -- local group name without spaces local_properties TEXT NOT NULL, -- local JSON group properties group_profile_id INTEGER REFERENCES group_profiles, -- shared group profile - user_group_member_details_id INTEGER NOT NULL - REFERENCES group_member_details (group_member_details_id) ON DELETE RESTRICT, user_id INTEGER NOT NULL REFERENCES users, UNIQUE (invited_by, external_group_id) ); @@ -80,21 +63,27 @@ CREATE TABLE groups ( CREATE TABLE group_members ( -- group members, excluding the local user group_member_id INTEGER PRIMARY KEY, group_id INTEGER NOT NULL REFERENCES groups ON DELETE RESTRICT, - group_member_details_id INTEGER NOT NULL REFERENCES group_member_details ON DELETE RESTRICT, - contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE RESTRICT, - connection_id INTEGER UNIQUE REFERENCES connections -); - -CREATE TABLE group_member_details ( - group_member_details_id INTEGER PRIMARY KEY, - group_id INTEGER NOT NULL REFERENCES groups ON DELETE RESTRICT, member_id BLOB NOT NULL, -- shared member ID, unique per group member_role TEXT NOT NULL DEFAULT '', -- owner, admin, moderator, '' member_status TEXT NOT NULL DEFAULT '', -- inv | con | full | off - invited_by INTEGER REFERENCES contacts ON DELETE RESTRICT, -- NULL for the members who joined before the current user and for the group creator + invited_by INTEGER REFERENCES contacts (contact_id) ON DELETE RESTRICT, -- NULL for the members who joined before the current user and for the group creator + contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE RESTRICT, UNIQUE (group_id, member_id) ); +CREATE TABLE connections ( -- all SMP agent connections + connection_id INTEGER PRIMARY KEY, + agent_conn_id BLOB NOT NULL UNIQUE, + conn_level INTEGER NOT NULL DEFAULT 0, + via_contact INTEGER REFERENCES contacts (contact_id), + conn_status TEXT NOT NULL, + conn_type TEXT NOT NULL, -- contact, member + contact_id INTEGER REFERENCES contacts ON DELETE RESTRICT, + group_member_id INTEGER REFERENCES group_members ON DELETE RESTRICT, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + user_id INTEGER NOT NULL REFERENCES users +); + CREATE TABLE events ( -- messages received by the agent, append only event_id INTEGER PRIMARY KEY, agent_msg_id INTEGER NOT NULL, -- internal message ID diff --git a/package.yaml b/package.yaml index e5991df418..2f42705dbf 100644 --- a/package.yaml +++ b/package.yaml @@ -12,6 +12,7 @@ extra-source-files: - README.md dependencies: + - aeson == 1.5.* - ansi-terminal == 0.10.* - attoparsec == 0.13.* - base >= 4.7 && < 5 @@ -21,6 +22,7 @@ dependencies: - simplexmq == 0.3.* - sqlite-simple == 0.4.* - text == 1.2.* + - time == 1.9.* library: source-dirs: src diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 6cf6a44c3f..6fa3d3823d 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -1,30 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Simplex.Chat.Types where +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) import Data.Text (Text) +import Data.Time.Clock (UTCTime) import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) +import GHC.Generics import Simplex.Messaging.Agent.Protocol (ConnId) import Simplex.Messaging.Agent.Store.SQLite (fromTextField_) data User = User { userId :: UserId, - profile :: Profile + localContactRef :: ContactRef, + profile :: Profile, + activeUser :: Bool } type UserId = Int64 -data Contact = Contact - { contactId :: Int64, - localContactRef :: ContactRef, - profile :: Maybe Profile, - activeConn :: Connection - } +data Contact + = Contact + { contactId :: Int64, + localContactRef :: ContactRef, + profile :: Profile, + activeConn :: Connection + } + | NewContact {activeConn :: Connection} deriving (Eq, Show) type ContactRef = Text @@ -36,18 +45,24 @@ data Group = Group deriving (Eq, Show) data Profile = Profile - { profileId :: Int64, - contactRef :: ContactRef, + { contactRef :: ContactRef, displayName :: Text } - deriving (Eq, Show) + deriving (Generic, Eq, Show) + +instance ToJSON Profile where toEncoding = J.genericToEncoding J.defaultOptions + +instance FromJSON Profile data Connection = Connection { connId :: Int64, agentConnId :: ConnId, connLevel :: Int, viaContact :: Maybe Int64, - connStatus :: ConnStatus + connType :: ConnType, + connStatus :: ConnStatus, + entityId :: Maybe Int64, -- contact or group member ID + createdAt :: UTCTime } deriving (Eq, Show) @@ -60,18 +75,36 @@ instance ToField ConnStatus where toField = toField . serializeConnStatus connStatusT :: Text -> Maybe ConnStatus connStatusT = \case - "NEW" -> Just ConnNew - "CONF" -> Just ConnConfirmed - "ACPT" -> Just ConnAccepted - "READY" -> Just ConnReady + "new" -> Just ConnNew + "confirmed" -> Just ConnConfirmed + "accepted" -> Just ConnAccepted + "ready" -> Just ConnReady _ -> Nothing serializeConnStatus :: ConnStatus -> Text serializeConnStatus = \case - ConnNew -> "NEW" - ConnConfirmed -> "CONF" - ConnAccepted -> "ACPT" - ConnReady -> "READY" + ConnNew -> "new" + ConnConfirmed -> "confirmed" + ConnAccepted -> "accepted" + ConnReady -> "ready" + +data ConnType = ConnContact | ConnMember + deriving (Eq, Show) + +instance FromField ConnType where fromField = fromTextField_ connTypeT + +instance ToField ConnType where toField = toField . serializeConnType + +connTypeT :: Text -> Maybe ConnType +connTypeT = \case + "contact" -> Just ConnContact + "member" -> Just ConnMember + _ -> Nothing + +serializeConnType :: ConnType -> Text +serializeConnType = \case + ConnContact -> "contact" + ConnMember -> "member" data NewConnection = NewConnection { agentConnId :: ByteString,