diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,3 +1,7 @@
+## 2.1.3.1
+
+Support foreign key references to composite primary keys
+
 ## 2.1.0.1
 
 Support for monad-control 1.0
diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs
--- a/Database/Persist/TH.hs
+++ b/Database/Persist/TH.hs
@@ -105,14 +105,16 @@
 -- afterwards, sets references to other entities
 parseReferences :: PersistSettings -> Text -> Q Exp
 parseReferences ps s = lift $
-     map (mkEntityDefSqlTypeExp entityMap . breakCycleEnt) entsWithEmbeds
+     map (mkEntityDefSqlTypeExp embedEntityMap entMap) noCycleEnts
   where
+    entMap = M.fromList $ map (\ent -> (entityHaskell ent, ent)) noCycleEnts
+    noCycleEnts = map breakCycleEnt entsWithEmbeds
     -- every EntityDef could reference each-other (as an EmbedRef)
     -- let Haskell tie the knot
-    entityMap = M.fromList $ map (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) entsWithEmbeds
+    embedEntityMap = M.fromList $ map (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) entsWithEmbeds
     entsWithEmbeds = map setEmbedEntity rawEnts
     setEmbedEntity ent = ent
-      { entityFields = map (setEmbedField (entityHaskell ent) entityMap) $ entityFields ent
+      { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent
       }
     rawEnts = parse ps s
 
@@ -203,28 +205,36 @@
 instance Lift EmbedFieldDef where
     lift (EmbedFieldDef name em cyc) = [|EmbedFieldDef name em cyc|]
 
-type EntityMap = M.Map HaskellName EmbedEntityDef
-mEmbedded :: EntityMap -> FieldType -> Maybe EmbedEntityDef
-mEmbedded _ (FTTypeCon Just{} _) = Nothing
+type EmbedEntityMap = M.Map HaskellName EmbedEntityDef
+type EntityMap = M.Map HaskellName EntityDef
+
+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
-    M.lookup name ents
+    maybe (Left Nothing) Right $ M.lookup name ents
 mEmbedded ents (FTList x) = mEmbedded ents x
-mEmbedded ents (FTApp x y) = maybe (mEmbedded ents y) Just (mEmbedded ents x)
+mEmbedded ents (FTApp x y) =
+  -- Key convets an Record to a RecordId
+  -- special casing this is obviously a hack
+  -- This problem may not be solvable with the current QuasiQuoted approach though
+  if x == FTTypeCon Nothing "Key"
+    then Left $ Just FTKeyCon
+    else mEmbedded ents y
 
-setEmbedField :: HaskellName -> EntityMap -> FieldDef -> FieldDef
+setEmbedField :: HaskellName -> EmbedEntityMap -> FieldDef -> FieldDef
 setEmbedField entName allEntities field = field
   { fieldReference = case fieldReference field of
       NoReference ->
         case mEmbedded allEntities (fieldType field) of
-            Nothing -> case stripId $ fieldType field of
+            Left _ -> case stripId $ fieldType field of
                 Nothing -> NoReference
-                Just name -> if M.member (HaskellName name) allEntities
-                    then ForeignRef (HaskellName name)
-                                    -- the EmebedEntityDef does not contain FieldType information
-                                    -- but we shouldn't need this anyway
+                Just name -> case M.lookup (HaskellName name) allEntities of
+                    Nothing -> NoReference
+                    Just x -> ForeignRef (HaskellName name)
+                                    -- This will get corrected in mkEntityDefSqlTypeExp
                                     (FTTypeCon Nothing $ pack $ nameBase ''Int)
-                    else NoReference
-            Just em -> if embeddedHaskell em /= entName
+            Right em -> if embeddedHaskell em /= entName
               then EmbedRef em
               else if maybeNullable field
                      then SelfReference
@@ -232,8 +242,8 @@
       existing@_   -> existing
   }
 
-mkEntityDefSqlTypeExp :: EntityMap -> EntityDef -> EntityDefSqlTypeExp
-mkEntityDefSqlTypeExp allEntities ent = EntityDefSqlTypeExp ent
+mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp
+mkEntityDefSqlTypeExp emEntities entMap ent = EntityDefSqlTypeExp ent
     (getSqlType $ entityId ent)
     $ (map getSqlType $ entityFields ent)
   where
@@ -245,10 +255,20 @@
 
     -- In the case of embedding, there won't be any datatype created yet.
     -- We just use SqlString, as the data will be serialized to JSON.
-    defaultSqlTypeExp field
-        | isJust (mEmbedded allEntities ftype) = SqlType' SqlString
-        | otherwise = case fieldReference field of
-            ForeignRef _ ft  -> SqlTypeExp ft
+    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 entMap of
+                Nothing  -> SqlTypeExp ft
+                -- A ForeignRef is blindly set to an Int 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
@@ -676,7 +696,7 @@
   where
     keyConE = keyConExp t
     unKeyE = unKeyExp t
-    dec = RecC (keyConName t) keyFields
+    dec = RecC (keyConName t) (keyFields mps t)
     k = ''Key
     recordType = genericDataType mps (entityHaskell t) backendT
     pfInstD = -- FIXME: generate a PersistMap instead of PersistList
@@ -748,22 +768,10 @@
           else fmap (alwaysInstances `mappend`) backendKeyGenericI
       return instances
 
-    useNewtype = length keyFields < 2
-    defaultIdType = fieldType (entityId t) == FTTypeCon Nothing (keyIdText t)
-    keyFields = case entityPrimary t of
-      Just pdef -> map primaryKeyVar $ (compositeFields pdef)
-      Nothing   -> if defaultIdType
-        then [idKeyVar backendKeyType]
-        else [idKeyVar $ ftToType $ fieldType $ entityId t]
-    customKeyType = not defaultIdType || not useNewtype || isJust (entityPrimary t)
+    useNewtype = pkNewtype mps t
+    customKeyType = not (defaultIdType t) || not useNewtype || isJust (entityPrimary t)
 
-    primaryKeyVar fd = (keyFieldName t fd, NotStrict, ftToType $ fieldType fd)
-    idKeyVar ft = (unKeyName t, NotStrict, ft)
 
-    backendKeyType
-        | mpsGeneric mps = ConT ''BackendKey `AppT` backendT
-        | otherwise      = ConT ''BackendKey `AppT` mpsBackend mps
-
 keyIdName :: EntityDef -> Name
 keyIdName = mkName . unpack . keyIdText
 
@@ -797,11 +805,36 @@
 keyText :: EntityDef -> Text
 keyText t = unHaskellName (entityHaskell t) ++ "Key"
 
-keyFieldName :: EntityDef -> FieldDef -> Name
-keyFieldName t fd = mkName $ unpack $ lowerFirst (keyText t) `mappend` (unHaskellName $ fieldHaskell fd)
+pkNewtype :: MkPersistSettings -> EntityDef -> Bool
+pkNewtype mps t = length (keyFields mps t) < 2
 
+defaultIdType :: EntityDef -> Bool
+defaultIdType t = fieldType (entityId t) == FTTypeCon Nothing (keyIdText t)
+
+keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)]
+keyFields mps t = case entityPrimary t of
+  Just pdef -> map primaryKeyVar $ (compositeFields pdef)
+  Nothing   -> if defaultIdType t
+    then [idKeyVar backendKeyType]
+    else [idKeyVar $ ftToType $ fieldType $ entityId t]
+  where
+    backendKeyType
+        | mpsGeneric mps = ConT ''BackendKey `AppT` backendT
+        | otherwise      = ConT ''BackendKey `AppT` mpsBackend mps
+    idKeyVar ft = (unKeyName t, NotStrict, ft)
+    primaryKeyVar fd = ( keyFieldName mps t fd
+                       , NotStrict
+                       , ftToType $ fieldType fd
+                       )
+
+keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
+keyFieldName mps t fd
+  | pkNewtype mps t = unKeyName t
+  | otherwise = mkName $ unpack
+    $ lowerFirst (keyText t) `mappend` (unHaskellName $ fieldHaskell fd)
+
 mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec
