Primary key implies a Unique constraint

.stylish-haskell.yaml

@@ -37,3 +37,4 @@ language_extensions:
   - TemplateHaskell
   - TypeApplications
   - ViewPatterns
+  - QuasiQuotes

persistent-test/src/PersistUniqueTest.hs

@@ -6,43 +6,139 @@ 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 "migration"] [persistLowerCase|
-  Fo
-      foo Int
-      bar Int
-      Primary foo
-      UniqueBar bar
-      deriving Eq Show
+
+Fo
+    foo Int
+    bar Int
+    Primary foo
+    UniqueBar bar
+    deriving Eq Show
+
+Ba
+    foo Int
+    baz Int
+    UniqueBaz baz
+    deriving Eq Show
+
+OnlyPrimaryKey
+    foo Int
+    name String
+    Primary foo
+    deriving Eq Show
+
 |]
 
+deriving stock instance Eq (Unique Fo)
+deriving stock instance Show (Unique Fo)
+
+deriving stock instance Show (Unique Ba)
+deriving stock instance Eq (Unique Ba)
+
+shouldCompile :: (OnlyOneUniqueKey OnlyPrimaryKey, AtLeastOneUniqueKey OnlyPrimaryKey) => IO ()
+shouldCompile = pure ()
+
 cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend) => ReaderT backend m ()
 cleanDB = do
   deleteWhere ([] :: [Filter Fo])
 
 specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec
