{-# OPTIONS_GHC -Wno-orphans #-}
module Database.GP.GenericPersistence
  ( retrieveById,
    retrieveAll,
    retrieveAllWhere,
    persist,
    insert,
    update,
    delete,
    setupTableFor,
    idValue,
    Entity (..),
    columnNameFor,
    fieldTypeFor,
    maybeFieldTypeFor,
    toString,
    evidence,
    evidenceFrom,
    ResolutionCache,
    EntityId,
    entityId,
    getElseRetrieve,
    TypeInfo (..),
    typeInfoFromContext,
    typeInfo,
    Ctx (..),
    GP,
    extendCtxCache,
    runGP,
    liftIO,
    local,
    ask,
  )
where

import Data.Convertible ( Convertible, ConvertResult )
import           Database.HDBC        
import           Database.GP.Entity
import           Database.GP.RecordtypeReflection
import           Database.GP.SqlGenerator
import           Database.GP.TypeInfo
import           Data.Dynamic (toDyn, fromDynamic)
import           Data.Data 
import Data.Convertible.Base (Convertible(safeConvert))
import           RIO

{--
 This module defines RDBMS Persistence operations for Record Data Types that are instances of 'Data'.
 I call instances of such a data type Entities.

 The Persistence operations are using Haskell generics to provide compile time reflection capabilities.
 HDBC is used to access the RDBMS.
--}




-- | A function that retrieves an entity from a database.
-- The function takes entity id as parameter.
-- If an entity with the given id exists in the database, it is returned as a Just value.
-- If no such entity exists, Nothing is returned.
-- An error is thrown if there are more than one entity with the given id.
retrieveById :: forall a id. (Entity a, Convertible id SqlValue) => id -> GP (Maybe a)
retrieveById :: forall a id.
(Entity a, Convertible id SqlValue) =>
id -> GP (Maybe a)
retrieveById id
idx = do
  ConnWrapper
conn <- GP ConnWrapper
askConnection
  [[SqlValue]]
resultRowsSqlValues <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn.
IConnection conn =>
conn -> String -> [SqlValue] -> IO [[SqlValue]]
quickQuery ConnWrapper
conn String
stmt [SqlValue
eid]
  case [[SqlValue]]
resultRowsSqlValues of
    []          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    [[SqlValue]
singleRow] -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Entity a => [SqlValue] -> GP a
fromRow [SqlValue]
singleRow
    [[SqlValue]]
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"More than one" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall {k} (a :: k). TypeInfo a -> Constr
typeConstructor TypeInfo a
ti) forall a. [a] -> [a] -> [a]
++ String
" found for id " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
eid
  where
    ti :: TypeInfo a
ti = forall a. Data a => TypeInfo a
typeInfoFromContext :: TypeInfo a
    stmt :: String
stmt = forall a. Entity a => TypeInfo a -> String
selectStmtFor TypeInfo a
ti
    eid :: SqlValue
eid = forall a. Convertible a SqlValue => a -> SqlValue
toSql id
idx


-- | This function retrieves all entities of type `a` from a database.
--  The function takes an HDBC connection as parameter.
--  The type `a` is determined by the context of the function call.
retrieveAll :: forall a. (Entity a) => GP [a]
retrieveAll :: forall a. Entity a => GP [a]
retrieveAll = do
  ConnWrapper
conn <- GP ConnWrapper
askConnection
  [[SqlValue]]
resultRows <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn.
IConnection conn =>
conn -> String -> [SqlValue] -> IO [[SqlValue]]
quickQuery ConnWrapper
conn String
stmt []
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Entity a => [SqlValue] -> GP a
fromRow [[SqlValue]]
resultRows
  where
    ti :: TypeInfo a
ti = forall a. Data a => TypeInfo a
typeInfoFromContext :: TypeInfo a
    stmt :: String
stmt = forall a. Entity a => TypeInfo a -> String
selectAllStmtFor TypeInfo a
ti 

retrieveAllWhere :: forall a. (Entity a) => String -> SqlValue -> GP [a]
retrieveAllWhere :: forall a. Entity a => String -> SqlValue -> GP [a]
retrieveAllWhere String
field SqlValue
val = do
  ConnWrapper
conn <- GP ConnWrapper
askConnection
  [[SqlValue]]
