diff --git a/test/Common/Test.hs b/test/Common/Test.hs index a5450fb..9c6d367 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -25,11 +25,14 @@ module Common.Test , testAscRandom , testRandomMath , migrateAll + , migrateUnique , cleanDB + , cleanUniques , RunDbMonad , Run , p1, p2, p3, p4, p5 , l1, l2, l3 + , u1, u2, u3, u4 , insert' , EntityField (..) , Foo (..) @@ -48,6 +51,7 @@ module Common.Test , Point (..) , Circle (..) , Numbers (..) + , OneUnique(..) ) where import Control.Monad (forM_, replicateM, replicateM_, void) @@ -157,8 +161,14 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| double Double |] - - +-- Unique Test schema +share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase| + OneUnique + name String + value Int + UniqueValue value + deriving Eq Show +|] -- | this could be achieved with S.fromList, but not all lists -- have Ord instances @@ -196,7 +206,17 @@ l2 = Lord "Dorset" Nothing l3 :: Lord l3 = Lord "Chester" (Just 17) +u1 :: OneUnique +u1 = OneUnique "First" 0 +u2 :: OneUnique +u2 = OneUnique "Second" 1 + +u3 :: OneUnique +u3 = OneUnique "Third" 0 + +u4 :: OneUnique +u4 = OneUnique "First" 2 testSelect :: Run -> Spec testSelect run = do @@ -1536,3 +1556,10 @@ cleanDB = do delete $ from $ \(_ :: SqlExpr (Entity Point)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Numbers)) -> return () + + +cleanUniques + :: (forall m. RunDbMonad m + => SqlPersistT (R.ResourceT m) ()) +cleanUniques = + delete $ from $ \(_ :: SqlExpr (Entity OneUnique)) -> return () \ No newline at end of file diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 8f2c4a2..316e058 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -11,6 +11,7 @@ module Main (main) where import Control.Arrow ((&&&)) +import Control.Exception (evaluate) import Control.Monad (void, when) import Control.Monad.Catch (MonadCatch, catch) import Control.Monad.IO.Class (MonadIO(liftIO)) @@ -33,7 +34,7 @@ import qualified Database.Esqueleto.PostgreSQL as EP import Database.Esqueleto.PostgreSQL.JSON hiding ((?.), (-.), (||.)) import qualified Database.Esqueleto.PostgreSQL.JSON as JSON import Database.Persist.Postgresql (withPostgresqlConn) -import Database.PostgreSQL.Simple (SqlError(..)) +import Database.PostgreSQL.Simple (SqlError(..), ExecStatus(..)) import System.Environment import Test.Hspec @@ -949,6 +950,20 @@ testHashMinusOperator = where_ $ v @>. jsonbVal (object []) where_ $ f v +testInsertUniqueViolation :: Spec +testInsertUniqueViolation = + describe "Unique Violation on Insert" $ + it "Unique throws exception" $ run (do + u1k <- insert u1 + u2k <- insert u2 + insert u3) `shouldThrow` (==) exception + where + exception = SqlError { + sqlState = "23505", + sqlExecStatus = FatalError, + sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"", + sqlErrorDetail = "Key (value)=(0) already exists.", + sqlErrorHint = ""} type JSONValue = Maybe (JSONB A.Value) @@ -1021,6 +1036,7 @@ main = do testPostgresqlUpdate testPostgresqlCoalesce testPostgresqlTextFunctions + testInsertUniqueViolation describe "PostgreSQL JSON tests" $ do -- NOTE: We only clean the table once, so we -- can use its contents across all JSON tests @@ -1053,7 +1069,9 @@ run_worker act = withConn $ runSqlConn (migrateIt >> act) migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) () migrateIt = do void $ runMigrationSilent migrateAll + void $ runMigrationSilent migrateUnique cleanDB + cleanUniques withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a withConn =