Skip to content

Commit

Permalink
Improve foreign key discovery (#1446)
Browse files Browse the repository at this point in the history 
* Demonstrate bug with a test

* remove qualified problem

* tests pass

* styl, changelog, cabal

* gonna roll up some other things

* another

* docs

* more docs and links

* gonna release asap

* real tired of mongo shit
  • Loading branch information
@parsonsmatt
parsonsmatt committed Dec 3, 2022
1 parent f7382d9 commit c2751f5
Show file tree
Hide file tree
Showing 7 changed files with 188 additions and 37 deletions.
5 changes: 5 additions & 0 deletions docs/README.md
View file
Expand Up @@ -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

Expand Down
1 change: 1 addition & 0 deletions persistent-mongoDB/test/EmbedTestMongo.hs
View file
Expand Up @@ -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\" } }"

Expand Down
8 changes: 8 additions & 0 deletions persistent/ChangeLog.md
View file
@@ -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)
Expand Down
149 changes: 125 additions & 24 deletions persistent/Database/Persist/TH.hs
View file
Expand Up @@ -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)
Expand Down Expand Up @@ -193,8 +193,7 @@ persistFileWith ps fp = persistManyFileWith ps [fp]
--
-- @
-- -- Migrate.hs
-- 'share'
-- ['mkMigrate' "migrateAll"]
-- 'mkMigrate' "migrateAll"
-- $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"])
-- @
--
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down
2 changes: 1 addition & 1 deletion persistent/persistent.cabal
View file
@@ -1,5 +1,5 @@
name: persistent
version: 2.14.3.1
version: 2.14.3.2
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
Expand Down
3 changes: 2 additions & 1 deletion persistent/test/Database/Persist/TH/PersistWith/Model.hs
View file
Expand Up @@ -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

|]
57 changes: 46 additions & 11 deletions persistent/test/Database/Persist/TH/PersistWithSpec.hs
View file
@@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
Expand All @@ -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")

0 comments on commit c2751f5

Please sign in to comment.