{- This file is part of Vervis.
 -
 - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}

module Database.Persist.Box.Internal
    ( -- * TH
      model
    , modelFile
    , makeBox

      -- * Making types boxable
    , BoxPersistT ()
    , Boxable (..)
    , BoxableFormat (..)
    , BoxableVia (..)
    , BoxableRecord ()
    , BoxableField ()
    , BoxableShow ()
    , BoxableJSON ()
    , BoxableSerialize ()

-- MIGRATIONS
--
-- Use the SQLite user version pragma to track the version
--
-- Record: Adapt persistent-migration to single-field case
-- The rest: Provide 3 types of migrations:
--      1. Create the table
--      2. Adapt the value
--      3. Change the value's type
--
-- This should allow migrating *between* serialization types as well. Since
-- SQLite column types are just a recommendation (AFAIK so far), switching type
-- simply involves an in-place update, and an update to the schema for the
-- formality.
--
-- This can be automated by either having a typeclass for each switch between
-- serialization types, or have each serialization type specify its sqlType,
-- and then whenever a migration switches between serialization types with a
-- different SqlType, run a SQL command to change the column type.
--
-- And switching to/from record to simple field would be done by creating a new
-- table, migrating the row, and deleting the old table.
--
-- Actually, this can be done for the between-simples as well, it means there's
-- no need to define migration SQL for column type change, just reuse the SQL
-- for table creation. OTOH does it waste anything? Likely not, serialization
-- type changes would likely be rare, never something that would generate 1000s
-- of table create-deletes or anything like that.
--
-- Switching between different record types is same idea: Make new table,
-- migrate the row, delete old table.
--
-- NOTE: Old and new table names might clash, especially since all the "simple"
-- types use the same schema of table "cell" with column "value". Solution
-- would be to create the new table with some very unlikely name, do the
-- migration, delete old table, then finally rename new table. It's now the
-- only table, so, the remaming will just work.
--
-- Proposal: Somehow use types to force writing migration numbers in the
-- migration list, not just as comments? And then verify the numbers at *build*
-- time, i.e. compile successfully only if they're sequential and starting from
-- the earliest-supported number specified. And perhaps force having the
-- migration number at the end of the type name for "simple" ones, and have it
-- auto-prepended to type name and field accessor names using
-- persistent-migration's existing mechanism that does that?
--
-- Proposal: To have better type safety, rather than a plain list of possibly
-- inconsistent migrations, make sure that a migration a->b is followed by a
-- migration b->c etc. etc. and finally the last migration leads to the current
-- version of the boxable type.
--
-- Proposal: The "record" option might be most useful for debugging,
-- inspecting, accessing via non-haskell, etc. etc. but also migrations are
-- more involved, having to manually specify each column
-- change/removal/addition. So, idea: Add a migration that allows to specify
-- function PersonOld->PersonNew and simply creates a new table, writes the row
-- and deletes old table. Idk if it exhausts anything, but it allows to write a
-- migration in terms of Haskell types rather than columns. It's also safer,
-- more checked, unless I add support for column remove/add that verifies the
-- removed column actually existed and added one truly exists in the new
-- version of the type etc.

      -- * Box access
    , Box ()
    --, MigrationRecipes
    , loadBox
    , withBox
    , MonadBox (..)
    , runBox
    , bestow
    , obtain

      -- * Box viewer pool
    , BoxView ()
    , createBoxView
    , viewBox
    )
where

import Control.Exception.Base
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Data.ByteString (ByteString)
import Data.Int
import Data.Kind
import Data.Proxy
import Data.Text (Text)
import Database.Persist
import Database.Persist.Sql
import Database.Persist.Sqlite
import Language.Haskell.TH.Quote (QuasiQuoter)
import Language.Haskell.TH.Syntax (Q, Exp, Dec)
import Text.Read (readEither)
import Type.Reflection (Typeable, typeRep)

import qualified Data.Aeson as A
import qualified Data.Serialize as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Database.Persist.Types as PT

