From 35bf63f56dc8f3e04332ea2f70d30012b735f1bb Mon Sep 17 00:00:00 2001 From: kderme Date: Sun, 30 Aug 2020 20:23:28 +0300 Subject: [PATCH 01/21] Simplify type check For a composite reference, the foreign fields have to be checked against the parent fields for type equality. The parent field are found by searching the parent Entity, using 'getFD'. For the foreign fields,though, this is unecessary. Currently, for each composite field, we extract its fields name and search again for the same field using 'getFd'. This creates an unecessary round trip. --- persistent/Database/Persist/Quasi.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index c27a0dcc8..3d8f67b72 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -609,8 +609,9 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts ++ show (map (unHaskellName . fieldHaskell) (fd:fds)) isNull = (NotNullable /=) . nullable . fieldAttrs + toForeignFields :: EntityDef -> Text -> FieldDef -> (FieldDef, ((HaskellName, DBName), (HaskellName, DBName))) toForeignFields pent fieldText pfd = - case chktypes fd haskellField (entityFields pent) pfh of + case chktypes fd haskellField pfd of Just err -> error err Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) where @@ -619,12 +620,9 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts haskellField = HaskellName fieldText (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd) - chktypes :: FieldDef -> HaskellName -> [FieldDef] -> HaskellName -> Maybe String - chktypes ffld _fkey pflds pkey = + chktypes ffld _fkey pfld = if fieldType ffld == fieldType pfld then Nothing else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) - where - pfld = getFd pflds pkey entName = entityHaskell ent getFd [] t = error $ "foreign key constraint for: " ++ show (unHaskellName entName) From 19324125a6ab898b771628072a81c040bd983cdb Mon Sep 17 00:00:00 2001 From: kderme Date: Sat, 29 Aug 2020 19:31:27 +0300 Subject: [PATCH 02/21] Allow to reference implicit Primary Keys This required a small tweak to TH. This is because when the primary key is autogenerated it has an extra layer. So when TH defines a function :: ChildFields -> ParentKey, we need an extra unwrapping. --- persistent-template/Database/Persist/TH.hs | 12 ++-- persistent-test/src/ForeignKey.hs | 16 +++++ persistent/Database/Persist/Quasi.hs | 77 +++++++++++----------- persistent/Database/Persist/Types/Base.hs | 8 +++ 4 files changed, 71 insertions(+), 42 deletions(-) diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index b4c74b4ac..913c0533e 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -1104,11 +1104,11 @@ mkEntity entityMap mps t = do fpv <- mkFromPersistValues mps t utv <- mkUniqueToValues $ entityUniques t puk <- mkUniqueKeys t + let primaryField = entityId t + fields <- mapM (mkField mps t) $ primaryField : entityFields t fkc <- mapM (mkForeignKeysComposite mps t) $ entityForeigns t - let primaryField = entityId t - fields <- mapM (mkField mps t) $ primaryField : entityFields t toFieldNames <- mkToFieldNames $ entityUniques t (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps t @@ -1343,8 +1343,12 @@ mkForeignKeysComposite mps t ForeignDef {..} = do let tablename = mkName $ unpack $ entityText t recordName <- newName "record" - let fldsE = map (\((foreignName, _),_) -> VarE (fieldName foreignName) - `AppE` VarE recordName) foreignFields + let mkFldE ((foreignName, _),ff) = case ff of + (HaskellName {unHaskellName = "Id"}, DBName {unDBName = "id"}) + -> AppE (VarE $ mkName "toBackendKey") $ + VarE (fieldName foreignName) `AppE` VarE recordName + _ -> VarE (fieldName foreignName) `AppE` VarE recordName + let fldsE = map mkFldE foreignFields let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE let fn = FunD fname [normalClause [VarP recordName] mkKeyE] diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs index 756952358..9717e78dc 100644 --- a/persistent-test/src/ForeignKey.hs +++ b/persistent-test/src/ForeignKey.hs @@ -16,6 +16,15 @@ share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMig Foreign Parent OnDeleteCascade OnUpdateCascade fkparent pname deriving Show Eq + ParentImplicit + name String + + ChildImplicit + pname String + parentId ParentImplicitId noreference + Foreign ParentImplicit OnDeleteCascade OnUpdateCascade fkparent parentId + deriving Show Eq + ParentComposite name String lastName String @@ -50,6 +59,13 @@ specsWith runDb = describe "foreign keys options" $ do update kf [ParentName =. "B"] cs <- selectList [] [] fmap (childPname . entityVal) cs @== ["B"] + it "delete cascades on implicit Primary key" $ runDb $ do + kf <- insert $ ParentImplicit "A" + kc <- insert $ ChildImplicit "B" kf + delete kf + cs <- selectList [] [] + let expected = [] :: [Entity ChildImplicit] + cs @== expected it "delete Composite cascades" $ runDb $ do kf <- insert $ ParentComposite "A" "B" kc <- insert $ ChildComposite "A" "B" diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 3d8f67b72..5771f9ac1 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -565,42 +565,41 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef fixForeignKey ent (UnboundForeignDef foreignFieldTexts fdef) = - let pentError = - error $ "could not find table " ++ show (foreignRefTableHaskell fdef) - ++ " fdef=" ++ show fdef ++ " allnames=" - ++ show (map (unHaskellName . entityHaskell . unboundEntityDef) unEnts) - ++ "\n\nents=" ++ show ents - pent = - fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup - in - case entityPrimary pent of - Just pdef -> - if length foreignFieldTexts /= length (compositeFields pdef) - then - lengthError pdef - else - let - fds_ffs = - zipWith (toForeignFields pent) - foreignFieldTexts - (compositeFields pdef) - dbname = - unDBName (entityDB pent) - oldDbName = - unDBName (foreignRefTableDBName fdef) - in fdef - { foreignFields = map snd fds_ffs - , foreignNullable = setNull $ map fst fds_ffs - , foreignRefTableDBName = - DBName dbname - , foreignConstraintNameDBName = - DBName - . T.replace oldDbName dbname . unDBName - $ foreignConstraintNameDBName fdef - } - Nothing -> - error $ "no explicit primary key fdef="++show fdef++ " ent="++show ent + case entitiesPrimary pent of + Just fds -> + if length foreignFieldTexts /= length fds + then + lengthError fds + else + let + fds_ffs = + zipWith toForeignFields + foreignFieldTexts + fds + dbname = + unDBName (entityDB pent) + oldDbName = + unDBName (foreignRefTableDBName fdef) + in fdef + { foreignFields = map snd fds_ffs + , foreignNullable = setNull $ map fst fds_ffs + , foreignRefTableDBName = + DBName dbname + , foreignConstraintNameDBName = + DBName + . T.replace oldDbName dbname . unDBName + $ foreignConstraintNameDBName fdef + } + Nothing -> + error $ "no explicit primary key fdef="++show fdef++ " ent="++show ent where + pentError = + error $ "could not find table " ++ show (foreignRefTableHaskell fdef) + ++ " fdef=" ++ show fdef ++ " allnames=" + ++ show (map (unHaskellName . entityHaskell . unboundEntityDef) unEnts) + ++ "\n\nents=" ++ show ents + pent = + fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup setNull :: [FieldDef] -> Bool setNull [] = error "setNull: impossible!" setNull (fd:fds) = let nullSetting = isNull fd in @@ -609,8 +608,9 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts ++ show (map (unHaskellName . fieldHaskell) (fd:fds)) isNull = (NotNullable /=) . nullable . fieldAttrs - toForeignFields :: EntityDef -> Text -> FieldDef -> (FieldDef, ((HaskellName, DBName), (HaskellName, DBName))) - toForeignFields pent fieldText pfd = + toForeignFields :: Text -> FieldDef + -> (FieldDef, (ForeignFieldDef, ForeignFieldDef)) + toForeignFields fieldText pfd = case chktypes fd haskellField pfd of Just err -> error err Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) @@ -625,13 +625,14 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) entName = entityHaskell ent + getFd :: [FieldDef] -> HaskellName -> FieldDef getFd [] t = error $ "foreign key constraint for: " ++ show (unHaskellName entName) ++ " unknown column: " ++ show t getFd (f:fs) t | fieldHaskell f == t = f | otherwise = getFd fs t - lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length (compositeFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef + lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length pdef) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef data UnboundEntityDef = UnboundEntityDef diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 4788f7b81..17248f13a 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -139,6 +139,14 @@ data EntityDef = EntityDef } deriving (Show, Eq, Read, Ord) +entitiesPrimary :: EntityDef -> Maybe [FieldDef] +entitiesPrimary t = case fieldReference primaryField of + CompositeRef c -> Just $ (compositeFields c) + ForeignRef _ _ -> Just [primaryField] + _ -> Nothing + where + primaryField = entityId t + entityPrimary :: EntityDef -> Maybe CompositeDef entityPrimary t = case fieldReference (entityId t) of CompositeRef c -> Just c From e57f9df708785e358c23276b77a4c425562db070 Mon Sep 17 00:00:00 2001 From: kderme Date: Sun, 30 Aug 2020 22:29:55 +0300 Subject: [PATCH 03/21] Parse References keyword after explicit Foreign Key The `References` keyword can be omitted to have backwords compatibility. The fields before and after the key word must have the same length (and are type checked as before). --- persistent/Database/Persist/Quasi.hs | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 5771f9ac1..bdb59ab6d 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -562,9 +562,9 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts fixForeignKeys (UnboundEntityDef foreigns ent) = ent { entityForeigns = map (fixForeignKey ent) foreigns } - -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns + -- check the count and the sqltypes match and update the foreignFields with the names of the referenced columns fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef - fixForeignKey ent (UnboundForeignDef foreignFieldTexts fdef) = + fixForeignKey ent (UnboundForeignDef foreignFieldTexts _parentFieldTexts fdef) = case entitiesPrimary pent of Just fds -> if length foreignFieldTexts /= length fds @@ -899,7 +899,8 @@ takeUniq _ tableName _ xs = ++ show xs data UnboundForeignDef = UnboundForeignDef - { _unboundFields :: [Text] -- ^ fields in other entity + { _unboundForeignFields :: [Text] -- ^ fields in the parent entity + , _unboundParentFields :: [Text] -- ^ fields in parent entity , _unboundForeignDef :: ForeignDef } @@ -919,7 +920,7 @@ takeForeign ps tableName _defs = takeRefTable where go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef go (n:rest) onDelete onUpdate | not (T.null n) && isLower (T.head n) - = UnboundForeignDef fields $ ForeignDef + = UnboundForeignDef fFields pFields $ ForeignDef { foreignRefTableHaskell = HaskellName refTableName , foreignRefTableDBName = @@ -940,7 +941,14 @@ takeForeign ps tableName _defs = takeRefTable False } where - (fields,attrs) = break ("!" `T.isPrefixOf`) rest + (fields ,attrs) = break ("!" `T.isPrefixOf`) rest + (fFields, pFields) = case break (== "References") fields of + (ffs, []) -> (ffs, []) + (ffs, _ : pfs) -> case (length ffs, length pfs) of + (flen, plen) | flen == plen -> (ffs, pfs) + (flen, plen) -> error $ errorPrefix ++ concat + [ "Found ", show flen, " foreign fields but " + , show plen, " parent fields" ] go ((T.stripPrefix "OnDelete" -> Just onDelete) : rest) onDelete' onUpdate = case (onDelete', readEither $ T.unpack onDelete) of (Nothing, Right cascadingAction) -> go rest (Just cascadingAction) onUpdate From 6f5b4cc26497d792f3006c7a31c3214df536bb8a Mon Sep 17 00:00:00 2001 From: kderme Date: Mon, 31 Aug 2020 03:06:49 +0300 Subject: [PATCH 04/21] Use explicit parent fields references TH needed a small tweak, because the function ChildFields -> ParentKey can't be generated when we reference manual fields. This is just a utility function and missing it in this case shouldn't create any issues. --- persistent-template/Database/Persist/TH.hs | 3 +- persistent-test/src/ForeignKey.hs | 59 ++++++++++++++++++++++ persistent/Database/Persist/Quasi.hs | 35 ++++++++----- persistent/Database/Persist/Types/Base.hs | 1 + 4 files changed, 83 insertions(+), 15 deletions(-) diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index 913c0533e..55ed5e30c 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -1335,7 +1335,8 @@ mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do ] mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec] -mkForeignKeysComposite mps t ForeignDef {..} = do +mkForeignKeysComposite mps t ForeignDef {..} = + if not foreignToPrimary then return [] else do let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f let fname = fieldName foreignConstraintNameHaskell let reftableString = unpack $ unHaskellName foreignRefTableHaskell diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs index 9717e78dc..72fe36753 100644 --- a/persistent-test/src/ForeignKey.hs +++ b/persistent-test/src/ForeignKey.hs @@ -42,6 +42,33 @@ share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMig Primary name Foreign SelfReferenced OnDeleteCascade fkparent pname deriving Show Eq + + A + aa String + ab Int + U1 aa + + B + ba String + bb Int + Foreign A OnDeleteCascade fkA ba References aa + deriving Show Eq + + AComposite + aa String + ab Int + U2 aa ab + + BComposite + ba String + bb Int + Foreign AComposite OnDeleteCascade fkAComposite ba bb References aa ab + deriving Show Eq + + BExplicit + ba AId noreference + Foreign A OnDeleteCascade fkAI ba References Id + deriving Show Eq |] specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec @@ -80,3 +107,35 @@ specsWith runDb = describe "foreign keys options" $ do srs <- selectList [] [] let expected = [] :: [Entity SelfReferenced] srs @== expected + it "delete cascades with explicit Reference" $ runDb $ do + kf <- insert $ A "A" 40 + kc <- insert $ B "A" 15 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Composite Reference" $ runDb $ do + kf <- insert $ AComposite "A" 20 + kc <- insert $ BComposite "A" 20 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Composite Reference" $ runDb $ do + kf <- insert $ AComposite "A" 20 + kc <- insert $ BComposite "A" 20 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Id field" $ runDb $ do + kf <- insert $ A "A" 20 + kc <- insert $ BExplicit kf + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index bdb59ab6d..1c0cf1759 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -564,18 +564,18 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts -- check the count and the sqltypes match and update the foreignFields with the names of the referenced columns fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef - fixForeignKey ent (UnboundForeignDef foreignFieldTexts _parentFieldTexts fdef) = - case entitiesPrimary pent of - Just fds -> - if length foreignFieldTexts /= length fds + fixForeignKey ent (UnboundForeignDef foreignFieldTexts parentFieldTexts fdef) = + case mfdefs of + Just fdefs -> + if length foreignFieldTexts /= length fdefs then - lengthError fds + lengthError fdefs else let fds_ffs = zipWith toForeignFields foreignFieldTexts - fds + fdefs dbname = unDBName (entityDB pent) oldDbName = @@ -591,7 +591,7 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts $ foreignConstraintNameDBName fdef } Nothing -> - error $ "no explicit primary key fdef="++show fdef++ " ent="++show ent + error $ "no primary key found fdef="++show fdef++ " ent="++show ent where pentError = error $ "could not find table " ++ show (foreignRefTableHaskell fdef) @@ -600,6 +600,10 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts ++ "\n\nents=" ++ show ents pent = fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup + mfdefs = case parentFieldTexts of + [] -> entitiesPrimary pent + _ -> Just $ map (getFd pent . HaskellName) parentFieldTexts + setNull :: [FieldDef] -> Bool setNull [] = error "setNull: impossible!" setNull (fd:fds) = let nullSetting = isNull fd in @@ -615,7 +619,7 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts Just err -> error err Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) where - fd = getFd (entityFields ent) haskellField + fd = getFd ent haskellField haskellField = HaskellName fieldText (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd) @@ -624,13 +628,14 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts if fieldType ffld == fieldType pfld then Nothing else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) - entName = entityHaskell ent - getFd :: [FieldDef] -> HaskellName -> FieldDef - getFd [] t = error $ "foreign key constraint for: " ++ show (unHaskellName entName) - ++ " unknown column: " ++ show t - getFd (f:fs) t + getFd :: EntityDef -> HaskellName -> FieldDef + getFd entity t = go (keyAndEntityFields entity) + where + go [] = error $ "foreign key constraint for: " ++ show (unHaskellName $ entityHaskell entity) + ++ " unknown column: " ++ show t + go (f:fs) | fieldHaskell f == t = f - | otherwise = getFd fs t + | otherwise = go fs lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length pdef) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef @@ -939,6 +944,8 @@ takeForeign ps tableName _defs = takeRefTable attrs , foreignNullable = False + , foreignToPrimary = + null pFields } where (fields ,attrs) = break ("!" `T.isPrefixOf`) rest diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 17248f13a..dc7cd6920 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -308,6 +308,7 @@ data ForeignDef = ForeignDef , foreignFields :: ![(ForeignFieldDef, ForeignFieldDef)] -- this entity plus the primary entity , foreignAttrs :: ![Attr] , foreignNullable :: Bool + , foreignToPrimary :: Bool } deriving (Show, Eq, Read, Ord) From a598778ee858b76afdf6c3ce74fb80e1e41af8d7 Mon Sep 17 00:00:00 2001 From: kderme Date: Mon, 31 Aug 2020 11:15:01 +0300 Subject: [PATCH 05/21] Use Cascade options on simple field references --- persistent-mysql/Database/Persist/MySQL.hs | 32 +++++++++++-------- .../Database/Persist/Postgresql.hs | 18 +++++++---- persistent-sqlite/Database/Persist/Sqlite.hs | 2 +- persistent-template/Database/Persist/TH.hs | 16 ++++++---- persistent/Database/Persist/Quasi.hs | 25 +++++++++++++-- persistent/Database/Persist/Sql/Internal.hs | 11 +++++-- persistent/Database/Persist/Sql/Types.hs | 11 ++++++- persistent/Database/Persist/Types/Base.hs | 1 + 8 files changed, 82 insertions(+), 34 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index db2952ee7..980fb70f2 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -349,7 +349,9 @@ migrate' connectInfo allDefs getter val = do $ map (findTypeAndMaxLen name) ucols let foreigns = do - Column { cName=cname, cReference=Just (refTblName, refConstraintName) } <- newcols + Column { cName=cname, cReference=Just cRef } <- newcols + let refConstraintName = crConstraintName cRef + let refTblName = crTableName cRef let refTarget = addReference allDefs refConstraintName refTblName cname @@ -386,7 +388,7 @@ migrate' connectInfo allDefs getter val = do ( map (\c -> case cReference c of - Just (_,fk) -> + Just ColumnReference {crConstraintName=fk} -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of Just _ -> c { cReference = Nothing } Nothing -> c @@ -614,7 +616,7 @@ getColumn -> (Text -> IO Statement) -> DBName -> [PersistValue] - -> Maybe (DBName, DBName) + -> Maybe ColumnReference -> IO (Either Text Column) getColumn connectInfo getter tname [ PersistText cname , PersistText null_ @@ -623,7 +625,7 @@ getColumn connectInfo getter tname [ PersistText cname , colMaxLen , colPrecision , colScale - , default'] refName = + , default'] cRef = fmap (either (Left . pack) Right) $ runExceptT $ do -- Default value @@ -638,7 +640,7 @@ getColumn connectInfo getter tname [ PersistText cname Right t -> return (Just t) _ -> fail $ "Invalid default column: " ++ show default' - ref <- getRef refName + ref <- getRef (crConstraintName <$> cRef) let colMaxLen' = case colMaxLen of PersistInt64 l -> Just (fromIntegral l) _ -> Nothing @@ -660,7 +662,7 @@ getColumn connectInfo getter tname [ PersistText cname , cReference = ref } where getRef Nothing = return Nothing - getRef (Just (_, refName')) = do + getRef (Just refName') = do -- Foreign key (if any) stmt <- lift . getter $ T.concat [ "SELECT REFERENCED_TABLE_NAME, " @@ -684,7 +686,9 @@ getColumn connectInfo getter tname [ PersistText cname case cntrs of [] -> return Nothing [[PersistText tab, PersistText ref, PersistInt64 pos]] -> - return $ if pos == 1 then Just (DBName tab, DBName ref) else Nothing + -- TODO: Fix cascade reference is ignored + return $ if pos == 1 then Just (ColumnReference (DBName tab) (DBName ref) noCascade) + else Nothing xs -> error $ mconcat [ "MySQL.getColumn/getRef: error fetching constraints. Expected a single result for foreign key query for table: " , T.unpack (unDBName tname) @@ -756,7 +760,7 @@ getAlters allDefs edef (c1, u1) (c2, u2) = dropColumn col = map ((,) (cName col)) $ - [DropReference n | Just (_, n) <- [cReference col]] ++ + [DropReference (crConstraintName cr) | Just cr <- [cReference col]] ++ [Drop] getAltersU [] old = map (DropUniqueConstraint . fst) old @@ -795,7 +799,7 @@ findAlters edef allDefs col@(Column name isNull type_ def _defConstraintName max [] -> case ref of Nothing -> ([(name, Add' col)],[]) - Just (tname, cname) -> + Just ColumnReference {crTableName=tname, crConstraintName=cname} -> let cnstr = [addReference allDefs cname tname name] in (map ((,) tname) (Add' col : cnstr), cols) @@ -803,13 +807,13 @@ findAlters edef allDefs col@(Column name isNull type_ def _defConstraintName max let -- Foreign key refDrop = case (ref == ref', ref') of - (False, Just (_, cname)) -> + (False, Just ColumnReference {crConstraintName=cname}) -> [(name, DropReference cname)] _ -> [] refAdd = case (ref == ref', ref) of - (False, Just (tname, cname)) + (False, Just ColumnReference {crTableName=tname, crConstraintName=cname}) | tname /= entityDB edef , cname /= fieldDB (entityId edef) -> @@ -851,7 +855,7 @@ showColumn (Column n nu t def _defConstraintName maxLen ref) = concat else " DEFAULT " ++ T.unpack s , case ref of Nothing -> "" - Just (s, _) -> " REFERENCES " ++ escapeDBName s + Just cRef -> " REFERENCES " ++ escapeDBName (crTableName cRef) ] @@ -1081,8 +1085,8 @@ mockMigrate _connectInfo allDefs _getter val = do AddUniqueConstraint uname $ map (findTypeAndMaxLen name) ucols ] let foreigns = do - Column { cName=cname, cReference=Just (refTblName, refConstraintName) } <- newcols - return $ AlterColumn name (refTblName, addReference allDefs refConstraintName refTblName cname) + Column { cName=cname, cReference= Just ColumnReference{crTableName = refTable, crConstraintName = refConstr}} <- newcols + return $ AlterColumn name (refTable, addReference allDefs refConstr refTable cname) let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 07254947f..a2c8c17f7 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NamedFieldPuns #-} @@ -849,7 +850,7 @@ getColumns getter def cols = do us <- with (stmtQuery stmt' vals) (\src -> runConduit $ src .| helperU) return $ cs ++ us where - refMap = Map.fromList $ foldl' ref [] cols + refMap = fmap (\cr -> (crTableName cr, crConstraintName cr)) $ Map.fromList $ foldl' ref [] cols where ref rs c = case cReference c of Nothing -> rs (Just r) -> (unDBName $ cName c, r) : rs @@ -942,7 +943,8 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per , cDefault = fmap stripSuffixes d'' , cDefaultConstraintName = Nothing , cMaxLen = Nothing - , cReference = ref + -- TODO: Fix cascade reference is ignored + , cReference = fmap (\(a,b) -> ColumnReference a b noCascade) ref } where stripSuffixes t = @@ -1053,9 +1055,9 @@ findAlters defs edef col@(Column name isNull sqltype def _defConstraintName _max ([(name, Add' col)], cols) Just (Column _oldName isNull' sqltype' def' _defConstraintName' _maxLen' ref') -> let refDrop Nothing = [] - refDrop (Just (_, cname)) = [(name, DropReference cname)] + refDrop (Just ColumnReference {crConstraintName=cname}) = [(name, DropReference cname)] refAdd Nothing = [] - refAdd (Just (tname, a)) = + refAdd (Just ColumnReference {crTableName=tname, crConstraintName=a}) = case find ((==tname) . entityDB) defs of Just refdef | entityDB edef /= tname @@ -1066,6 +1068,7 @@ findAlters defs edef col@(Column name isNull sqltype def _defConstraintName _max a [name] (Util.dbIdColumnsEsc escape refdef) + -- TODO: Fix cascade reference is ignored noCascade ) ] @@ -1073,7 +1076,7 @@ findAlters defs edef col@(Column name isNull sqltype def _defConstraintName _max Nothing -> error $ "could not find the entityDef for reftable[" ++ show tname ++ "]" modRef = - if fmap snd ref == fmap snd ref' + if fmap crConstraintName ref == fmap crConstraintName ref' then [] else refDrop ref' ++ refAdd ref modNull = case (isNull, isNull') of @@ -1113,13 +1116,14 @@ getAddReference :: [EntityDef] -> EntityDef -> DBName - -> (DBName, DBName) + -> ColumnReference -> Maybe AlterDB -getAddReference allDefs entity cname (s, constraintName) = do +getAddReference allDefs entity cname ColumnReference {crTableName = s, crConstraintName=constraintName} = do guard $ table /= s && cname /= fieldDB (entityId entity) pure $ AlterColumn table ( s + -- TODO: Fix cascade reference is ignored , AddReference constraintName [cname] id_ noCascade ) where diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 624b507e2..4160f91f2 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -581,7 +581,7 @@ sqlColumn noRef (Column name isNull typ def _cn _maxLen ref) = T.concat , mayDefault def , case ref of Nothing -> "" - Just (table, _) -> if noRef then "" else " REFERENCES " <> escape table + Just cref -> if noRef then "" else " REFERENCES " <> escape (crTableName cref) ] sqlForeign :: ForeignDef -> Text diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index 55ed5e30c..e5a512039 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -290,7 +290,7 @@ data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp instance Lift FieldSqlTypeExp where lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) = - [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldComments|] + [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldComments fieldCascadeOpts|] #if MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift #endif @@ -1694,18 +1694,22 @@ liftAndFixKeys entityMap EntityDef{..} = |] liftAndFixKey :: EntityMap -> FieldDef -> Q Exp -liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef mcomments) = - [|FieldDef a b c $(sqlTyp') e f fieldRef' mcomments|] +liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef mcomments casc) = + [|FieldDef a b c $(sqlTyp') e f fieldRef' mcomments casc|] where (fieldRef', sqlTyp') = fromMaybe (fieldRef, lift sqlTyp) $ case fieldRef of ForeignRef refName _ft -> case M.lookup refName entityMap of - Nothing -> Nothing + Nothing -> checkCascade Just ent -> case fieldReference $ entityId ent of fr@(ForeignRef _Name ft) -> Just (fr, lift $ SqlTypeExp ft) - _ -> Nothing - _ -> Nothing + _ -> checkCascade + _ -> checkCascade + checkCascade = case casc of + FieldCascade Nothing Nothing -> Nothing + _ -> error $ "cascade field is not allown for field " <> show a + <> ". It doesn't reference any other tables." deriving instance Lift EntityDef diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 1c0cf1759..edb069bbd 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -741,6 +741,7 @@ mkAutoIdField ps entName idName idSqlType = FieldDef , fieldAttrs = [] , fieldStrict = True , fieldComments = Nothing + , fieldCascadeOpts = FieldCascade Nothing Nothing } defaultReferenceTypeCon :: FieldType @@ -772,25 +773,43 @@ takeCols -> [Text] -> Maybe FieldDef takeCols _ _ ("deriving":_) = Nothing -takeCols onErr ps (n':typ:rest) +takeCols onErr ps (n':typ:rest') | not (T.null n) && isLower (T.head n) = case parseFieldType typ of Left err -> onErr typ err Right ft -> Just FieldDef { fieldHaskell = HaskellName n - , fieldDB = DBName $ getDbName ps n rest + , fieldDB = DBName $ getDbName ps n attr , fieldType = ft , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n - , fieldAttrs = rest + , fieldAttrs = attr , fieldStrict = fromMaybe (psStrictFields ps) mstrict , fieldReference = NoReference , fieldComments = Nothing + , fieldCascadeOpts = FieldCascade onUpd onDel } where (mstrict, n) | Just x <- T.stripPrefix "!" n' = (Just True, x) | Just x <- T.stripPrefix "~" n' = (Just False, x) | otherwise = (Nothing, n') + (onDel, onUpd, attr) = go rest' Nothing Nothing + + go (txt : rest) onDelete' onUpdate' = + case (T.stripPrefix "OnDelete" txt, T.stripPrefix "OnUpdate" txt) of + (Just onDelete, _) -> case (readEither $ T.unpack onDelete, onDelete') of + (Right action, Nothing) -> go rest (Just action) onUpdate' + (Right _, Just _) -> error $ + "found more than one OnDelete actions at field " ++ show (n':typ:rest') + (Left _, _) -> (onDelete', onUpdate', txt : rest) + (_, Just onUpdate) -> case (readEither $ T.unpack onUpdate, onUpdate') of + (Right action, Nothing) -> go rest onDelete' (Just action) + (Right _, Just _) -> error $ + "found more than one OnUpdate actions at field " ++ show (n':typ:rest') + _ -> (onDelete', onUpdate', txt : rest) + _ -> (onDelete', onUpdate', txt : rest) + go [] onDelete' onUpdate' = (onDelete', onUpdate', []) + takeCols _ _ _ = Nothing getDbName :: PersistSettings -> Text -> [Text] -> Text diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index 9a19c7520..cf9330c3b 100644 --- a/persistent/Database/Persist/Sql/Internal.hs +++ b/persistent/Database/Persist/Sql/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -- | Intended for creating new backends. module Database.Persist.Sql.Internal @@ -87,12 +88,13 @@ mkColumns allDefs t overrides = , cDefaultConstraintName = Nothing , cMaxLen = maxLen $ fieldAttrs fd - , cReference = ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd) + , cReference = mkColumnReference fd } tableName :: DBName tableName = entityDB t + go :: FieldDef -> Column go fd = Column @@ -102,7 +104,7 @@ mkColumns allDefs t overrides = , cDefault = defaultAttribute $ fieldAttrs fd , cDefaultConstraintName = Nothing , cMaxLen = maxLen $ fieldAttrs fd - , cReference = ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd) + , cReference = mkColumnReference fd } maxLen :: [Attr] -> Maybe Integer @@ -117,6 +119,11 @@ mkColumns allDefs t overrides = refNameFn = fromMaybe refName (backendSpecificForeignKeyName overrides) + mkColumnReference :: FieldDef -> Maybe ColumnReference + mkColumnReference fd = + fmap (\(tName, cName) -> ColumnReference tName cName (fieldCascadeOpts fd)) + $ ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd) + ref :: DBName -> ReferenceDef -> [Attr] diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index f00339ad6..da687b88f 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -7,6 +7,8 @@ module Database.Persist.Sql.Types , OverflowNatural(..) ) where +import Database.Persist.Types.Base (FieldCascade) + import Control.Exception (Exception(..)) import Control.Monad.Logger (NoLoggingT) import Control.Monad.Trans.Reader (ReaderT (..)) @@ -25,7 +27,14 @@ data Column = Column , cDefault :: !(Maybe Text) , cDefaultConstraintName :: !(Maybe DBName) , cMaxLen :: !(Maybe Integer) - , cReference :: !(Maybe (DBName, DBName)) -- table name, constraint name + , cReference :: !(Maybe ColumnReference) + } + deriving (Eq, Ord, Show) + +data ColumnReference = ColumnReference + { crTableName :: DBName + , crConstraintName :: DBName + , crFieldCascade :: FieldCascade } deriving (Eq, Ord, Show) diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index dc7cd6920..78c35f35a 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -209,6 +209,7 @@ data FieldDef = FieldDef -- attach comments to a field in the quasiquoter. -- -- @since 2.10.0 + , fieldCascadeOpts :: !FieldCascade } deriving (Show, Eq, Read, Ord) From 5e8cda49a2a55e30bd60359d9e76ea50212fc7b0 Mon Sep 17 00:00:00 2001 From: kderme Date: Mon, 31 Aug 2020 11:16:55 +0300 Subject: [PATCH 06/21] Support Cascade options for SQLite Tests for this are missing because there is not yet postgres support. --- persistent-sqlite/Database/Persist/Sqlite.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 4160f91f2..85305e1d9 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -581,8 +581,14 @@ sqlColumn noRef (Column name isNull typ def _cn _maxLen ref) = T.concat , mayDefault def , case ref of Nothing -> "" - Just cref -> if noRef then "" else " REFERENCES " <> escape (crTableName cref) + Just ColumnReference {crTableName=table, crFieldCascade=cascadeOpts} -> + if noRef then "" else " REFERENCES " <> escape table + <> onDelete cascadeOpts <> onUpdate cascadeOpts ] + where + + onDelete opts = maybe "" (T.append " ON DELETE " . renderCascadeAction) (fcOnDelete opts) + onUpdate opts = maybe "" (T.append " ON UPDATE " . renderCascadeAction) (fcOnUpdate opts) sqlForeign :: ForeignDef -> Text sqlForeign fdef = T.concat $ From ad2cf9e67febb7ed258cbc4c95b8fcb2ea067bd1 Mon Sep 17 00:00:00 2001 From: kderme Date: Mon, 31 Aug 2020 23:42:50 +0300 Subject: [PATCH 07/21] Update Changelog and add `@since` --- persistent-postgresql/ChangeLog.md | 4 ++++ persistent-sqlite/ChangeLog.md | 5 +++++ persistent/ChangeLog.md | 4 ++++ persistent/Database/Persist/Types/Base.hs | 7 +++++++ 4 files changed, 20 insertions(+) diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 7d9b14a23..7e7633963 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -2,6 +2,10 @@ ## (Unreleased) 2.11.0.0 +* Foreign Key improvements [#1121] https://github.com/yesodweb/persistent/pull/1121 + * It is now supported to refer to a table with an auto generated Primary Kay + * It is now supported to refer to non-primary fields, using the keyword `References` + * Implement interval support. [#1053](https://github.com/yesodweb/persistent/pull/1053) * [#1060](https://github.com/yesodweb/persistent/pull/1060) * The QuasiQuoter now supports `OnDelete` and `OnUpdate` cascade options. diff --git a/persistent-sqlite/ChangeLog.md b/persistent-sqlite/ChangeLog.md index 21f94083a..a9aa02bbe 100644 --- a/persistent-sqlite/ChangeLog.md +++ b/persistent-sqlite/ChangeLog.md @@ -2,6 +2,11 @@ ## (Unreleased) 2.11.0.0 +* Foreign Key improvements [#1121] (https://github.com/yesodweb/persistent/pull/1121) + * It is now supported to refer to a table with an auto generated Primary Kay + * It is now supported to refer to non-primary fields, using the keyword `References` + * It is now supported to have cascade options for simple/single-field Foreign Keys + * [#1060](https://github.com/yesodweb/persistent/pull/1060) * The QuasiQuoter now supports `OnDelete` and `OnUpdate` cascade options. * [#1131](https://github.com/yesodweb/persistent/pull/1131) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 63de661c9..10165b3d2 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -2,6 +2,10 @@ ## (Unreleased) 2.11.0.0 +* Foreign Key improvements [#1121] https://github.com/yesodweb/persistent/pull/1121 + * It is now supported to refer to a table with an auto generated Primary Kay + * It is now supported to refer to non-primary fields, using the keyword `References` + * It is now supported to have cascade options for simple/single-field Foreign Keys * Introduces a breaking change to the internal function `mkColumns`, which can now be passed a record of functions to override its default behavior. [#996](https://github.com/yesodweb/persistent/pull/996) * Added explicit `forall` notation to make most API functions play nice when using `TypeApplications`. (e.g. instead of `selectList @_ @_ @User [] []`, you can now write `selectList @User [] []`) [#1006](https://github.com/yesodweb/persistent/pull/1006) * [#1060](https://github.com/yesodweb/persistent/pull/1060) diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 78c35f35a..deaffe0e5 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -210,6 +210,10 @@ data FieldDef = FieldDef -- -- @since 2.10.0 , fieldCascadeOpts :: !FieldCascade + -- ^ The cascade options of this fields. Used when this field refers to + -- another field. + -- + -- @since 2.11.0 } deriving (Show, Eq, Read, Ord) @@ -310,6 +314,9 @@ data ForeignDef = ForeignDef , foreignAttrs :: ![Attr] , foreignNullable :: Bool , foreignToPrimary :: Bool + -- ^ Determines if the reference is towards a Primary Key or not. + -- + -- @since 2.11.0 } deriving (Show, Eq, Read, Ord) From bec37c66d764f4b8d7a9c6d40d8e2ca5b2b47283 Mon Sep 17 00:00:00 2001 From: kderme Date: Wed, 2 Sep 2020 21:49:03 +0300 Subject: [PATCH 08/21] Test nullable self reference Nullable references are currently broken, since TH generates code which doesn't compile. The tests in this commit provide a good workaround to make this case work properly. --- persistent-test/src/ForeignKey.hs | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs index 72fe36753..a7616f7b2 100644 --- a/persistent-test/src/ForeignKey.hs +++ b/persistent-test/src/ForeignKey.hs @@ -69,6 +69,18 @@ share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMig ba AId noreference Foreign A OnDeleteCascade fkAI ba References Id deriving Show Eq + + Chain + name String + previous ChainId Maybe noreference + Foreign Chain OnDeleteSetNull fkChain previous References Id + deriving Show Eq + + Chain2 + name String + previous Chain2Id Maybe noreference + Foreign Chain2 OnDeleteCascade fkChain previous References Id + deriving Show Eq |] specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec @@ -139,3 +151,18 @@ specsWith runDb = describe "foreign keys options" $ do cs <- selectList [] [] let expected = [] :: [Entity B] cs @== expected + it "deletes sets null with self reference" $ runDb $ do + kf <- insert $ Chain "A" Nothing + insert $ Chain "B" (Just kf) + delete kf + cs <- selectList [] [] + let expected = [Entity {entityKey = ChainKey 2, entityVal = Chain "B" Nothing}] + cs @== expected + it "deletes cascades with self reference to the whole chain" $ runDb $ do + k1 <- insert $ Chain2 "A" Nothing + k2 <- insert $ Chain2 "B" (Just k1) + k3 <- insert $ Chain2 "C" (Just k2) + delete k1 + cs <- selectList [] [] + let expected = [] :: [Entity Chain2] + cs @== expected From b3261a99d9c8b8977ca4f0f22c9eadc4a60ee1be Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 30 Oct 2020 16:30:30 -0600 Subject: [PATCH 09/21] cascade on reference --- persistent-sqlite/Database/Persist/Sqlite.hs | 12 +- persistent-sqlite/test/main.hs | 4 +- persistent-template/Database/Persist/TH.hs | 139 +++++++++------ persistent-template/test/main.hs | 76 ++++++++ persistent-test/src/ForeignKey.hs | 117 ++++++++---- persistent/Database/Persist/Quasi.hs | 178 ++++++++++++++----- persistent/Database/Persist/Sql/Internal.hs | 14 +- persistent/Database/Persist/Sql/Types.hs | 2 +- persistent/Database/Persist/Types/Base.hs | 41 ++++- persistent/test/main.hs | 95 +++++++++- 10 files changed, 527 insertions(+), 151 deletions(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 624b507e2..0f3a63e44 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -581,7 +581,17 @@ sqlColumn noRef (Column name isNull typ def _cn _maxLen ref) = T.concat , mayDefault def , case ref of Nothing -> "" - Just (table, _) -> if noRef then "" else " REFERENCES " <> escape table + Just (table, _, c) -> + if noRef + then "" + else mconcat + [ " REFERENCES " + , escape table + ] + <> + fromMaybe "" (fmap (mappend "ON DELETE " . renderCascadeAction) (fcOnDelete c)) + <> + fromMaybe "" (fmap (mappend "ON UPDATE " . renderCascadeAction) (fcOnUpdate c)) ] sqlForeign :: ForeignDef -> Text diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs index 97dc5bcd4..7dd748116 100644 --- a/persistent-sqlite/test/main.hs +++ b/persistent-sqlite/test/main.hs @@ -135,7 +135,8 @@ main = do runConn $ do mapM_ setup - [ PersistentTest.testMigrate + [ ForeignKey.compositeMigrate + , PersistentTest.testMigrate , PersistentTest.noPrefixMigrate , PersistentTest.customPrefixMigrate , EmbedTest.embedMigrate @@ -145,7 +146,6 @@ main = do , MaxLenTest.maxlenMigrate , Recursive.recursiveMigrate , CompositeTest.compositeMigrate - , ForeignKey.compositeMigrate , MigrationTest.migrationMigrate , PersistUniqueTest.migration , RenameTest.migration diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index b4c74b4ac..0fdeb53ba 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -12,6 +13,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveLift #-} + {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} -- | This module provides the tools for defining your database schema and using @@ -250,7 +252,7 @@ stripId _ = Nothing foreignReference :: FieldDef -> Maybe HaskellName foreignReference field = case fieldReference field of - ForeignRef ref _ -> Just ref + ForeignRef ref _ _cascade -> Just ref _ -> Nothing @@ -290,7 +292,7 @@ data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp instance Lift FieldSqlTypeExp where lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) = - [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldComments|] + [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldCascade fieldComments|] #if MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift #endif @@ -323,14 +325,29 @@ constructEntityMap :: [EntityDef] -> EntityMap constructEntityMap = M.fromList . fmap (\ent -> (entityHaskell ent, ent)) -data FTTypeConDescr = FTKeyCon deriving Show +data FTTypeConDescr = FTKeyCon + deriving Show -mEmbedded :: EmbedEntityMap -> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef -mEmbedded _ (FTTypeCon Just{} _) = Left Nothing -mEmbedded ents (FTTypeCon Nothing n) = - let name = HaskellName n - in maybe (Left Nothing) Right $ M.lookup name ents -mEmbedded ents (FTList x) = mEmbedded ents x +-- | Recurses through the 'FieldType'. Returns a 'Right' with the +-- 'EmbedEntityDef' if the 'FieldType' corresponds to an unqualified use of +-- a name and that name is present in the 'EmbedEntityMap' provided as +-- a first argument. +-- +-- If the 'FieldType' represents a @Key something@, this returns a @'Left +-- ('Just' 'FTKeyCon')@. +-- +-- If the 'FieldType' has a module qualified value, then it returns @'Left' +-- 'Nothing'@. +mEmbedded + :: EmbedEntityMap + -> FieldType + -> Either (Maybe FTTypeConDescr) EmbedEntityDef +mEmbedded _ (FTTypeCon Just{} _) = + Left Nothing +mEmbedded ents (FTTypeCon Nothing (HaskellName -> name)) = + maybe (Left Nothing) Right $ M.lookup name ents +mEmbedded ents (FTList x) = + mEmbedded ents x mEmbedded ents (FTApp x y) = -- Key converts an Record to a RecordId -- special casing this is obviously a hack @@ -342,18 +359,23 @@ mEmbedded ents (FTApp x y) = setEmbedField :: HaskellName -> EmbedEntityMap -> FieldDef -> FieldDef setEmbedField entName allEntities field = field { fieldReference = - case fieldReference field of + setReferenceDefCascade (fieldCascade field) $ case fieldReference field of NoReference -> case mEmbedded allEntities (fieldType field) of Left _ -> case stripId $ fieldType field of - Nothing -> NoReference + Nothing -> + NoReference Just name -> case M.lookup (HaskellName name) allEntities of - Nothing -> NoReference - Just _ -> ForeignRef (HaskellName name) - -- This can get corrected in mkEntityDefSqlTypeExp - (FTTypeCon (Just "Data.Int") "Int64") + Nothing -> + NoReference + Just _ -> + ForeignRef + (HaskellName name) + -- This can get corrected in mkEntityDefSqlTypeExp + (FTTypeCon (Just "Data.Int") "Int64") + (fieldCascade field) Right em -> if embeddedHaskell em /= entName then EmbedRef em @@ -362,7 +384,8 @@ setEmbedField entName allEntities field = field else case fieldType field of FTList _ -> SelfReference _ -> error $ unpack $ unHaskellName entName <> ": a self reference must be a Maybe" - existing -> existing + existing -> + existing } mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp @@ -379,32 +402,39 @@ mkEntityDefSqlTypeExp emEntities entityMap ent = -- We just use SqlString, as the data will be serialized to JSON. defaultSqlTypeExp field = case mEmbedded emEntities ftype of - Right _ -> SqlType' SqlString - Left (Just FTKeyCon) -> SqlType' SqlString - Left Nothing -> case fieldReference field of - ForeignRef refName ft -> case M.lookup refName entityMap of - Nothing -> SqlTypeExp ft - -- A ForeignRef is blindly set to an Int64 in setEmbedField - -- correct that now - Just ent' -> case entityPrimary ent' of - Nothing -> SqlTypeExp ft - Just pdef -> case compositeFields pdef of - [] -> error "mkEntityDefSqlTypeExp: no composite fields" - [x] -> SqlTypeExp $ fieldType x - _ -> SqlType' $ SqlOther "Composite Reference" - CompositeRef _ -> SqlType' $ SqlOther "Composite Reference" - _ -> - case ftype of - -- In the case of lists, we always serialize to a string - -- value (via JSON). - -- - -- Normally, this would be determined automatically by - -- SqlTypeExp. However, there's one corner case: if there's - -- a list of entity IDs, the datatype for the ID has not - -- yet been created, so the compiler will fail. This extra - -- clause works around this limitation. - FTList _ -> SqlType' SqlString - _ -> SqlTypeExp ftype + Right _ -> + SqlType' SqlString + Left (Just FTKeyCon) -> + SqlType' SqlString + Left Nothing -> + case fieldReference field of + ForeignRef refName ft _cascde -> + case M.lookup refName entityMap of + Nothing -> SqlTypeExp ft + -- A ForeignRef is blindly set to an Int64 in setEmbedField + -- correct that now + Just ent' -> + case entityPrimary ent' of + Nothing -> SqlTypeExp ft + Just pdef -> + case compositeFields pdef of + [] -> error "mkEntityDefSqlTypeExp: no composite fields" + [x] -> SqlTypeExp $ fieldType x + _ -> SqlType' $ SqlOther "Composite Reference" + CompositeRef _ _cascade -> + SqlType' $ SqlOther "Composite Reference" + _ -> + case ftype of + -- In the case of lists, we always serialize to a string + -- value (via JSON). + -- + -- Normally, this would be determined automatically by + -- SqlTypeExp. However, there's one corner case: if there's + -- a list of entity IDs, the datatype for the ID has not + -- yet been created, so the compiler will fail. This extra + -- clause works around this limitation. + FTList _ -> SqlType' SqlString + _ -> SqlTypeExp ftype where ftype = fieldType field @@ -1689,18 +1719,21 @@ liftAndFixKeys entityMap EntityDef{..} = |] liftAndFixKey :: EntityMap -> FieldDef -> Q Exp -liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef mcomments) = - [|FieldDef a b c $(sqlTyp') e f fieldRef' mcomments|] +liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments) = + [|FieldDef a b c $(sqlTyp') e f (setReferenceDefCascade fc fieldRef') fc mcomments|] where - (fieldRef', sqlTyp') = fromMaybe (fieldRef, lift sqlTyp) $ - case fieldRef of - ForeignRef refName _ft -> case M.lookup refName entityMap of - Nothing -> Nothing - Just ent -> - case fieldReference $ entityId ent of - fr@(ForeignRef _Name ft) -> Just (fr, lift $ SqlTypeExp ft) - _ -> Nothing - _ -> Nothing + (fieldRef', sqlTyp') = + fromMaybe (fieldRef, lift sqlTyp) $ + case fieldRef of + ForeignRef refName _ft cascade -> do + ent <- M.lookup refName entityMap + case fieldReference $ entityId ent of + ForeignRef targetName ft _targetCascade -> + Just (ForeignRef targetName ft cascade, lift $ SqlTypeExp ft) + _ -> + Nothing + _ -> + Nothing deriving instance Lift EntityDef diff --git a/persistent-template/test/main.hs b/persistent-template/test/main.hs index 25e602bbb..966d4f34b 100644 --- a/persistent-template/test/main.hs +++ b/persistent-template/test/main.hs @@ -34,6 +34,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen (Gen) import GHC.Generics (Generic) +import qualified Data.List as List import Database.Persist import Database.Persist.Sql @@ -43,12 +44,18 @@ import TemplateTestImports share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase| + Person json name Text age Int Maybe foo Foo address Address deriving Show Eq + +HasSimpleCascadeRef + person PersonId OnDeleteCascade + deriving Show Eq + Address json street Text city Text @@ -106,6 +113,75 @@ instance Arbitrary Address where main :: IO () main = hspec $ do + describe "OnCascadeDelete" $ do + let subject :: FieldDef + Just subject = + List.find ((HaskellName "person" ==) . fieldHaskell) + $ entityFields + $ simpleCascadeDef + simpleCascadeDef = + entityDef (Proxy :: Proxy HasSimpleCascadeRef) + expected = + FieldCascade + { fcOnDelete = Just Cascade + , fcOnUpdate = Nothing + } + describe "entityDef" $ do + it "works" $ do + simpleCascadeDef + `shouldBe` + EntityDef + { entityHaskell = HaskellName "HasSimpleCascadeRef" + , entityDB = DBName "HasSimpleCascadeRef" + , entityId = + FieldDef + { fieldHaskell = HaskellName "Id" + , fieldDB = DBName "id" + , fieldType = FTTypeCon Nothing "HasSimpleCascadeRefId" + , fieldSqlType = SqlInt64 + , fieldReference = + ForeignRef (HaskellName "HasSimpleCascadeRef") (FTTypeCon (Just "Data.Int") "Int64") noCascade + , fieldAttrs = [] + , fieldStrict = True + , fieldComments = Nothing + , fieldCascade = noCascade + } + , entityAttrs = [] + , entityFields = + [ FieldDef + { fieldHaskell = HaskellName "person" + , fieldDB = DBName "person" + , fieldType = FTTypeCon Nothing "PersonId" + , fieldSqlType = SqlInt64 + , fieldAttrs = [] + , fieldStrict = True + , fieldReference = + ForeignRef + (HaskellName "Person") + (FTTypeCon (Just "Data.Int") "Int64") + (FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade }) + , fieldCascade = + FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade } + , fieldComments = Nothing + } + ] + , entityUniques = [] + , entityForeigns = [] + , entityDerives = ["Show", "Eq"] + , entityExtra = mempty + , entitySum = False + , entityComments = Nothing + } + it "has the cascade on the field def" $ do + fieldCascade subject `shouldBe` expected + it "has the cascade on the reference def" $ do + ForeignRef _ _ fc <- pure $ fieldReference subject + fc `shouldBe` expected + it "doesn't have any extras" $ do + entityExtra simpleCascadeDef + `shouldBe` + mempty + describe "hasNaturalKey" $ do let subject :: PersistEntity a => Proxy a -> Bool subject p = hasNaturalKey (entityDef p) diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs index 756952358..e72d0c283 100644 --- a/persistent-test/src/ForeignKey.hs +++ b/persistent-test/src/ForeignKey.hs @@ -1,33 +1,44 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications, UndecidableInstances #-} + module ForeignKey where +import Data.Proxy +import qualified Data.List as List import Init -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate"] [persistLowerCase| - Parent +SimpleCascadeChild + ref SimpleCascadeId OnDeleteCascade + deriving Show Eq + +SimpleCascade + name String + deriving Show Eq + +Parent name String Primary name - Child +Child pname String Foreign Parent OnDeleteCascade OnUpdateCascade fkparent pname deriving Show Eq - ParentComposite +ParentComposite name String lastName String Primary name lastName - ChildComposite +ChildComposite pname String plastName String Foreign ParentComposite OnDeleteCascade fkparent pname plastName deriving Show Eq - SelfReferenced +SelfReferenced name String pname String Primary name @@ -36,31 +47,69 @@ share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMig |] specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec -specsWith runDb = describe "foreign keys options" $ do - it "delete cascades" $ runDb $ do - kf <- insert $ Parent "A" - kc <- insert $ Child "A" - delete kf - cs <- selectList [] [] - let expected = [] :: [Entity Child] - cs @== expected - it "update cascades" $ runDb $ do - kf <- insert $ Parent "A" - kc <- insert $ Child "A" - update kf [ParentName =. "B"] - cs <- selectList [] [] - fmap (childPname . entityVal) cs @== ["B"] - it "delete Composite cascades" $ runDb $ do - kf <- insert $ ParentComposite "A" "B" - kc <- insert $ ChildComposite "A" "B" - delete kf - cs <- selectList [] [] - let expected = [] :: [Entity ChildComposite] - cs @== expected - it "delete self referenced cascades" $ runDb $ do - kf <- insert $ SelfReferenced "A" "A" -- bootstrap self reference - kc <- insert $ SelfReferenced "B" "A" - delete kf - srs <- selectList [] [] - let expected = [] :: [Entity SelfReferenced] - srs @== expected +specsWith runDb = fdescribe "foreign keys options" $ do + it "delete cascades" $ runDb $ do + kf <- insert $ Parent "A" + kc <- insert $ Child "A" + delete kf + cs <- selectList [] [] + let expected = [] :: [Entity Child] + cs @== expected + it "update cascades" $ runDb $ do + kf <- insert $ Parent "A" + kc <- insert $ Child "A" + update kf [ParentName =. "B"] + cs <- selectList [] [] + fmap (childPname . entityVal) cs @== ["B"] + it "delete Composite cascades" $ runDb $ do + kf <- insert $ ParentComposite "A" "B" + kc <- insert $ ChildComposite "A" "B" + delete kf + cs <- selectList [] [] + let expected = [] :: [Entity ChildComposite] + cs @== expected + it "delete self referenced cascades" $ runDb $ do + kf <- insert $ SelfReferenced "A" "A" -- bootstrap self reference + kc <- insert $ SelfReferenced "B" "A" + delete kf + srs <- selectList [] [] + let expected = [] :: [Entity SelfReferenced] + srs @== expected + it "delete cascade works on simple references" $ runDb $ do + scId <- insert $ SimpleCascade "Hello" + sccId <- insert $ SimpleCascadeChild scId + Just _ <- get sccId + delete scId + mres <- get sccId + mxs <- selectList @SimpleCascadeChild [] [] + liftIO $ do + mres `shouldBe` Nothing + mxs `shouldBe` [] + + describe "EntityDef" $ do + let ed = + entityDef (Proxy @SimpleCascadeChild) + isRefCol = + (HaskellName "ref" ==) . fieldHaskell + expected = FieldCascade + { fcOnUpdate = Nothing + , fcOnDelete = Just Cascade + } + Just refField = + List.find isRefCol (entityFields ed) + + it "parses into fieldCascade" $ do + fieldCascade refField `shouldBe` expected + + it "parses into the fieldReference" $ do + ForeignRef haskName _ cascade <- + pure $ fieldReference refField + + haskName `shouldBe` HaskellName "SimpleCascade" + + cascade `shouldBe` expected + + it "shouldn't have cascade in extras" $ do + entityExtra ed + `shouldBe` + mempty diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index c27a0dcc8..3af2cc674 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -255,11 +255,15 @@ module Database.Persist.Quasi , associateLines , skipEmpty , LinesWithComments(..) + , splitExtras + , takeColsEx #endif ) where import Prelude hiding (lines) +import qualified Debug.Trace as Debug + import qualified Data.List.NonEmpty as NEL import Data.List.NonEmpty (NonEmpty(..)) import Control.Arrow ((&&&)) @@ -697,7 +701,7 @@ mkEntityDef ps name entattribs lines = derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef] - cols = reverse . fst . foldr k ([], []) $ reverse attribs + cols = fmap setReferenceCascade . reverse . fst . foldr k ([], []) $ reverse attribs k x (!acc, !comments) = case isComment =<< listToMaybe x of Just comment -> @@ -709,12 +713,17 @@ mkEntityDef ps name entattribs lines = setFieldComments [] x = x setFieldComments xs fld = fld { fieldComments = Just (T.unlines xs) } + setReferenceCascade fd = fd + { fieldReference = setReferenceDefCascade (fieldCascade fd) (fieldReference fd) + } autoIdField = mkAutoIdField ps entName (DBName `fmap` idName) idSqlType idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite setComposite Nothing fd = fd - setComposite (Just c) fd = fd { fieldReference = CompositeRef c } + setComposite (Just c) fd = fd + { fieldReference = CompositeRef c (fieldCascade fd) + } just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x @@ -722,22 +731,23 @@ 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" - -- this should be modeled as a Maybe - -- but that sucks for non-ID field - -- TODO: use a sumtype FieldDef | IdFieldDef - , fieldDB = fromMaybe (DBName $ psIdName ps) idName - , fieldType = FTTypeCon Nothing $ keyConName $ unHaskellName entName - , fieldSqlType = idSqlType - -- the primary field is actually a reference to the entity - , fieldReference = ForeignRef entName defaultReferenceTypeCon - , fieldAttrs = [] - , fieldStrict = True - , fieldComments = Nothing - } +mkAutoIdField ps entName idName idSqlType = + FieldDef + { fieldHaskell = HaskellName "Id" + -- this should be modeled as a Maybe + -- but that sucks for non-ID field + -- TODO: use a sumtype FieldDef | IdFieldDef + , fieldDB = fromMaybe (DBName $ psIdName ps) idName + , fieldType = FTTypeCon Nothing $ keyConName $ unHaskellName entName + , fieldSqlType = idSqlType + -- the primary field is actually a reference to the entity + , fieldReference = ForeignRef entName defaultReferenceTypeCon noCascade + , fieldAttrs = [] + , fieldStrict = True + , fieldComments = Nothing + , fieldCascade = noCascade + } defaultReferenceTypeCon :: FieldType defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" @@ -745,8 +755,11 @@ defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" keyConName :: Text -> Text keyConName entName = entName `mappend` "Id" - -splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]]) +splitExtras + :: [Line] + -> ( [[Text]] + , M.Map Text [[Text]] + ) splitExtras [] = ([], M.empty) splitExtras (Line indent [name]:rest) | not (T.null name) && isUpper (T.head name) = @@ -772,17 +785,19 @@ takeCols onErr ps (n':typ:rest) | not (T.null n) && isLower (T.head n) = case parseFieldType typ of Left err -> onErr typ err - Right ft -> Just FieldDef + Right ft -> Just $ FieldDef { fieldHaskell = HaskellName n , fieldDB = DBName $ getDbName ps n rest , fieldType = ft , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n - , fieldAttrs = rest + , fieldAttrs = attrs_ , fieldStrict = fromMaybe (psStrictFields ps) mstrict , fieldReference = NoReference , fieldComments = Nothing + , fieldCascade = cascade_ } where + (cascade_, attrs_) = parseCascade rest (mstrict, n) | Just x <- T.stripPrefix "!" n' = (Just True, x) | Just x <- T.stripPrefix "~" n' = (Just False, x) @@ -811,19 +826,29 @@ takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing) -- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. -- need to re-work takeCols function takeId :: PersistSettings -> Text -> [Text] -> FieldDef -takeId ps tableName (n:rest) = fromMaybe (error "takeId: impossible!") $ setFieldDef $ - takeCols (\_ _ -> addDefaultIdType) ps (field:rest `mappend` setIdName) +takeId ps tableName (n:rest) = + setFieldDef + $ fromMaybe (error "takeId: impossible!") + $ takeCols (\_ _ -> addDefaultIdType) ps (field:rest `mappend` setIdName) where field = case T.uncons n of - Nothing -> error "takeId: empty field" - Just (f, ield) -> toLower f `T.cons` ield + Nothing -> error "takeId: empty field" + Just (f, ield) -> toLower f `T.cons` ield addDefaultIdType = takeColsEx ps (field : keyCon : rest `mappend` setIdName) - setFieldDef = fmap (\fd -> - let refFieldType = if fieldType fd == FTTypeCon Nothing keyCon - then defaultReferenceTypeCon - else fieldType fd - in fd { fieldReference = ForeignRef (HaskellName tableName) $ refFieldType - }) + setFieldDef fd = + let refFieldType = + if fieldType fd == FTTypeCon Nothing keyCon + then defaultReferenceTypeCon + else fieldType fd + -- this is fine because we're only calling this function with + -- the primary key type + cascade = + fieldCascade fd + in + fd + { fieldReference = + ForeignRef (HaskellName tableName) refFieldType cascade + } keyCon = keyConName tableName -- this will be ignored if there is already an existing sql= -- TODO: I think there is a ! ignore syntax that would screw this up @@ -831,13 +856,12 @@ takeId ps tableName (n:rest) = fromMaybe (error "takeId: impossible!") $ setFiel takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName -takeComposite :: [FieldDef] - -> [Text] - -> CompositeDef -takeComposite fields pkcols - = CompositeDef - (map (getDef fields) pkcols) - attrs +takeComposite + :: [FieldDef] + -> [Text] + -> CompositeDef +takeComposite fields pkcols = + CompositeDef (map (getDef fields) pkcols) attrs where (_, attrs) = break ("!" `T.isPrefixOf`) pkcols getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t @@ -942,18 +966,76 @@ takeForeign ps tableName _defs = takeRefTable } where (fields,attrs) = break ("!" `T.isPrefixOf`) rest - go ((T.stripPrefix "OnDelete" -> Just onDelete) : rest) onDelete' onUpdate - = case (onDelete', readEither $ T.unpack onDelete) of - (Nothing, Right cascadingAction) -> go rest (Just cascadingAction) onUpdate - (Nothing, Left _) -> error $ errorPrefix ++ "could not parse OnDelete action" - (Just _, _) -> error $ errorPrefix ++ "found more than one OnDelete actions" - go ((T.stripPrefix "OnUpdate" -> Just onUpdate) : rest) onDelete onUpdate' - = case (onUpdate', readEither $ T.unpack onUpdate) of - (Nothing, Right cascadingAction) -> go rest onDelete (Just cascadingAction) - (Nothing, Left _) -> error $ errorPrefix ++ "could not parse OnUpdate action" - (Just _, _) -> error $ errorPrefix ++ "found more than one OnUpdate actions" + + go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = + case onDelete' of + Nothing -> + go rest (Just cascadingAction) onUpdate + Just _ -> + error $ errorPrefix ++ "found more than one OnDelete actions" + + go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = + case onUpdate' of + Nothing -> + go rest onDelete (Just cascadingAction) + Just _ -> + error $ errorPrefix ++ "found more than one OnUpdate actions" + go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs +data CascadePrefix = CascadeUpdate | CascadeDelete + +parseCascade :: [Text] -> (FieldCascade, [Text]) +parseCascade allTokens = + go [] Nothing Nothing allTokens + where + go acc mupd mdel tokens = + case tokens of + [] -> + ( FieldCascade + { fcOnDelete = mdel + , fcOnUpdate = mupd + } + , acc + ) + this : rest -> + case parseCascadeAction CascadeUpdate this of + Just cascUpd -> + case mupd of + Nothing -> + go acc (Just cascUpd) mdel rest + Just _ -> + nope "found more than one OnUpdate action" + Nothing -> + case parseCascadeAction CascadeDelete this of + Just cascDel -> + case mdel of + Nothing -> + go acc mupd (Just cascDel) rest + Just _ -> + nope "found more than one OnDelete action: " + Nothing -> + go (this : acc) mupd mdel rest + nope msg = + error $ msg <> ", tokens: " <> show allTokens + +parseCascadeAction + :: CascadePrefix + -> Text + -> Maybe CascadeAction +parseCascadeAction prfx text = do + cascadeStr <- T.stripPrefix ("On" <> toPrefix prfx) text + case readEither (T.unpack cascadeStr) of + Right a -> + Just a + Left _ -> + Nothing + where + toPrefix cp = + case cp of + CascadeUpdate -> "Update" + CascadeDelete -> "Delete" + takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest takeDerives _ = Nothing diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index 9a19c7520..d690f0454 100644 --- a/persistent/Database/Persist/Sql/Internal.hs +++ b/persistent/Database/Persist/Sql/Internal.hs @@ -120,19 +120,19 @@ mkColumns allDefs t overrides = ref :: DBName -> ReferenceDef -> [Attr] - -> Maybe (DBName, DBName) -- table name, constraint name + -> Maybe (DBName, DBName, FieldCascade) -- table name, constraint name ref c fe [] - | ForeignRef f _ <- fe = - Just (resolveTableName allDefs f, refNameFn tableName c) + | ForeignRef f _ cascade <- fe = + Just (resolveTableName allDefs f, refNameFn tableName c, cascade) | otherwise = Nothing ref _ _ ("noreference":_) = Nothing ref c fe (a:as) | Just x <- T.stripPrefix "reference=" a = do - constraintName <- snd <$> (ref c fe as) - pure (DBName x, constraintName) + (_, constraintName, _) <- ref c fe as + pure (DBName x, constraintName, fromMaybe noCascade $ getReferenceDefCascade fe) | Just x <- T.stripPrefix "constraint=" a = do - tableName <- fst <$> (ref c fe as) - pure (tableName, DBName x) + (tableName, _, _) <- ref c fe as + pure (tableName, DBName x, fromMaybe noCascade $ getReferenceDefCascade fe) ref c x (_:as) = ref c x as refName :: DBName -> DBName -> DBName diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index f00339ad6..7044de6fb 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -25,7 +25,7 @@ data Column = Column , cDefault :: !(Maybe Text) , cDefaultConstraintName :: !(Maybe DBName) , cMaxLen :: !(Maybe Integer) - , cReference :: !(Maybe (DBName, DBName)) -- table name, constraint name + , cReference :: !(Maybe (DBName, DBName, FieldCascade)) -- table name, constraint name } deriving (Eq, Ord, Show) diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 4788f7b81..40ab8985b 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -141,7 +141,7 @@ data EntityDef = EntityDef entityPrimary :: EntityDef -> Maybe CompositeDef entityPrimary t = case fieldReference (entityId t) of - CompositeRef c -> Just c + CompositeRef c _ -> Just c _ -> Nothing entityKeyFields :: EntityDef -> [FieldDef] @@ -165,9 +165,21 @@ newtype DBName = DBName { unDBName :: Text } type Attr = Text +-- | A 'FieldType' describes a field parsed from the QuasiQuoter and is +-- used to determine the Haskell type in the generated code. +-- +-- @name Text@ parses into @FTTypeCon Nothing "Text"@ +-- +-- @name T.Text@ parses into @FTTypeCon (Just "T" "Text")@ +-- +-- @name (Jsonb User)@ parses into: +-- +-- @ +-- FTApp (FTTypeCon Nothing "Jsonb") (FTTypeCon Nothing "User") +-- @ data FieldType = FTTypeCon (Maybe Text) Text - -- ^ Optional module and name. + -- ^ Optional module and name. | FTApp FieldType FieldType | FTList FieldType deriving (Show, Eq, Read, Ord) @@ -196,6 +208,13 @@ data FieldDef = FieldDef -- ^ If this is 'True', then the Haskell datatype will have a strict -- record field. The default value for this is 'True'. , fieldReference :: !ReferenceDef + , fieldCascade :: !FieldCascade + -- ^ Defines how operations on the field cascade on to the referenced + -- tables. This doesn't have any meaning if the 'fieldReference' is set + -- to 'NoReference' or 'SelfReference'. The cascade option here should + -- be the same as the one obtained in the 'fieldReference'. + -- + -- @since 2.11.0 , fieldComments :: !(Maybe Text) -- ^ Optional comments for a 'Field'. There is not currently a way to -- attach comments to a field in the quasiquoter. @@ -210,14 +229,28 @@ data FieldDef = FieldDef -- 2) single field -- 3) embedded data ReferenceDef = NoReference - | ForeignRef !HaskellName !FieldType + | ForeignRef !HaskellName !FieldType !FieldCascade -- ^ A ForeignRef has a late binding to the EntityDef it references via HaskellName and has the Haskell type of the foreign key in the form of FieldType | EmbedRef EmbedEntityDef - | CompositeRef CompositeDef + | CompositeRef CompositeDef !FieldCascade | SelfReference -- ^ A SelfReference stops an immediate cycle which causes non-termination at compile-time (issue #311). deriving (Show, Eq, Read, Ord) +getReferenceDefCascade :: ReferenceDef -> Maybe FieldCascade +getReferenceDefCascade rd = + case rd of + ForeignRef _ _ fc -> Just fc + CompositeRef _ fc -> Just fc + _ -> Nothing + +setReferenceDefCascade :: FieldCascade -> ReferenceDef -> ReferenceDef +setReferenceDefCascade fc rd = + case rd of + ForeignRef a b _ -> ForeignRef a b fc + CompositeRef a _ -> CompositeRef a fc + _ -> rd + -- | An EmbedEntityDef is the same as an EntityDef -- But it is only used for fieldReference -- so it only has data needed for embedding diff --git a/persistent/test/main.hs b/persistent/test/main.hs index e138a0aca..78a56605d 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -1,4 +1,4 @@ -{-# language RecordWildCards #-} +{-# language RecordWildCards, OverloadedStrings #-} import Test.Hspec import qualified Data.Text as T @@ -13,6 +13,99 @@ import Database.Persist.Types main :: IO () main = hspec $ do + describe "splitExtras" $ do + it "works" $ do + splitExtras [] + `shouldBe` + mempty + it "works2" $ do + splitExtras + [ Line 0 ["hello", "world"] + ] + `shouldBe` + ( [["hello", "world"]], mempty ) + it "works3" $ do + splitExtras + [ Line 0 ["hello", "world"] + , Line 2 ["foo", "bar", "baz"] + ] + `shouldBe` + ( [["hello", "world"], ["foo", "bar", "baz"]], mempty ) + it "works4" $ do + let foobarbarz = ["foo", "Bar", "baz"] + splitExtras + [ Line 0 ["Hello"] + , Line 2 foobarbarz + , Line 2 foobarbarz + ] + `shouldBe` + ( [] + , Map.fromList + [ ("Hello", [foobarbarz, foobarbarz]) + ] + ) + it "works5" $ do + let foobarbarz = ["foo", "Bar", "baz"] + splitExtras + [ Line 0 ["Hello"] + , Line 2 foobarbarz + , Line 4 foobarbarz + ] + `shouldBe` + ( [] + , Map.fromList + [ ("Hello", [foobarbarz, foobarbarz]) + ] + ) + describe "takeColsEx" $ do + let subject = takeColsEx upperCaseSettings + it "fails on a single word" $ do + subject ["asdf"] + `shouldBe` + Nothing + it "works if it has a name and a type" $ do + subject ["asdf", "Int"] + `shouldBe` + Just FieldDef + { fieldHaskell = HaskellName "asdf" + , fieldDB = DBName "asdf" + , fieldType = FTTypeCon Nothing "Int" + , fieldSqlType = SqlOther "SqlType unset for asdf" + , fieldAttrs = [] + , fieldStrict = True + , fieldReference = NoReference + , fieldCascade = noCascade + , fieldComments = Nothing + } + it "works if it has a name, type, and cascade" $ do + subject ["asdf", "Int", "OnDeleteCascade", "OnUpdateCascade"] + `shouldBe` + Just FieldDef + { fieldHaskell = HaskellName "asdf" + , fieldDB = DBName "asdf" + , fieldType = FTTypeCon Nothing "Int" + , fieldSqlType = SqlOther "SqlType unset for asdf" + , fieldAttrs = [] + , fieldStrict = True + , fieldReference = NoReference + , fieldCascade = FieldCascade (Just Cascade) (Just Cascade) + , fieldComments = Nothing + } + it "never tries to make a refernece" $ do + subject ["asdf", "UserId", "OnDeleteCascade"] + `shouldBe` + Just FieldDef + { fieldHaskell = HaskellName "asdf" + , fieldDB = DBName "asdf" + , fieldType = FTTypeCon Nothing "UserId" + , fieldSqlType = SqlOther "SqlType unset for asdf" + , fieldAttrs = [] + , fieldStrict = True + , fieldReference = NoReference + , fieldCascade = FieldCascade Nothing (Just Cascade) + , fieldComments = Nothing + } + describe "tokenization" $ do it "handles normal words" $ tokenize " foo bar baz" `shouldBe` From 31a383b62db0e882c7536f16b050497bee385a7e Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 30 Oct 2020 16:44:55 -0600 Subject: [PATCH 10/21] built --- persistent-test/src/ForeignKey.hs | 146 +++++++++++------------------- 1 file changed, 54 insertions(+), 92 deletions(-) diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs index 5a88d6dc5..c9402fe57 100644 --- a/persistent-test/src/ForeignKey.hs +++ b/persistent-test/src/ForeignKey.hs @@ -54,40 +54,40 @@ SelfReferenced Foreign SelfReferenced OnDeleteCascade fkparent pname deriving Show Eq - A +A aa String ab Int U1 aa - B +B ba String bb Int Foreign A OnDeleteCascade fkA ba References aa deriving Show Eq - AComposite +AComposite aa String ab Int U2 aa ab - BComposite +BComposite ba String bb Int Foreign AComposite OnDeleteCascade fkAComposite ba bb References aa ab deriving Show Eq - BExplicit +BExplicit ba AId noreference Foreign A OnDeleteCascade fkAI ba References Id deriving Show Eq - Chain +Chain name String previous ChainId Maybe noreference Foreign Chain OnDeleteSetNull fkChain previous References Id deriving Show Eq - Chain2 +Chain2 name String previous Chain2Id Maybe noreference Foreign Chain2 OnDeleteCascade fkChain previous References Id @@ -95,7 +95,6 @@ SelfReferenced |] specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec -<<<<<<< HEAD specsWith runDb = fdescribe "foreign keys options" $ do it "delete cascades" $ runDb $ do kf <- insert $ Parent "A" @@ -134,6 +133,53 @@ specsWith runDb = fdescribe "foreign keys options" $ do liftIO $ do mres `shouldBe` Nothing mxs `shouldBe` [] + it "delete cascades with explicit Reference" $ runDb $ do + kf <- insert $ A "A" 40 + kc <- insert $ B "A" 15 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Composite Reference" $ runDb $ do + kf <- insert $ AComposite "A" 20 + kc <- insert $ BComposite "A" 20 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Composite Reference" $ runDb $ do + kf <- insert $ AComposite "A" 20 + kc <- insert $ BComposite "A" 20 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Id field" $ runDb $ do + kf <- insert $ A "A" 20 + kc <- insert $ BExplicit kf + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "deletes sets null with self reference" $ runDb $ do + kf <- insert $ Chain "A" Nothing + insert $ Chain "B" (Just kf) + delete kf + cs <- selectList [] [] + let expected = [Entity {entityKey = ChainKey 2, entityVal = Chain "B" Nothing}] + cs @== expected + it "deletes cascades with self reference to the whole chain" $ runDb $ do + k1 <- insert $ Chain2 "A" Nothing + k2 <- insert $ Chain2 "B" (Just k1) + k3 <- insert $ Chain2 "C" (Just k2) + delete k1 + cs <- selectList [] [] + let expected = [] :: [Entity Chain2] + cs @== expected describe "EntityDef" $ do let ed = @@ -162,87 +208,3 @@ specsWith runDb = fdescribe "foreign keys options" $ do entityExtra ed `shouldBe` mempty -======= -specsWith runDb = describe "foreign keys options" $ do - it "delete cascades" $ runDb $ do - kf <- insert $ Parent "A" - kc <- insert $ Child "A" - delete kf - cs <- selectList [] [] - let expected = [] :: [Entity Child] - cs @== expected - it "update cascades" $ runDb $ do - kf <- insert $ Parent "A" - kc <- insert $ Child "A" - update kf [ParentName =. "B"] - cs <- selectList [] [] - fmap (childPname . entityVal) cs @== ["B"] - it "delete cascades on implicit Primary key" $ runDb $ do - kf <- insert $ ParentImplicit "A" - kc <- insert $ ChildImplicit "B" kf - delete kf - cs <- selectList [] [] - let expected = [] :: [Entity ChildImplicit] - cs @== expected - it "delete Composite cascades" $ runDb $ do - kf <- insert $ ParentComposite "A" "B" - kc <- insert $ ChildComposite "A" "B" - delete kf - cs <- selectList [] [] - let expected = [] :: [Entity ChildComposite] - cs @== expected - it "delete self referenced cascades" $ runDb $ do - kf <- insert $ SelfReferenced "A" "A" -- bootstrap self reference - kc <- insert $ SelfReferenced "B" "A" - delete kf - srs <- selectList [] [] - let expected = [] :: [Entity SelfReferenced] - srs @== expected - it "delete cascades with explicit Reference" $ runDb $ do - kf <- insert $ A "A" 40 - kc <- insert $ B "A" 15 - delete kf - return () - cs <- selectList [] [] - let expected = [] :: [Entity B] - cs @== expected - it "delete cascades with explicit Composite Reference" $ runDb $ do - kf <- insert $ AComposite "A" 20 - kc <- insert $ BComposite "A" 20 - delete kf - return () - cs <- selectList [] [] - let expected = [] :: [Entity B] - cs @== expected - it "delete cascades with explicit Composite Reference" $ runDb $ do - kf <- insert $ AComposite "A" 20 - kc <- insert $ BComposite "A" 20 - delete kf - return () - cs <- selectList [] [] - let expected = [] :: [Entity B] - cs @== expected - it "delete cascades with explicit Id field" $ runDb $ do - kf <- insert $ A "A" 20 - kc <- insert $ BExplicit kf - delete kf - return () - cs <- selectList [] [] - let expected = [] :: [Entity B] - cs @== expected - it "deletes sets null with self reference" $ runDb $ do - kf <- insert $ Chain "A" Nothing - insert $ Chain "B" (Just kf) - delete kf - cs <- selectList [] [] - let expected = [Entity {entityKey = ChainKey 2, entityVal = Chain "B" Nothing}] - cs @== expected - it "deletes cascades with self reference to the whole chain" $ runDb $ do - k1 <- insert $ Chain2 "A" Nothing - k2 <- insert $ Chain2 "B" (Just k1) - k3 <- insert $ Chain2 "C" (Just k2) - delete k1 - cs <- selectList [] [] - let expected = [] :: [Entity Chain2] - cs @== expected ->>>>>>> bec37c66d764f4b8d7a9c6d40d8e2ca5b2b47283 From d58ea2af889f31dfdee38267863f1a22dbbc447f Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 30 Oct 2020 16:52:40 -0600 Subject: [PATCH 11/21] remove trace --- persistent-sqlite/Database/Persist/Sqlite.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 85305e1d9..92b27186e 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -45,8 +45,6 @@ module Database.Persist.Sqlite , withRawSqlitePoolInfo_ ) where -import qualified Debug.Trace as Debug - import Control.Concurrent (threadDelay) import qualified Control.Exception as E import Control.Monad (forM_) From 1ba1af64f546149562cbe69785b9d7d7307b106a Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 30 Oct 2020 18:38:42 -0600 Subject: [PATCH 12/21] add some docs --- persistent/Database/Persist/Sql/Types.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index da687b88f..e6ee92b70 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -31,10 +31,23 @@ data Column = Column } deriving (Eq, Ord, Show) +-- | This value specifies how a field references another table. +-- +-- @since 2.11.0.0 data ColumnReference = ColumnReference { crTableName :: DBName + -- ^ The table name that the + -- + -- @since 2.11.0.0 , crConstraintName :: DBName + -- ^ The name of the foreign key constraint. + -- + -- @since 2.11.0.0 , crFieldCascade :: FieldCascade + -- ^ Whether or not updates/deletions to the referenced table cascade + -- to this table. + -- + -- @since 2.11.0.0 } deriving (Eq, Ord, Show) From 337d6b62b47b6fff2069abe02d97dd1c53919971 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 30 Oct 2020 20:04:08 -0600 Subject: [PATCH 13/21] uhhh these tests should not be failing --- persistent-mysql/test/main.hs | 2 +- persistent-template/Database/Persist/TH.hs | 13 ++- persistent-template/test/main.hs | 106 ++++++++++++++++++++- persistent-test/src/Init.hs | 2 + persistent-test/src/RenameTest.hs | 29 +++--- persistent/Database/Persist/Quasi.hs | 4 +- 6 files changed, 138 insertions(+), 18 deletions(-) diff --git a/persistent-mysql/test/main.hs b/persistent-mysql/test/main.hs index 751abb77f..2051e7ea8 100644 --- a/persistent-mysql/test/main.hs +++ b/persistent-mysql/test/main.hs @@ -102,7 +102,7 @@ instance Arbitrary (DataTypeTableGeneric backend) where setup :: (HasCallStack, MonadUnliftIO m) => Migration -> ReaderT SqlBackend m () setup migration = do printMigration migration - _ <- runMigrationSilent migration + _ <- runMigrationUnsafe migration pure () main :: IO () diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index de73e82ef..f508d427d 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -55,13 +55,17 @@ module Database.Persist.TH , fieldError , AtLeastOneUniqueKey(..) , OnlyOneUniqueKey(..) + , pkNewtype ) where -- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code -- It's highly recommended to check the diff between master and your PR's generated code. +import qualified Debug.Trace as Debug + import Prelude hiding ((++), take, concat, splitAt, exp) +import Control.Applicative import Data.Either import Control.Monad (forM, mzero, filterM, guard, unless) import Data.Aeson @@ -1014,6 +1018,9 @@ keyString = unpack . keyText keyText :: EntityDef -> Text keyText t = unHaskellName (entityHaskell t) ++ "Key" +-- | Returns 'True' if the key definition has more than 1 field. +-- +-- @since 2.11.0.0 pkNewtype :: MkPersistSettings -> EntityDef -> Bool pkNewtype mps t = length (keyFields mps t) < 2 @@ -1733,8 +1740,8 @@ liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments) = ForeignRef refName _ft cascade -> do ent <- M.lookup refName entityMap case fieldReference $ entityId ent of - ForeignRef targetName ft _targetCascade -> - Just (ForeignRef targetName ft cascade, lift $ SqlTypeExp ft) + fr@(ForeignRef targetName ft _targetCascade) -> + Just (fr, lift $ SqlTypeExp ft) _ -> Nothing _ -> diff --git a/persistent-template/test/main.hs b/persistent-template/test/main.hs index 966d4f34b..6015a8437 100644 --- a/persistent-template/test/main.hs +++ b/persistent-template/test/main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeApplications, DeriveGeneric #-} +{-# LANGUAGE TypeApplications, DeriveGeneric, RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -23,6 +23,7 @@ module Main module Main ) where +import Data.Int import Data.Proxy import Control.Applicative (Const (..)) import Data.Aeson @@ -35,6 +36,7 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen (Gen) import GHC.Generics (Generic) import qualified Data.List as List +import Data.Coerce import Database.Persist import Database.Persist.Sql @@ -84,6 +86,21 @@ HasIdDef HasDefaultId name String +HasCustomSqlId + Id String sql=my_id + name String + +SharedPrimaryKey + Id (Key HasDefaultId) + name String + +SharedPrimaryKeyWithCascade + Id (Key HasDefaultId) OnDeleteCascade + name String + +SharedPrimaryKeyWithCascadeAndCustomName + Id (Key HasDefaultId) OnDeleteCascade sql=my_id + name String |] share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase| @@ -113,6 +130,93 @@ instance Arbitrary Address where main :: IO () main = hspec $ do + describe "HasDefaultId" $ do + let FieldDef{..} = + entityId (entityDef (Proxy @HasDefaultId)) + it "should have usual db name" $ do + fieldDB `shouldBe` DBName "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` HaskellName "Id" + it "should have correct underlying sql type" $ do + fieldSqlType `shouldBe` SqlInt64 + it "persistfieldsql should be right" $ do + sqlType (Proxy @HasDefaultIdId) `shouldBe` SqlInt64 + it "should have correct haskell type" $ do + fieldType `shouldBe` FTTypeCon Nothing "HasDefaultIdId" + + describe "HasCustomSqlId" $ do + let FieldDef{..} = + entityId (entityDef (Proxy @HasCustomSqlId)) + it "should have custom db name" $ do + fieldDB `shouldBe` DBName "my_id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` HaskellName "id" + it "should have correct underlying sql type" $ do + fieldSqlType `shouldBe` SqlString + it "should have correct haskell type" $ do + fieldType `shouldBe` FTTypeCon Nothing "String" + describe "HasIdDef" $ do + let FieldDef{..} = + entityId (entityDef (Proxy @HasIdDef)) + it "should have usual db name" $ do + fieldDB `shouldBe` DBName "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` HaskellName "id" + it "should have correct underlying sql type" $ do + fieldSqlType `shouldBe` SqlInt64 + it "should have correct haskell type" $ do + fieldType `shouldBe` FTTypeCon Nothing "Int" + + describe "SharedPrimaryKey" $ do + let sharedDef = entityDef (Proxy @SharedPrimaryKey) + FieldDef{..} = + entityId sharedDef + it "should have usual db name" $ do + fieldDB `shouldBe` DBName "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` HaskellName "id" + it "should have correct underlying sql type" $ do + fieldSqlType `shouldBe` SqlInt64 + it "should have correct haskell type" $ do + fieldType `shouldBe` FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId") + it "should have correct sql type from PersistFieldSql" $ do + sqlType (Proxy @SharedPrimaryKeyId) + `shouldBe` + SqlInt64 + it "should have same sqlType as underlying record" $ do + sqlType (Proxy @SharedPrimaryKeyId) + `shouldBe` + sqlType (Proxy @HasDefaultIdId) + it "should be a coercible newtype" $ do + coerce @Int64 3 + `shouldBe` + SharedPrimaryKeyKey (toSqlKey 3) + + it "is a newtype" $ do + pkNewtype sqlSettings sharedDef + `shouldBe` + True + + describe "SharedPrimaryKeyWithCascade" $ do + let FieldDef{..} = + entityId (entityDef (Proxy @SharedPrimaryKeyWithCascade)) + it "should have usual db name" $ do + fieldDB `shouldBe` DBName "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` HaskellName "id" + it "should have correct underlying sql type" $ do + fieldSqlType `shouldBe` SqlInt64 + it "should have correct haskell type" $ do + fieldType + `shouldBe` + FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId") + it "should have cascade in field def" $ do + fieldCascade `shouldBe` noCascade { fcOnDelete = Just Cascade } + it "should have cascade in foreign ref" $ do + getReferenceDefCascade fieldReference + `shouldBe` Just noCascade { fcOnDelete = Just Cascade } + + describe "OnCascadeDelete" $ do let subject :: FieldDef Just subject = diff --git a/persistent-test/src/Init.hs b/persistent-test/src/Init.hs index ecb892e46..274d3480b 100644 --- a/persistent-test/src/Init.hs +++ b/persistent-test/src/Init.hs @@ -41,6 +41,7 @@ module Init ( , arbText , liftA2 , changeBackend + , Proxy(..) ) where -- needed for backwards compatibility @@ -66,6 +67,7 @@ import qualified Data.Text as T import Data.Time import Test.Hspec import Test.QuickCheck.Instances () +import Data.Proxy import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) diff --git a/persistent-test/src/RenameTest.hs b/persistent-test/src/RenameTest.hs index e8ed14b0b..d407623e2 100644 --- a/persistent-test/src/RenameTest.hs +++ b/persistent-test/src/RenameTest.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications, UndecidableInstances #-} + module RenameTest where import qualified Data.Map as Map @@ -72,17 +73,23 @@ specsWith => RunDb backend m -> Spec specsWith runDb = describe "rename specs" $ do + describe "LowerCaseTable" $ do + it "LowerCaseTable has the right sql name" $ do + fieldDB (entityId (entityDef (Proxy @LowerCaseTable))) + `shouldBe` + DBName "my_id" + it "user specified id, insertKey, no default=" $ runDb $ do - let rec2 = IdTable "Foo2" Nothing - let rec1 = IdTable "Foo1" $ Just rec2 - let rec = IdTable "Foo" $ Just rec1 - now <- liftIO getCurrentTime - let key = IdTableKey $ utctDay now - insertKey key rec - Just rec' <- get key - rec' @== rec - (Entity key' _):_ <- selectList ([] :: [Filter (IdTableGeneric backend)]) [] - key' @== key + let rec2 = IdTable "Foo2" Nothing + let rec1 = IdTable "Foo1" $ Just rec2 + let rec = IdTable "Foo" $ Just rec1 + now <- liftIO getCurrentTime + let key = IdTableKey $ utctDay now + insertKey key rec + Just rec' <- get key + rec' @== rec + (Entity key' _):_ <- selectList ([] :: [Filter (IdTableGeneric backend)]) [] + key' @== key it "extra blocks" $ entityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?= diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 55746037f..c6688d39b 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -834,12 +834,12 @@ takeId :: PersistSettings -> Text -> [Text] -> FieldDef takeId ps tableName (n:rest) = setFieldDef $ fromMaybe (error "takeId: impossible!") - $ takeCols (\_ _ -> addDefaultIdType) ps (field:rest `mappend` setIdName) + $ takeCols (\_ _ -> addDefaultIdType) ps (field:rest) -- `mappend` setIdName) where field = case T.uncons n of Nothing -> error "takeId: empty field" Just (f, ield) -> toLower f `T.cons` ield - addDefaultIdType = takeColsEx ps (field : keyCon : rest `mappend` setIdName) + addDefaultIdType = takeColsEx ps (field : keyCon : rest ) -- `mappend` setIdName) setFieldDef fd = let refFieldType = if fieldType fd == FTTypeCon Nothing keyCon From 89aea41e220f411a75332a8d95b371bb985daaad Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Sun, 1 Nov 2020 16:45:03 -0700 Subject: [PATCH 14/21] postgres tests are passing --- .../Database/Persist/Postgresql.hs | 199 ++++++++++-------- persistent-postgresql/test/main.hs | 1 + persistent-sqlite/test/main.hs | 1 + persistent-test/src/ForeignKey.hs | 32 ++- persistent-test/src/PersistentTest.hs | 2 - persistent/Database/Persist/Sql/Types.hs | 6 +- 6 files changed, 149 insertions(+), 92 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index a2c8c17f7..4cd516031 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -40,9 +40,11 @@ import qualified Database.PostgreSQL.Simple.Types as PG import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS import Database.PostgreSQL.Simple.Ok (Ok (..)) +import Data.Foldable import Control.Arrow import Control.Exception (Exception, throw, throwIO) -import Control.Monad (forM, guard) +import Control.Monad +import Control.Monad.Trans.Except import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) import Control.Monad.Logger (MonadLogger, runNoLoggingT) import Control.Monad.Trans.Reader (runReaderT) @@ -817,23 +819,25 @@ getColumns getter def cols = do , "AND table_name=? " ] --- DOMAINS Postgres supports the concept of domains, which are data types with optional constraints. --- An app might make an "email" domain over the varchar type, with a CHECK that the emails are valid --- In this case the generated SQL should use the domain name: ALTER TABLE users ALTER COLUMN foo TYPE email --- This code exists to use the domain name (email), instead of the underlying type (varchar). --- This is tested in EquivalentTypeTest.hs +-- DOMAINS Postgres supports the concept of domains, which are data types +-- with optional constraints. An app might make an "email" domain over the +-- varchar type, with a CHECK that the emails are valid In this case the +-- generated SQL should use the domain name: ALTER TABLE users ALTER COLUMN +-- foo TYPE email This code exists to use the domain name (email), instead +-- of the underlying type (varchar). This is tested in +-- EquivalentTypeTest.hs stmt <- getter sqlv let vals = [ PersistText $ unDBName $ entityDB def ] - cs <- with (stmtQuery stmt vals) (\src -> runConduit $ src .| helper) + columns <- with (stmtQuery stmt vals) (\src -> runConduit $ src .| processColumns .| CL.consume) let sqlc = T.concat [ "SELECT " , "c.constraint_name, " , "c.column_name " - , "FROM information_schema.key_column_usage c, " - , "information_schema.table_constraints k " + , "FROM information_schema.key_column_usage AS c, " + , "information_schema.table_constraints AS k " , "WHERE c.table_catalog=current_database() " , "AND c.table_catalog=k.table_catalog " , "AND c.table_schema=current_schema() " @@ -848,34 +852,34 @@ getColumns getter def cols = do stmt' <- getter sqlc us <- with (stmtQuery stmt' vals) (\src -> runConduit $ src .| helperU) - return $ cs ++ us + return $ columns ++ us where - refMap = fmap (\cr -> (crTableName cr, crConstraintName cr)) $ Map.fromList $ foldl' ref [] cols - where ref rs c = case cReference c of - Nothing -> rs - (Just r) -> (unDBName $ cName c, r) : rs - getAll front = do - x <- CL.head - case x of - Nothing -> return $ front [] - Just [PersistText con, PersistText col] -> getAll (front . (:) (con, col)) - Just [PersistByteString con, PersistByteString col] -> getAll (front . (:) (T.decodeUtf8 con, T.decodeUtf8 col)) - Just o -> error $ "unexpected datatype returned for postgres o="++show o + refMap = + fmap (\cr -> (crTableName cr, crConstraintName cr)) + $ Map.fromList + $ foldl' ref [] cols + where + ref rs c = + maybe rs (\r -> (unDBName $ cName c, r) : rs) (cReference c) + getAll = + CL.mapM $ \x -> + pure $ case x of + [PersistText con, PersistText col] -> + (con, col) + [PersistByteString con, PersistByteString col] -> + (T.decodeUtf8 con, T.decodeUtf8 col) + o -> + error $ "unexpected datatype returned for postgres o="++show o helperU = do - rows <- getAll id + rows <- getAll .| CL.consume return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) $ groupBy ((==) `on` fst) rows - helper = do - x <- CL.head - case x of - Nothing -> return [] - Just x'@((PersistText cname):_) -> do - col <- liftIO $ getColumn getter (entityDB def) x' (Map.lookup cname refMap) - let col' = case col of - Left e -> Left e - Right c -> Right $ Left c - cols <- helper - return $ col' : cols + processColumns = + CL.mapM $ \x'@((PersistText cname) : _) -> do + col <- liftIO $ getColumn getter (entityDB def) x' (Map.lookup cname refMap) + pure $ case col of + Left e -> Left e + Right c -> Right $ Left c -- | Check if a column name is listed as the "safe to remove" in the entity -- list. @@ -920,33 +924,49 @@ getAlters defs def (c1, u1) (c2, u2) = -- Don't drop constraints which were manually added. isManual (DBName x) = "__manual_" `T.isPrefixOf` x -getColumn :: (Text -> IO Statement) - -> DBName -> [PersistValue] - -> Maybe (DBName, DBName) - -> IO (Either Text Column) -getColumn getter tableName' [PersistText columnName, PersistText isNullable, PersistText typeName, defaultValue, numericPrecision, numericScale, maxlen] refName = - case d' of - Left s -> return $ Left s - Right d'' -> - let typeStr = case maxlen of - PersistInt64 n -> T.concat [typeName, "(", T.pack (show n), ")"] - _ -> typeName - in case getType typeStr of - Left s -> return $ Left s - Right t -> do - let cname = DBName columnName - ref <- getRef cname refName - return $ Right Column - { cName = cname - , cNull = isNullable == "YES" - , cSqlType = t - , cDefault = fmap stripSuffixes d'' - , cDefaultConstraintName = Nothing - , cMaxLen = Nothing - -- TODO: Fix cascade reference is ignored - , cReference = fmap (\(a,b) -> ColumnReference a b noCascade) ref - } +getColumn + :: (Text -> IO Statement) + -> DBName + -> [PersistValue] + -> Maybe (DBName, DBName) + -> IO (Either Text Column) +getColumn getter tableName' [PersistText columnName, PersistText isNullable, PersistText typeName, defaultValue, numericPrecision, numericScale, maxlen] refName = runExceptT $ do + d'' <- ExceptT $ pure d' + let typeStr = case maxlen of + PersistInt64 n -> T.concat [typeName, "(", T.pack (show n), ")"] + _ -> typeName + t <- either throwE pure $ getType typeStr + let cname = DBName columnName + ref <- ExceptT $ fmap Right $ fmap join $ traverse (getRef cname) refName + return Column + { cName = cname + , cNull = isNullable == "YES" + , cSqlType = t + , cDefault = fmap stripSuffixes d'' + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = fmap (\(a,b,c,d) -> ColumnReference a b (mkCascade c d)) ref + } where + mkCascade updText delText = + FieldCascade + { fcOnUpdate = parseCascade updText + , fcOnDelete = parseCascade delText + } + parseCascade txt = + case txt of + "NO ACTION" -> + Nothing + "CASCADE" -> + Just Cascade + "SET NULL" -> + Just SetNull + "SET DEFAULT" -> + Just SetDefault + "RESTRICT" -> + Just Restrict + _ -> + error $ "Unexpected value in parseCascade: " <> show txt stripSuffixes t = loop' [ "::character varying" @@ -958,21 +978,27 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per case T.stripSuffix p t of Nothing -> loop' ps Just t' -> t' - getRef _ Nothing = return Nothing - getRef cname (Just (_, refName')) = do - let sql = T.concat ["SELECT DISTINCT " - ,"ccu.table_name, " - ,"tc.constraint_name " - ,"FROM information_schema.constraint_column_usage ccu, " - ,"information_schema.key_column_usage kcu, " - ,"information_schema.table_constraints tc " - ,"WHERE tc.constraint_type='FOREIGN KEY' " - ,"AND kcu.constraint_name=tc.constraint_name " - ,"AND ccu.constraint_name=kcu.constraint_name " - ,"AND kcu.ordinal_position=1 " - ,"AND kcu.table_name=? " - ,"AND kcu.column_name=? " - ,"AND tc.constraint_name=?"] + + getRef cname (_, refName') = do + let sql = T.concat + [ "SELECT DISTINCT " + , "ccu.table_name, " + , "tc.constraint_name, " + , "rc.update_rule, " + , "rc.delete_rule " + , "FROM information_schema.constraint_column_usage ccu " + , "INNER JOIN information_schema.key_column_usage kcu " + , " ON ccu.constraint_name = kcu.constraint_name " + , "INNER JOIN information_schema.table_constraints tc " + , " ON tc.constraint_name = kcu.constraint_name " + , "LEFT JOIN information_schema.referential_constraints AS rc" + , " ON rc.constraint_name = ccu.constraint_name " + , "WHERE tc.constraint_type='FOREIGN KEY' " + , "AND kcu.ordinal_position=1 " + , "AND kcu.table_name=? " + , "AND kcu.column_name=? " + , "AND tc.constraint_name=?" + ] stmt <- getter sql cntrs <- with (stmtQuery stmt [PersistText $ unDBName tableName' ,PersistText $ unDBName cname @@ -980,8 +1006,8 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per (\src -> runConduit $ src .| CL.consume) case cntrs of [] -> return Nothing - [[PersistText table, PersistText constraint]] -> - return $ Just (DBName table, DBName constraint) + [[PersistText table, PersistText constraint, PersistText updRule, PersistText delRule]] -> + return $ Just (DBName table, DBName constraint, updRule, delRule) xs -> error $ mconcat [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " @@ -991,6 +1017,7 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per , " but got: " , show xs ] + d' = case defaultValue of PersistNull -> Right Nothing PersistText t -> Right $ Just t @@ -1055,26 +1082,28 @@ findAlters defs edef col@(Column name isNull sqltype def _defConstraintName _max ([(name, Add' col)], cols) Just (Column _oldName isNull' sqltype' def' _defConstraintName' _maxLen' ref') -> let refDrop Nothing = [] - refDrop (Just ColumnReference {crConstraintName=cname}) = [(name, DropReference cname)] + refDrop (Just ColumnReference {crConstraintName=cname}) = + [(name, DropReference cname)] + refAdd Nothing = [] - refAdd (Just ColumnReference {crTableName=tname, crConstraintName=a}) = - case find ((==tname) . entityDB) defs of + refAdd (Just colRef) = + case find ((== crTableName colRef) . entityDB) defs of Just refdef - | entityDB edef /= tname + | entityDB edef /= crTableName colRef && _oldName /= fieldDB (entityId edef) -> - [ ( tname + [ ( crTableName colRef , AddReference - a + (crConstraintName colRef) [name] (Util.dbIdColumnsEsc escape refdef) - -- TODO: Fix cascade reference is ignored - noCascade + (crFieldCascade colRef) ) ] Just _ -> [] Nothing -> - error $ "could not find the entityDef for reftable[" ++ show tname ++ "]" + error $ "could not find the entityDef for reftable[" + ++ show (crTableName colRef) ++ "]" modRef = if fmap crConstraintName ref == fmap crConstraintName ref' then [] diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index 4db6a5624..cde25208d 100644 --- a/persistent-postgresql/test/main.hs +++ b/persistent-postgresql/test/main.hs @@ -129,6 +129,7 @@ main = do , PgIntervalTest.pgIntervalMigrate ] PersistentTest.cleanDB + ForeignKey.cleanDB hspec $ do RenameTest.specsWith runConnAssert diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs index 7dd748116..261ba7709 100644 --- a/persistent-sqlite/test/main.hs +++ b/persistent-sqlite/test/main.hs @@ -157,6 +157,7 @@ main = do , LongIdentifierTest.migration ] PersistentTest.cleanDB + ForeignKey.cleanDB hspec $ do RenameTest.specsWith db diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs index c9402fe57..74d0e029b 100644 --- a/persistent-test/src/ForeignKey.hs +++ b/persistent-test/src/ForeignKey.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeApplications, UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications, UndecidableInstances #-} module ForeignKey where @@ -208,3 +208,31 @@ specsWith runDb = fdescribe "foreign keys options" $ do entityExtra ed `shouldBe` mempty + +cleanDB :: (MonadIO m) => SqlPersistT m () +cleanDB = do + del @SimpleCascadeChild + del @SimpleCascade + del @Parent + del @ParentComposite + del @ParentImplicit + del @Child + del @ChildComposite + del @ChildImplicit + del @SelfReferenced + del @A + del @AComposite + del @B + del @BExplicit + del @BComposite + del @Chain + del @Chain2 + +del + :: forall a m. + ( PersistEntity a + , PersistEntityBackend a ~ SqlBackend + , MonadIO m + ) + => SqlPersistT m () +del = deleteWhere @_ @_ @a [] diff --git a/persistent-test/src/PersistentTest.hs b/persistent-test/src/PersistentTest.hs index 629398a99..ab7ddad22 100644 --- a/persistent-test/src/PersistentTest.hs +++ b/persistent-test/src/PersistentTest.hs @@ -711,5 +711,3 @@ specsWith runDb = describe "persistent" $ do , ("blood", toJSON jsonEncoding2Blood) , ("id", toJSON key) ]) - - diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index e6ee92b70..7fe74edd7 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -35,15 +35,15 @@ data Column = Column -- -- @since 2.11.0.0 data ColumnReference = ColumnReference - { crTableName :: DBName + { crTableName :: !DBName -- ^ The table name that the -- -- @since 2.11.0.0 - , crConstraintName :: DBName + , crConstraintName :: !DBName -- ^ The name of the foreign key constraint. -- -- @since 2.11.0.0 - , crFieldCascade :: FieldCascade + , crFieldCascade :: !FieldCascade -- ^ Whether or not updates/deletions to the referenced table cascade -- to this table. -- From b44f94672a65aa9493818e01eec31b7889dc3066 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Sun, 1 Nov 2020 17:39:44 -0700 Subject: [PATCH 15/21] psql, sqlite, mysql pass tests --- persistent-mysql/Database/Persist/MySQL.hs | 209 +++++++++++------- persistent-mysql/test/main.hs | 4 + .../Database/Persist/Postgresql.hs | 5 +- persistent-template/Database/Persist/TH.hs | 2 - persistent-test/src/ForeignKey.hs | 86 +++---- persistent/Database/Persist/Quasi.hs | 2 - 6 files changed, 180 insertions(+), 128 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 980fb70f2..95eb03340 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -353,10 +353,10 @@ migrate' connectInfo allDefs getter val = do let refConstraintName = crConstraintName cRef let refTblName = crTableName cRef let refTarget = - addReference allDefs refConstraintName refTblName cname + addReference allDefs refConstraintName refTblName cname (crFieldCascade cRef) guard $ refTblName /= name && cname /= fieldDB (entityId val) - return $ Debug.traceShowId $ AlterColumn name (refTblName, refTarget) + return $ AlterColumn name (refTblName, refTarget) let foreignsAlt = map @@ -373,6 +373,7 @@ migrate' connectInfo allDefs getter val = do (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields + (foreignFieldCascade fdef) ) ) fdefs @@ -490,9 +491,19 @@ findMaxLenOfField fieldDef = do readMaybe $ T.unpack maxLenAttr -- | Helper for 'AddReference' that finds out the which primary key columns to reference. -addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn -addReference allDefs fkeyname reftable cname = - AddReference reftable fkeyname [cname] referencedColumns +addReference + :: [EntityDef] + -- ^ List of all known 'EntityDef's. + -> DBName + -- ^ Foreign key name + -> DBName + -- ^ Referenced table name + -> DBName + -- ^ Column name + -> FieldCascade + -> AlterColumn +addReference allDefs fkeyname reftable cname fc = + AddReference reftable fkeyname [cname] referencedColumns fc where errorMessage = error @@ -515,6 +526,7 @@ data AlterColumn = Change Column DBName -- Foreign key name [DBName] -- Referencing columns [DBName] -- Referenced columns + FieldCascade | DropReference DBName deriving Show @@ -628,67 +640,88 @@ getColumn connectInfo getter tname [ PersistText cname , default'] cRef = fmap (either (Left . pack) Right) $ runExceptT $ do - -- Default value - default_ <- case default' of - PersistNull -> return Nothing - PersistText t -> return (Just t) - PersistByteString bs -> - case T.decodeUtf8' bs of - Left exc -> fail $ "Invalid default column: " ++ - show default' ++ " (error: " ++ - show exc ++ ")" - Right t -> return (Just t) - _ -> fail $ "Invalid default column: " ++ show default' - - ref <- getRef (crConstraintName <$> cRef) - let colMaxLen' = case colMaxLen of - PersistInt64 l -> Just (fromIntegral l) - _ -> Nothing - ci = ColumnInfo - { ciColumnType = colType - , ciMaxLength = colMaxLen' - , ciNumericPrecision = colPrecision - , ciNumericScale = colScale + -- Default value + default_ <- case default' of + PersistNull -> return Nothing + PersistText t -> return (Just t) + PersistByteString bs -> + case T.decodeUtf8' bs of + Left exc -> fail $ "Invalid default column: " ++ + show default' ++ " (error: " ++ + show exc ++ ")" + Right t -> return (Just t) + _ -> fail $ "Invalid default column: " ++ show default' + + ref <- getRef (crConstraintName <$> cRef) + let colMaxLen' = case colMaxLen of + PersistInt64 l -> Just (fromIntegral l) + _ -> Nothing + ci = ColumnInfo + { ciColumnType = colType + , ciMaxLength = colMaxLen' + , ciNumericPrecision = colPrecision + , ciNumericScale = colScale + } + (typ, maxLen) <- parseColumnType dataType ci + -- Okay! + return Column + { cName = DBName $ cname + , cNull = null_ == "YES" + , cSqlType = typ + , cDefault = default_ + , cDefaultConstraintName = Nothing + , cMaxLen = maxLen + , cReference = ref } - (typ, maxLen) <- parseColumnType dataType ci - -- Okay! - return Column - { cName = DBName $ cname - , cNull = null_ == "YES" - , cSqlType = typ - , cDefault = default_ - , cDefaultConstraintName = Nothing - , cMaxLen = maxLen - , cReference = ref - } - where getRef Nothing = return Nothing - getRef (Just refName') = do - -- Foreign key (if any) - stmt <- lift . getter $ T.concat - [ "SELECT REFERENCED_TABLE_NAME, " - , "CONSTRAINT_NAME, " - , "ORDINAL_POSITION " - , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE " - , "WHERE TABLE_SCHEMA = ? " - , "AND TABLE_NAME = ? " - , "AND COLUMN_NAME = ? " - , "AND REFERENCED_TABLE_SCHEMA = ? " - , "AND CONSTRAINT_NAME = ? " - , "ORDER BY CONSTRAINT_NAME, " - , "COLUMN_NAME" + where + getRef Nothing = return Nothing + getRef (Just refName') = do + -- Foreign key (if any) + stmt <- lift . getter $ T.concat + [ "SELECT KCU.REFERENCED_TABLE_NAME, " + , "KCU.CONSTRAINT_NAME, " + , "KCU.ORDINAL_POSITION, " + , "DELETE_RULE, " + , "UPDATE_RULE " + , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS KCU " + , "INNER JOIN INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS AS RC " + , " ON KCU.CONSTRAINT_NAME = RC.CONSTRAINT_NAME " + , "WHERE KCU.TABLE_SCHEMA = ? " + , "AND KCU.TABLE_NAME = ? " + , "AND KCU.COLUMN_NAME = ? " + , "AND KCU.REFERENCED_TABLE_SCHEMA = ? " + , "AND KCU.CONSTRAINT_NAME = ? " + , "ORDER BY KCU.CONSTRAINT_NAME, " + , "KCU.COLUMN_NAME" ] - let vars = [ PersistText $ pack $ MySQL.connectDatabase connectInfo - , PersistText $ unDBName $ tname - , PersistText cname - , PersistText $ pack $ MySQL.connectDatabase connectInfo - , PersistText $ unDBName refName' ] - cntrs <- liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume) - case cntrs of - [] -> return Nothing - [[PersistText tab, PersistText ref, PersistInt64 pos]] -> - -- TODO: Fix cascade reference is ignored - return $ if pos == 1 then Just (ColumnReference (DBName tab) (DBName ref) noCascade) - else Nothing + let vars = + [ PersistText $ pack $ MySQL.connectDatabase connectInfo + , PersistText $ unDBName $ tname + , PersistText cname + , PersistText $ pack $ MySQL.connectDatabase connectInfo + , PersistText $ unDBName refName' + ] + parseCascadeAction txt = + case txt of + "RESTRICT" -> Just Restrict + "CASCADE" -> Just Cascade + "SET NULL" -> Just SetNull + "SET DEFAULT" -> Just SetDefault + "NO ACTION" -> Nothing + _ -> + error $ "Unexpected value in parseCascadeAction: " <> show txt + + cntrs <- liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume) + pure $ case cntrs of + [] -> + Nothing + [[PersistText tab, PersistText ref, PersistInt64 pos, PersistText onDel, PersistText onUpd]] -> + if pos == 1 + then Just $ ColumnReference (DBName tab) (DBName ref) FieldCascade + { fcOnUpdate = parseCascadeAction onUpd + , fcOnDelete = parseCascadeAction onDel + } + else Nothing xs -> error $ mconcat [ "MySQL.getColumn/getRef: error fetching constraints. Expected a single result for foreign key query for table: " , T.unpack (unDBName tname) @@ -799,8 +832,10 @@ findAlters edef allDefs col@(Column name isNull type_ def _defConstraintName max [] -> case ref of Nothing -> ([(name, Add' col)],[]) - Just ColumnReference {crTableName=tname, crConstraintName=cname} -> - let cnstr = [addReference allDefs cname tname name] + Just cr -> + let tname = crTableName cr + cname = crConstraintName cr + cnstr = [addReference allDefs cname tname name (crFieldCascade cr)] in (map ((,) tname) (Add' col : cnstr), cols) Column _ isNull' type_' def' _defConstraintName' maxLen' ref' : _ -> @@ -813,11 +848,11 @@ findAlters edef allDefs col@(Column name isNull type_ def _defConstraintName max [] refAdd = case (ref == ref', ref) of - (False, Just ColumnReference {crTableName=tname, crConstraintName=cname}) + (False, Just ColumnReference {crTableName=tname, crConstraintName=cname, crFieldCascade = cfc }) | tname /= entityDB edef , cname /= fieldDB (entityId edef) -> - [(tname, addReference allDefs cname tname name)] + [(tname, addReference allDefs cname tname name cfc)] _ -> [] -- Type and nullability modType | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False && isNull == isNull' = [] @@ -825,9 +860,10 @@ findAlters edef allDefs col@(Column name isNull type_ def _defConstraintName max -- Default value -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields modDef | def == def' = [] - | otherwise = case def of - Nothing -> [(name, NoDefault)] - Just s -> if T.toUpper s == "NULL" then [] + | otherwise = + case def of + Nothing -> [(name, NoDefault)] + Just s -> if T.toUpper s == "NULL" then [] else [(name, Default $ T.unpack s)] in ( refDrop ++ modType ++ modDef ++ refAdd , filter ((name /=) . cName) cols @@ -856,6 +892,7 @@ showColumn (Column n nu t def _defConstraintName maxLen ref) = concat , case ref of Nothing -> "" Just cRef -> " REFERENCES " ++ escapeDBName (crTableName cRef) + <> " " <> T.unpack (renderFieldCascade (crFieldCascade cRef)) ] @@ -969,7 +1006,7 @@ showAlter table (n, Update' s) = , escapeDBName n , " IS NULL" ] -showAlter table (_, AddReference reftable fkeyname t2 id2) = concat +showAlter table (_, AddReference reftable fkeyname t2 id2 fc) = concat [ "ALTER TABLE " , escapeDBName table , " ADD CONSTRAINT " @@ -980,7 +1017,8 @@ showAlter table (_, AddReference reftable fkeyname t2 id2) = concat , escapeDBName reftable , "(" , intercalate "," $ map escapeDBName id2 - , ")" + , ") " + , T.unpack $ renderFieldCascade fc ] showAlter table (_, DropReference cname) = concat [ "ALTER TABLE " @@ -1085,11 +1123,26 @@ mockMigrate _connectInfo allDefs _getter val = do AddUniqueConstraint uname $ map (findTypeAndMaxLen name) ucols ] let foreigns = do - Column { cName=cname, cReference= Just ColumnReference{crTableName = refTable, crConstraintName = refConstr}} <- newcols - return $ AlterColumn name (refTable, addReference allDefs refConstr refTable cname) - - let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) - in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs + Column { cName=cname, cReference= Just ColumnReference{crTableName = refTable, crConstraintName = refConstr, crFieldCascade = cfc }} <- newcols + return $ AlterColumn name (refTable, addReference allDefs refConstr refTable cname cfc) + + let foreignsAlt = + map + (\fdef -> + let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) + in + AlterColumn + name + ( foreignRefTableDBName fdef + , AddReference + (foreignRefTableDBName fdef) + (foreignConstraintNameDBName fdef) + childfields + parentfields + (foreignFieldCascade fdef) + ) + ) + fdefs return $ Right $ map showAlterDb $ (addTable newcols val): uniques ++ foreigns ++ foreignsAlt diff --git a/persistent-mysql/test/main.hs b/persistent-mysql/test/main.hs index 2051e7ea8..fce4ebde7 100644 --- a/persistent-mysql/test/main.hs +++ b/persistent-mysql/test/main.hs @@ -52,6 +52,7 @@ import qualified UniqueTest import qualified UpsertTest import qualified CustomConstraintTest import qualified LongIdentifierTest +import qualified ForeignKey type Tuple a b = (a, b) @@ -128,8 +129,10 @@ main = do , MigrationColumnLengthTest.migration , TransactionLevelTest.migration -- , LongIdentifierTest.migration + , ForeignKey.compositeMigrate ] PersistentTest.cleanDB + ForeignKey.cleanDB hspec $ do xdescribe "This is pending on MySQL because you can't have DEFAULT CURRENT_DATE" $ do @@ -178,6 +181,7 @@ main = do UpsertTest.Don'tUpdateNull UpsertTest.UpsertPreserveOldKey + ForeignKey.specsWith db MpsNoPrefixTest.specsWith db MpsCustomPrefixTest.specsWith db EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 4cd516031..d6d1673af 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1147,13 +1147,12 @@ getAddReference -> DBName -> ColumnReference -> Maybe AlterDB -getAddReference allDefs entity cname ColumnReference {crTableName = s, crConstraintName=constraintName} = do +getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crConstraintName=constraintName} = do guard $ table /= s && cname /= fieldDB (entityId entity) pure $ AlterColumn table ( s - -- TODO: Fix cascade reference is ignored - , AddReference constraintName [cname] id_ noCascade + , AddReference constraintName [cname] id_ (crFieldCascade cr) ) where table = entityDB entity diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index 7dab00a0d..eceeca736 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -61,8 +61,6 @@ module Database.Persist.TH -- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code -- It's highly recommended to check the diff between master and your PR's generated code. -import qualified Debug.Trace as Debug - import Prelude hiding ((++), take, concat, splitAt, exp) import Control.Applicative diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs index 74d0e029b..35d12b68e 100644 --- a/persistent-test/src/ForeignKey.hs +++ b/persistent-test/src/ForeignKey.hs @@ -15,63 +15,63 @@ SimpleCascadeChild deriving Show Eq SimpleCascade - name String + name Int deriving Show Eq Parent - name String + name Int Primary name Child - pname String + pname Int Foreign Parent OnDeleteCascade OnUpdateCascade fkparent pname deriving Show Eq ParentImplicit - name String + name Int ChildImplicit - pname String + pname Int parentId ParentImplicitId noreference Foreign ParentImplicit OnDeleteCascade OnUpdateCascade fkparent parentId deriving Show Eq ParentComposite - name String - lastName String + name Int + lastName Int Primary name lastName ChildComposite - pname String - plastName String + pname Int + plastName Int Foreign ParentComposite OnDeleteCascade fkparent pname plastName deriving Show Eq SelfReferenced - name String - pname String + name Int + pname Int Primary name Foreign SelfReferenced OnDeleteCascade fkparent pname deriving Show Eq A - aa String + aa Int ab Int U1 aa B - ba String + ba Int bb Int Foreign A OnDeleteCascade fkA ba References aa deriving Show Eq AComposite - aa String + aa Int ab Int U2 aa ab BComposite - ba String + ba Int bb Int Foreign AComposite OnDeleteCascade fkAComposite ba bb References aa ab deriving Show Eq @@ -82,13 +82,13 @@ BExplicit deriving Show Eq Chain - name String + name Int previous ChainId Maybe noreference Foreign Chain OnDeleteSetNull fkChain previous References Id - deriving Show Eq + deriving Show Eq Ord Chain2 - name String + name Int previous Chain2Id Maybe noreference Foreign Chain2 OnDeleteCascade fkChain previous References Id deriving Show Eq @@ -97,34 +97,34 @@ Chain2 specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specsWith runDb = fdescribe "foreign keys options" $ do it "delete cascades" $ runDb $ do - kf <- insert $ Parent "A" - kc <- insert $ Child "A" + kf <- insert $ Parent 1 + kc <- insert $ Child 1 delete kf cs <- selectList [] [] let expected = [] :: [Entity Child] cs @== expected it "update cascades" $ runDb $ do - kf <- insert $ Parent "A" - kc <- insert $ Child "A" - update kf [ParentName =. "B"] + kf <- insert $ Parent 1 + kc <- insert $ Child 1 + update kf [ParentName =. 2] cs <- selectList [] [] - fmap (childPname . entityVal) cs @== ["B"] + fmap (childPname . entityVal) cs @== [2] it "delete Composite cascades" $ runDb $ do - kf <- insert $ ParentComposite "A" "B" - kc <- insert $ ChildComposite "A" "B" + kf <- insert $ ParentComposite 1 2 + kc <- insert $ ChildComposite 1 2 delete kf cs <- selectList [] [] let expected = [] :: [Entity ChildComposite] cs @== expected it "delete self referenced cascades" $ runDb $ do - kf <- insert $ SelfReferenced "A" "A" -- bootstrap self reference - kc <- insert $ SelfReferenced "B" "A" + kf <- insert $ SelfReferenced 1 1 + kc <- insert $ SelfReferenced 2 1 delete kf srs <- selectList [] [] let expected = [] :: [Entity SelfReferenced] srs @== expected it "delete cascade works on simple references" $ runDb $ do - scId <- insert $ SimpleCascade "Hello" + scId <- insert $ SimpleCascade 1 sccId <- insert $ SimpleCascadeChild scId Just _ <- get sccId delete scId @@ -134,31 +134,31 @@ specsWith runDb = fdescribe "foreign keys options" $ do mres `shouldBe` Nothing mxs `shouldBe` [] it "delete cascades with explicit Reference" $ runDb $ do - kf <- insert $ A "A" 40 - kc <- insert $ B "A" 15 + kf <- insert $ A 1 40 + kc <- insert $ B 1 15 delete kf return () cs <- selectList [] [] let expected = [] :: [Entity B] cs @== expected it "delete cascades with explicit Composite Reference" $ runDb $ do - kf <- insert $ AComposite "A" 20 - kc <- insert $ BComposite "A" 20 + kf <- insert $ AComposite 1 20 + kc <- insert $ BComposite 1 20 delete kf return () cs <- selectList [] [] let expected = [] :: [Entity B] cs @== expected it "delete cascades with explicit Composite Reference" $ runDb $ do - kf <- insert $ AComposite "A" 20 - kc <- insert $ BComposite "A" 20 + kf <- insert $ AComposite 1 20 + kc <- insert $ BComposite 1 20 delete kf return () cs <- selectList [] [] let expected = [] :: [Entity B] cs @== expected it "delete cascades with explicit Id field" $ runDb $ do - kf <- insert $ A "A" 20 + kf <- insert $ A 1 20 kc <- insert $ BExplicit kf delete kf return () @@ -166,16 +166,16 @@ specsWith runDb = fdescribe "foreign keys options" $ do let expected = [] :: [Entity B] cs @== expected it "deletes sets null with self reference" $ runDb $ do - kf <- insert $ Chain "A" Nothing - insert $ Chain "B" (Just kf) + kf <- insert $ Chain 1 Nothing + kf' <- insert $ Chain 2 (Just kf) delete kf cs <- selectList [] [] - let expected = [Entity {entityKey = ChainKey 2, entityVal = Chain "B" Nothing}] - cs @== expected + let expected = [Entity {entityKey = kf', entityVal = Chain 2 Nothing}] + List.sort cs @== List.sort expected it "deletes cascades with self reference to the whole chain" $ runDb $ do - k1 <- insert $ Chain2 "A" Nothing - k2 <- insert $ Chain2 "B" (Just k1) - k3 <- insert $ Chain2 "C" (Just k2) + k1 <- insert $ Chain2 1 Nothing + k2 <- insert $ Chain2 2 (Just k1) + k3 <- insert $ Chain2 3 (Just k2) delete k1 cs <- selectList [] [] let expected = [] :: [Entity Chain2] diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index c6688d39b..6ed8e5cba 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -262,8 +262,6 @@ module Database.Persist.Quasi import Prelude hiding (lines) -import qualified Debug.Trace as Debug - import qualified Data.List.NonEmpty as NEL import Data.List.NonEmpty (NonEmpty(..)) import Control.Arrow ((&&&)) From 48420ace16480efa20a02bff3ea8b15b9755a080 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 2 Nov 2020 08:12:51 -0700 Subject: [PATCH 16/21] fix migrations messing with foreign keys --- persistent/Database/Persist/Sql/Internal.hs | 15 ++++++++++++++- persistent/Database/Persist/Types/Base.hs | 5 +++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index 95e162b20..5905e9d67 100644 --- a/persistent/Database/Persist/Sql/Internal.hs +++ b/persistent/Database/Persist/Sql/Internal.hs @@ -10,6 +10,7 @@ module Database.Persist.Sql.Internal , emptyBackendSpecificOverrides ) where +import Control.Applicative ((<|>)) import Data.Char (isSpace) import Data.Monoid (mappend, mconcat) import Data.Text (Text) @@ -121,9 +122,21 @@ mkColumns allDefs t overrides = mkColumnReference :: FieldDef -> Maybe ColumnReference mkColumnReference fd = - fmap (\(tName, cName) -> ColumnReference tName cName (fieldCascade fd)) + fmap + (\(tName, cName) -> + ColumnReference tName cName $ overrideNothings $ fieldCascade fd + ) $ ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd) + -- a 'Nothing' in the definition means that the QQ migration doesn't + -- specify behavior. the default is RESTRICT. setting this here + -- explicitly makes migrations run smoother. + overrideNothings (FieldCascade { fcOnUpdate = upd, fcOnDelete = del }) = + FieldCascade + { fcOnUpdate = upd <|> Just Restrict + , fcOnDelete = del <|> Just Restrict + } + ref :: DBName -> ReferenceDef -> [Attr] diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 182dfe055..71992acd9 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -351,6 +351,11 @@ data ForeignDef = ForeignDef -- | This datatype describes how a foreign reference field cascades deletes -- or updates. -- +-- This type is used in both parsing the model definitions and performing +-- migrations. A 'Nothing' in either of the field values means that the +-- user has not specified a 'CascadeAction'. An unspecified 'CascadeAction' +-- is defaulted to 'Restrict' when doing migrations. +-- -- @since 2.11.0 data FieldCascade = FieldCascade { fcOnUpdate :: !(Maybe CascadeAction) From 8ea1418c68327daa05f0602d4ad16ea0f21f55d2 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 2 Nov 2020 08:22:24 -0700 Subject: [PATCH 17/21] don't need cascade on reference def --- persistent-template/Database/Persist/TH.hs | 15 ++++++------- persistent-template/test/main.hs | 10 +-------- persistent-test/src/ForeignKey.hs | 8 ------- persistent/Database/Persist/Quasi.hs | 24 ++++++--------------- persistent/Database/Persist/Sql/Internal.hs | 2 +- persistent/Database/Persist/Types/Base.hs | 24 +++++---------------- 6 files changed, 21 insertions(+), 62 deletions(-) diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index eceeca736..5dc5b39bb 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -254,7 +254,7 @@ stripId _ = Nothing foreignReference :: FieldDef -> Maybe HaskellName foreignReference field = case fieldReference field of - ForeignRef ref _ _cascade -> Just ref + ForeignRef ref _ -> Just ref _ -> Nothing @@ -361,7 +361,7 @@ mEmbedded ents (FTApp x y) = setEmbedField :: HaskellName -> EmbedEntityMap -> FieldDef -> FieldDef setEmbedField entName allEntities field = field { fieldReference = - setReferenceDefCascade (fieldCascade field) $ case fieldReference field of + case fieldReference field of NoReference -> case mEmbedded allEntities (fieldType field) of Left _ -> @@ -377,7 +377,6 @@ setEmbedField entName allEntities field = field (HaskellName name) -- This can get corrected in mkEntityDefSqlTypeExp (FTTypeCon (Just "Data.Int") "Int64") - (fieldCascade field) Right em -> if embeddedHaskell em /= entName then EmbedRef em @@ -410,7 +409,7 @@ mkEntityDefSqlTypeExp emEntities entityMap ent = SqlType' SqlString Left Nothing -> case fieldReference field of - ForeignRef refName ft _cascde -> + ForeignRef refName ft -> case M.lookup refName entityMap of Nothing -> SqlTypeExp ft -- A ForeignRef is blindly set to an Int64 in setEmbedField @@ -423,7 +422,7 @@ mkEntityDefSqlTypeExp emEntities entityMap ent = [] -> error "mkEntityDefSqlTypeExp: no composite fields" [x] -> SqlTypeExp $ fieldType x _ -> SqlType' $ SqlOther "Composite Reference" - CompositeRef _ _cascade -> + CompositeRef _ -> SqlType' $ SqlOther "Composite Reference" _ -> case ftype of @@ -1730,15 +1729,15 @@ liftAndFixKeys entityMap EntityDef{..} = liftAndFixKey :: EntityMap -> FieldDef -> Q Exp liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments) = - [|FieldDef a b c $(sqlTyp') e f (setReferenceDefCascade fc fieldRef') fc mcomments|] + [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments|] where (fieldRef', sqlTyp') = fromMaybe (fieldRef, lift sqlTyp) $ case fieldRef of - ForeignRef refName _ft cascade -> do + ForeignRef refName _ft -> do ent <- M.lookup refName entityMap case fieldReference $ entityId ent of - fr@(ForeignRef targetName ft _targetCascade) -> + fr@(ForeignRef targetName ft) -> Just (fr, lift $ SqlTypeExp ft) _ -> Nothing diff --git a/persistent-template/test/main.hs b/persistent-template/test/main.hs index 065a32fb7..95469713c 100644 --- a/persistent-template/test/main.hs +++ b/persistent-template/test/main.hs @@ -216,10 +216,6 @@ main = hspec $ do FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId") it "should have cascade in field def" $ do fieldCascade `shouldBe` noCascade { fcOnDelete = Just Cascade } - it "should have cascade in foreign ref" $ do - getReferenceDefCascade fieldReference - `shouldBe` Just noCascade { fcOnDelete = Just Cascade } - describe "OnCascadeDelete" $ do let subject :: FieldDef @@ -248,7 +244,7 @@ main = hspec $ do , fieldType = FTTypeCon Nothing "HasSimpleCascadeRefId" , fieldSqlType = SqlInt64 , fieldReference = - ForeignRef (HaskellName "HasSimpleCascadeRef") (FTTypeCon (Just "Data.Int") "Int64") noCascade + ForeignRef (HaskellName "HasSimpleCascadeRef") (FTTypeCon (Just "Data.Int") "Int64") , fieldAttrs = [] , fieldStrict = True , fieldComments = Nothing @@ -267,7 +263,6 @@ main = hspec $ do ForeignRef (HaskellName "Person") (FTTypeCon (Just "Data.Int") "Int64") - (FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade }) , fieldCascade = FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade } , fieldComments = Nothing @@ -282,9 +277,6 @@ main = hspec $ do } it "has the cascade on the field def" $ do fieldCascade subject `shouldBe` expected - it "has the cascade on the reference def" $ do - ForeignRef _ _ fc <- pure $ fieldReference subject - fc `shouldBe` expected it "doesn't have any extras" $ do entityExtra simpleCascadeDef `shouldBe` diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs index 35d12b68e..3bb3c66ed 100644 --- a/persistent-test/src/ForeignKey.hs +++ b/persistent-test/src/ForeignKey.hs @@ -196,14 +196,6 @@ specsWith runDb = fdescribe "foreign keys options" $ do it "parses into fieldCascade" $ do fieldCascade refField `shouldBe` expected - it "parses into the fieldReference" $ do - ForeignRef haskName _ cascade <- - pure $ fieldReference refField - - haskName `shouldBe` HaskellName "SimpleCascade" - - cascade `shouldBe` expected - it "shouldn't have cascade in extras" $ do entityExtra ed `shouldBe` diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 6ed8e5cba..b6c964dd9 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -703,7 +703,7 @@ mkEntityDef ps name entattribs lines = derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef] - cols = fmap setReferenceCascade . reverse . fst . foldr k ([], []) $ reverse attribs + cols = reverse . fst . foldr k ([], []) $ reverse attribs k x (!acc, !comments) = case isComment =<< listToMaybe x of Just comment -> @@ -715,16 +715,13 @@ mkEntityDef ps name entattribs lines = setFieldComments [] x = x setFieldComments xs fld = fld { fieldComments = Just (T.unlines xs) } - setReferenceCascade fd = fd - { fieldReference = setReferenceDefCascade (fieldCascade fd) (fieldReference fd) - } autoIdField = mkAutoIdField ps entName (DBName `fmap` idName) idSqlType idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite setComposite Nothing fd = fd setComposite (Just c) fd = fd - { fieldReference = CompositeRef c (fieldCascade fd) + { fieldReference = CompositeRef c } @@ -744,7 +741,7 @@ mkAutoIdField ps entName idName idSqlType = , fieldType = FTTypeCon Nothing $ keyConName $ unHaskellName entName , fieldSqlType = idSqlType -- the primary field is actually a reference to the entity - , fieldReference = ForeignRef entName defaultReferenceTypeCon noCascade + , fieldReference = ForeignRef entName defaultReferenceTypeCon , fieldAttrs = [] , fieldStrict = True , fieldComments = Nothing @@ -838,20 +835,13 @@ takeId ps tableName (n:rest) = Nothing -> error "takeId: empty field" Just (f, ield) -> toLower f `T.cons` ield addDefaultIdType = takeColsEx ps (field : keyCon : rest ) -- `mappend` setIdName) - setFieldDef fd = - let refFieldType = + setFieldDef fd = fd + { fieldReference = + ForeignRef (HaskellName tableName) $ if fieldType fd == FTTypeCon Nothing keyCon then defaultReferenceTypeCon else fieldType fd - -- this is fine because we're only calling this function with - -- the primary key type - cascade = - fieldCascade fd - in - fd - { fieldReference = - ForeignRef (HaskellName tableName) refFieldType cascade - } + } keyCon = keyConName tableName -- this will be ignored if there is already an existing sql= -- TODO: I think there is a ! ignore syntax that would screw this up diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index 5905e9d67..ece17e119 100644 --- a/persistent/Database/Persist/Sql/Internal.hs +++ b/persistent/Database/Persist/Sql/Internal.hs @@ -142,7 +142,7 @@ mkColumns allDefs t overrides = -> [Attr] -> Maybe (DBName, DBName) -- table name, constraint name ref c fe [] - | ForeignRef f _ cascade <- fe = + | ForeignRef f _ <- fe = Just (resolveTableName allDefs f, refNameFn tableName c) | otherwise = Nothing ref _ _ ("noreference":_) = Nothing diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 71992acd9..8ef4bd075 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -141,15 +141,15 @@ data EntityDef = EntityDef entitiesPrimary :: EntityDef -> Maybe [FieldDef] entitiesPrimary t = case fieldReference primaryField of - CompositeRef c _ -> Just $ (compositeFields c) - ForeignRef _ _ _ -> Just [primaryField] + CompositeRef c -> Just $ (compositeFields c) + ForeignRef _ _ -> Just [primaryField] _ -> Nothing where primaryField = entityId t entityPrimary :: EntityDef -> Maybe CompositeDef entityPrimary t = case fieldReference (entityId t) of - CompositeRef c _ -> Just c + CompositeRef c -> Just c _ -> Nothing entityKeyFields :: EntityDef -> [FieldDef] @@ -237,28 +237,14 @@ data FieldDef = FieldDef -- 2) single field -- 3) embedded data ReferenceDef = NoReference - | ForeignRef !HaskellName !FieldType !FieldCascade + | ForeignRef !HaskellName !FieldType -- ^ A ForeignRef has a late binding to the EntityDef it references via HaskellName and has the Haskell type of the foreign key in the form of FieldType | EmbedRef EmbedEntityDef - | CompositeRef CompositeDef !FieldCascade + | CompositeRef CompositeDef | SelfReference -- ^ A SelfReference stops an immediate cycle which causes non-termination at compile-time (issue #311). deriving (Show, Eq, Read, Ord) -getReferenceDefCascade :: ReferenceDef -> Maybe FieldCascade -getReferenceDefCascade rd = - case rd of - ForeignRef _ _ fc -> Just fc - CompositeRef _ fc -> Just fc - _ -> Nothing - -setReferenceDefCascade :: FieldCascade -> ReferenceDef -> ReferenceDef -setReferenceDefCascade fc rd = - case rd of - ForeignRef a b _ -> ForeignRef a b fc - CompositeRef a _ -> CompositeRef a fc - _ -> rd - -- | An EmbedEntityDef is the same as an EntityDef -- But it is only used for fieldReference -- so it only has data needed for embedding From ebb6f59c6bc5fb2261c0d3baa40a7950ccbe075f Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 2 Nov 2020 08:35:16 -0700 Subject: [PATCH 18/21] syntax and formatting --- persistent-mysql/Database/Persist/MySQL.hs | 32 ++-- .../Database/Persist/Postgresql.hs | 148 ++++++++++-------- .../persistent-postgresql.cabal | 1 + 3 files changed, 102 insertions(+), 79 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 95eb03340..14af3fcdf 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -641,21 +641,27 @@ getColumn connectInfo getter tname [ PersistText cname fmap (either (Left . pack) Right) $ runExceptT $ do -- Default value - default_ <- case default' of - PersistNull -> return Nothing - PersistText t -> return (Just t) - PersistByteString bs -> - case T.decodeUtf8' bs of - Left exc -> fail $ "Invalid default column: " ++ - show default' ++ " (error: " ++ - show exc ++ ")" - Right t -> return (Just t) - _ -> fail $ "Invalid default column: " ++ show default' + default_ <- + case default' of + PersistNull -> return Nothing + PersistText t -> return (Just t) + PersistByteString bs -> + case T.decodeUtf8' bs of + Left exc -> + fail + $ "Invalid default column: " + ++ show default' + ++ " (error: " ++ show exc ++ ")" + Right t -> + return (Just t) + _ -> + fail $ "Invalid default column: " ++ show default' ref <- getRef (crConstraintName <$> cRef) - let colMaxLen' = case colMaxLen of - PersistInt64 l -> Just (fromIntegral l) - _ -> Nothing + let colMaxLen' = + case colMaxLen of + PersistInt64 l -> Just (fromIntegral l) + _ -> Nothing ci = ColumnInfo { ciColumnType = colType , ciMaxLength = colMaxLen' diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index d6d1673af..05af39546 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -44,7 +44,7 @@ import Data.Foldable import Control.Arrow import Control.Exception (Exception, throw, throwIO) import Control.Monad -import Control.Monad.Trans.Except +import Control.Monad.Except import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) import Control.Monad.Logger (MonadLogger, runNoLoggingT) import Control.Monad.Trans.Reader (runReaderT) @@ -931,13 +931,24 @@ getColumn -> Maybe (DBName, DBName) -> IO (Either Text Column) getColumn getter tableName' [PersistText columnName, PersistText isNullable, PersistText typeName, defaultValue, numericPrecision, numericScale, maxlen] refName = runExceptT $ do - d'' <- ExceptT $ pure d' - let typeStr = case maxlen of - PersistInt64 n -> T.concat [typeName, "(", T.pack (show n), ")"] - _ -> typeName - t <- either throwE pure $ getType typeStr + d'' <- + case defaultValue of + PersistNull -> + pure Nothing + PersistText t -> + pure $ Just t + _ -> + throwError $ T.pack $ "Invalid default column: " ++ show defaultValue + + let typeStr = + case maxlen of + PersistInt64 n -> + T.concat [typeName, "(", T.pack (show n), ")"] + _ -> + typeName + t <- getType typeStr let cname = DBName columnName - ref <- ExceptT $ fmap Right $ fmap join $ traverse (getRef cname) refName + ref <- lift $ fmap join $ traverse (getRef cname) refName return Column { cName = cname , cNull = isNullable == "YES" @@ -1000,65 +1011,68 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per , "AND tc.constraint_name=?" ] stmt <- getter sql - cntrs <- with (stmtQuery stmt [PersistText $ unDBName tableName' - ,PersistText $ unDBName cname - ,PersistText $ unDBName refName']) - (\src -> runConduit $ src .| CL.consume) + cntrs <- + with + (stmtQuery stmt + [ PersistText $ unDBName tableName' + , PersistText $ unDBName cname + , PersistText $ unDBName refName' + ] + ) + (\src -> runConduit $ src .| CL.consume) case cntrs of - [] -> return Nothing + [] -> + return Nothing [[PersistText table, PersistText constraint, PersistText updRule, PersistText delRule]] -> - return $ Just (DBName table, DBName constraint, updRule, delRule) + return $ Just (DBName table, DBName constraint, updRule, delRule) xs -> - error $ mconcat - [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " - , T.unpack (unDBName tableName') - , " and column: " - , T.unpack (unDBName cname) - , " but got: " - , show xs - ] - - d' = case defaultValue of - PersistNull -> Right Nothing - PersistText t -> Right $ Just t - _ -> Left $ T.pack $ "Invalid default column: " ++ show defaultValue - getType "int4" = Right SqlInt32 - getType "int8" = Right SqlInt64 - getType "varchar" = Right SqlString - getType "text" = Right SqlString - getType "date" = Right SqlDay - getType "bool" = Right SqlBool - getType "timestamptz" = Right SqlDayTime - getType "float4" = Right SqlReal - getType "float8" = Right SqlReal - getType "bytea" = Right SqlBlob - getType "time" = Right SqlTime + error $ mconcat + [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " + , T.unpack (unDBName tableName') + , " and column: " + , T.unpack (unDBName cname) + , " but got: " + , show xs + ] + + getType "int4" = pure SqlInt32 + getType "int8" = pure SqlInt64 + getType "varchar" = pure SqlString + getType "text" = pure SqlString + getType "date" = pure SqlDay + getType "bool" = pure SqlBool + getType "timestamptz" = pure SqlDayTime + getType "float4" = pure SqlReal + getType "float8" = pure SqlReal + getType "bytea" = pure SqlBlob + getType "time" = pure SqlTime getType "numeric" = getNumeric numericPrecision numericScale - getType a = Right $ SqlOther a - - getNumeric (PersistInt64 a) (PersistInt64 b) = Right $ SqlNumeric (fromIntegral a) (fromIntegral b) - getNumeric PersistNull PersistNull = Left $ T.concat - [ "No precision and scale were specified for the column: " - , columnName - , " in table: " - , unDBName tableName' - , ". Postgres defaults to a maximum scale of 147,455 and precision of 16383," - , " which is probably not what you intended." - , " Specify the values as numeric(total_digits, digits_after_decimal_place)." - ] - getNumeric a b = Left $ T.concat - [ "Can not get numeric field precision for the column: " - , columnName - , " in table: " - , unDBName tableName' - , ". Expected an integer for both precision and scale, " - , "got: " - , T.pack $ show a - , " and " - , T.pack $ show b - , ", respectively." - , " Specify the values as numeric(total_digits, digits_after_decimal_place)." - ] + getType a = pure $ SqlOther a + + getNumeric (PersistInt64 a) (PersistInt64 b) = + pure $ SqlNumeric (fromIntegral a) (fromIntegral b) + getNumeric PersistNull PersistNull = throwError $ T.concat + [ "No precision and scale were specified for the column: " + , columnName + , " in table: " + , unDBName tableName' + , ". Postgres defaults to a maximum scale of 147,455 and precision of 16383," + , " which is probably not what you intended." + , " Specify the values as numeric(total_digits, digits_after_decimal_place)." + ] + getNumeric a b = throwError $ T.concat + [ "Can not get numeric field precision for the column: " + , columnName + , " in table: " + , unDBName tableName' + , ". Expected an integer for both precision and scale, " + , "got: " + , T.pack $ show a + , " and " + , T.pack $ show b + , ", respectively." + , " Specify the values as numeric(total_digits, digits_after_decimal_place)." + ] getColumn _ _ columnName _ = return $ Left $ T.pack $ "Invalid result from information_schema: " ++ show columnName @@ -1134,11 +1148,14 @@ findAlters defs edef col@(Column name isNull sqltype def _defConstraintName _max if def == def' || isJust (T.stripPrefix "nextval" =<< def') then [] - else case def of + else + case def of Nothing -> [(name, NoDefault)] Just s -> [(name, Default s)] - in (modRef ++ modDef ++ modNull ++ modType, - filter (\c -> cName c /= name) cols) + in + ( modRef ++ modDef ++ modNull ++ modType + , filter (\c -> cName c /= name) cols + ) -- | Get the references to be added to a table for the given column. getAddReference @@ -1163,7 +1180,6 @@ getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crCons entDef <- find ((== s) . entityDB) allDefs return $ Util.dbIdColumnsEsc escape entDef - showColumn :: Column -> Text showColumn (Column n nu sqlType' def _defConstraintName _maxLen _ref) = T.concat [ escape n diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index afa861742..a2875798f 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -24,6 +24,7 @@ library , conduit >= 1.2.12 , containers >= 0.5 , monad-logger >= 0.3.25 + , mtl , postgresql-simple >= 0.6.1 && < 0.7 , postgresql-libpq >= 0.9.4.2 && < 0.10 , resourcet >= 1.1.9 From 6ada710940f632e201b29d55be169f88f7631108 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 2 Nov 2020 09:17:11 -0700 Subject: [PATCH 19/21] Doc comments on Foreign --- persistent/Database/Persist/Quasi.hs | 186 ++++++++++++++++++++++++++- 1 file changed, 180 insertions(+), 6 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index b6c964dd9..33f95e498 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -144,7 +144,10 @@ CREATE TABLE email ( PRIMARY KEY (first_part, second_part) @ -You can specify 1 or more columns in the primary key. +Since the primary key for this table is part of the record, it's called a "natural key" in the SQL lingo. +As a key with multiple fields, it is also a "composite key." + +You can specify a @Primary@ key with a single field, too. = Overriding SQL @@ -193,6 +196,176 @@ userAttrs = do -- [["sad"],["sogood"]] @ += Foreign Keys + +If you define an entity and want to refer to it in another table, you can use the entity's Id type in a column directly. + +@ +Person + name Text + +Dog + name Text + owner PersonId +@ + +This automatically creates a foreign key reference from @Dog@ to @Person@. +The foreign key constraint means that, if you have a @PersonId@ on the @Dog@, the database guarantees that the corresponding @Person@ exists in the database. +If you try to delete a @Person@ out of the database that has a @Dog@, you'll receive an exception that a foreign key violation has occurred. + +== OnUpdate and OnDelete + +These options affects how a referring record behaves when the target record is changed. +There are several options: + +* 'Restrict' - This is the default. It prevents the action from occurring. +* 'Cascade' - this copies the change to the child record. If a parent record is deleted, then the child record will be deleted too. +* 'SetNull' - If the parent record is modified, then this sets the reference to @NULL@. This only works on @Maybe@ foreign keys. +* 'SetDefault' - This will set the column's value to the @default@ for the column, if specified. + +To specify the behavior for a reference, write @OnUpdate@ or @OnDelete@ followed by the action. + +@ +Record + -- If the referred Foo is deleted or updated, then this record will + -- also be deleted or updated. + fooId FooId OnDeleteCascade OnUpdateCascade + + -- If the referred Bar is deleted, then we'll set the reference to + -- 'Nothing'. If the referred Bar is updated, then we'll cascade the + -- update. + barId BarId Maybe OnDeleteSetNull OnUpdateCascade + + -- If the referred Baz is deleted, then we set to the default ID. + bazId BazId OnDeleteSetDefault default=1 +@ + +Let's demonstrate this with a shopping cart example. + +@ +User + name Text + +Cart + user UserId Maybe + +CartItem + cartId CartId + itemId ItemId + +Item + name Text + price Int +@ + +Let's consider how we want to handle deletions and updates. +If a @User@ is deleted or update, then we want to cascade the action to the associated @Cart@. + +@ +Cart + user UserId Maybe OnDeleteCascade OnUpdateCascade +@ + +If an @Item@ is deleted, then we want to set the @CartItem@ to refer to a special "deleted item" in the database. +If a @Cart@ is deleted, though, then we just want to delete the @CartItem@. + +@ +CartItem + cartId CartId OnDeleteCascade + itemId ItemId OnDeleteSetDefault default=1 +@ + +== @Foreign@ keyword + +The above example is a "simple" foreign key. It refers directly to the Id column, and it only works with a non-composite primary key. We can define more complicated foreign keys using the @Foreign@ keyword. + +A pseudo formal syntax for @Foreign@ is: + +@ +Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] + +columns := column0 [column1 column2 .. columnX] +references := References $(target-columns) +target-columns := target-column0 [target-column1 target-columns2 .. target-columnX] +@ + +Columns are the columns as defined on this entity. +@target-columns@ are the columns as defined on the target entity. + +Let's look at some examples. + +=== Composite Primary Key References + +The most common use for this is to refer to a composite primary key. +Since composite primary keys take up more than one column, we can't refer to them with a single @persistent@ column. + +@ +Email + firstPart Text + secondPart Text + Primary firstPart secondPart + +User + name Text + emailFirstPart Text + emailSecondPart Text + + Foreign Email fk_user_email emailFirstPart emailSecondPart +@ + +If you omit the @References@ keyword, then it assumes that the foreign key reference is for the target table's primary key. +If we wanted to be fully redundant, we could specify the @References@ keyword. + +@ + Foreign Email fk_user_email emailFirstPart emailSecondPart References firstPart secondPart +@ + +We can specify delete/cascade behavior directly after the target table. + +@ + Foreign Email OnDeleteCascade OnUpdateCascade fk_user_email emailFirstPart emailSecondPart +@ + +Now, if the email is deleted or updated, the user will be deleted or updated to match. + +=== Non-Primary Key References + +SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint. +Persistent does not check this, because you might be defining your uniqueness constraints outside of Persistent. +To do this, we must use the @References@ keyword. + +@ +User + name Text + email Text + + UniqueEmail email + +Notification + content Text + sentTo Text + + Foreign User fk_noti_user sentTo References email +@ + +If the target uniqueness constraint has multiple columns, then you must specify them independently. + +@ +User + name Text + emailFirst Text + emailSecond Text + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + + Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond +@ + = Documentation Comments The quasiquoter supports ordinary comments with @--@ and @#@. @@ -922,11 +1095,12 @@ data UnboundForeignDef = UnboundForeignDef , _unboundForeignDef :: ForeignDef } -takeForeign :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> UnboundForeignDef +takeForeign + :: PersistSettings + -> Text + -> [FieldDef] + -> [Text] + -> UnboundForeignDef takeForeign ps tableName _defs = takeRefTable where errorPrefix :: String From 490f96682d7fcecbe247341954d2347966be4956 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 2 Nov 2020 09:18:27 -0700 Subject: [PATCH 20/21] sigh parsing --- persistent-mysql/Database/Persist/MySQL.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 14af3fcdf..4c960913a 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -652,8 +652,8 @@ getColumn connectInfo getter tname [ PersistText cname $ "Invalid default column: " ++ show default' ++ " (error: " ++ show exc ++ ")" - Right t -> - return (Just t) + Right t -> + return (Just t) _ -> fail $ "Invalid default column: " ++ show default' From 1cc17647ecc28fc43646337b202fd1f7cb116b93 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 2 Nov 2020 09:28:05 -0700 Subject: [PATCH 21/21] sigh --- persistent-mysql/Database/Persist/MySQL.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 4c960913a..e407910df 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -29,8 +29,6 @@ module Database.Persist.MySQL , copyUnlessEq ) where -import qualified Debug.Trace as Debug - import qualified Blaze.ByteString.Builder.Char8 as BBB import qualified Blaze.ByteString.Builder.ByteString as BBS @@ -654,8 +652,8 @@ getColumn connectInfo getter tname [ PersistText cname ++ " (error: " ++ show exc ++ ")" Right t -> return (Just t) - _ -> - fail $ "Invalid default column: " ++ show default' + _ -> + fail $ "Invalid default column: " ++ show default' ref <- getRef (crConstraintName <$> cRef) let colMaxLen' =