persistent 2.7.0 → 2.7.1
raw patch · 11 files changed
+103/−26 lines, 11 files
Files
- ChangeLog.md +5/−0
- Database/Persist/Class.hs +2/−0
- Database/Persist/Class/PersistStore.hs +49/−3
- Database/Persist/Class/PersistUnique.hs +14/−1
- Database/Persist/Quasi.hs +12/−12
- Database/Persist/Sql.hs +3/−3
- Database/Persist/Sql/Class.hs +1/−1
- Database/Persist/Sql/Orphan/PersistQuery.hs +4/−4
- Database/Persist/Sql/Orphan/PersistStore.hs +11/−0
- Database/Persist/Sql/Run.hs +1/−1
- persistent.cabal +1/−1
ChangeLog.md view
@@ -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)
Database/Persist/Class.hs view
@@ -23,6 +23,7 @@ , PersistUniqueWrite (..) , getByValue , insertBy+ , insertUniqueEntity , replaceUnique , checkUnique , onlyUnique@@ -52,6 +53,7 @@ , HasPersistBackend (..) , IsPersistBackend () , liftPersist+ , BackendCompatible (..) -- * JSON utilities , keyValueEntityToJSON, keyValueEntityFromJSON
Database/Persist/Class/PersistStore.hs view
@@ -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-
Database/Persist/Class/PersistUnique.hs view
@@ -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
Database/Persist/Quasi.hs view
@@ -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 -- <https://github.com/yesodweb/persistent/wiki/Persistent-entity-syntax> --- -- 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]
Database/Persist/Sql.hs view
@@ -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
Database/Persist/Sql/Class.hs view
@@ -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
Database/Persist/Sql/Orphan/PersistQuery.hs view
@@ -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]
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -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 ()
Database/Persist/Sql/Run.hs view
@@ -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
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.7.0+version: 2.7.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>