diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,16 @@ # Changelog for persistent +## 2.14.5.0 + +* [#1469](https://github.com/yesodweb/persistent/pull/1469) + * Change default implementation for `insertUnique_` to not perform + unecessary queries (mirrors 1449) +* [#1437](https://github.com/yesodweb/persistent/pull/1437) + * Add `existsBy` to `PersistUniqueRead` + ## 2.14.4.5 -* [#1460] https://github.com/yesodweb/persistent/pull/1468 +* [#1460](https://github.com/yesodweb/persistent/pull/1468) * Remove extraneous `map toPersistValue` call in the `mkInsertValues` function, as it evaluates to `id`. * [#1476](https://github.com/yesodweb/persistent/pull/1476) @@ -10,7 +18,7 @@ ## 2.14.4.4 -* [#1460] https://github.com/yesodweb/persistent/pull/1460 +* [#1460](https://github.com/yesodweb/persistent/pull/1460) * Fix a problem where a `Primary` key causes `mkPersist` to generate code that doesn't compile under `NoFieldSelectors` diff --git a/Database/Persist/Class/PersistUnique.hs b/Database/Persist/Class/PersistUnique.hs --- a/Database/Persist/Class/PersistUnique.hs +++ b/Database/Persist/Class/PersistUnique.hs @@ -33,7 +33,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, isJust) import GHC.TypeLits (ErrorMessage(..)) import Database.Persist.Class.PersistEntity @@ -78,6 +78,26 @@ :: forall record m. (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m (Maybe (Entity record)) + -- | Returns True if a record with this unique key exists, otherwise False. + -- + -- === __Example usage__ + -- + -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>: + -- + -- > existsBySpjName :: MonadIO m => ReaderT SqlBackend m Bool + -- > existsBySpjName = existsBy $ UniqueUserName "SPJ" + -- + -- > spjEntExists <- existsBySpjName + -- + -- The above query when applied on <#dataset-persist-unique-1 dataset-1>, will return + -- the value True. + -- + -- @since 2.14.5 + existsBy + :: forall record m. (MonadIO m, PersistRecordBackend record backend) + => Unique record -> ReaderT backend m Bool + existsBy uniq = isJust <$> getBy uniq + -- | Some functions in this module ('insertUnique', 'insertBy', and -- 'replaceUnique') first query the unique indexes to check for -- conflicts. You could instead optimistically attempt to perform the @@ -138,6 +158,37 @@ conflict <- checkUnique datum case conflict of Nothing -> Just `liftM` insert datum + Just _ -> return Nothing + + -- | Same as 'insertUnique' but doesn't return a @Key@. + -- + -- === __Example usage__ + -- + -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>, we try to insert the following two records: + -- + -- > linusId <- insertUnique_ $ User "Linus" 48 + -- > spjId <- insertUnique_ $ User "SPJ" 90 + -- + -- > +-----+------+-----+ + -- > |id |name |age | + -- > +-----+------+-----+ + -- > |1 |SPJ |40 | + -- > +-----+------+-----+ + -- > |2 |Simon |41 | + -- > +-----+------+-----+ + -- > |3 |Linus |48 | + -- > +-----+------+-----+ + -- + -- Linus's record was inserted to <#dataset-persist-unique-1 dataset-1>, while SPJ wasn't because SPJ already exists in <#dataset-persist-unique-1 dataset-1>. + -- + -- @since 2.14.5.0 + insertUnique_ + :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) + => record -> ReaderT backend m (Maybe ()) + insertUnique_ datum = do + conflict <- checkUnique datum + case conflict of + Nothing -> Just `liftM` insert_ datum Just _ -> return Nothing -- | Update based on a uniqueness constraint or insert: diff --git a/Database/Persist/Compatible/Types.hs b/Database/Persist/Compatible/Types.hs --- a/Database/Persist/Compatible/Types.hs +++ b/Database/Persist/Compatible/Types.hs @@ -12,10 +12,10 @@ ( Compatible(..) ) where +import Control.Monad.Trans.Reader (withReaderT) import Data.Aeson import Database.Persist.Class import Database.Persist.Sql.Class -import Control.Monad.Trans.Reader (withReaderT) -- | A newtype wrapper for compatible backends, mainly useful for @DerivingVia@. @@ -104,6 +104,7 @@ instance (HasPersistBackend b, BackendCompatible b s, PersistUniqueRead b) => PersistUniqueRead (Compatible b s) where getBy = withReaderT (projectBackend @b @s . unCompatible) . getBy + existsBy = withReaderT (projectBackend @b @s . unCompatible) . existsBy instance (HasPersistBackend b, BackendCompatible b s, PersistStoreWrite b) => PersistStoreWrite (Compatible b s) where insert = withReaderT (projectBackend @b @s . unCompatible) . insert diff --git a/Database/Persist/Sql/Orphan/PersistQuery.hs b/Database/Persist/Sql/Orphan/PersistQuery.hs --- a/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -41,6 +41,7 @@ , keyAndEntityColumnNames , mkUpdateText , parseEntityValues + , parseExistsResult , updatePersistValue ) @@ -82,15 +83,7 @@ ] withRawQuery sql (getFiltsValues conn filts) $ do mm <- CL.head - case mm of - Just [PersistBool b] -> return b -- Postgres - Just [PersistInt64 i] -> return $ i > 0 -- MySQL, SQLite - Just [PersistDouble i] -> return $ (truncate i :: Int64) > 0 -- gb oracle - Just [PersistByteString i] -> case readInteger i of -- gb mssql - Just (ret,"") -> return $ ret > 0 - xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]" - Just xs -> error $ "PersistQuery.exists: Expected a boolean, int, double, or bytestring; got: " ++ show xs ++ " for query: " ++ show sql - Nothing -> error $ "PersistQuery.exists: Expected a boolean, int, double, or bytestring; got: Nothing for query: " ++ show sql + return $ parseExistsResult mm sql "PersistQuery.exists" where t = entityDef $ dummyFromFilts filts diff --git a/Database/Persist/Sql/Orphan/PersistUnique.hs b/Database/Persist/Sql/Orphan/PersistUnique.hs --- a/Database/Persist/Sql/Orphan/PersistUnique.hs +++ b/Database/Persist/Sql/Orphan/PersistUnique.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE ExplicitForAll #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistUnique () @@ -8,18 +8,25 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ask) import qualified Data.Conduit.List as CL +import Data.Foldable (toList) import Data.Function (on) import Data.List (nubBy) import qualified Data.Text as T -import Data.Foldable (toList) import Database.Persist -import Database.Persist.Class.PersistUnique (defaultUpsertBy, defaultPutMany, persistUniqueKeyValues) +import Database.Persist.Class.PersistUnique + (defaultPutMany, defaultUpsertBy, persistUniqueKeyValues) -import Database.Persist.Sql.Types.Internal -import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) -import Database.Persist.Sql.Util (dbColumns, parseEntityValues, updatePersistValue, mkUpdateText') +import Database.Persist.Sql.Raw +import Database.Persist.Sql.Types.Internal +import Database.Persist.Sql.Util + ( dbColumns + , mkUpdateText' + , parseEntityValues + , parseExistsResult + , updatePersistValue + ) instance PersistUniqueWrite SqlBackend where upsertBy uniqueKey record updates = do @@ -110,11 +117,34 @@ t = entityDef $ dummyFromUnique uniq toFieldNames' = toList . fmap snd . persistUniqueToFieldNames + existsBy uniq = do + conn <- ask + let sql = + T.concat + [ "SELECT EXISTS(SELECT 1 FROM " + , connEscapeTableName conn t + , " WHERE " + , sqlClause conn + , ")" + ] + uvals = persistUniqueToValues uniq + withRawQuery sql uvals $ do + mm <- CL.head + return $ parseExistsResult mm sql "PersistUnique.existsBy" + where + sqlClause conn = + T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq + go conn x = connEscapeFieldName conn x `mappend` "=?" + t = entityDef $ dummyFromUnique uniq + toFieldNames' = toList . fmap snd . persistUniqueToFieldNames + instance PersistUniqueRead SqlReadBackend where getBy uniq = withBaseBackend $ getBy uniq + existsBy uniq = withBaseBackend $ existsBy uniq instance PersistUniqueRead SqlWriteBackend where getBy uniq = withBaseBackend $ getBy uniq + existsBy uniq = withBaseBackend $ existsBy uniq dummyFromUnique :: Unique v -> Maybe v dummyFromUnique _ = Nothing diff --git a/Database/Persist/Sql/Util.hs b/Database/Persist/Sql/Util.hs --- a/Database/Persist/Sql/Util.hs +++ b/Database/Persist/Sql/Util.hs @@ -18,8 +18,11 @@ , parenWrapped , mkInsertValues , mkInsertPlaceholders + , parseExistsResult ) where +import Data.ByteString.Char8 (readInteger) +import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Maybe as Maybe import Data.Text (Text, pack) @@ -34,7 +37,7 @@ , FieldNameHS(FieldNameHS) , PersistEntity(..) , PersistUpdate(..) - , PersistValue + , PersistValue(..) , Update(..) , compositeFields , entityPrimary @@ -270,3 +273,15 @@ Just (escape (fieldDB fd), "?") Just _ -> Nothing + +parseExistsResult :: Maybe [PersistValue] -> Text -> String -> Bool +parseExistsResult mm sql errloc = + case mm of + Just [PersistBool b] -> b -- Postgres + Just [PersistInt64 i] -> i > 0 -- MySQL, SQLite + Just [PersistDouble i] -> (truncate i :: Int64) > 0 -- gb oracle + Just [PersistByteString i] -> case readInteger i of -- gb mssql + Just (ret,"") -> ret > 0 + xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]" + Just xs -> error $ errloc ++ ": Expected a boolean, int, double, or bytestring; got: " ++ show xs ++ " for query: " ++ show sql + Nothing -> error $ errloc ++ ": Expected a boolean, int, double, or bytestring; got: Nothing for query: " ++ show sql diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.14.4.5 +version: 2.14.5.0 license: MIT license-file: LICENSE author: Michael Snoyman