resultRows <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn.
IConnection conn =>
conn -> String -> [SqlValue] -> IO [[SqlValue]]
quickQuery ConnWrapper
conn String
stmt [SqlValue
val]
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Entity a => [SqlValue] -> GP a
fromRow [[SqlValue]]
resultRows
  where
    ti :: TypeInfo a
ti = forall a. Data a => TypeInfo a
typeInfoFromContext :: TypeInfo a
    stmt :: String
stmt = forall a. Entity a => TypeInfo a -> String -> String
selectAllWhereStmtFor TypeInfo a
ti String
field

-- | A function that persists an entity to a database.
-- The function takes an HDBC connection and an entity as parameters.
-- The entity is either inserted or updated, depending on whether it already exists in the database.
-- The required SQL statements are generated dynamically using Haskell generics and reflection
persist :: (Entity a) => a -> GP ()
persist :: forall a. Entity a => a -> GP ()
persist a
entity = do
  ConnWrapper
conn <- GP ConnWrapper
askConnection
  [[SqlValue]]
resultRows <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn.
IConnection conn =>
conn -> String -> [SqlValue] -> IO [[SqlValue]]
quickQuery ConnWrapper
conn String
preparedSelectStmt [SqlValue
eid]
  case [[SqlValue]]
resultRows of
    []           -> forall a. Entity a => a -> GP ()
insert a
entity
    [[SqlValue]
_singleRow] -> forall a. Entity a => a -> GP ()
update a
entity
    [[SqlValue]]
_            -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"More than one entity found for id " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SqlValue
eid
  where
    ti :: TypeInfo a
ti = forall a. Data a => a -> TypeInfo a
typeInfo a
entity
    eid :: SqlValue
eid = forall a. Entity a => a -> SqlValue
idValue a
entity
    preparedSelectStmt :: String
preparedSelectStmt = forall a. Entity a => TypeInfo a -> String
selectStmtFor TypeInfo a
ti

-- | A function that explicitely inserts an entity into a database.
insert :: (Entity a) => a -> GP ()
insert :: forall a. Entity a => a -> GP ()
insert a
entity = do
  ConnWrapper
conn <- GP ConnWrapper
askConnection
  [SqlValue]
row <- forall a. Entity a => a -> GP [SqlValue]
toRow a
entity
  Integer
_rowcount <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn.
IConnection conn =>
conn -> String -> [SqlValue] -> IO Integer
run ConnWrapper
conn (forall a. Entity a => a -> String
insertStmtFor a
entity) [SqlValue]
row
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn. IConnection conn => conn -> IO ()
commit ConnWrapper
conn

-- | A function that explicitely updates an entity in a database.
update :: (Entity a) => a -> GP ()
update :: forall a. Entity a => a -> GP ()
update a
entity = do
  ConnWrapper
conn <- GP ConnWrapper
askConnection
  [SqlValue]
row <- forall a. Entity a => a -> GP [SqlValue]
toRow a
entity
  Integer
_rowcount <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn.
IConnection conn =>
conn -> String -> [SqlValue] -> IO Integer
run ConnWrapper
conn (forall a. Entity a => a -> String
updateStmtFor a
entity) ([SqlValue]
row forall a. [a] -> [a] -> [a]
++ [forall a. Entity a => a -> SqlValue
idValue a
entity])
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn. IConnection conn => conn -> IO ()
commit ConnWrapper
conn

delete :: (Entity a) => a -> GP ()
delete :: forall a. Entity a => a -> GP ()
delete a
entity = do
  ConnWrapper
conn <- GP ConnWrapper
askConnection
  Integer
_rowCount <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn.
IConnection conn =>
conn -> String -> [SqlValue] -> IO Integer
run ConnWrapper
conn (forall a. Entity a => a -> String
deleteStmtFor a
entity) [forall a. Entity a => a -> SqlValue
idValue a
entity]
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn. IConnection conn => conn -> IO ()
commit ConnWrapper
conn

-- | set up a table for a given entity type. The table is dropped and recreated.
setupTableFor :: forall a. (Entity a) => GP a
setupTableFor :: forall a. Entity a => GP a
setupTableFor = do
  ConnWrapper
