{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Simplex.Chat.Archive
  ( exportArchive,
    importArchive,
    deleteStorage,
    sqlCipherExport,
    sqlCipherTestKey,
  )
where

import qualified Codec.Archive.Zip as Z
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import qualified Data.ByteArray as BA
import Data.Functor (($>))
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Database.SQLite3 as SQL
import Simplex.Chat.Controller
import Simplex.Chat.Util ()
import Simplex.Messaging.Agent.Client (agentClientStore)
import Simplex.Messaging.Agent.Store.SQLite (closeDBStore, keyString, sqlString, storeKey)
import Simplex.Messaging.Agent.Store.SQLite.Common (DBStore (..))
import Simplex.Messaging.Util
import System.FilePath
import UnliftIO.Directory
import UnliftIO.Exception (SomeException, bracket, catch)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
import UnliftIO.Temporary

archiveAgentDbFile :: String
archiveAgentDbFile :: String
archiveAgentDbFile = String
"simplex_v1_agent.db"

archiveChatDbFile :: String
archiveChatDbFile :: String
archiveChatDbFile = String
"simplex_v1_chat.db"

archiveFilesFolder :: String
archiveFilesFolder :: String
archiveFilesFolder = String
"simplex_v1_files"

archiveAssetsFolder :: String
archiveAssetsFolder :: String
archiveAssetsFolder = String
"simplex_v1_assets"

wallpapersFolder :: String
wallpapersFolder :: String
wallpapersFolder = String
"wallpapers"

exportArchive :: ArchiveConfig -> CM' [ArchiveError]
exportArchive :: ArchiveConfig -> CM' [ArchiveError]
exportArchive cfg :: ArchiveConfig
cfg@ArchiveConfig {String
archivePath :: String
archivePath :: ArchiveConfig -> String
archivePath, Maybe Bool
disableCompression :: Maybe Bool
disableCompression :: ArchiveConfig -> Maybe Bool
disableCompression} =
  ArchiveConfig
-> String -> (String -> CM' [ArchiveError]) -> CM' [ArchiveError]
forall a. ArchiveConfig -> String -> (String -> CM' a) -> CM' a
withTempDir ArchiveConfig
cfg String
"simplex-chat." ((String -> CM' [ArchiveError]) -> CM' [ArchiveError])
-> (String -> CM' [ArchiveError]) -> CM' [ArchiveError]
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
    StorageFiles {DBStore
chatStore :: DBStore
chatStore :: StorageFiles -> DBStore
chatStore, DBStore
agentStore :: DBStore
agentStore :: StorageFiles -> DBStore
agentStore, Maybe String
filesPath :: Maybe String
filesPath :: StorageFiles -> Maybe String
filesPath, Maybe String
assetsPath :: Maybe String
assetsPath :: StorageFiles -> Maybe String
assetsPath} <- CM' StorageFiles
storageFiles
    String -> String -> ReaderT ChatController IO ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
copyFile (DBStore -> String
dbFilePath DBStore
chatStore) (String -> ReaderT ChatController IO ())
-> String -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
archiveChatDbFile
    String -> String -> ReaderT ChatController IO ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
copyFile (DBStore -> String
dbFilePath DBStore
agentStore) (String -> ReaderT ChatController IO ())
-> String -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
archiveAgentDbFile
    Maybe [ArchiveError]
errs <-
      Maybe String
-> (String -> CM' [ArchiveError])
-> ReaderT ChatController IO (Maybe [ArchiveError])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe String
filesPath ((String -> CM' [ArchiveError])
 -> ReaderT ChatController IO (Maybe [ArchiveError]))
-> (String -> CM' [ArchiveError])
-> ReaderT ChatController IO (Maybe [ArchiveError])
forall a b. (a -> b) -> a -> b
$ \String
fp ->
        (String -> IO (Maybe String))
-> String -> String -> CM' [ArchiveError]
copyValidDirectoryFiles String -> IO (Maybe String)
forall {m :: * -> *}.
(MonadUnliftIO m, MonadThrow m) =>
String -> m (Maybe String)
entrySelectorError String
fp (String -> CM' [ArchiveError]) -> String -> CM' [ArchiveError]
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
archiveFilesFolder
    Maybe String
-> (String -> CM' [ArchiveError]) -> ReaderT ChatController IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
assetsPath ((String -> CM' [ArchiveError]) -> ReaderT ChatController IO ())
-> (String -> CM' [ArchiveError]) -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ \String
fp ->
      String -> String -> CM' [ArchiveError]
copyDirectoryFiles (String
fp String -> String -> String
</> String
wallpapersFolder) (String -> CM' [ArchiveError]) -> String -> CM' [ArchiveError]
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
archiveAssetsFolder String -> String -> String
</> String
wallpapersFolder
    let method :: CompressionMethod
method = if Maybe Bool
disableCompression Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True then CompressionMethod
Z.Store else CompressionMethod
Z.Deflate
    String -> ZipArchive () -> ReaderT ChatController IO ()
forall (m :: * -> *) a. MonadIO m => String -> ZipArchive a -> m a
Z.createArchive String
archivePath (ZipArchive () -> ReaderT ChatController IO ())
-> ZipArchive () -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ CompressionMethod
-> (String -> ZipArchive EntrySelector) -> String -> ZipArchive ()
Z.packDirRecur CompressionMethod
method String -> ZipArchive EntrySelector
forall (m :: * -> *). MonadThrow m => String -> m EntrySelector
Z.mkEntrySelector String
dir
    [ArchiveError] -> CM' [ArchiveError]
forall a. a -> ReaderT ChatController IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ArchiveError] -> CM' [ArchiveError])
-> [ArchiveError] -> CM' [ArchiveError]
forall a b. (a -> b) -> a -> b
$ [ArchiveError] -> Maybe [ArchiveError] -> [ArchiveError]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [ArchiveError]
errs
  where
    entrySelectorError :: String -> m (Maybe String)
entrySelectorError String
f = (String -> m EntrySelector
forall (m :: * -> *). MonadThrow m => String -> m EntrySelector
Z.mkEntrySelector String
f m EntrySelector -> Maybe String -> m (Maybe String)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe String
forall a. Maybe a
Nothing) m (Maybe String)
-> (SomeException -> m (Maybe String)) -> m (Maybe String)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`E.catchAny` (Maybe String -> m (Maybe String)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> m (Maybe String))
-> (SomeException -> Maybe String)
-> SomeException
-> m (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (SomeException -> String) -> SomeException -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show)

importArchive :: ArchiveConfig -> CM' [ArchiveError]
importArchive :: ArchiveConfig -> CM' [ArchiveError]
importArchive cfg :: ArchiveConfig
cfg@ArchiveConfig {String
archivePath :: ArchiveConfig -> String
archivePath :: String
archivePath} =
  ArchiveConfig
-> String -> (String -> CM' [ArchiveError]) -> CM' [ArchiveError]
forall a. ArchiveConfig -> String -> (String -> CM' a) -> CM' a
withTempDir ArchiveConfig
cfg String
"simplex-chat." ((String -> CM' [ArchiveError]) -> CM' [ArchiveError])
-> (String -> CM' [ArchiveError]) -> CM' [ArchiveError]
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
    String -> ZipArchive () -> ReaderT ChatController IO ()
forall (m :: * -> *) a. MonadIO m => String -> ZipArchive a -> m a
Z.withArchive String
archivePath (ZipArchive () -> ReaderT ChatController IO ())
-> ZipArchive () -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ String -> ZipArchive ()
Z.unpackInto String
dir
    fs :: StorageFiles
fs@StorageFiles {DBStore
chatStore :: StorageFiles -> DBStore
chatStore :: DBStore
chatStore, DBStore
agentStore :: StorageFiles -> DBStore
agentStore :: DBStore
agentStore, Maybe String
filesPath :: StorageFiles -> Maybe String
filesPath :: Maybe String
filesPath, Maybe String
assetsPath :: StorageFiles -> Maybe String
assetsPath :: Maybe String
assetsPath} <- CM' StorageFiles
storageFiles
    IO () -> ReaderT ChatController IO ()
forall a. IO a -> ReaderT ChatController IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT ChatController IO ())
-> IO () -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ DBStore -> IO ()
closeDBStore (DBStore -> IO ()) -> StorageFiles -> IO ()
forall (m :: * -> *) b.
Monad m =>
(DBStore -> m b) -> StorageFiles -> m b
`withStores` StorageFiles
fs
    String -> ReaderT ChatController IO ()
forall {m :: * -> *}. MonadIO m => String -> m ()
backup (String -> ReaderT ChatController IO ())
-> StorageFiles -> ReaderT ChatController IO ()
forall (m :: * -> *) b.
Monad m =>
(String -> m b) -> StorageFiles -> m b
`withDBs` StorageFiles
fs
    String -> String -> ReaderT ChatController IO ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
copyFile (String
dir String -> String -> String
</> String
archiveChatDbFile) (String -> ReaderT ChatController IO ())
-> String -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ DBStore -> String
dbFilePath DBStore
chatStore
    String -> String -> ReaderT ChatController IO ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
copyFile (String
dir String -> String -> String
</> String
archiveAgentDbFile) (String -> ReaderT ChatController IO ())
-> String -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ DBStore -> String
dbFilePath DBStore
agentStore
    [ArchiveError]
errs <- String -> Maybe String -> CM' [ArchiveError]
copyFiles (String
dir String -> String -> String
</> String
archiveFilesFolder) Maybe String
filesPath
    [ArchiveError]
errs' <- String -> Maybe String -> CM' [ArchiveError]
copyFiles (String
dir String -> String -> String
</> String
archiveAssetsFolder String -> String -> String
</> String
wallpapersFolder) ((String -> String -> String
</> String
wallpapersFolder) (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
assetsPath)
    [ArchiveError] -> CM' [ArchiveError]
forall a. a -> ReaderT ChatController IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ArchiveError] -> CM' [ArchiveError])
-> [ArchiveError] -> CM' [ArchiveError]
forall a b. (a -> b) -> a -> b
$ [ArchiveError]
errs [ArchiveError] -> [ArchiveError] -> [ArchiveError]
forall a. Semigroup a => a -> a -> a
<> [ArchiveError]
errs'
  where
    backup :: String -> m ()
backup String
f = m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> m Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
f) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> m ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
copyFile String
f (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".bak"
    copyFiles :: String -> Maybe String -> CM' [ArchiveError]
copyFiles String
fromDir = \case
      Just String
fp ->
        ReaderT ChatController IO Bool
-> CM' [ArchiveError] -> CM' [ArchiveError] -> CM' [ArchiveError]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
          (String -> ReaderT ChatController IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesDirectoryExist String
fromDir)
          (String -> String -> CM' [ArchiveError]
copyDirectoryFiles String
fromDir String
fp)
          ([ArchiveError] -> CM' [ArchiveError]
forall a. a -> ReaderT ChatController IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
          CM' [ArchiveError]
-> (SomeException -> CM' [ArchiveError]) -> CM' [ArchiveError]
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \(SomeException
e :: E.SomeException) -> [ArchiveError] -> CM' [ArchiveError]
forall a. a -> ReaderT ChatController IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String -> ArchiveError
AEImport (String -> ArchiveError) -> String -> ArchiveError
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e]
      Maybe String
_ -> [ArchiveError] -> CM' [ArchiveError]
forall a. a -> ReaderT ChatController IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

withTempDir :: ArchiveConfig -> (String -> (FilePath -> CM' a) -> CM' a)
withTempDir :: forall a. ArchiveConfig -> String -> (String -> CM' a) -> CM' a
withTempDir ArchiveConfig
cfg = case ArchiveConfig -> Maybe String
parentTempDirectory (ArchiveConfig
cfg :: ArchiveConfig) of
  Just String
tmpDir -> String -> String -> (String -> CM' a) -> CM' a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> (String -> m a) -> m a
withTempDirectory String
tmpDir
  Maybe String
_ -> String -> (String -> CM' a) -> CM' a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (String -> m a) -> m a
withSystemTempDirectory

copyDirectoryFiles :: FilePath -> FilePath -> CM' [ArchiveError]
copyDirectoryFiles :: String -> String -> CM' [ArchiveError]
copyDirectoryFiles String
fromDir String
toDir = (String -> IO (Maybe String))
-> String -> String -> CM' [ArchiveError]
copyValidDirectoryFiles (\String
_ -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing) String
fromDir String
toDir

copyValidDirectoryFiles :: (FilePath -> IO (Maybe String)) -> FilePath -> FilePath -> CM' [ArchiveError]
copyValidDirectoryFiles :: (String -> IO (Maybe String))
-> String -> String -> CM' [ArchiveError]
copyValidDirectoryFiles String -> IO (Maybe String)
isFileError String
fromDir String
toDir = do
  Bool -> String -> ReaderT ChatController IO ()
forall (m :: * -> *). MonadIO m => Bool -> String -> m ()
createDirectoryIfMissing Bool
True String
toDir
  [String]
fs <- String -> ReaderT ChatController IO [String]
forall (m :: * -> *). MonadIO m => String -> m [String]
listDirectory String
fromDir
  ([ArchiveError] -> String -> CM' [ArchiveError])
-> [ArchiveError] -> [String] -> CM' [ArchiveError]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [ArchiveError] -> String -> CM' [ArchiveError]
forall {m :: * -> *}.
MonadUnliftIO m =>
[ArchiveError] -> String -> m [ArchiveError]
copyFileCatchError [] [String]
fs
  where
    copyFileCatchError :: [ArchiveError] -> String -> m [ArchiveError]
copyFileCatchError [ArchiveError]
fileErrs String
f =
      IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
isFileError String
f) m (Maybe String)
-> (Maybe String -> m [ArchiveError]) -> m [ArchiveError]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe String
Nothing ->
          (String -> m ()
forall {m :: * -> *}. MonadIO m => String -> m ()
copyDirectoryFile String
f m () -> [ArchiveError] -> m [ArchiveError]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [ArchiveError]
fileErrs)
            m [ArchiveError]
-> (SomeException -> m [ArchiveError]) -> m [ArchiveError]
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \(SomeException
e :: E.SomeException) -> String -> m [ArchiveError]
forall {f :: * -> *}. Applicative f => String -> f [ArchiveError]
addErr (String -> m [ArchiveError]) -> String -> m [ArchiveError]
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
        Just String
e -> String -> m [ArchiveError]
forall {f :: * -> *}. Applicative f => String -> f [ArchiveError]
addErr String
e
      where
        addErr :: String -> f [ArchiveError]
addErr String
e = [ArchiveError] -> f [ArchiveError]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ArchiveError] -> f [ArchiveError])
-> [ArchiveError] -> f [ArchiveError]
forall a b. (a -> b) -> a -> b
$ String -> String -> ArchiveError
AEFileError String
f String
e ArchiveError -> [ArchiveError] -> [ArchiveError]
forall a. a -> [a] -> [a]
: [ArchiveError]
fileErrs
    copyDirectoryFile :: String -> m ()
copyDirectoryFile String
f = do
      let fn :: String
fn = String -> String
takeFileName String
f
          f' :: String
f' = String
fromDir String -> String -> String
</> String
fn
      m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> m Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
f') (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> m ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
copyFile String
f' (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
toDir String -> String -> String
</> String
fn

deleteStorage :: CM ()
deleteStorage :: CM ()
deleteStorage = do
  StorageFiles
fs <- CM' StorageFiles
-> ExceptT ChatError (ReaderT ChatController IO) StorageFiles
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift CM' StorageFiles
storageFiles
  IO () -> CM ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CM ()) -> IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ DBStore -> IO ()
closeDBStore (DBStore -> IO ()) -> StorageFiles -> IO ()
forall (m :: * -> *) b.
Monad m =>
(DBStore -> m b) -> StorageFiles -> m b
`withStores` StorageFiles
fs
  String -> CM ()
forall {m :: * -> *}. MonadIO m => String -> m ()
remove (String -> CM ()) -> StorageFiles -> CM ()
forall (m :: * -> *) b.
Monad m =>
(String -> m b) -> StorageFiles -> m b
`withDBs` StorageFiles
fs
  (String -> CM ()) -> Maybe String -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> CM ()
forall {m :: * -> *}. MonadIO m => String -> m ()
removeDir (Maybe String -> CM ()) -> Maybe String -> CM ()
forall a b. (a -> b) -> a -> b
$ StorageFiles -> Maybe String
filesPath StorageFiles
fs
  (String -> CM ()) -> Maybe String -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> CM ()
forall {m :: * -> *}. MonadIO m => String -> m ()
removeDir (Maybe String -> CM ()) -> Maybe String -> CM ()
forall a b. (a -> b) -> a -> b
$ StorageFiles -> Maybe String
assetsPath StorageFiles
fs
  (String -> CM ()) -> Maybe String -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> CM ()
forall {m :: * -> *}. MonadIO m => String -> m ()
removeDir (Maybe String -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe String)
-> CM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChatController -> TVar (Maybe String))
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe String)
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar (Maybe String)
tempDirectory
  where
    remove :: String -> m ()
remove String
f = m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> m Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
f) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall {m :: * -> *}. MonadIO m => String -> m ()
removeFile String
f
    removeDir :: String -> m ()
removeDir String
d = m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> m Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesDirectoryExist String
d) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall {m :: * -> *}. MonadIO m => String -> m ()
removePathForcibly String
d

data StorageFiles = StorageFiles
  { StorageFiles -> DBStore
chatStore :: DBStore,
    StorageFiles -> DBStore
agentStore :: DBStore,
    StorageFiles -> Maybe String
filesPath :: Maybe FilePath,
    StorageFiles -> Maybe String
assetsPath :: Maybe FilePath
  }

storageFiles :: CM' StorageFiles
storageFiles :: CM' StorageFiles
storageFiles = do
  ChatController {DBStore
chatStore :: DBStore
chatStore :: ChatController -> DBStore
chatStore, TVar (Maybe String)
filesFolder :: TVar (Maybe String)
filesFolder :: ChatController -> TVar (Maybe String)
filesFolder, TVar (Maybe String)
assetsDirectory :: TVar (Maybe String)
assetsDirectory :: ChatController -> TVar (Maybe String)
assetsDirectory, AgentClient
smpAgent :: AgentClient
smpAgent :: ChatController -> AgentClient
smpAgent} <- ReaderT ChatController IO ChatController
forall r (m :: * -> *). MonadReader r m => m r
ask
  let agentStore :: DBStore
agentStore = AgentClient -> DBStore
agentClientStore AgentClient
smpAgent
  Maybe String
filesPath <- TVar (Maybe String) -> ReaderT ChatController IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe String)
filesFolder
  Maybe String
assetsPath <- TVar (Maybe String) -> ReaderT ChatController IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe String)
assetsDirectory
  StorageFiles -> CM' StorageFiles
forall a. a -> ReaderT ChatController IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StorageFiles {DBStore
chatStore :: DBStore
chatStore :: DBStore
chatStore, DBStore
agentStore :: DBStore
agentStore :: DBStore
agentStore, Maybe String
filesPath :: Maybe String
filesPath :: Maybe String
filesPath, Maybe String
assetsPath :: Maybe String
assetsPath :: Maybe String
assetsPath}

sqlCipherExport :: DBEncryptionConfig -> CM ()
sqlCipherExport :: DBEncryptionConfig -> CM ()
sqlCipherExport DBEncryptionConfig {currentKey :: DBEncryptionConfig -> DBEncryptionKey
currentKey = DBEncryptionKey ScrubbedBytes
key, newKey :: DBEncryptionConfig -> DBEncryptionKey
newKey = DBEncryptionKey ScrubbedBytes
key', Maybe Bool
keepKey :: Maybe Bool
keepKey :: DBEncryptionConfig -> Maybe Bool
keepKey} =
  Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScrubbedBytes
key ScrubbedBytes -> ScrubbedBytes -> Bool
forall a. Eq a => a -> a -> Bool
/= ScrubbedBytes
key') (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
    StorageFiles
fs <- CM' StorageFiles
-> ExceptT ChatError (ReaderT ChatController IO) StorageFiles
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift CM' StorageFiles
storageFiles
    String -> CM ()
checkFile (String -> CM ()) -> StorageFiles -> CM ()
forall (m :: * -> *) b.
Monad m =>
(String -> m b) -> StorageFiles -> m b
`withDBs` StorageFiles
fs
    String -> CM ()
forall {m :: * -> *}. MonadIO m => String -> m ()
backup (String -> CM ()) -> StorageFiles -> CM ()
forall (m :: * -> *) b.
Monad m =>
(String -> m b) -> StorageFiles -> m b
`withDBs` StorageFiles
fs
    DBStore -> CM ()
checkEncryption (DBStore -> CM ()) -> StorageFiles -> CM ()
forall (m :: * -> *) b.
Monad m =>
(DBStore -> m b) -> StorageFiles -> m b
`withStores` StorageFiles
fs
    String -> CM ()
forall {m :: * -> *}. MonadIO m => String -> m ()
removeExported (String -> CM ()) -> StorageFiles -> CM ()
forall (m :: * -> *) b.
Monad m =>
(String -> m b) -> StorageFiles -> m b
`withDBs` StorageFiles
fs
    String -> CM ()
export (String -> CM ()) -> StorageFiles -> CM ()
forall (m :: * -> *) b.
Monad m =>
(String -> m b) -> StorageFiles -> m b
`withDBs` StorageFiles
fs
    -- closing after encryption prevents closing in case wrong encryption key was passed
    IO () -> CM ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CM ()) -> IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ DBStore -> IO ()
closeDBStore (DBStore -> IO ()) -> StorageFiles -> IO ()
forall (m :: * -> *) b.
Monad m =>
(DBStore -> m b) -> StorageFiles -> m b
`withStores` StorageFiles
fs
    (DBStore -> CM ()
forall {m :: * -> *}. MonadIO m => DBStore -> m ()
moveExported (DBStore -> CM ()) -> StorageFiles -> CM ()
forall (m :: * -> *) b.
Monad m =>
(DBStore -> m b) -> StorageFiles -> m b
`withStores` StorageFiles
fs)
      CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
e -> (String -> CM ()
forall {m :: * -> *}. MonadIO m => String -> m ()
restore (String -> CM ()) -> StorageFiles -> CM ()
forall (m :: * -> *) b.
Monad m =>
(String -> m b) -> StorageFiles -> m b
`withDBs` StorageFiles
fs) CM () -> CM () -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ChatError -> CM ()
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
e
  where
    backup :: String -> m ()
backup String
f = String -> String -> m ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
copyFile String
f (String
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".bak")
    restore :: String -> m ()
restore String
f = String -> String -> m ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
copyFile (String
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".bak") String
f
    checkFile :: String -> CM ()
checkFile String
f = ExceptT ChatError (ReaderT ChatController IO) Bool
-> CM () -> CM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
f) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ DatabaseError -> CM ()
throwDBError (DatabaseError -> CM ()) -> DatabaseError -> CM ()
forall a b. (a -> b) -> a -> b
$ String -> DatabaseError
DBErrorNoFile String
f
    checkEncryption :: DBStore -> CM ()
checkEncryption DBStore {TVar (Maybe ScrubbedBytes)
dbKey :: TVar (Maybe ScrubbedBytes)
dbKey :: DBStore -> TVar (Maybe ScrubbedBytes)
dbKey} = do
      Bool
enc <- Bool -> (ScrubbedBytes -> Bool) -> Maybe ScrubbedBytes -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not (Bool -> Bool) -> (ScrubbedBytes -> Bool) -> ScrubbedBytes -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScrubbedBytes -> Bool
forall a. ByteArrayAccess a => a -> Bool
BA.null) (Maybe ScrubbedBytes -> Bool)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe ScrubbedBytes)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe ScrubbedBytes)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe ScrubbedBytes)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe ScrubbedBytes)
dbKey
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
enc Bool -> Bool -> Bool
&& ScrubbedBytes -> Bool
forall a. ByteArrayAccess a => a -> Bool
BA.null ScrubbedBytes
key) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ DatabaseError -> CM ()
throwDBError DatabaseError
DBErrorEncrypted
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
enc Bool -> Bool -> Bool
&& Bool -> Bool
not (ScrubbedBytes -> Bool
forall a. ByteArrayAccess a => a -> Bool
BA.null ScrubbedBytes
key)) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ DatabaseError -> CM ()
throwDBError DatabaseError
DBErrorPlaintext
    exported :: String -> String
exported = (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".exported")
    removeExported :: String -> m ()
removeExported String
f = m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> m Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist (String -> m Bool) -> String -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> String
exported String
f) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall {m :: * -> *}. MonadIO m => String -> m ()
removeFile (String -> String
exported String
f)
    moveExported :: DBStore -> m ()
moveExported DBStore {dbFilePath :: DBStore -> String
dbFilePath = String
f, TVar (Maybe ScrubbedBytes)
dbKey :: DBStore -> TVar (Maybe ScrubbedBytes)
dbKey :: TVar (Maybe ScrubbedBytes)
dbKey} = do
      String -> String -> m ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
renameFile (String -> String
exported String
f) String
f
      STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe ScrubbedBytes) -> Maybe ScrubbedBytes -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe ScrubbedBytes)
