diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 2.7.1 + +* Added an `insertUniqueEntity` function [#718](https://github.com/yesodweb/persistent/pull/718) +* Added `BackendCompatible` class [#701](https://github.com/yesodweb/persistent/pull/701) + ## 2.7.0 * Fix upsert behavior [#613](https://github.com/yesodweb/persistent/issues/613) diff --git a/Database/Persist/Class.hs b/Database/Persist/Class.hs --- a/Database/Persist/Class.hs +++ b/Database/Persist/Class.hs @@ -23,6 +23,7 @@ , PersistUniqueWrite (..) , getByValue , insertBy + , insertUniqueEntity , replaceUnique , checkUnique , onlyUnique @@ -52,6 +53,7 @@ , HasPersistBackend (..) , IsPersistBackend () , liftPersist + , BackendCompatible (..) -- * JSON utilities , keyValueEntityToJSON, keyValueEntityFromJSON diff --git a/Database/Persist/Class/PersistStore.hs b/Database/Persist/Class/PersistStore.hs --- a/Database/Persist/Class/PersistStore.hs +++ b/Database/Persist/Class/PersistStore.hs @@ -18,6 +18,7 @@ , insertEntity , insertRecord , ToBackendKey(..) + , BackendCompatible(..) ) where import qualified Data.Text as T @@ -48,6 +49,50 @@ -- to accidentally run a write query against a read-only database. mkPersistBackend :: BaseBackend backend -> backend +-- | This class witnesses that two backend are compatible, and that you can +-- convert from the @sub@ backend into the @sup@ backend. This is similar +-- to the 'HasPersistBackend' and 'IsPersistBackend' classes, but where you +-- don't want to fix the type associated with the 'PersistEntityBackend' of +-- a record. +-- +-- Generally speaking, where you might have: +-- +-- @ +-- foo :: +-- ( 'PersistEntity' record +-- , 'PeristEntityBackend' record ~ 'BaseBackend' backend +-- , 'IsSqlBackend' backend +-- ) +-- @ +-- +-- this can be replaced with: +-- +-- @ +-- foo :: +-- ( 'PersistEntity' record, +-- , 'PersistEntityBackend' record ~ backend +-- , 'BackendCompatible' 'SqlBackend' backend +-- ) +-- @ +-- +-- This works for 'SqlReadBackend' because of the @instance 'BackendCompatible' 'SqlBackend' 'SqlReadBackend'@, without needing to go through the 'BaseBackend' type family. +-- +-- Likewise, functions that are currently hardcoded to use 'SqlBackend' can be generalized: +-- +-- @ +-- -- before: +-- asdf :: 'ReaderT' 'SqlBackend' m () +-- asdf = pure () +-- +-- -- after: +-- asdf' :: 'BackendCompatible' SqlBackend backend => ReaderT backend m () +-- asdf' = withReaderT 'projectBackend' asdf +-- @ +-- +-- @since 2.7.1 +class BackendCompatible sup sub where + projectBackend :: sub -> sup + -- | A convenient alias for common type signatures type PersistRecordBackend record backend = (PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) @@ -176,7 +221,7 @@ get key >>= maybe (liftIO $ throwIO $ KeyNotFound $ show key) return --- | Same as 'get', but for a non-null (not Maybe) foreign key +-- | Same as 'get', but for a non-null (not Maybe) foreign key. -- Unsafe unless your database is enforcing that the foreign key is valid. getJust :: ( PersistStoreRead backend , Show (Key record) @@ -188,6 +233,7 @@ return -- | Same as 'getJust', but returns an 'Entity' instead of just the record. +-- -- @since 2.6.1 getJustEntity :: (PersistEntityBackend record ~ BaseBackend backend @@ -238,7 +284,7 @@ -- | Like @get@, but returns the complete @Entity@. getEntity :: - ( PersistStoreWrite backend + ( PersistStoreRead backend , PersistRecordBackend e backend , MonadIO m ) => Key e -> ReaderT backend m (Maybe (Entity e)) @@ -247,6 +293,7 @@ return $ fmap (key `Entity`) maybeModel -- | Like 'insertEntity' but just returns the record instead of 'Entity'. +-- -- @since 2.6.1 insertRecord :: (PersistEntityBackend record ~ BaseBackend backend @@ -257,4 +304,3 @@ insertRecord record = do insert_ record return $ record - 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 @@ -6,6 +6,7 @@ ,PersistUniqueWrite(..) ,getByValue ,insertBy + ,insertUniqueEntity ,replaceUnique ,checkUnique ,onlyUnique) @@ -130,6 +131,18 @@ Nothing -> insert val Just (Entity key _) -> return key +-- | Like 'insertEntity', but returns 'Nothing' when the record +-- couldn't be inserted because of a uniqueness constraint. +-- +-- @since 2.7.1 +insertUniqueEntity + :: (MonadIO m + ,PersistRecordBackend record backend + ,PersistUniqueWrite backend) + => record -> ReaderT backend m (Maybe (Entity record)) +insertUniqueEntity datum = + fmap (\key -> Entity key datum) `liftM` insertUnique datum + -- | Return the single unique key for a record. onlyUnique :: (MonadIO m @@ -192,7 +205,7 @@ -- Return 'Nothing' if the replacement was made. -- If uniqueness is violated, return a 'Just' with the 'Unique' violation -- --- Since 1.2.2.0 +-- @since 1.2.2.0 replaceUnique :: (MonadIO m ,Eq record diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -74,20 +74,20 @@ PSSuccess x t' -> goMany (front . (x:)) t' PSFail err -> PSFail err PSDone -> PSSuccess (front []) t - -- _ -> + -- _ -> data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) , psStrictFields :: !Bool -- ^ Whether fields are by default strict. Default value: @True@. -- - -- Since 1.2 + -- @since 1.2 , psIdName :: !Text -- ^ The name of the id column. Default value: @id@ -- The name of the id column can also be changed on a per-model basis -- -- - -- Since 2.0 + -- @since 2.0 } defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings @@ -321,12 +321,12 @@ attribPrefix = flip lookupKeyVal entattribs idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql=" | otherwise = Nothing - - (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> - let (i, p, u, f) = takeConstraint ps name' cols attr + + (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> + let (i, p, u, f) = takeConstraint ps name' cols attr squish xs m = xs `mappend` maybeToList m in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) attribs - + derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef] @@ -343,8 +343,8 @@ just1 (Just x) (Just y) = error $ "expected only one of: " `mappend` show x `mappend` " " `mappend` show y just1 x y = x `mplus` y - + mkAutoIdField :: PersistSettings -> HaskellName -> Maybe DBName -> SqlType -> FieldDef mkAutoIdField ps entName idName idSqlType = FieldDef { fieldHaskell = HaskellName "Id" @@ -412,9 +412,9 @@ -> [FieldDef] -> [Text] -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) -takeConstraint ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) = takeConstraint' +takeConstraint ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) = takeConstraint' where - takeConstraint' + takeConstraint' | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps tableName defs rest, Nothing) | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps tableName defs rest) | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing) @@ -444,7 +444,7 @@ setIdName = ["sql=" `mappend` psIdName ps] takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName - + takeComposite :: [FieldDef] -> [Text] -> CompositeDef @@ -462,7 +462,7 @@ else d | otherwise = getDef ds t --- Unique UppercaseConstraintName list of lowercasefields +-- Unique UppercaseConstraintName list of lowercasefields takeUniq :: PersistSettings -> Text -> [FieldDef] diff --git a/Database/Persist/Sql.hs b/Database/Persist/Sql.hs --- a/Database/Persist/Sql.hs +++ b/Database/Persist/Sql.hs @@ -28,7 +28,7 @@ import Database.Persist.Sql.Migration import Database.Persist.Sql.Internal -import Database.Persist.Sql.Orphan.PersistQuery +import Database.Persist.Sql.Orphan.PersistQuery import Database.Persist.Sql.Orphan.PersistStore import Database.Persist.Sql.Orphan.PersistUnique () import Control.Monad.IO.Class @@ -36,7 +36,7 @@ -- | Commit the current transaction and begin a new one. -- --- Since 1.2.0 +-- @since 1.2.0 transactionSave :: MonadIO m => ReaderT SqlBackend m () transactionSave = do conn <- ask @@ -45,7 +45,7 @@ -- | Roll back the current transaction and begin a new one. -- --- Since 1.2.0 +-- @since 1.2.0 transactionUndo :: MonadIO m => ReaderT SqlBackend m () transactionUndo = do conn <- ask diff --git a/Database/Persist/Sql/Class.hs b/Database/Persist/Sql/Class.hs --- a/Database/Persist/Sql/Class.hs +++ b/Database/Persist/Sql/Class.hs @@ -95,7 +95,7 @@ nKeyFields = length $ entityKeyFields entDef entDef = entityDef (Nothing :: Maybe record) --- | Since 1.0.1. +-- | @since 1.0.1 instance RawSql a => RawSql (Maybe a) where rawSqlCols e = rawSqlCols e . extractMaybe rawSqlColCountReason = rawSqlColCountReason . extractMaybe 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 @@ -116,14 +116,14 @@ case xs of [PersistInt64 x] -> return [PersistInt64 x] [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double - _ -> liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys False: " <> T.pack (show xs) + _ -> return xs Just pdef -> let pks = map fieldHaskell $ compositeFields pdef keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) xs in return keyvals case keyFromValues keyvals of Right k -> return k - Left _ -> error "selectKeysImpl: keyFromValues failed" + Left err -> error $ "selectKeysImpl: keyFromValues failed" <> show err instance PersistQueryRead SqlReadBackend where count filts = withReaderT persistBackend $ count filts selectSourceRes filts opts = withReaderT persistBackend $ selectSourceRes filts opts @@ -146,7 +146,7 @@ -- | Same as 'deleteWhere', but returns the number of rows affected. -- --- Since 1.1.5 +-- @since 1.1.5 deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend, IsSqlBackend backend) => [Filter val] -> ReaderT backend m Int64 @@ -165,7 +165,7 @@ -- | Same as 'updateWhere', but returns the number of rows affected. -- --- Since 1.1.5 +-- @since 1.1.5 updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val, IsSqlBackend backend) => [Filter val] -> [Update val] diff --git a/Database/Persist/Sql/Orphan/PersistStore.hs b/Database/Persist/Sql/Orphan/PersistStore.hs --- a/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/Database/Persist/Sql/Orphan/PersistStore.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} @@ -39,6 +40,7 @@ import Database.Persist.Sql.Class (PersistFieldSql) import qualified Data.Aeson as A import Control.Exception.Lifted (throwIO) +import Database.Persist.Class () withRawQuery :: MonadIO m => Text @@ -113,6 +115,15 @@ instance PersistCore SqlWriteBackend where newtype BackendKey SqlWriteBackend = SqlWriteBackendKey { unSqlWriteBackendKey :: Int64 } deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) + +instance BackendCompatible SqlBackend SqlBackend where + projectBackend = id + +instance BackendCompatible SqlBackend SqlReadBackend where + projectBackend = unSqlReadBackend + +instance BackendCompatible SqlBackend SqlWriteBackend where + projectBackend = unSqlWriteBackend instance PersistStoreWrite SqlBackend where update _ [] = return () diff --git a/Database/Persist/Sql/Run.hs b/Database/Persist/Sql/Run.hs --- a/Database/Persist/Sql/Run.hs +++ b/Database/Persist/Sql/Run.hs @@ -35,7 +35,7 @@ -- | Like 'withResource', but times out the operation if resource -- allocation does not complete within the given timeout period. -- --- Since 2.0.0 +-- @since 2.0.0 withResourceTimeout :: forall a m b. (MonadBaseControl IO m) => Int -- ^ Timeout period in microseconds diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.7.0 +version: 2.7.1 license: MIT license-file: LICENSE author: Michael Snoyman