68 lines
2.9 KiB
Haskell
68 lines
2.9 KiB
Haskell
module Utils.DB where
|
|
|
|
import ClassyPrelude.Yesod
|
|
|
|
import qualified Data.List as List
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import qualified Database.Esqueleto as E
|
|
-- import Database.Persist -- currently not needed here
|
|
|
|
emptyOrIn :: PersistField typ =>
|
|
E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
|
|
emptyOrIn criterion testSet
|
|
| Set.null testSet = E.val True
|
|
| otherwise = criterion `E.in_` E.valList (Set.toList testSet)
|
|
|
|
entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
|
|
entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
|
|
|
|
getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
|
=> Unique record -> ReaderT backend m (Maybe (Key record))
|
|
getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
|
|
|
|
getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
|
=> Unique record -> ReaderT backend m (Key record)
|
|
getKeyBy404 = fmap entityKey . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
|
|
|
|
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
|
=> Unique record -> ReaderT backend m Bool
|
|
existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record
|
|
|
|
existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m)
|
|
=> Key record -> ReaderT backend m Bool
|
|
existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
|
|
|
|
myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq record which is not needed anyway)
|
|
:: (MonadIO m
|
|
,Eq (Unique record)
|
|
,PersistRecordBackend record backend
|
|
,PersistUniqueWrite backend)
|
|
=> Key record -> record -> ReaderT backend m (Maybe (Unique record))
|
|
myReplaceUnique 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 List.\\ uniqueKeysOriginal
|
|
uniqueKeysOriginal = persistUniqueKeys original
|
|
|
|
checkUniqueKeys
|
|
:: (MonadIO m
|
|
,PersistEntity record
|
|
,PersistUniqueRead backend
|
|
,PersistRecordBackend record backend)
|
|
=> [Unique record] -> ReaderT backend m (Maybe (Unique record))
|
|
checkUniqueKeys [] = return Nothing
|
|
checkUniqueKeys (x:xs) = do
|
|
y <- getBy x
|
|
case y of
|
|
Nothing -> checkUniqueKeys xs
|
|
Just _ -> return (Just x)
|