core: support SMP basic auth / server password (#1358)

This commit is contained in:
Evgeny Poberezkin
2022-11-14 08:04:11 +00:00
committed by GitHub
parent cb0c499f57
commit e14ab0fed0
13 changed files with 45 additions and 25 deletions
+15 -12
View File
@@ -252,6 +252,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe)
import Data.Ord (Down (..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Data.Time.LocalTime (TimeZone, getCurrentTimeZone)
import Data.Type.Equality
@@ -295,6 +296,7 @@ import Simplex.Chat.Migrations.M20221021_auto_accept__group_links
import Simplex.Chat.Migrations.M20221024_contact_used
import Simplex.Chat.Migrations.M20221025_chat_settings
import Simplex.Chat.Migrations.M20221029_group_link_id
import Simplex.Chat.Migrations.M20221112_server_password
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..))
@@ -302,9 +304,9 @@ import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Protocol (ProtocolServer (..), SMPServer, pattern SMPServer)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), SMPServerWithAuth, pattern SMPServer)
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
import UnliftIO.STM
schemaMigrations :: [(String, Query)]
@@ -341,7 +343,8 @@ schemaMigrations =
("20221021_auto_accept__group_links", m20221021_auto_accept__group_links),
("20221024_contact_used", m20221024_contact_used),
("20221025_chat_settings", m20221025_chat_settings),
("20221029_group_link_id", m20221029_group_link_id)
("20221029_group_link_id", m20221029_group_link_id),
("20221112_server_password", m20221112_server_password)
]
-- | The list of migrations in ascending order by date
@@ -4234,35 +4237,35 @@ toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just
either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_)
toGroupChatItemList _ _ _ _ = []
getSMPServers :: DB.Connection -> User -> IO [SMPServer]
getSMPServers :: DB.Connection -> User -> IO [SMPServerWithAuth]
getSMPServers db User {userId} =
map toSmpServer
<$> DB.query
db
[sql|
SELECT host, port, key_hash
SELECT host, port, key_hash, basic_auth
FROM smp_servers
WHERE user_id = ?;
|]
(Only userId)
where
toSmpServer :: (NonEmpty TransportHost, String, C.KeyHash) -> SMPServer
toSmpServer (host, port, keyHash) = SMPServer host port keyHash
toSmpServer :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text) -> SMPServerWithAuth
toSmpServer (host, port, keyHash, auth_) = ProtoServerWithAuth (SMPServer host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
overwriteSMPServers :: DB.Connection -> User -> [SMPServer] -> ExceptT StoreError IO ()
overwriteSMPServers :: DB.Connection -> User -> [SMPServerWithAuth] -> ExceptT StoreError IO ()
overwriteSMPServers db User {userId} smpServers =
checkConstraint SEUniqueID . ExceptT $ do
currentTs <- getCurrentTime
DB.execute db "DELETE FROM smp_servers WHERE user_id = ?" (Only userId)
forM_ smpServers $ \ProtocolServer {host, port, keyHash} ->
forM_ smpServers $ \(ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_) ->
DB.execute
db
[sql|
INSERT INTO smp_servers
(host, port, key_hash, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?)
(host, port, key_hash, basic_auth, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?)
|]
(host, port, keyHash, userId, currentTs, currentTs)
(host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_, userId, currentTs, currentTs)
pure $ Right ()
createCall :: DB.Connection -> User -> Call -> UTCTime -> IO ()