dbKey (Maybe ScrubbedBytes -> STM ()) -> Maybe ScrubbedBytes -> STM ()
forall a b. (a -> b) -> a -> b
$ ScrubbedBytes -> Bool -> Maybe ScrubbedBytes
storeKey ScrubbedBytes
key' (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
keepKey)
    export :: String -> CM ()
export String
f = do
      String
-> (Database -> IO ()) -> (SQLiteError -> DatabaseError) -> CM ()
forall a.
String
-> (Database -> IO a) -> (SQLiteError -> DatabaseError) -> CM ()
withDB String
f (Database -> Text -> IO ()
`SQL.exec` Text
exportSQL) SQLiteError -> DatabaseError
DBErrorExport
      String
-> (Database -> IO ()) -> (SQLiteError -> DatabaseError) -> CM ()
forall a.
String
-> (Database -> IO a) -> (SQLiteError -> DatabaseError) -> CM ()
withDB (String -> String
exported String
f) (Database -> Text -> IO ()
`SQL.exec` ScrubbedBytes -> Text
testSQL ScrubbedBytes
key') SQLiteError -> DatabaseError
DBErrorOpen
      where
        exportSQL :: Text
exportSQL =
          [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
            ScrubbedBytes -> [Text]
keySQL ScrubbedBytes
key
              [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"ATTACH DATABASE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sqlString (String -> Text
T.pack String
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".exported") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AS exported KEY " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScrubbedBytes -> Text
keyString ScrubbedBytes
key' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";",
                   Text
"SELECT sqlcipher_export('exported');",
                   Text
"DETACH DATABASE exported;"
                 ]

withDB :: FilePath -> (SQL.Database -> IO a) -> (SQLiteError -> DatabaseError) -> CM ()
withDB :: forall a.
String
-> (Database -> IO a) -> (SQLiteError -> DatabaseError) -> CM ()
withDB String
f' Database -> IO a
a SQLiteError -> DatabaseError
err =
  IO (Maybe SQLiteError)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Database -> (Database -> IO ()) -> (Database -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Text -> IO Database
SQL.open (Text -> IO Database) -> Text -> IO Database
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
f') Database -> IO ()
SQL.close Database -> IO a
a IO a -> Maybe SQLiteError -> IO (Maybe SQLiteError)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe SQLiteError
forall a. Maybe a
Nothing)
    ExceptT ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
-> (SQLError
    -> ExceptT
         ChatError (ReaderT ChatController IO) (Maybe SQLiteError))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SQLError
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
checkSQLError
    ExceptT ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
-> (SomeException
    -> ExceptT
         ChatError (ReaderT ChatController IO) (Maybe SQLiteError))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
e :: SomeException) -> SomeException
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
forall e.
Show e =>
e
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
sqliteError' SomeException
e)
    ExceptT ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
