diff --git a/package.yaml b/package.yaml index 4bcec591e..fb4aa6269 100644 --- a/package.yaml +++ b/package.yaml @@ -22,7 +22,6 @@ dependencies: - network == 3.1.* - sqlite-simple == 0.4.* - stm - - text == 1.2.* - time == 1.9.* - unliftio == 0.2.* - unliftio-core == 0.1.* diff --git a/smp-agent.db b/smp-agent.db index d16a954f9..f063759a1 100644 Binary files a/smp-agent.db and b/smp-agent.db differ diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 03f399513..9c787a1b5 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -35,9 +35,10 @@ runClient :: MonadUnliftIO m => AgentClient -> m () runClient c = race_ (respond c) (process c) receive :: MonadUnliftIO m => Handle -> AgentClient -> m () -receive h AgentClient {rcvQ} = forever $ do - cmdOrError <- aCmdGet SUser h - atomically $ writeTBQueue rcvQ cmdOrError +receive h AgentClient {rcvQ, sndQ} = forever $ do + aCmdGet SUser h >>= \case + Right cmd -> atomically $ writeTBQueue rcvQ cmd + Left e -> atomically $ writeTBQueue sndQ $ ERR e send :: MonadUnliftIO m => Handle -> AgentClient -> m () send h AgentClient {sndQ} = forever $ do @@ -46,10 +47,8 @@ send h AgentClient {sndQ} = forever $ do process :: MonadUnliftIO m => AgentClient -> m () process AgentClient {rcvQ, respQ} = forever $ do - atomically (readTBQueue rcvQ) - >>= \case - Left e -> liftIO $ print e - Right cmd -> liftIO $ print cmd + cmd <- atomically (readTBQueue rcvQ) + liftIO $ print cmd atomically $ writeTBQueue respQ () respond :: MonadUnliftIO m => AgentClient -> m () diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 2d57ec7d7..c10c7f9eb 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -31,7 +31,7 @@ data Env = Env } data AgentClient = AgentClient - { rcvQ :: TBQueue (Either ErrorType (ACommand User)), + { rcvQ :: TBQueue (ACommand User), sndQ :: TBQueue (ACommand Agent), respQ :: TBQueue (), servers :: Map (HostName, ServiceName) ServerClient diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs index 602c31977..3ef9c35a0 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs @@ -1,20 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Simplex.Messaging.Agent.Store.SQLite.Schema where -import Control.Monad.IO.Unlift -import qualified Data.Text as T import Database.SQLite.Simple -createSchema :: MonadUnliftIO m => Connection -> m () +createSchema :: Connection -> IO () createSchema conn = do - sql "recipient_queues" - -- sql "sender_queues" - -- sql "connections" - -- sql "messages" - return () - where - sql name = liftIO $ do - q <- readFile $ "./src/Simplex/Messaging/Agent/Store/SQLite/sql/" <> name <> ".sql" - putStrLn q - execute_ conn . Query . T.pack $ q + map + (execute_ conn) + [ recipientQueues --, + -- senderQueues, + -- connections, + -- messages + ] + +recipientQueues :: Query +recipientQueues = + "CREATE TABLE IF NOT EXISTS recipient_queues\ + \ ( id INTEGER PRIMARY KEY,\ + \ rcvId TEXT\ + \ )" + +senderQueues :: Query +senderQueues = "" + +connections :: Query +connections = "" + +messages :: Query +messages = ""