{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}

module Simplex.Messaging.Agent.Store.SQLite.Migrations
  ( initialize,
    run,
    getCurrentMigrations,
  )
where

import Control.Monad (forM_, when)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (Only (..), Query (..))
import qualified Database.SQLite.Simple as SQL
import qualified Database.SQLite3 as SQLite3
import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Agent.Store.SQLite.Common
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users
import Simplex.Messaging.Agent.Store.Shared
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Transport.Client (TransportHost)

getCurrentMigrations :: Maybe Query -> DB.Connection -> IO [Migration]
getCurrentMigrations :: Maybe Query -> Connection -> IO [Migration]
getCurrentMigrations Maybe Query
migrationsTable DB.Connection {Connection
conn :: Connection
conn :: Connection -> Connection
DB.conn} =
  ((String, Maybe Text) -> Migration)
-> [(String, Maybe Text)] -> [Migration]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe Text) -> Migration
toMigration
    ([(String, Maybe Text)] -> [Migration])
-> IO [(String, Maybe Text)] -> IO [Migration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> IO [(String, Maybe Text)]
forall r. FromRow r => Connection -> Query -> IO [r]
SQL.query_ Connection
conn (Query
"SELECT name, down FROM " Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
table Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" ORDER BY name ASC;")
  where
    table :: Query
table = Query -> Maybe Query -> Query
forall a. a -> Maybe a -> a
fromMaybe Query
"migrations" Maybe Query
migrationsTable
    toMigration :: (String, Maybe Text) -> Migration
toMigration (String
name, Maybe Text
down) = Migration {String
name :: String
name :: String
name, up :: Text
up = Text
"", Maybe Text
down :: Maybe Text
down :: Maybe Text
down}

run :: DBStore -> Maybe Query -> Bool -> MigrationsToRun -> IO ()
run :: DBStore -> Maybe Query -> Bool -> MigrationsToRun -> IO ()
run DBStore
st Maybe Query
migrationsTable Bool
vacuum = \case
  MTRUp [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  MTRUp [Migration]
ms -> do
    (Migration -> IO ()) -> [Migration] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Migration -> IO ()
runUp [Migration]
ms
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
vacuum (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DBStore -> (Connection -> IO ()) -> IO ()
forall a. DBStore -> (Connection -> IO a) -> IO a
withConnection' DBStore
st (Connection -> Text -> IO ()
`execSQL` Text
"VACUUM;")
  MTRDown [DownMigration]
ms -> (DownMigration -> IO ()) -> [DownMigration] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DownMigration -> IO ()
runDown ([DownMigration] -> IO ()) -> [DownMigration] -> IO ()
forall a b. (a -> b) -> a -> b
$ [DownMigration] -> [DownMigration]
forall a. [a] -> [a]
reverse [DownMigration]
ms
  MigrationsToRun
MTRNone -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    table :: Query
table = Query -> Maybe Query -> Query
forall a. a -> Maybe a -> a
fromMaybe Query
"migrations" Maybe Query
migrationsTable
    runUp :: Migration -> IO ()
runUp Migration {String
name :: Migration -> String
name :: String
name, Text
up :: Migration -> Text
up :: Text
up, Maybe Text
down :: Migration -> Maybe Text
down :: Maybe Text
down} = DBStore -> (Connection -> IO ()) -> IO ()
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction' DBStore
st ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"m20220811_onion_hosts") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> IO ()
updateServers Connection
db
      Connection -> IO ()
insert Connection
db IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Connection -> Text -> IO ()
execSQL Connection
db Text
up'
      where
        insert :: Connection -> IO ()
insert Connection
db = Connection -> Query -> (String, Maybe Text, UTCTime) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
SQL.execute Connection
db (Query
"INSERT INTO " Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
table Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" (name, down, ts) VALUES (?,?,?)") ((String, Maybe Text, UTCTime) -> IO ())
-> (UTCTime -> (String, Maybe Text, UTCTime)) -> UTCTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
name,Maybe Text
down,) (UTCTime -> IO ()) -> IO UTCTime -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
        up' :: Text
up'
          | DBStore -> Bool
dbNew DBStore
st Bool -> Bool -> Bool
&& String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"m20230110_users" = Query -> Text
fromQuery Query
new_m20230110_users
          | Bool
otherwise = Text
up
        updateServers :: Connection -> IO ()
updateServers Connection
db = [(TransportHost, TransportHost)]
-> ((TransportHost, TransportHost) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map TransportHost TransportHost -> [(TransportHost, TransportHost)]
forall k a. Map k a -> [(k, a)]
M.assocs Map TransportHost TransportHost
extraSMPServerHosts) (((TransportHost, TransportHost) -> IO ()) -> IO ())
-> ((TransportHost, TransportHost) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(TransportHost
h, TransportHost
h') ->
          let hs :: Text
hs = ByteString -> Text
decodeLatin1 (ByteString -> Text)
-> (NonEmpty TransportHost -> ByteString)
-> NonEmpty TransportHost
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty TransportHost -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (NonEmpty TransportHost -> Text) -> NonEmpty TransportHost -> Text
forall a b. (a -> b) -> a -> b
$ ([Item (NonEmpty TransportHost)
TransportHost
h, Item (NonEmpty TransportHost)
TransportHost
h'] :: NonEmpty TransportHost)
           in Connection -> Query -> (Text, Text) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
SQL.execute Connection
db Query
"UPDATE servers SET host = ? WHERE host = ?" (Text
hs, ByteString -> Text
decodeLatin1 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ TransportHost -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode TransportHost
h)
    runDown :: DownMigration -> IO ()
runDown DownMigration {String
downName :: String
downName :: DownMigration -> String
downName, Text
downQuery :: Text
downQuery :: DownMigration -> Text
downQuery} = DBStore -> (Connection -> IO ()) -> IO ()
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction' DBStore
st ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
      Connection -> Text -> IO ()
execSQL Connection
db Text
downQuery
      Connection -> Query -> Only String -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
SQL.execute Connection
db (Query
"DELETE FROM " Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
table Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" WHERE name = ?") (String -> Only String
forall a. a -> Only a
Only String
downName)
    execSQL :: Connection -> Text -> IO ()
execSQL Connection
db = Database -> Text -> IO ()
SQLite3.exec (Database -> Text -> IO ()) -> Database -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Database
SQL.connectionHandle Connection
db

initialize :: DBStore -> Maybe Query -> IO ()
initialize :: DBStore -> Maybe Query -> IO ()
initialize DBStore
st Maybe Query
migrationsTable = DBStore -> (Connection -> IO ()) -> IO ()
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction' DBStore
st ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
  [Text]
cs :: [Text] <- (Only Text -> Text) -> [Only Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Only Text -> Text
forall a. Only a -> a
fromOnly ([Only Text] -> [Text]) -> IO [Only Text] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> IO [Only Text]
forall r. FromRow r => Connection -> Query -> IO [r]
SQL.query_ Connection
db (Query
"SELECT name FROM pragma_table_info('" Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
table Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
"')")
  case [Text]
cs of
    [] -> Connection -> IO ()
createMigrations Connection
db
    [Text]
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
"down" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
cs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO ()
SQL.execute_ Connection
db (Query -> IO ()) -> Query -> IO ()
forall a b. (a -> b) -> a -> b
$ Query
"ALTER TABLE " Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
table Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" ADD COLUMN down TEXT"
  where
    table :: Query
table = Query -> Maybe Query -> Query
forall a. a -> Maybe a -> a
fromMaybe Query
"migrations" Maybe Query
migrationsTable
    createMigrations :: Connection -> IO ()
createMigrations Connection
db =
      Connection -> Query -> IO ()
SQL.execute_ Connection
db (Query -> IO ()) -> Query -> IO ()
forall a b. (a -> b) -> a -> b
$
        Query
"CREATE TABLE IF NOT EXISTS "
          Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
table
          Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" (name TEXT NOT NULL PRIMARY KEY, ts TEXT NOT NULL, down TEXT)"