157 lines
6.5 KiB
Haskell
157 lines
6.5 KiB
Haskell
module Utils.DB where
|
|
|
|
import ClassyPrelude.Yesod
|
|
|
|
import qualified Data.List as List
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import qualified Database.Esqueleto as E
|
|
-- import Database.Persist -- currently not needed here
|
|
|
|
import Utils
|
|
import Control.Lens
|
|
import Control.Lens.Extras (is)
|
|
|
|
import Control.Monad.Catch
|
|
|
|
|
|
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
|
|
|
|
getJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
|
=> Unique record -> ReaderT backend m (Entity record)
|
|
getJustBy u = getBy u >>= maybe
|
|
(throwM . PersistForeignConstraintUnmet $ tshow u)
|
|
return
|
|
|
|
getKeyBy :: (PersistRecordBackend record backend, 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!
|
|
|
|
getKeyJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
|
=> Unique record -> ReaderT backend m (Key record)
|
|
getKeyJustBy u = getKeyBy u >>= maybe
|
|
(throwM . PersistForeignConstraintUnmet $ tshow u)
|
|
return
|
|
|
|
getKeyBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
|
|
=> Unique record -> ReaderT backend m (Key record)
|
|
getKeyBy404 u = getKeyBy u >>= maybe notFound return
|
|
|
|
getEntity404 :: (PersistStoreRead backend, PersistRecordBackend record backend, MonadHandler m)
|
|
=> Key record -> ReaderT backend m (Entity record)
|
|
getEntity404 k = Entity k <$> get404 k
|
|
|
|
existsBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
|
|
=> Unique record -> ReaderT backend m Bool
|
|
existsBy = fmap (is _Just) . getKeyBy
|
|
|
|
existsBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
|
|
=> Unique record -> ReaderT backend m ()
|
|
existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy
|
|
|
|
existsKey :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
|
=> Key record -> ReaderT backend m Bool
|
|
existsKey = exists . pure . (persistIdField ==.)
|
|
|
|
-- -- Available in persistent since 2.11.0.0
|
|
-- exists :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
|
-- => [Filter record] -> ReaderT backend m Bool
|
|
-- exists = fmap (not . null) . flip selectKeysList [LimitTo 1]
|
|
|
|
exists404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
|
|
=> [Filter record] -> ReaderT backend m ()
|
|
exists404 = bool (return ()) notFound <=< fmap null . flip selectKeysList [LimitTo 1]
|
|
|
|
existsKey404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
|
|
=> Key record -> ReaderT backend m ()
|
|
existsKey404 = bool notFound (return ()) <=< existsKey
|
|
|
|
updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
|
|
=> Unique record -> [Update record] -> ReaderT backend m ()
|
|
updateBy uniq updates = do
|
|
key <- getKeyBy uniq
|
|
for_ key $ flip update updates
|
|
|
|
updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record)
|
|
updateGetEntity k = fmap (Entity k) . updateGet k
|
|
|
|
-- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible,
|
|
-- and 'Just key' for the successfully replaced record
|
|
uniqueReplace :: ( MonadIO m
|
|
, Eq (Unique record)
|
|
, PersistRecordBackend record backend
|
|
, PersistUniqueWrite backend
|
|
)
|
|
=> Key record -> record -> ReaderT backend m (Maybe (Key record))
|
|
uniqueReplace key datumNew = flipMaybe key <$> myReplaceUnique key datumNew
|
|
|
|
-- | Identical to 'Database.Persist.Class', except for the better type signature (original requires Eq record which is not needed anyway)
|
|
myReplaceUnique :: ( 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
|
|
|
|
replaceEntity :: ( MonadIO m
|
|
, PersistRecordBackend record backend
|
|
, PersistStoreWrite backend
|
|
)
|
|
=> Entity record -> ReaderT backend m ()
|
|
replaceEntity Entity{..} = replace entityKey entityVal
|
|
|
|
checkUniqueKeys :: ( MonadIO m
|
|
, 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)
|
|
|
|
|
|
put :: ( MonadIO m
|
|
, PersistUniqueWrite backend
|
|
, PersistRecordBackend record backend
|
|
)
|
|
=> record -> ReaderT backend m (Key record)
|
|
-- ^ `insert`, but remove all records with matching uniqueness constraints first
|
|
put v = do
|
|
forM_ (persistUniqueKeys v) deleteBy
|
|
insert v
|
|
|
|
selectMaybe :: forall record backend m.
|
|
( MonadIO m
|
|
, PersistQueryRead backend
|
|
, PersistRecordBackend record backend
|
|
)
|
|
=> [Filter record] -> [SelectOpt record]
|
|
-> ReaderT backend m (Maybe (Entity record))
|
|
selectMaybe fltrs opts = listToMaybe <$> selectList fltrs (LimitTo 1 : opts')
|
|
where opts' = filter (not . isLimit) opts
|
|
isLimit = \case
|
|
LimitTo _ -> True
|
|
_other -> False
|
|
|