{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Database
    ( migrateAll

      -- * User types
    , User (..)
    , UserId

      -- * Repository types
    , Repository (..)
    , RepositoryId

      -- * SessionKey types
    , SessionKey (..)

      -- * Associated types for Unique: 'UniqueUsername', 'UniqueUserRepo'
    , Persistent.Unique (..)
    , Sqlite.PersistEntity (..)
    , Sqlite.EntityField (..)

      -- * Convenience function for migration
    , insertOrIgnoreUser
    , insertOrIgnoreRepository
    , runMigrationPool
    ) where

import ClassyPrelude hiding (onException)

import qualified Database.Persist as Persistent
import qualified Database.Persist.SqlBackend.Internal as SqlBackend
import qualified Database.Persist.Sqlite as Sqlite
import qualified Database.Persist.TH as Persistent

#if __GLASGOW_HASKELL__ >= 904
import Data.Type.Equality (type (~))
#endif
import Database.Persist.Sql (ConnectionPool, SqlBackend)
import Database.Persist.TH (mkMigrate, mkPersist, persistLowerCase)
import Yesod (sqlSettings)
import Yesod.Auth.HashDB (HashDBUser (..))

Persistent.share
    [mkPersist sqlSettings, mkMigrate "migrateAll"]
    [persistLowerCase|
        User
            username Text
            password Text

            UniqueUsername username

        Repository
            name Text
            summary Text Maybe
            user UserId
            private Bool

            UniqueUserRepo name user

        SessionKey
            value ByteString
    |]

insertOrIgnoreUser
    :: ( Persistent.BaseBackend backend ~ SqlBackend
       , MonadIO m
       , Persistent.PersistUniqueRead backend
       , Persistent.PersistStoreWrite backend
       )
    => User
    -> ReaderT backend m (Persistent.Key User)
insertOrIgnoreUser user@User{userUsername} =
    Persistent.getBy (UniqueUsername userUsername) >>= \case
        Nothing -> Persistent.insert user
        Just x -> pure $ Persistent.entityKey x

insertOrIgnoreRepository
    :: ( Persistent.BaseBackend backend ~ SqlBackend
       , MonadIO m
       , Persistent.PersistUniqueRead backend
       , Persistent.PersistStoreWrite backend
       )
    => Repository
    -> ReaderT backend m (Persistent.Key Repository)
insertOrIgnoreRepository repo@Repository{repositoryName, repositoryUser} =
    Persistent.getBy (UniqueUserRepo repositoryName repositoryUser) >>= \case
        Nothing -> Persistent.insert repo
        Just x -> pure $ Persistent.entityKey x

-- | Runs a migration action on a pool. Exactly like 'runSqlPool', but it will
--   disable foreign keys if running on a sqlite database per the recommendation
--   in the <https://sqlite.org/lang_altertable.html#making_other_kinds_of_table_schema_changes
--   relevant sqlite documentation>.
--
--   Workaround for <https://github.com/yesodweb/persistent/issues/1125>
--   Taken from https://github.com/yesodweb/persistent/issues/1125
runMigrationPool
    :: forall m a
     . (MonadUnliftIO m)
    => ReaderT SqlBackend m a
    -> ConnectionPool
    -> m a
runMigrationPool r pconn =
    Sqlite.runSqlPoolWithHooks r pconn Nothing before after onException
  where
    before conn = do
        let sqlBackend = Sqlite.projectBackend conn
        let getter = Sqlite.getStmtConn sqlBackend
        whenSqlite conn $ Sqlite.rawExecute "PRAGMA foreign_keys=OFF" []
        liftIO $ SqlBackend.connBegin sqlBackend getter Nothing
    after conn = do
        let sqlBackend = Sqlite.projectBackend conn
        let getter = Sqlite.getStmtConn sqlBackend
        whenSqlite conn $ Sqlite.rawExecute "PRAGMA foreign_keys=ON" []
        liftIO $ SqlBackend.connCommit sqlBackend getter
    onException conn _ = do
        let sqlBackend = Sqlite.projectBackend conn
        let getter = Sqlite.getStmtConn sqlBackend
        liftIO $ SqlBackend.connRollback sqlBackend getter

    whenSqlite conn act | SqlBackend.connRDBMS conn == "sqlite" = runReaderT `flip` conn $ act
    whenSqlite _ _ = pure ()

instance HashDBUser User where
    userPasswordHash = Just . userPassword
    setPasswordHash h u = u{userPassword = h}