module Database.Persist.Class.PersistUnique
( PersistUnique (..)
, getByValue
, insertBy
, replaceUnique
, checkUnique
) where
import qualified Prelude
import Prelude hiding ((++), show)
import Control.Monad (liftM)
import Control.Monad.Trans.Error (Error (..))
import Control.Monad.Trans.Class (lift)
import Data.Monoid (Monoid)
import Data.List ((\\))
import Data.Conduit.Internal (Pipe)
import Control.Monad.Logger (LoggingT)
import Control.Monad.Trans.Identity ( IdentityT)
import Control.Monad.Trans.List ( ListT )
import Control.Monad.Trans.Maybe ( MaybeT )
import Control.Monad.Trans.Error ( ErrorT )
#if MIN_VERSION_transformers(0,4,0)
import Control.Monad.Trans.Except ( ExceptT )
#endif
import Control.Monad.Trans.Reader ( ReaderT )
import Control.Monad.Trans.Cont ( ContT )
import Control.Monad.Trans.State ( StateT )
import Control.Monad.Trans.Writer ( WriterT )
import Control.Monad.Trans.RWS ( RWST )
import Control.Monad.Trans.Resource ( ResourceT)
import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )
import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
import Database.Persist.Class.PersistStore
import Database.Persist.Class.PersistEntity
class PersistStore m => PersistUnique m where
getBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m (Maybe (Entity val))
deleteBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m ()
insertUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => val -> m (Maybe (Key val))
insertUnique datum = do
conflict <- checkUnique datum
case conflict of
Nothing -> Just `liftM` insert datum
Just _ -> return Nothing
insertBy :: (PersistEntity val, PersistUnique m, PersistEntityBackend val ~ PersistMonadBackend m)
=> val -> m (Either (Entity val) (Key val))
insertBy val = do
res <- getByValue val
case res of
Nothing -> Right `liftM` insert val
Just z -> return $ Left z
getByValue :: (PersistEntity value, PersistUnique m, PersistEntityBackend value ~ PersistMonadBackend m)
=> value -> m (Maybe (Entity value))
getByValue = checkUniques . persistUniqueKeys
where
checkUniques [] = return Nothing
checkUniques (x:xs) = do
y <- getBy x
case y of
Nothing -> checkUniques xs
Just z -> return $ Just z
replaceUnique :: (Eq record, Eq (Unique record), PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistStore m, PersistUnique m)
=> Key record -> record -> m (Maybe (Unique record))
replaceUnique key datumNew = getJust key >>= replaceOriginal
where
uniqueKeysNew = persistUniqueKeys datumNew
replaceOriginal original = do
conflict <- checkUniqueKeys changedKeys
case conflict of
Nothing -> replace key datumNew >> return Nothing
(Just conflictingKey) -> return $ Just conflictingKey
where
changedKeys = uniqueKeysNew \\ uniqueKeysOriginal
uniqueKeysOriginal = persistUniqueKeys original
checkUnique :: (PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistUnique m)
=> record -> m (Maybe (Unique record))
checkUnique = checkUniqueKeys . persistUniqueKeys
checkUniqueKeys :: (PersistEntity record, PersistUnique m, PersistEntityBackend record ~ PersistMonadBackend m)
=> [Unique record] -> m (Maybe (Unique record))
checkUniqueKeys [] = return Nothing
checkUniqueKeys (x:xs) = do
y <- getBy x
case y of
Nothing -> checkUniqueKeys xs
Just _ -> return (Just x)
#define DEF(T) { getBy = lift . getBy; deleteBy = lift . deleteBy; insertUnique = lift . insertUnique }
#define GO(T) instance (PersistUnique m) => PersistUnique (T m) where DEF(T)
#define GOX(X, T) instance (X, PersistUnique m) => PersistUnique (T m) where DEF(T)
GO(LoggingT)
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GOX(Error e, ErrorT e)
#if MIN_VERSION_transformers(0,4,0)
GO(ExceptT e)
#endif
GO(ReaderT r)
GO(ContT r)
GO(StateT s)
GO(ResourceT)
GO(Pipe l i o u)
GOX(Monoid w, WriterT w)
GOX(Monoid w, RWST r w s)
GOX(Monoid w, Strict.RWST r w s)
GO(Strict.StateT s)
GOX(Monoid w, Strict.WriterT w)
#undef DEF
#undef GO
#undef GOX