{-# language DataKinds              #-}
{-# language FlexibleContexts       #-}
{-# language FlexibleInstances      #-}
{-# language FunctionalDependencies #-}
{-# language GADTs                  #-}
{-# language KindSignatures         #-}
{-# language ScopedTypeVariables    #-}
{-# language TypeApplications       #-}
{-# language TypeOperators          #-}
{-# language UndecidableInstances   #-}
{-|
Description : Utilities for interoperation between Mu and Persistent

The @persistent@ library, and in particular its quasi-quoters
for entities, generate data types which do not look exactly as
plain records. This module defines some wrappers which modify
the 'ToSchema' and 'FromSchema' derivation to work with them.
-}
module Mu.Adapter.Persistent (
  -- * Wrappers for use with @DerivingVia@
  WithEntityNestedId(..)
, WithEntityPlainId(..)
  -- * Generic utilities
, runDb, Pool, runDbPool
) where

import           Control.Monad.IO.Class
import           Control.Monad.Logger
import           Control.Monad.Trans.Reader
import           Control.Monad.Trans.Resource.Internal
import           Data.Int
import           Data.Pool                             (Pool)
import           Database.Persist.Sql
import           GHC.Generics
import           GHC.TypeLits

import           Mu.Schema
import           Mu.Schema.Class

-- | Wrapper for 'Entity' to be used with @DerivingVia@.
--   This wrappers indicates that the identifier is to be found
--   as the sole field of another object, like in:
--
--   > { id: { key: 3 }, name: "Somebody" }
newtype WithEntityNestedId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a
  = WithEntityNestedId { WithEntityNestedId ty fmap a -> a
unWithEntityNestedId :: a }

-- | Wrapper for 'Entity' to be used with @DerivingVia@.
--   This wrappers indicates that the identifier is to be found
--   in the schema at the same level as other fields, like in:
--
--   > { id: 3, name: "Somebody" }
newtype WithEntityPlainId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a
  = WithEntityPlainId { WithEntityPlainId ty fmap a -> a
unWithEntityPlainId :: a }

instance ( Generic t
         , (sch :/: sty) ~ 'DRecord name (idArg ': args)
         , idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64)
         , Rep t ~ D1 dInfo (C1 cInfo f)
         , GToSchemaRecord sch fmap args f
         , ToBackendKey (PersistEntityBackend t) t
         , PersistEntityBackend t ~ SqlBackend )
         => ToSchema sch sty (WithEntityPlainId sty fmap (Entity t)) where
  toSchema :: WithEntityPlainId sty fmap (Entity t) -> Term sch (sch :/: sty)
toSchema (WithEntityPlainId (Entity Key t
key t
x))
    = NP (Field sch) ('FieldDef idArgName ('TPrimitive Int64) : args)
-> Term
     sch
     ('DRecord name ('FieldDef idArgName ('TPrimitive Int64) : args))
forall typeName fieldName (sch :: Schema typeName fieldName)
       (args :: [FieldDef typeName fieldName]) (name :: typeName).
NP (Field sch) args -> Term sch ('DRecord name args)
TRecord (NP (Field sch) ('FieldDef idArgName ('TPrimitive Int64) : args)
 -> Term
      sch
      ('DRecord name ('FieldDef idArgName ('TPrimitive Int64) : args)))
-> NP (Field sch) ('FieldDef idArgName ('TPrimitive Int64) : args)
-> Term
     sch
     ('DRecord name ('FieldDef idArgName ('TPrimitive Int64) : args))
forall a b. (a -> b) -> a -> b
$ FieldValue sch ('TPrimitive Int64)
-> Field sch ('FieldDef idArgName ('TPrimitive Int64))
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName) (name :: fieldName).
FieldValue sch t -> Field sch ('FieldDef name t)
Field (Int64 -> FieldValue sch ('TPrimitive Int64)
forall typeName fieldName t1 (sch :: Schema typeName fieldName).
t1 -> FieldValue sch ('TPrimitive t1)
FPrimitive (BackendKey SqlBackend -> Int64
unSqlBackendKey (BackendKey SqlBackend -> Int64) -> BackendKey SqlBackend -> Int64
forall a b. (a -> b) -> a -> b
$ Key t -> BackendKey SqlBackend
forall backend record.
ToBackendKey backend record =>
Key record -> BackendKey backend
toBackendKey Key t
key))
      Field sch ('FieldDef idArgName ('TPrimitive Int64))
-> NP (Field sch) args
-> NP (Field sch) ('FieldDef idArgName ('TPrimitive Int64) : args)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* Proxy fmap -> f Any -> NP (Field sch) args
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (args :: [FieldDef ts fs]) (f :: * -> *) a.
GToSchemaRecord sch fmap args f =>
Proxy fmap -> f a -> NP (Field sch) args
toSchemaRecord (Proxy fmap
forall k (t :: k). Proxy t
Proxy @fmap) (M1 C cInfo f Any -> f Any
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (M1 C cInfo f Any -> f Any) -> M1 C cInfo f Any -> f Any
forall a b. (a -> b) -> a -> b
$ M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any)
-> M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any
forall a b. (a -> b) -> a -> b
$ t -> Rep t Any
forall a x. Generic a => a -> Rep a x
from t
x)

instance ( Generic t
         , (sch :/: sty) ~ 'DRecord name (nestedIdArg ': args)
         , nestedIdArg ~ 'Mu.Schema.FieldDef fname k
         , ToSchemaKey sch idTy k
         , (sch :/: idTy) ~ 'DRecord idName '[idArg]
         , idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64)
         , Rep t ~ D1 dInfo (C1 cInfo f)
         , GToSchemaRecord sch fmap args f
         , ToBackendKey (PersistEntityBackend t) t
         , PersistEntityBackend t ~ SqlBackend )
         => ToSchema sch sty (WithEntityNestedId sty fmap (Entity t)) where
  toSchema :: WithEntityNestedId sty fmap (Entity t) -> Term sch (sch :/: sty)
toSchema (WithEntityNestedId (Entity Key t
key t
x))
    = NP (Field sch) ('FieldDef fname k : args)
-> Term sch ('DRecord name ('FieldDef fname k : args))
forall typeName fieldName (sch :: Schema typeName fieldName)
       (args :: [FieldDef typeName fieldName]) (name :: typeName).
NP (Field sch) args -> Term sch ('DRecord name args)
TRecord (NP (Field sch) ('FieldDef fname k : args)
 -> Term sch ('DRecord name ('FieldDef fname k : args)))
-> NP (Field sch) ('FieldDef fname k : args)
-> Term sch ('DRecord name ('FieldDef fname k : args))
forall a b. (a -> b) -> a -> b
$ FieldValue sch k -> Field sch ('FieldDef fname k)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName) (name :: fieldName).
FieldValue sch t -> Field sch ('FieldDef name t)
Field (FieldValue sch ('TSchematic idTy) -> FieldValue sch k
forall (sch :: Schema Symbol Symbol) (idTy :: Symbol)
       (t :: FieldTypeB * Symbol).
ToSchemaKey sch idTy t =>
FieldValue sch ('TSchematic idTy) -> FieldValue sch t
toSchemaKey (FieldValue sch ('TSchematic idTy) -> FieldValue sch k)
-> FieldValue sch ('TSchematic idTy) -> FieldValue sch k
forall a b. (a -> b) -> a -> b
$ Term sch (sch :/: idTy) -> FieldValue sch ('TSchematic idTy)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t1 :: typeName).
Term sch (sch :/: t1) -> FieldValue sch ('TSchematic t1)
FSchematic (Term sch (sch :/: idTy) -> FieldValue sch ('TSchematic idTy))
-> Term sch (sch :/: idTy) -> FieldValue sch ('TSchematic idTy)
forall a b. (a -> b) -> a -> b
$ NP (Field sch) '[ 'FieldDef idArgName ('TPrimitive Int64)]
-> Term
     sch ('DRecord idName '[ 'FieldDef idArgName ('TPrimitive Int64)])
forall typeName fieldName (sch :: Schema typeName fieldName)
       (args :: [FieldDef typeName fieldName]) (name :: typeName).
NP (Field sch) args -> Term sch ('DRecord name args)
TRecord (FieldValue sch ('TPrimitive Int64)
-> Field sch ('FieldDef idArgName ('TPrimitive Int64))
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName) (name :: fieldName).
FieldValue sch t -> Field sch ('FieldDef name t)
Field (Int64 -> FieldValue sch ('TPrimitive Int64)
forall typeName fieldName t1 (sch :: Schema typeName fieldName).
t1 -> FieldValue sch ('TPrimitive t1)
FPrimitive Int64
key') Field sch ('FieldDef idArgName ('TPrimitive Int64))
-> NP (Field sch) '[]
-> NP (Field sch) '[ 'FieldDef idArgName ('TPrimitive Int64)]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (Field sch) '[]
forall k (a :: k -> *). NP a '[]
Nil))
      Field sch ('FieldDef fname k)
-> NP (Field sch) args -> NP (Field sch) ('FieldDef fname k : args)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* Proxy fmap -> f Any -> NP (Field sch) args
forall ts fs (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
       (args :: [FieldDef ts fs]) (f :: * -> *) a.
GToSchemaRecord sch fmap args f =>
Proxy fmap -> f a -> NP (Field sch) args
toSchemaRecord (Proxy fmap
forall k (t :: k). Proxy t
Proxy @fmap) (M1 C cInfo f Any -> f Any
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (M1 C cInfo f Any -> f Any) -> M1 C cInfo f Any -> f Any
forall a b. (a -> b) -> a -> b
$ M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any)
-> M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any
forall a b. (a -> b) -> a -> b
$ t -> Rep t Any
forall a x. Generic a => a -> Rep a x
from t
x)
    where key' :: Int64
key' = BackendKey SqlBackend -> Int64
unSqlBackendKey (BackendKey SqlBackend -> Int64) -> BackendKey SqlBackend -> Int64
forall a b. (a -> b) -> a -> b
$ Key t -> BackendKey SqlBackend
forall backend record.
ToBackendKey backend record =>
Key record -> BackendKey backend
toBackendKey Key t
key

class ToSchemaKey (sch :: Schema') (idTy :: Symbol) t | sch t -> idTy where
  toSchemaKey :: FieldValue sch ('TSchematic idTy) -> FieldValue sch t
instance ToSchemaKey sch idTy ('TSchematic idTy) where
  toSchemaKey :: FieldValue sch ('TSchematic idTy)
-> FieldValue sch ('TSchematic idTy)
toSchemaKey = FieldValue sch ('TSchematic idTy)
-> FieldValue sch ('TSchematic idTy)
forall a. a -> a
id
instance ToSchemaKey sch idTy t => ToSchemaKey sch idTy ('TOption t) where
  toSchemaKey :: FieldValue sch ('TSchematic idTy) -> FieldValue sch ('TOption t)
toSchemaKey = Maybe (FieldValue sch t) -> FieldValue sch ('TOption t)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t1 :: FieldType typeName).
Maybe (FieldValue sch t1) -> FieldValue sch ('TOption t1)
FOption (Maybe (FieldValue sch t) -> FieldValue sch ('TOption t))
-> (FieldValue sch ('TSchematic idTy) -> Maybe (FieldValue sch t))
-> FieldValue sch ('TSchematic idTy)
-> FieldValue sch ('TOption t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldValue sch t -> Maybe (FieldValue sch t)
forall a. a -> Maybe a
Just (FieldValue sch t -> Maybe (FieldValue sch t))
-> (FieldValue sch ('TSchematic idTy) -> FieldValue sch t)
-> FieldValue sch ('TSchematic idTy)
-> Maybe (FieldValue sch t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldValue sch ('TSchematic idTy) -> FieldValue sch t
forall (sch :: Schema Symbol Symbol) (idTy :: Symbol)
       (t :: FieldTypeB * Symbol).
ToSchemaKey sch idTy t =>
FieldValue sch ('TSchematic idTy) -> FieldValue sch t
toSchemaKey

-- | Simple utility to execute a database operation
--   in any monad which supports 'IO' operations.
--   Note that all logging messages are discarded.
runDb :: MonadIO m
      => SqlBackend
      -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
      -> m a
runDb :: SqlBackend
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a
runDb = (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a)
 -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a)
-> (SqlBackend
    -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a)
-> SqlBackend
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
 -> SqlBackend -> IO a)
-> SqlBackend
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> SqlBackend -> IO a
forall backend a.
BackendCompatible SqlBackend backend =>
ReaderT backend (NoLoggingT (ResourceT IO)) a -> backend -> IO a
runSqlPersistM

-- | Simple utility to execute a database operation
--   in any monad which supports 'IO' operations.
--   Note that all logging messages are discarded.
runDbPool :: MonadIO m
          => Pool SqlBackend
          -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
          -> m a
runDbPool :: Pool SqlBackend
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a
runDbPool = (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a)
 -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a)
-> (Pool SqlBackend
    -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a)
-> Pool SqlBackend
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
 -> Pool SqlBackend -> IO a)
-> Pool SqlBackend
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> Pool SqlBackend -> IO a
forall backend a.
BackendCompatible SqlBackend backend =>
ReaderT backend (NoLoggingT (ResourceT IO)) a
-> Pool backend -> IO a
runSqlPersistMPool