import qualified Database.Persist.Schema.TH as PS

import Database.Persist.Sqlite.Local

{-
getVersion :: MonadIO m => SqlPersistT m Int
getVersion = do
    r <- rawSql "PRAGMA user_version" []
    case r of
        [] -> error "No user_version"
        [Single n] -> return n
        _ -> error "Multiple user_version"

setVersion :: MonadIO m => Int -> SqlPersistT m ()
setVersion n = rawExecute "PRAGMA user_version = ?" [toPersistValue n]
-}

createEntityIfNeeded
    :: (Monad proxy, MonadIO m, PersistRecordBackend record SqlBackend)
    => proxy record -> SqlPersistT m ()
createEntityIfNeeded p = runMigration $ migrate [] (entityDef p)

createCellIfNeeded
    :: forall m a. (MonadIO m, PersistFieldSql a)
    => Proxy a -> SqlPersistT m ()
createCellIfNeeded p = do
    r <-
        rawSql
            "SELECT name FROM sqlite_schema WHERE type='table' AND name=?"
            [PersistText "cell"]
    case r  of
        [] ->
            let query = T.concat
                    ["CREATE TABLE cell(id INTEGER PRIMARY KEY, value "
                    , showSqlType $ sqlType p
                    , " NOT NULL)"
                    ]
            in  rawExecute query []
        [Single (_ :: a)] -> pure ()
        _ -> error "Multiple cell tables in sqlite_schema"

model :: QuasiQuoter
model = PS.model ""

modelFile :: FilePath -> Q Exp
modelFile = PS.modelFile ""

-- | Declare datatypes and a 'PeristEntity' instance, from the entity
-- definition produced by 'model' or 'modelFile'
makeBox :: [PT.EntityDef] -> Q [Dec]
makeBox [e] = PS.makeEntities [e]
makeBox _   = fail "makeBox requires exactly 1 entity"

newtype BoxPersistT r m a = BoxPersistT (SqlPersistT m a)
    deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)

class Boxable a where
    --type MonadMigrateBox :: (* -> *) -> Constraint
    --type MigrationRecipes a :: * -> *
    --migrateBox :: (MonadIO m, MonadLogger m, MonadMigrateBox m) => MigrationRecipe a m -> SqlPersistT m (Either Text (Int, Int))
    createBoxStorageIfNeeded :: MonadIO m => Proxy a -> SqlPersistT m ()
    bestowB :: MonadIO m => a -> SqlPersistT m ()
    obtainB :: MonadIO m => SqlPersistT m a

class BoxableFormat (f :: Type -> Type) where
    wrapBF :: a -> f a
    unwrapBF :: f a -> a

class (BoxableFormat (BV a), Boxable (BV a a)) => BoxableVia a where
    type BV a :: Type -> Type

bestow' :: (MonadIO m, Boxable a) => a -> BoxPersistT a m ()
bestow' = BoxPersistT . bestowB

obtain' :: (MonadIO m, Boxable a) => BoxPersistT a m a
obtain' = BoxPersistT obtainB

bestow :: forall m a. (MonadIO m, BoxableVia a) => a -> BoxPersistT a m ()
bestow = BoxPersistT . bestowB . wrapBF @(BV a) @a

obtain :: forall m a. (MonadIO m, BoxableVia a) => BoxPersistT a m a
obtain = BoxPersistT $ unwrapBF @(BV a) @a <$> obtainB

newtype BoxableRecord a = BoxableRecord { unBoxableRecord :: a }

instance BoxableFormat BoxableRecord where
    wrapBF = BoxableRecord
    unwrapBF = unBoxableRecord

keyN :: Int64
keyN = 1

key :: ToBackendKey SqlBackend record => Key record
key = toSqlKey keyN