-specsWith runDb = describe "custom primary key" $ do
-  it "getBy" $ runDb $ do
-    let b = 5
-    k <- insert $ Fo 3 b
-    Just vk <- get k
-    Just vu <- getBy (UniqueBar b)
-    vu @== Entity k vk
-  it "insertUniqueEntity" $ runDb $ do
-    let fo = Fo 3 5
-    Just (Entity _ insertedFoValue) <- insertUniqueEntity fo
-    Nothing <- insertUniqueEntity fo
-    fo @== insertedFoValue
-  it "checkUniqueUpdateable" $ runDb $ do
-    let f = 3
-    let b = 5
-    let fo = Fo f b
-    k <- insert fo
-    Just _ <- checkUnique fo -- conflicts with itself
-
-    let fo' = Fo (f + 1) b
-    Just _ <- checkUnique fo' -- conflicts with fo
-    Nothing <- checkUniqueUpdateable $ Entity k fo' -- but fo can be updated to fo'
-
-    let fo'' = Fo (f + 1) (b + 1)
-    insert_ fo''
-    Just (UniqueBar conflict) <- checkUniqueUpdateable $ Entity k fo'' -- fo can't be updated to fo''
-    conflict @== b + 1
+specsWith runDb = describe "PersistUniqueTest" $ do
+    describe "getBy" $ do
+        it "works to pull a record from the database" $ runDb $ do
+            let b = 5
+            k <- insert Fo { foFoo = 3, foBar = b }
+            Just vk <- get k
+            Just vu <- getBy (UniqueBar b)
+            vu @== Entity k vk
+
+    describe "insertUniqueEntity" $ do
+        it "inserts a value if no conflicts are present" $ runDb $ do
+            let fo = Fo 3 5
+            Just (Entity _ insertedFoValue) <- insertUniqueEntity fo
+            fo @== insertedFoValue
+
+        it "does not insert if the record is entirely the same" $ runDb $ do
+            let fo = Fo 3 5
+            Just (Entity _ insertedFoValue) <- insertUniqueEntity fo
+            mresult <- insertUniqueEntity fo
+            mresult @== Nothing
+
+        it "does not insert if there is a primary key conflict" $ runDb $ do
+            let fo = Fo 3 5
+            Just (Entity _ insertedFoValue) <- insertUniqueEntity fo
+            mresult <- insertUniqueEntity fo { foFoo = 4 }
+            mresult @== Nothing
+
+        it "does not insert if there is a unique key conflict" $ runDb $ do
+            let fo = Fo 3 5
+            Just (Entity _ insertedFoValue) <- insertUniqueEntity fo
+            mresult <- insertUniqueEntity fo { foBar = 4 }
+            mresult @== Nothing
+
+    describe "checkUniqueUpdateable" $ do
+        describe "with standard id" $ do
+            it "returns the unique constraint that failed" $ runDb $ do
+                let ba = Ba { baFoo = 1, baBaz = 2 }
+                bk <- insert ba
+                mresult <- checkUnique ba
+                mresult @== Just (UniqueBaz 2)
+            it "returns Nothing if no constraint conflict exists" $ runDb $ do
+                let ba = Ba { baFoo = 1, baBaz = 2 }
+                mresult <- checkUnique ba
+                mresult @== Nothing
+
+        describe "with Primary" $ do
+            it "conflicts with itself" $ runDb $ do
+                let f = 3
+                let b = 5
+                let fo = Fo f b
+                k <- insert fo
+                mresult <- checkUnique fo
+                mresult @== Just (FoPrimaryKey f)
+
+            it "returns the key that failed" $ runDb $ do
+                let f = 3
+                let b = 5
+                let fo = Fo f b
+                k <- insert fo
+                _ <- checkUnique fo -- conflicts with itself
+
+                let fo' = Fo (f + 1) b
+                Just _ <- checkUnique fo' -- conflicts with fo
+                Nothing <- checkUniqueUpdateable $ Entity k fo' -- but fo can be updated to fo'
+
+                let fo'' = Fo (f + 1) (b + 1)
+                insert_ fo''
+                mresult <- checkUniqueUpdateable $ Entity k fo'' -- fo can't be updated to fo''
+                mresult @== Just (FoPrimaryKey (f + 1))
+
+    describe "upsert" $ do
+        describe "OnlyPrimaryKey" $ do
+            it "can upsert" $ runDb $ do
+                let
+                    record =
+                        OnlyPrimaryKey
+                            { onlyPrimaryKeyFoo = 1
+                            , onlyPrimaryKeyName = "Oh no"
+                            }
+                entity <- upsert record [OnlyPrimaryKeyName =. "Hello"]
+                entityVal entity @== record
+                entity' <- upsert record [OnlyPrimaryKeyName =. "Hello"]
+                entityVal entity' @== record { onlyPrimaryKeyName = "Hello" }
+
+        describe "Fo" $ do
+            it "cannot upsert" $ runDb $ do
+                -- uncomment to verify
+                -- _ <- upsert Fo { foFoo = 1, foBar = 2 } [FoFoo +=. 1]
+                pure ()
+            it "can upsertBy" $ runDb $ do
+                let f = Fo { foFoo = 1, foBar = 2 }
+                entity <- upsertBy (FoPrimaryKey 1) f [FoBar +=. 1]
+                entityVal entity @== f
+                entity' <- upsertBy (FoPrimaryKey 1) f [FoBar +=. 1]
+                entityVal entity' @== f { foBar = 1 + foBar f }
+
+    describe "OnlyPrimaryKey" $ do
+        it "has unique constraints" $ do
+            shouldCompile
+

persistent/ChangeLog.md

@@ -1,5 +1,14 @@
 # Changelog for persistent
 
