persistent-test-2.13.2.1: src/UniqueTest.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module UniqueTest where

import Init

share
    [mkPersist sqlSettings, mkMigrate "uniqueMigrate"]
    [persistLowerCase|
  TestNonNull
    fieldA Int
    UniqueTestNonNull fieldA sql=UniqueTestNonNull !force
    deriving Eq Show
  TestNull
    fieldA Int
    fieldB Int Maybe
    UniqueTestNull fieldA fieldB sql=UniqueTestNonNullSqlName !force
    deriving Eq Show

  TestCheckmark
    name   Text
    value  Text
    active Checkmark nullable
    UniqueTestCheckmark name active !force
    deriving Eq Show
|]

cleanDB
    :: (MonadIO m, PersistQuery backend, PersistEntityBackend TestNonNull ~ backend)
    => ReaderT backend m ()
cleanDB = do
    deleteWhere ([] :: [Filter TestNonNull])
    deleteWhere ([] :: [Filter TestNull])

specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec
specsWith runDb =
    describe "uniqueness constraints" $ do
        it "are respected for non-nullable Ints" $ do
            let
                ins = insert . TestNonNull
            (runDb $ void $ ins 1 >> ins 2)
            (runDb $ void $ ins 1 >> ins 2 >> ins 1) `shouldThrow` anyException
            (runDb $ void $ ins 1 >>= \k -> ins 2 >> delete k >> ins 1)
        it "are respected for nullable Ints" $ do
            let
                ins a b = insert $ TestNull a b
                ctx =
                    ins 1 Nothing
                        >> ins 1 Nothing
                        >> ins 1 Nothing
                        >> ins 1 (Just 3)
                        >> ins 1 (Just 4)
            (runDb $ void ctx)
            (runDb $ void $ ctx >> ins 1 (Just 3)) `shouldThrow` anyException
            (runDb $ void $ ctx >> ins 1 (Just 4)) `shouldThrow` anyException
            (runDb $ void $ ctx >>= \k -> delete k >> ins 1 (Just 4))
        it "work for Checkmark" $ do
            let
                ins k v a = insert $ TestCheckmark k v a
                ctx =
                    ins "name" "John" Inactive
                        >> ins "name" "Stewart" Inactive
                        >> ins "name" "Doroty" Active
                        >> ins "color" "blue" Inactive
            (runDb $ void ctx)
            (runDb $ void $ ctx >> ins "name" "Melissa" Active) `shouldThrow` anyException
            (runDb $ void $ ctx >> ins "name" "Melissa" Inactive)
            (runDb $ void $ ctx >>= flip update [TestCheckmarkActive =. Active])
            ( runDb $ void $ do
                    void ctx
                    updateWhere
                        [TestCheckmarkName ==. "name"]
                        [TestCheckmarkActive =. Inactive]
                    ins "name" "Melissa" Active
                )