instance (PersistRecordBackend a SqlBackend, ToBackendKey SqlBackend a) => Boxable (BoxableRecord a) where
    --type MigrationRecipe (BoxablePersist a) m = [Migration SqlBackend m]
    --migrateBox ms = second (,length ms) <$> runMigrations schemaBackend? "" 1 ms
    createBoxStorageIfNeeded = createEntityIfNeeded . fmap unBoxableRecord
    bestowB (BoxableRecord r) = repsert key r
    obtainB = BoxableRecord <$> getJust key

newtype BoxableField a = BoxableField { unBoxableField :: a }

instance BoxableFormat BoxableField where
    wrapBF = BoxableField
    unwrapBF = unBoxableField

newtype BoxException = BoxException Text deriving Show

instance Exception BoxException

instance PersistFieldSql a => Boxable (BoxableField a) where
    --type MigrationRecipe (BoxablePersist a) = ???
    --migrateBox ms = ???
    createBoxStorageIfNeeded = createCellIfNeeded . fmap unBoxableField
    bestowB (BoxableField v) =
        rawExecute query [toPersistValue keyN, toPersistValue v]
        where
        query =
            "INSERT INTO cell(id,value) VALUES (?,?)\
            \ ON CONFLICT (id) DO UPDATE SET value=EXCLUDED.value"
    obtainB = do
        r <- rawSql query [toPersistValue keyN]
        case r of
            [] -> liftIO $ throwIO $ BoxException "obtainB: row not found"
            [Single v] -> return $ BoxableField v
            _ -> liftIO $ throwIO $ BoxException "obtainB: multiple rows found"
        where
        query = "SELECT value FROM cell WHERE id=?"

{-
adapt :: BoxPersistT x m a -> BoxPersistT y m a
adapt (BoxPersistT action) = BoxPersistT action
-}

newtype WrapShow a = WrapShow { unWrapShow :: a }

instance (Typeable a, Show a, Read a) => PersistField (WrapShow a) where
    toPersistValue = toPersistValue . show . unWrapShow
    fromPersistValue v = do
        s <- fromPersistValue v
        case readEither s of
            Left e' ->
                Left $ T.pack $
                    "Invalid " ++ show (typeRep @a) ++ ": " ++
                    e' ++ ": " ++ s
            Right x -> Right $ WrapShow x

instance PersistField (WrapShow a) => PersistFieldSql (WrapShow a) where
    sqlType _ = sqlType (Proxy :: Proxy String)

newtype BoxableShow a = BoxableShow { unBoxableShow :: a }

instance BoxableFormat BoxableShow where
    wrapBF = BoxableShow
    unwrapBF = unBoxableShow

instance (Typeable a, Show a, Read a) => Boxable (BoxableShow a) where
    --type MigrationRecipe (BoxablePersist a) = ???
    --migrateBox ms = ???
    createBoxStorageIfNeeded =
        createCellIfNeeded . fmap (WrapShow . unBoxableShow)
    bestowB = bestowB . BoxableField . WrapShow . unBoxableShow
    obtainB = BoxableShow . unWrapShow . unBoxableField <$> obtainB

newtype WrapJSON a = WrapJSON { unWrapJSON :: a }

instance (Typeable a, A.FromJSON a, A.ToJSON a) => PersistField (WrapJSON a) where
    toPersistValue = PersistText . toJsonText . unWrapJSON
    fromPersistValue v = do
        text <- fromPersistValue v
        let bs = TE.encodeUtf8 text
        case A.eitherDecodeStrict' bs of
            Left e ->
                Left $
                    T.concat
                        [ "JSON decoding error for "
                        , T.pack $ show $ typeRep @a
                        , ": ", T.pack e, " on input: ", text
                        ]
            Right x -> Right $ WrapJSON x

instance PersistField (WrapJSON a) => PersistFieldSql (WrapJSON a) where
    sqlType _ = SqlString

newtype BoxableJSON a = BoxableJSON { unBoxableJSON :: a }

instance BoxableFormat BoxableJSON where
    wrapBF = BoxableJSON
    unwrapBF = unBoxableJSON