+# 2.14.0.0 (unreleased)
+
+* [#1383](https://github.com/yesodweb/persistent/pull/1383)
+    * Primary keys have a `NonEmpty` of fields, not a `[]` of fields.
+    * A `Primary` key on an entity now creates a `Unique` constructror for that
+      record, with the name `#{entityName}PrimaryKey`. This also affects the
+      generation of `AtLeastOneUniqueKey` and `OnlyOneUniqueKey` instances, so
+      you may need to change behavior on these classes.
+
 # 2.13.3.4
 
 * [#1379](https://github.com/yesodweb/persistent/pull/1379)

persistent/Database/Persist/Class/PersistUnique.hs

@@ -601,7 +601,8 @@ checkUniqueUpdateable
        , PersistRecordBackend record backend
        , PersistUniqueRead backend)
     => Entity record -> ReaderT backend m (Maybe (Unique record))
-checkUniqueUpdateable (Entity key record) = checkUniqueKeysUpdateable key (persistUniqueKeys record)
+checkUniqueUpdateable (Entity key record) =
+    checkUniqueKeysUpdateable key (persistUniqueKeys record)
 
 checkUniqueKeysUpdateable
     :: forall record backend m. ( MonadIO m
@@ -612,10 +613,13 @@ checkUniqueKeysUpdateable _ [] = return Nothing
 checkUniqueKeysUpdateable key (x:xs) = do
     y <- getBy x
     case y of
-        Nothing -> checkUniqueKeysUpdateable key xs
+        Nothing ->
+            checkUniqueKeysUpdateable key xs
         Just (Entity k _)
-          | key == k -> checkUniqueKeysUpdateable key xs
-        Just _ ->  return (Just x)
+          | key == k ->
+              checkUniqueKeysUpdateable key xs
+        Just _ ->
+            return (Just x)
 
 -- | The slow but generic 'upsertBy' implementation for any 'PersistUniqueRead'.
 -- * Lookup corresponding entities (if any) 'getBy'.

persistent/Database/Persist/EntityDef.hs

@@ -13,6 +13,7 @@ module Database.Persist.EntityDef
     , getEntityFieldsDatabase
     , getEntityForeignDefs
     , getEntityUniques
+    , getEntityUniquesNoPrimaryKey
     , getEntityId
     , getEntityIdField
     , getEntityKeyFields
@@ -31,30 +32,43 @@ module Database.Persist.EntityDef
     , EntityIdDef(..)
     ) where
 
-import Data.Text (Text)
-import Data.Map (Map)
 import Data.List.NonEmpty (NonEmpty)
+import Data.Map (Map)
+import Data.Text (Text)
 
 import Database.Persist.EntityDef.Internal
 import Database.Persist.FieldDef
 
-import Database.Persist.Types.Base
-    ( UniqueDef
-    , ForeignDef
-    , entityKeyFields
-    )
 import Database.Persist.Names
+import Database.Persist.Types.Base (ForeignDef, UniqueDef(..), entityKeyFields)
+
+-- | Retrieve the list of 'UniqueDef' from an 'EntityDef'. This does not include
+-- a @Primary@ key, if one is defined. A future version of @persistent@ will
+-- include a @Primary@ key among the 'Unique' constructors for the 'Entity'.
+--
+-- @since 2.14.0.0
+getEntityUniquesNoPrimaryKey
+    :: EntityDef
+    -> [UniqueDef]
+getEntityUniquesNoPrimaryKey ed =
+    filter isNotPrimaryKey $ entityUniques ed
+  where
+    isNotPrimaryKey ud =
+        let
+            constraintName = unConstraintNameHS $ uniqueHaskell ud
+         in
+            constraintName /= unEntityNameHS (getEntityHaskellName ed) <> "PrimaryKey"
 
--- | Retrieve the list of 'UniqueDef' from an 'EntityDef'. This currently does
--- not include a @Primary@ key, if one is defined. A future version of
--- @persistent@ will include a @Primary@ key among the 'Unique' constructors for
--- the 'Entity'.
+-- | Retrieve the list of 'UniqueDef' from an 'EntityDef'.  As of version 2.14,
+-- this will also include the primary key on the entity, if one is defined. If
+-- you do not want the primary key, see 'getEntityUniquesNoPrimaryKey'.
 --
 -- @since 2.13.0.0
 getEntityUniques
     :: EntityDef
     -> [UniqueDef]
-getEntityUniques = entityUniques
+getEntityUniques =
+    entityUniques
 
 -- | Retrieve the Haskell name of the given entity.
 --

persistent/Database/Persist/Quasi/Internal.hs

@@ -52,6 +52,7 @@ module Database.Persist.Quasi.Internal
 import Prelude hiding (lines)
 
 import Control.Applicative (Alternative((<|>)))
+import Control.Monad
 import Data.Char (isLower, isSpace, isUpper, toLower)
 import Data.List (find, foldl')
 import Data.List.NonEmpty (NonEmpty(..))
@@ -461,7 +462,7 @@ unbindCompositeDef :: CompositeDef -> UnboundCompositeDef
 unbindCompositeDef cd =
     UnboundCompositeDef
         { unboundCompositeCols =
-            NEL.toList $ fmap fieldHaskell (compositeFields cd)
+            fmap fieldHaskell (compositeFields cd)
         , unboundCompositeAttrs =
             compositeAttrs cd
         }
@@ -984,10 +985,16 @@ takeConstraint ps entityName defs (n :| rest) =
                     Just $ pure (takeForeign ps entityName rest)
                 }
         "Primary" ->
-            mempty
-                { entityConstraintDefsPrimaryComposite =
-                    SetOnce (takeComposite (unboundFieldNameHS <$> defs) rest)
-                }
+            let
+                unboundComposite =
+                    takeComposite (unboundFieldNameHS <$> defs) rest
+            in
+                mempty
+                    { entityConstraintDefsPrimaryComposite =
+                        SetOnce unboundComposite
+                    , entityConstraintDefsUniques =
+                        Just $ pure $ compositeToUniqueDef entityName defs unboundComposite
+                    }
         "Id" ->
             mempty
                 { entityConstraintDefsIdField =
@@ -1067,7 +1074,7 @@ takeId ps entityName texts =
 --
 -- @since.2.13.0.0
 data UnboundCompositeDef = UnboundCompositeDef
-    { unboundCompositeCols :: [FieldNameHS]
+    { unboundCompositeCols :: NonEmpty FieldNameHS
     -- ^ The field names for the primary key.
     --
     -- @since 2.13.0.0
@@ -1079,18 +1086,49 @@ data UnboundCompositeDef = UnboundCompositeDef
     }
     deriving (Eq, Ord, Show, Lift)
 
+compositeToUniqueDef :: EntityNameHS -> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef
+compositeToUniqueDef entityName fields UnboundCompositeDef {..} =
+    UniqueDef
+        { uniqueHaskell =
+            ConstraintNameHS (unEntityNameHS entityName <> "PrimaryKey")
+        , uniqueDBName =
+            ConstraintNameDB "primary_key"
+        , uniqueFields =
+            fmap (\hsName -> (hsName, getDbNameFor hsName)) unboundCompositeCols
+        , uniqueAttrs =
+            unboundCompositeAttrs
+        }
+  where
+    getDbNameFor hsName =
+        case mapMaybe (matchHsName hsName) fields of
+            [] ->
+                error "Unable to find `hsName` in fields"
+            (a : _) ->
+                a
+    matchHsName hsName UnboundFieldDef {..} = do
+        guard $ unboundFieldNameHS == hsName
+        pure unboundFieldNameDB
+
+
+
 takeComposite
     :: [FieldNameHS]
     -> [Text]
     -> UnboundCompositeDef
 takeComposite fields pkcols =
     UnboundCompositeDef
         { unboundCompositeCols =
-            map (getDef fields) cols
+            fmap (getDef fields) neCols
         , unboundCompositeAttrs =
             attrs
         }
   where
+    neCols =
+        case NEL.nonEmpty cols of
+            Nothing ->
+                error "No fields provided for primary key"
+            Just xs ->
+                xs
     (cols, attrs) = break ("!" `T.isPrefixOf`) pkcols
     getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t
     getDef (d:ds) t

persistent/Database/Persist/Sql/Internal.hs

@@ -81,7 +81,7 @@ mkColumns
     -> BackendSpecificOverrides
     -> ([Column], [UniqueDef], [ForeignDef])
 mkColumns allDefs t overrides =
-    (cols, getEntityUniques t, getEntityForeignDefs t)
+    (cols, getEntityUniquesNoPrimaryKey t, getEntityForeignDefs t)
   where
     cols :: [Column]
     cols = map goId idCol `mappend` map go (getEntityFieldsDatabase t)