-> (Maybe SQLiteError -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SQLiteError -> CM ()) -> Maybe SQLiteError -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DatabaseError -> CM ()
throwDBError (DatabaseError -> CM ())
-> (SQLiteError -> DatabaseError) -> SQLiteError -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQLiteError -> DatabaseError
err)
  where
    checkSQLError :: SQLError
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
checkSQLError SQLError
e = case SQLError -> Error
SQL.sqlError SQLError
e of
      Error
SQL.ErrorNotADatabase -> Maybe SQLiteError
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SQLiteError
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe SQLiteError))
-> Maybe SQLiteError
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
forall a b. (a -> b) -> a -> b
$ SQLiteError -> Maybe SQLiteError
forall a. a -> Maybe a
Just SQLiteError
SQLiteErrorNotADatabase
      Error
_ -> SQLError
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
forall e.
Show e =>
e
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
sqliteError' SQLError
e
    sqliteError' :: Show e => e -> CM (Maybe SQLiteError)
    sqliteError' :: forall e.
Show e =>
e
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
sqliteError' = Maybe SQLiteError
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SQLiteError
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe SQLiteError))
-> (e -> Maybe SQLiteError)
-> e
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe SQLiteError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQLiteError -> Maybe SQLiteError
forall a. a -> Maybe a
Just (SQLiteError -> Maybe SQLiteError)
-> (e -> SQLiteError) -> e -> Maybe SQLiteError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SQLiteError
SQLiteError (String -> SQLiteError) -> (e -> String) -> e -> SQLiteError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show

