{-# 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
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
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
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
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
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
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
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)
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)
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)
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