conn <- GP ConnWrapper
askConnection
  ()
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn. IConnection conn => conn -> String -> IO ()
runRaw ConnWrapper
conn (forall a. Entity a => TypeInfo a -> String
dropTableStmtFor TypeInfo a
ti)
  ()
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn. IConnection conn => conn -> String -> IO ()
runRaw ConnWrapper
conn (forall a. Entity a => TypeInfo a -> String
createTableStmtFor TypeInfo a
ti)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall conn. IConnection conn => conn -> IO ()
commit ConnWrapper
conn
  forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  where
    ti :: TypeInfo a
ti = forall a. Data a => TypeInfo a
typeInfoFromContext :: TypeInfo a
    x :: a
x = forall a. Entity a => TypeInfo a -> a
evidenceFrom TypeInfo a
ti :: a


-- | Lookup an entity in the cache, or retrieve it from the database.
--   The Entity is identified by its EntityId, which is a (typeRep, idValue) tuple.
getElseRetrieve :: forall a . (Entity a) => EntityId -> GP (Maybe a)
getElseRetrieve :: forall a. Entity a => EntityId -> GP (Maybe a)
getElseRetrieve eid :: EntityId
eid@(SomeTypeRep
_tr,SqlValue
pk) = do
  ResolutionCache
rc <- GP ResolutionCache
askCache
  case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup EntityId
eid ResolutionCache
rc of
    Just Dynamic
dyn -> case forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn :: Maybe a of
      Just a
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
e)
      Maybe a
Nothing -> forall a. HasCallStack => String -> a
error String
"should not be possible" 
    Maybe Dynamic
Nothing -> forall a id.
(Entity a, Convertible id SqlValue) =>
id -> GP (Maybe a)
retrieveById SqlValue
pk :: GP (Maybe a)


extendCtxCache :: Entity a => a -> Ctx -> Ctx
extendCtxCache :: forall a. Entity a => a -> Ctx -> Ctx
extendCtxCache a
x (Ctx ConnWrapper
conn ResolutionCache
rc) = ConnWrapper -> ResolutionCache -> Ctx
Ctx ConnWrapper
conn ((EntityId, Dynamic)
cacheEntry forall a. a -> [a] -> [a]
: ResolutionCache
rc)
  where
    cacheEntry :: (EntityId, Dynamic)
cacheEntry = (forall a. Entity a => a -> EntityId
entityId a
x, forall a. Typeable a => a -> Dynamic
toDyn a
x)


-- | Computes the EntityId of an entity.
--   The EntityId of an entity is a (typeRep, idValue) tuple.
entityId :: (Entity a) => a -> EntityId
entityId :: forall a. Entity a => a -> EntityId
entityId a
x = (forall a. Typeable a => a -> SomeTypeRep
typeOf a
x, forall a. Entity a => a -> SqlValue
idValue a
x)

-- | A function that returns the primary key value of an entity as a SqlValue.
idValue :: forall a. (Entity a) => a -> SqlValue
idValue :: forall a. Entity a => a -> SqlValue
idValue a
x = forall a. Data a => a -> String -> SqlValue
fieldValue a
x (forall a. Entity a => a -> String
idField a
x)

askConnection :: GP ConnWrapper
askConnection :: GP ConnWrapper
askConnection = Ctx -> ConnWrapper
connection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask

askCache :: GP ResolutionCache
askCache :: GP ResolutionCache
askCache = Ctx -> ResolutionCache
cache forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask

runGP :: (MonadIO m, IConnection conn) => conn -> RIO Ctx a -> m a
runGP :: forall (m :: * -> *) conn a.
(MonadIO m, IConnection conn) =>
conn -> RIO Ctx a -> m a
runGP conn
conn = forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (ConnWrapper -> ResolutionCache -> Ctx
Ctx (forall conn. IConnection conn => conn -> ConnWrapper
ConnWrapper conn
conn) forall a. Monoid a => a
mempty)

-- These instances are needed to make the Convertible type class work with Enum types out of the box.
instance {-# OVERLAPS #-} forall a . (Enum a) => Convertible SqlValue a where
  safeConvert :: SqlValue -> ConvertResult a
  safeConvert :: SqlValue -> ConvertResult a
safeConvert = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Convertible SqlValue a => SqlValue -> a
fromSql

instance {-# OVERLAPS #-} forall a . (Enum a) => Convertible a SqlValue where
  safeConvert :: a -> ConvertResult SqlValue
  safeConvert :: a -> ConvertResult SqlValue
safeConvert = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Convertible a SqlValue => a -> SqlValue
toSql forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum