{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

module Simplex.Messaging.Agent.Store.SQLite.Migrations
  ( Migration (..),
    app,
    initialize,
    get,
    run,
  )
where

import Control.Monad (forM_)
import Data.FileEmbed (embedDir, makeRelativeToProject)
import Data.Function (on)
import Data.List (intercalate, sortBy)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (Connection, Only (..))
import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.QQ (sql)
import qualified Database.SQLite3 as SQLite3
import System.FilePath (takeBaseName, takeExtension)

data Migration = Migration {Migration -> String
name :: String, Migration -> Text
up :: Text}
  deriving (Int -> Migration -> ShowS
[Migration] -> ShowS
Migration -> String
(Int -> Migration -> ShowS)
-> (Migration -> String)
-> ([Migration] -> ShowS)
-> Show Migration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Migration] -> ShowS
$cshowList :: [Migration] -> ShowS
show :: Migration -> String
$cshow :: Migration -> String
showsPrec :: Int -> Migration -> ShowS
$cshowsPrec :: Int -> Migration -> ShowS
Show)

-- | The list of migrations in ascending order by date
app :: [Migration]
app :: [Migration]
app =
  (Migration -> Migration -> Ordering) -> [Migration] -> [Migration]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (String -> String -> Ordering)
-> (Migration -> String) -> Migration -> Migration -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Migration -> String
name) ([Migration] -> [Migration])
-> ([(String, ByteString)] -> [Migration])
-> [(String, ByteString)]
-> [Migration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, ByteString) -> Migration)
-> [(String, ByteString)] -> [Migration]
forall a b. (a -> b) -> [a] -> [b]
map (String, ByteString) -> Migration
migration ([(String, ByteString)] -> [Migration])
-> ([(String, ByteString)] -> [(String, ByteString)])
-> [(String, ByteString)]
-> [Migration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, ByteString) -> Bool)
-> [(String, ByteString)] -> [(String, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String, ByteString) -> Bool
forall b. (String, b) -> Bool
sqlFile ([(String, ByteString)] -> [Migration])
-> [(String, ByteString)] -> [Migration]
forall a b. (a -> b) -> a -> b
$
    $(makeRelativeToProject "migrations" >>= embedDir)
  where
    sqlFile :: (String, b) -> Bool
sqlFile (String
file, b
_) = ShowS
takeExtension String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".sql"
    migration :: (String, ByteString) -> Migration
migration (String
file, ByteString
qStr) = Migration :: String -> Text -> Migration
Migration {name :: String
name = ShowS
takeBaseName String
file, up :: Text
up = ByteString -> Text
decodeUtf8 ByteString
qStr}

get :: Connection -> [Migration] -> IO (Either String [Migration])
get :: Connection -> [Migration] -> IO (Either String [Migration])
get Connection
conn [Migration]
migrations =
  [Migration] -> [String] -> Either String [Migration]
migrationsToRun [Migration]
migrations ([String] -> Either String [Migration])
-> ([Only String] -> [String])
-> [Only String]
-> Either String [Migration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Only String -> String) -> [Only String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Only String -> String
forall a. Only a -> a
fromOnly
    ([Only String] -> Either String [Migration])
-> IO [Only String] -> IO (Either String [Migration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> IO [Only String]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_ Connection
conn Query
"SELECT name FROM migrations ORDER BY name ASC;"

run :: Connection -> [Migration] -> IO ()
run :: Connection -> [Migration] -> IO ()
run Connection
conn [Migration]
ms = Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
DB.withImmediateTransaction Connection
conn (IO () -> IO ())
-> ((Migration -> IO ()) -> IO ()) -> (Migration -> IO ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Migration] -> (Migration -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Migration]
ms ((Migration -> IO ()) -> IO ()) -> (Migration -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
  \Migration {String
name :: String
name :: Migration -> String
name, Text
up :: Text
up :: Migration -> Text
up} -> String -> IO ()
forall t. ToField t => t -> IO ()
insert String
name IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> IO ()
execSQL Text
up
  where
    insert :: t -> IO ()
insert t
name = Connection -> Query -> (t, UTCTime) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
conn Query
"INSERT INTO migrations (name, ts) VALUES (?, ?);" ((t, UTCTime) -> IO ())
-> (UTCTime -> (t, UTCTime)) -> UTCTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t
name,) (UTCTime -> IO ()) -> IO UTCTime -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
    execSQL :: Text -> IO ()
execSQL = Database -> Text -> IO ()
SQLite3.exec (Database -> Text -> IO ()) -> Database -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Database
DB.connectionHandle Connection
conn

initialize :: Connection -> IO ()
initialize :: Connection -> IO ()
initialize Connection
conn =
  Connection -> Query -> IO ()
DB.execute_
    Connection
conn
    [sql|
      CREATE TABLE IF NOT EXISTS migrations (
        name TEXT NOT NULL,
        ts TEXT NOT NULL,
        PRIMARY KEY (name)
      );
    |]

migrationsToRun :: [Migration] -> [String] -> Either String [Migration]
migrationsToRun :: [Migration] -> [String] -> Either String [Migration]
migrationsToRun [Migration]
appMs [] = [Migration] -> Either String [Migration]
forall a b. b -> Either a b
Right [Migration]
appMs
migrationsToRun [] [String]
dbMs = String -> Either String [Migration]
forall a b. a -> Either a b
Left (String -> Either String [Migration])
-> String -> Either String [Migration]
forall a b. (a -> b) -> a -> b
$ String
"database version is newer than the app: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
dbMs
migrationsToRun (Migration
a : [Migration]
as) (String
d : [String]
ds)
  | Migration -> String
name Migration
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
d = [Migration] -> [String] -> Either String [Migration]
migrationsToRun [Migration]
as [String]
ds
  | Bool
otherwise = String -> Either String [Migration]
forall a b. a -> Either a b
Left (String -> Either String [Migration])
-> String -> Either String [Migration]
forall a b. (a -> b) -> a -> b
$ String
"different migration in the app/database: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Migration -> String
name Migration
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" / " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
d