diff --git a/docs/README.md b/docs/README.md index e7007f55f..50b8a9d7e 100644 --- a/docs/README.md +++ b/docs/README.md @@ -15,6 +15,11 @@ Get started with Persistent at: http://www.yesodweb.com/book/persistent * [Triggers for SQL](https://github.com/jcristovao/migrationplus) * [ODBC](https://github.com/gbwey/persistent-odbc) * [Zookeeper](https://hackage.haskell.org/package/persistent-zookeeper) +* [`persistent-typed-db`](https://hackage.haskell.org/package/persistent-typed-db) + allows type safe access to multiple databases with different schemas +* [`esqueleto`](https://hackage.haskell.org/package/esqueleto) allows for more + complex SQL queries using the Persistent backend types + ## Persistent with MongoDB diff --git a/persistent-mongoDB/test/EmbedTestMongo.hs b/persistent-mongoDB/test/EmbedTestMongo.hs index b64f45405..79643a359 100644 --- a/persistent-mongoDB/test/EmbedTestMongo.hs +++ b/persistent-mongoDB/test/EmbedTestMongo.hs @@ -428,6 +428,7 @@ specs = describe "embedded entities" $ do it "re-orders json inserted from another source" $ db $ do + liftIO $ pendingWith "mongoimport fails on GitHub CI" let cname = T.unpack $ collectionName (error "ListEmbed" :: ListEmbed) liftIO $ putStrLn =<< readProcess "mongoimport" ["-d", T.unpack dbName, "-c", cname] "{ \"nested\": [{ \"one\": 1, \"two\": 2 }, { \"two\": 2, \"one\": 1}], \"two\": 2, \"one\": 1, \"_id\" : { \"$oid\" : \"50184f5a92d7ae0000001e89\" } }" diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 5dba2c2c9..5771e0171 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,13 @@ # Changelog for persistent +## 2.14.3.2 + +* [#1446](https://github.com/yesodweb/persistent/pull/1446) + * Foreign key discovery was fixed for qualified names, `Key Model`, and + `Maybe` references. +* [#1438](https://github.com/yesodweb/persistent/pull/1438) + * Clarify wording on the error message for null in unique constraint + ## 2.14.3.1 * [#1428](https://github.com/yesodweb/persistent/pull/1428) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 0bb9280e8..08fc44e06 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -111,7 +111,7 @@ import GHC.TypeLits import Instances.TH.Lift () -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text` -import Data.Foldable (toList) +import Data.Foldable (asum, toList) import qualified Data.Set as Set import Language.Haskell.TH.Lib (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) @@ -193,8 +193,7 @@ persistFileWith ps fp = persistManyFileWith ps [fp] -- -- @ -- -- Migrate.hs --- 'share' --- ['mkMigrate' "migrateAll"] +-- 'mkMigrate' "migrateAll" -- $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"]) -- @ -- @@ -282,10 +281,6 @@ preprocessUnboundDefs preexistingEntities unboundDefs = (embedEntityMap, noCycleEnts) = embedEntityDefsMap preexistingEntities unboundDefs -stripId :: FieldType -> Maybe Text -stripId (FTTypeCon Nothing t) = stripSuffix "Id" t -stripId _ = Nothing - liftAndFixKeys :: MkPersistSettings -> M.Map EntityNameHS a @@ -513,13 +508,22 @@ guessFieldReference = guessReference . unboundFieldType guessReference :: FieldType -> Maybe EntityNameHS guessReference ft = - case ft of - FTTypeCon Nothing (T.stripSuffix "Id" -> Just tableName) -> - Just (EntityNameHS tableName) - FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing tableName) -> - Just (EntityNameHS tableName) - _ -> - Nothing + EntityNameHS <$> guessReferenceText (Just ft) + where + checkIdSuffix = + T.stripSuffix "Id" + guessReferenceText mft = + asum + [ do + FTTypeCon _ (checkIdSuffix -> Just tableName) <- mft + pure tableName + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon _ tableName) <- mft + pure tableName + , do + FTApp (FTTypeCon _ "Maybe") next <- mft + guessReferenceText (Just next) + ] mkDefaultKey :: MkPersistSettings @@ -691,7 +695,18 @@ constructEmbedEntityMap = lookupEmbedEntity :: M.Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS lookupEmbedEntity allEntities field = do - entName <- EntityNameHS <$> stripId (fieldType field) + let mfieldTy = Just $ fieldType field + entName <- EntityNameHS <$> asum + [ do + FTTypeCon _ t <- mfieldTy + stripSuffix "Id" t + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon _ entName) <- mfieldTy + pure entName + , do + FTApp (FTTypeCon _ "Maybe") (FTTypeCon _ t) <- mfieldTy + stripSuffix "Id" t + ] guard (M.member entName allEntities) -- check entity name exists in embed fmap pure entName @@ -757,14 +772,89 @@ setFieldReference :: ReferenceDef -> FieldDef -> FieldDef setFieldReference ref field = field { fieldReference = ref } -- | Create data types and appropriate 'PersistEntity' instances for the given --- 'EntityDef's. Works well with the persist quasi-quoter. +-- 'UnboundEntityDef's. +-- +-- This function should be used if you are only defining a single block of +-- Persistent models for the entire application. If you intend on defining +-- multiple blocks in different fiels, see 'mkPersistWith' which allows you +-- to provide existing entity definitions so foreign key references work. +-- +-- Example: +-- +-- @ +-- mkPersist 'sqlSettings' ['persistLowerCase'| +-- User +-- name Text +-- age Int +-- +-- Dog +-- name Text +-- owner UserId +-- +-- |] +-- @ +-- +-- Example from a file: +-- +-- @ +-- mkPersist 'sqlSettings' $('persistFileWith' 'lowerCaseSettings' "models.persistentmodels") +-- @ +-- +-- For full information on the 'QuasiQuoter' syntax, see +-- "Database.Persist.Quasi" documentation. mkPersist :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec] mkPersist mps = mkPersistWith mps [] --- | Like ' +-- | Like 'mkPersist', but allows you to provide a @['EntityDef']@ +-- representing the predefined entities. This function will include those +-- 'EntityDef' when looking for foreign key references. +-- +-- You should use this if you intend on defining Persistent models in +-- multiple files. +-- +-- Suppose we define a table @Foo@ which has no dependencies. +-- +-- @ +-- module DB.Foo where +-- +-- 'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'| +-- Foo +-- name Text +-- |] +-- @ +-- +-- Then, we define a table @Bar@ which depends on @Foo@: +-- +-- @ +-- module DB.Bar where +-- +-- import DB.Foo +-- +-- 'mkPersistWith' 'sqlSettings' [entityDef (Proxy :: Proxy Foo)] ['persistLowerCase'| +-- Bar +-- fooId FooId +-- |] +-- @ +-- +-- Writing out the list of 'EntityDef' can be annoying. The +-- @$('discoverEntities')@ shortcut will work to reduce this boilerplate. +-- +-- @ +-- module DB.Quux where +-- +-- import DB.Foo +-- import DB.Bar +-- +-- 'mkPersistWith' 'sqlSettings' $('discoverEntities') ['persistLowerCase'| +-- Quux +-- name Text +-- fooId FooId +-- barId BarId +-- |] +-- @ -- -- @since 2.13.0.0 mkPersistWith @@ -2231,16 +2321,10 @@ mkPlainTV -> TyVarBndr () mkPlainTV n = PlainTV n () -mkDoE :: [Stmt] -> Exp -mkDoE stmts = DoE Nothing stmts - mkForallTV :: Name -> TyVarBndr Specificity mkForallTV n = PlainTV n SpecifiedSpec #else -mkDoE :: [Stmt] -> Exp -mkDoE = DoE - mkPlainTV :: Name -> TyVarBndr @@ -2398,7 +2482,24 @@ persistFieldFromEntity mps entDef = do -- -- This function is useful for cases such as: -- --- >>> share [mkEntityDefList "myDefs", mkPersist sqlSettings] [persistLowerCase|...|] +-- @ +-- share ['mkEntityDefList' "myDefs", 'mkPersist' sqlSettings] ['persistLowerCase'| +-- -- ... +-- |] +-- @ +-- +-- If you only have a single function, though, you don't need this. The +-- following is redundant: +-- +-- @ +-- 'share' ['mkPersist' 'sqlSettings'] ['persistLowerCase'| +-- -- ... +-- |] +-- @ +-- +-- Most functions require a full @['EntityDef']@, which can be provided +-- using @$('discoverEntities')@ for all entites in scope, or defining +-- 'mkEntityDefList' to define a list of entities from the given block. share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec] share fs x = mconcat <$> mapM ($ x) fs diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index bc08284b8..2dc995ffd 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.14.3.1 +version: 2.14.3.2 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/persistent/test/Database/Persist/TH/PersistWith/Model.hs b/persistent/test/Database/Persist/TH/PersistWith/Model.hs index c8270f649..41c632559 100644 --- a/persistent/test/Database/Persist/TH/PersistWith/Model.hs +++ b/persistent/test/Database/Persist/TH/PersistWith/Model.hs @@ -16,11 +16,12 @@ module Database.Persist.TH.PersistWith.Model where import TemplateTestImports -import Database.Persist.TH.PersistWith.Model2 +import Database.Persist.TH.PersistWith.Model2 as Model2 mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| IceCream flavor FlavorId + otherFlavor Model2.FlavorId |] diff --git a/persistent/test/Database/Persist/TH/PersistWithSpec.hs b/persistent/test/Database/Persist/TH/PersistWithSpec.hs index f69690394..25c9fff0f 100644 --- a/persistent/test/Database/Persist/TH/PersistWithSpec.hs +++ b/persistent/test/Database/Persist/TH/PersistWithSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} @@ -14,26 +15,60 @@ module Database.Persist.TH.PersistWithSpec where +import Control.Monad import TemplateTestImports -import Database.Persist.TH.PersistWith.Model (IceCreamId) -import Data.List (find) +import Database.Persist.TH.PersistWith.Model as Model (IceCream, IceCreamId) import Language.Haskell.TH as TH mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| BestTopping iceCream IceCreamId + otherCream Model.IceCreamId + keyCream (Key IceCream) + qualifiedKeyCream (Key Model.IceCream) + nullableCream IceCreamId Maybe + maybeCream (Maybe IceCreamId) + maybeQualifiedCream (Maybe Model.IceCreamId) + maybeQualifiedKeyCream (Maybe (Key Model.IceCream)) + maybeKeyCream (Maybe (Key IceCream)) |] +deriving instance Show (EntityField BestTopping a) +deriving instance Eq (EntityField BestTopping a) + +data SomeField where + SomeField :: EntityField BestTopping a -> SomeField + +allFields = + [ SomeField BestToppingIceCream + , SomeField BestToppingOtherCream + , SomeField BestToppingKeyCream + , SomeField BestToppingQualifiedKeyCream + , SomeField BestToppingMaybeCream + , SomeField BestToppingNullableCream + , SomeField BestToppingMaybeQualifiedCream + , SomeField BestToppingMaybeQualifiedKeyCream + , SomeField BestToppingMaybeKeyCream + ] + spec :: Spec spec = describe "mkPersistWith" $ do - it "works" $ do - let - edef = - entityDef (Proxy @BestTopping) - Just iceCreamField = - find ((FieldNameHS "iceCream" ==) . fieldHaskell) (getEntityFields edef) - fieldReference iceCreamField - `shouldBe` - ForeignRef (EntityNameHS "IceCream") + describe "finds references" $ do + forM_ allFields $ \(SomeField field) -> + it (show field) (shouldReferToIceCream field) + +shouldReferToIceCream :: EntityField BestTopping a -> IO () +shouldReferToIceCream field = + unless (reference == iceCreamRef) $ do + expectationFailure $ mconcat + [ "The field '", show field, "' does not have a reference to IceCream.\n" + , "Got Reference: ", show reference, "\n" + , "Expected : ", show iceCreamRef + ] + where + reference = + fieldReference (persistFieldDef field) + iceCreamRef = + ForeignRef (EntityNameHS "IceCream")