-mkKeyToValues _mps t = do
+mkKeyToValues mps t = do
     (p, e) <- case entityPrimary t of
         Nothing  ->
           ([],) <$> [|(:[]) . toPersistValue . $(return $ unKeyExp t)|]
@@ -811,7 +844,7 @@
   where
     toValuesPrimary pdef =
       ( [VarP recordName]
-      , ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName t fd) `AppE` VarE recordName)) $ compositeFields pdef
+      , ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName mps t fd) `AppE` VarE recordName)) $ compositeFields pdef
       )
     recordName = mkName "record"
 
@@ -872,7 +905,7 @@
     t' <- lift t
     let nameT = unHaskellName entName
     let nameS = unpack nameT
-    let clazz = ConT ''PersistEntity `AppT` genericDataType mps entName backendT
+    let clazz = ConT ''PersistEntity `AppT` genDataType
     tpf <- mkToPersistFields mps nameS t
     fpv <- mkFromPersistValues mps t
     utv <- mkUniqueToValues $ entityUniques t
diff --git a/persistent-template.cabal b/persistent-template.cabal
--- a/persistent-template.cabal
+++ b/persistent-template.cabal
@@ -1,5 +1,5 @@
 name:            persistent-template
-version:         2.1.3
+version:         2.1.3.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>