instance (Typeable a, A.FromJSON a, A.ToJSON a) => Boxable (BoxableJSON a) where
    --type MigrationRecipe (BoxablePersist a) = ???
    --migrateBox ms = ???
    createBoxStorageIfNeeded =
        createCellIfNeeded . fmap (WrapJSON . unBoxableJSON)
    bestowB = bestowB . BoxableField . WrapJSON . unBoxableJSON
    obtainB = BoxableJSON . unWrapJSON . unBoxableField <$> obtainB

newtype WrapSerialize a = WrapSerialize { unWrapSerialize :: a }

instance (Typeable a, S.Serialize a) => PersistField (WrapSerialize a) where
    toPersistValue = toPersistValue . S.encode . unWrapSerialize
    fromPersistValue v = do
        b <- fromPersistValue v
        case S.decode b of
            Left e ->
                Left $ T.pack $ "Invalid " ++ show (typeRep @a) ++ ": " ++ e
            Right x -> Right $ WrapSerialize x

instance PersistField (WrapSerialize a) => PersistFieldSql (WrapSerialize a) where
    sqlType _ = sqlType (Proxy :: Proxy ByteString)

newtype BoxableSerialize a = BoxableSerialize { unBoxableSerialize :: a }

instance BoxableFormat BoxableSerialize where
    wrapBF = BoxableSerialize
    unwrapBF = unBoxableSerialize

instance (Typeable a, S.Serialize a) => Boxable (BoxableSerialize a) where
    --type MigrationRecipe (BoxablSerialize a) = ???
    --migrateBox ms = ???
    createBoxStorageIfNeeded =
        createCellIfNeeded . fmap (WrapSerialize . unBoxableSerialize)
    bestowB = bestowB . BoxableField . WrapSerialize . unBoxableSerialize
    obtainB = BoxableSerialize . unWrapSerialize . unBoxableField <$> obtainB

data Box a = Box SqliteConnectionInfo ConnectionPool

type OsPath = FilePath
decodeUtf = pure

loadBox
    :: (MonadLoggerIO m, MonadUnliftIO m, BoxableVia a)
    => OsPath -> a -> m (Box a)
loadBox path val = do
    path' <- liftIO $ T.pack <$> decodeUtf path
    let info = mkSqliteConnectionInfo path'
    pool <- createSqlitePoolFromInfo info 1
    let box = Box info pool
    withBox box $ do
        let proxy :: a -> Proxy (BV a a)
            proxy _ = Proxy
        BoxPersistT $ createBoxStorageIfNeeded $ proxy val
        {-
        r <- migrateBox migrations
            Left err -> do
                let msg = "DB migration failed: " <> path' <> ": " <> err
                logError msg
                error $ T.unpack msg
            Right (from, to) -> do
                logInfo $ T.concat
                    [ "DB migration success: ", path', ": "
                    , T.pack $ show from, " ==> ", T.pack $ show to
                    ]
                mval <- get key
                when (isNothing val) $ insertKey key val
        -}
    return box

withBox :: MonadUnliftIO m => Box record -> BoxPersistT record m a -> m a
withBox (Box info pool) (BoxPersistT action) = runPool conf action pool
    where
    conf = SqliteConfInfo info 1

class (Monad m, BoxableVia (BoxType m)) => MonadBox m where
    type BoxType m
    askBox :: m (Box (BoxType m))

runBox :: (MonadUnliftIO m, MonadBox m) => BoxPersistT (BoxType m) m a -> m a
runBox action = do
    box <- askBox
    withBox box action

data BoxView a = BoxView SqliteConf ConnectionPool

createBoxView :: (MonadLoggerIO m, MonadUnliftIO m) => Box record -> Int -> m (BoxView record)
createBoxView (Box info _) size = do
    pool <- createSqlitePoolFromInfo info size
    let conf = SqliteConfInfo info size
    return $ BoxView conf pool

viewBox :: (MonadUnliftIO m, Boxable a) => BoxView a -> m a
viewBox (BoxView conf pool) = runPool conf obtainB pool