testSQL :: BA.ScrubbedBytes -> Text
testSQL :: ScrubbedBytes -> Text
testSQL ScrubbedBytes
k =
  [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    ScrubbedBytes -> [Text]
keySQL ScrubbedBytes
k
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"PRAGMA foreign_keys = ON;",
           Text
"PRAGMA secure_delete = ON;",
           Text
"SELECT count(*) FROM sqlite_master;"
         ]

keySQL :: BA.ScrubbedBytes -> [Text]
keySQL :: ScrubbedBytes -> [Text]
keySQL ScrubbedBytes
k = [Text
"PRAGMA key = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScrubbedBytes -> Text
keyString ScrubbedBytes
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";" | Bool -> Bool
not (ScrubbedBytes -> Bool
forall a. ByteArrayAccess a => a -> Bool
BA.null ScrubbedBytes
k)]

sqlCipherTestKey :: DBEncryptionKey -> CM ()
sqlCipherTestKey :: DBEncryptionKey -> CM ()
sqlCipherTestKey (DBEncryptionKey ScrubbedBytes
key) = do
  StorageFiles
fs <- CM' StorageFiles
-> ExceptT ChatError (ReaderT ChatController IO) StorageFiles
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift CM' StorageFiles
storageFiles
  String -> CM ()
