-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later -- also see Utils.Persist module Utils.DB where import ClassyPrelude.Yesod hiding (addMessageI) import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import qualified Database.Esqueleto.Legacy as E import Utils import Control.Lens import Control.Lens.Extras (is) import Control.Monad.Catch hiding (bracket) import qualified Utils.Pool as Custom import Database.Persist.Sql (runSqlConn) -- , updateWhereCount) import GHC.Stack (HasCallStack, CallStack, callStack) -- import Control.Monad.Fix (MonadFix) -- import Control.Monad.Fail (MonadFail) -- import Control.Monad.Trans.Reader (withReaderT) -- | Obtain a record projection from an EntityField getFieldEnt :: PersistEntity record => EntityField record typ -> Entity record -> typ getFieldEnt = view . fieldLens getField :: PersistEntity record => EntityField record typ -> record -> typ getField = view . fieldLensVal -- | Obtain a lens from an EntityField fieldLensVal :: PersistEntity record => EntityField record typ -> Lens' record typ fieldLensVal f = entityLens . fieldLens f where entityLens :: Lens' record (Entity record) entityLens = lens getVal setVal getVal :: record -> Entity record getVal = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally setVal :: record -> Entity record -> record setVal _ = entityVal 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 notExists :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) => [Filter record] -> ReaderT backend m Bool notExists = fmap not . exists 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 -- | given filter criteria like `selectList` this function returns Just if and only if there is precisely one result -- getByPeseudoUnique getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) => [Filter record] -> ReaderT backend m (Maybe (Entity record)) getByFilter crit = selectList crit [LimitTo 2] <&> \case [singleEntity] -> Just singleEntity _ -> Nothing -- not existing or not unique getKeyByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) => [Filter record] -> ReaderT backend m (Maybe (Key record)) getKeyByFilter crit = selectKeysList crit [LimitTo 2] <&> \case [singleKey] -> Just singleKey _ -> Nothing -- not existing or not unique 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 -- | update and retrieve an entity. Will throw an error if the key is updaded updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record) updateGetEntity k = fmap (Entity k) . updateGet k -- | insert or replace a record based on a single uniqueness constraint -- this function was meant to be supplied with the uniqueness constraint, but it would be unsafe if the uniqueness constraint would not match the supplied record replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend) => record -> ReaderT backend m () replaceBy r = do u <- onlyUnique r deleteBy u insert_ r -- | 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 -- Notes on upsertBy: -- * Unique denotes old record -- * Changes to fields involved in uniqueness work, but may throw an error if updated record already exists -- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint upsertBySafe :: ( MonadIO m , PersistEntity record , PersistUniqueWrite backend , PersistEntityBackend record ~ BaseBackend backend ) => Unique record -> record -> (record -> record) -> ReaderT backend m (Maybe (Key record)) upsertBySafe uniq newr upd = maybeM (insertUnique newr) do_upd (getBy uniq) where do_upd Entity{entityKey = oid, entityVal = oldr} = do delete oid insertUnique $ upd oldr 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 type DBConnLabel = CallStack customRunSqlPool :: (HasCallStack, MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Custom.Pool' m DBConnLabel c backend -> m a customRunSqlPool act p = customRunSqlPool' act p callStack customRunSqlPool' :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Custom.Pool' m DBConnLabel c backend -> CallStack -> m a customRunSqlPool' act p label = Custom.withResource' p label $ runSqlConn act class WithRunDB backend m' m | m -> backend m' where useRunDB :: ReaderT backend m' a -> m a instance WithRunDB backend m (ReaderT backend m) where useRunDB = id -- Could be used at Handler.Admin.postAdminProblemsR, but not yet elsewhere, thus inlined for now, as it may be too special: -- updateWithMessage -- :: ( YesodPersist site, PersistEntity val, BackendCompatible SqlBackend (YesodPersistBackend site), PersistEntityBackend val ~ SqlBackend -- , Num a, Ord a, RenderMessage site msg, RedirectUrl site (url,[(Text,Text)])) -- => url -- where to redirect, if changes were mage -- -> [Filter val] -- update filter -- -> [Update val] -- actual update -- -> a -- expected updates -- -> (a -> msg) -- message to add with number of actual changes -- -> HandlerFor site () -- updateWithMessage route flt upd no_req msg = do -- (fromIntegral -> oks) <- runDB $ updateWhereCount flt upd -- let mkind = if oks < no_req || no_req <= 0 then Warning else Success -- addMessageI mkind $ msg oks -- when (oks > 0) $ do -- reload to ensure updates are displayed -- getps <- reqGetParams <$> getRequest -- redirect (route, getps) -- newtype DBRunner' backend m = DBRunner' { runDBRunner' :: forall b. ReaderT backend m b -> m b } -- _DBRunner' :: Iso' (DBRunner site) (DBRunner' (YesodPersistBackend site) (HandlerFor site)) -- _DBRunner' = iso fromDBRunner' toDBRunner -- where -- fromDBRunner' :: forall site. -- DBRunner site -- -> DBRunner' (YesodPersistBackend site) (HandlerFor site) -- fromDBRunner' DBRunner{..} = DBRunner' runDBRunner -- toDBRunner :: forall site. -- DBRunner' (YesodPersistBackend site) (HandlerFor site) -- -> DBRunner site -- toDBRunner DBRunner'{..} = DBRunner runDBRunner' -- fromDBRunner :: BackendCompatible backend (YesodPersistBackend site) => DBRunner site -> DBRunner' backend (HandlerFor site) -- fromDBRunner DBRunner{..} = DBRunner' (runDBRunner . withReaderT projectBackend) -- newtype CachedDBRunner backend m a = CachedDBRunner { runCachedDBRunnerUsing :: m (DBRunner' backend m) -> m a } -- deriving (Functor, Applicative, Monad, MonadFix, MonadFail, Contravariant, MonadIO, Alternative, MonadPlus, MonadUnliftIO, MonadResource, MonadLogger, MonadThrow, MonadCatch, MonadMask) via (ReaderT (m (DBRunner' backend m)) m) -- instance MonadTrans (CachedDBRunner backend) where -- lift act = CachedDBRunner (const act) -- instance MonadHandler m => MonadHandler (CachedDBRunner backend m) where -- type HandlerSite (CachedDBRunner backend m) = HandlerSite m -- type SubHandlerSite (CachedDBRunner backend m) = SubHandlerSite m -- liftHandler = lift . liftHandler -- liftSubHandler = lift . liftSubHandler -- instance Monad m => WithRunDB backend m (CachedDBRunner backend m) where -- useRunDB act = CachedDBRunner (\getRunner -> getRunner >>= \DBRunner'{..} -> runDBRunner' act) -- runCachedDBRunnerSTM :: MonadUnliftIO m -- => m (DBRunner' backend m) -- -> CachedDBRunner backend m a -- -> m a -- runCachedDBRunnerSTM doAcquire act = do -- doAcquireLock <- newTMVarIO () -- runnerTMVar <- newEmptyTMVarIO -- let getRunner = bracket (atomically $ takeTMVar doAcquireLock) (void . atomically . tryPutTMVar doAcquireLock) . const $ do -- cachedRunner <- atomically $ tryReadTMVar runnerTMVar -- case cachedRunner of -- Just cachedRunner' -> return cachedRunner' -- Nothing -> do -- runner <- doAcquire -- void . atomically $ tryPutTMVar runnerTMVar runner -- return runner -- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar) -- runCachedDBRunnerUsing act getRunnerNoLock -- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens data CheckUpdate record iraw = forall typ. (Eq typ, PersistField typ) => CheckUpdate (EntityField record typ) (Getting typ iraw typ) -- A persistent record field and fitting getting mayUpdate :: PersistEntity record => record -> Maybe iraw -> CheckUpdate record iraw -> Bool mayUpdate ent (Just old) (CheckUpdate up l) | let oldval = old ^. l , let entval = ent ^. fieldLensVal up = oldval == entval mayUpdate _ _ _ = False -- | Compute necessary updates. Given a database record, the new and old raw data, and a pair consisting of a getter from raw data to a value and an EntityField of the same value, -- an update is returned, if the current value is identical to the old value, which changed in the new raw data mkUpdate :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record) mkUpdate ent new (Just old) (CheckUpdate up l) | let newval = new ^. l , let oldval = old ^. l , let entval = ent ^. fieldLensVal up , newval /= entval , oldval == entval = Just (up =. newval) mkUpdate _ _ _ _ = Nothing -- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited mkUpdate' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record) mkUpdate' ent new Nothing = mkUpdateDirect ent new mkUpdate' ent new just = mkUpdate ent new just mkUpdateDirect :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> Maybe (Update record) mkUpdateDirect ent new (CheckUpdate up l) | let newval = new ^. l , let entval = ent ^. fieldLensVal up , newval /= entval = Just (up =. newval) mkUpdateDirect _ _ _ = Nothing -- | Unconditionally update a record through ChecUpdate updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record updateRecord ent new (CheckUpdate up l) = let newval = new ^. l lensRec = fieldLensVal up in ent & lensRec .~ newval -- | like mkUpdate' but only returns the update if the new value would be unique -- mkUpdateCheckUnique' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> DB (Maybe (Update record)) mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) => record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record)) mkUpdateCheckUnique' ent new Nothing (CheckUpdate up l) | let newval = new ^. l , let entval = ent ^. fieldLensVal up , newval /= entval = do newval_exists <- exists [up ==. newval] return $ toMaybe (not newval_exists) (up =. newval) mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l) | let newval = new ^. l , let oldval = old ^. l , let entval = ent ^. fieldLensVal up , newval /= entval , oldval == entval = do newval_exists <- exists [up ==. newval] return $ toMaybe (not newval_exists) (up =. newval) mkUpdateCheckUnique' _ _ _ _ = return Nothing