Foreign key improvements

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,21 +799,21 @@ 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)
         Column _ isNull' type_' def' _defConstraintName' maxLen' ref' : _ ->
             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

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.

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,14 +1068,15 @@ findAlters defs edef col@(Column name isNull sqltype def _defConstraintName _max
                                     a
                                     [name]
                                     (Util.dbIdColumnsEsc escape refdef)
+                                    -- TODO: Fix cascade reference is ignored
                                     noCascade
                               )
                             ]
                         Just _ -> []
                         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

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.
 

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 (table, _) -> if noRef then "" else " REFERENCES " <> escape table
+        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 $

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
@@ -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
@@ -1335,16 +1335,21 @@ 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
     let reftableKeyName = mkName $ reftableString `mappend` "Key"
     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]
 
@@ -1689,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