testKey (String -> CM ()) -> StorageFiles -> CM ()
forall (m :: * -> *) b.
Monad m =>
(String -> m b) -> StorageFiles -> m b
`withDBs` StorageFiles
fs
  where
    testKey :: String -> CM ()
testKey String
f = String
-> (Database -> IO ()) -> (SQLiteError -> DatabaseError) -> CM ()
forall a.
String
-> (Database -> IO a) -> (SQLiteError -> DatabaseError) -> CM ()
withDB String
f (Database -> Text -> IO ()
`SQL.exec` ScrubbedBytes -> Text
testSQL ScrubbedBytes
key) SQLiteError -> DatabaseError
DBErrorOpen

withDBs :: Monad m => (FilePath -> m b) -> StorageFiles -> m b
String -> m b
action withDBs :: forall (m :: * -> *) b.
Monad m =>
(String -> m b) -> StorageFiles -> m b
`withDBs` StorageFiles {DBStore
chatStore :: StorageFiles -> DBStore
chatStore :: DBStore
chatStore, DBStore
agentStore :: StorageFiles -> DBStore
agentStore :: DBStore
agentStore} = String -> m b
action (DBStore -> String
dbFilePath DBStore
chatStore) m b -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> m b
action (DBStore -> String
dbFilePath DBStore
agentStore)

withStores :: Monad m => (DBStore -> m b) -> StorageFiles -> m b
DBStore -> m b
action withStores :: forall (m :: * -> *) b.
Monad m =>
(DBStore -> m b) -> StorageFiles -> m b
`withStores` StorageFiles {DBStore
chatStore :: StorageFiles -> DBStore
chatStore :: DBStore
chatStore, DBStore
agentStore :: StorageFiles -> DBStore
agentStore :: DBStore
agentStore} = DBStore -> m b
action DBStore
chatStore m b -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DBStore -> m b
action DBStore
agentStore