diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 595e154ef..6111cf2df 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -58,7 +58,7 @@ jobs: env: CONFIG: "--enable-tests --enable-benchmarks" steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: haskell/actions/setup@v2 id: setup-haskell-cabal with: diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs index 7e32f5007..3df5b62d2 100644 --- a/persistent/Database/Persist/Class/PersistEntity.hs +++ b/persistent/Database/Persist/Class/PersistEntity.hs @@ -23,7 +23,7 @@ module Database.Persist.Class.PersistEntity , Filter (..) , FilterValue (..) , BackendSpecificFilter - , Entity (.., Entity, entityKey, entityVal) + , Entity (..) , recordName , entityValues @@ -39,8 +39,6 @@ module Database.Persist.Class.PersistEntity , SafeToInsertErrorMessage ) where -import Data.Functor.Constant - import Data.Aeson ( FromJSON(..) , ToJSON(..) @@ -63,7 +61,6 @@ import qualified Data.Aeson.KeyMap as AM import qualified Data.HashMap.Strict as AM #endif -import GHC.Records import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (isJust) import Data.Text (Text) @@ -553,9 +550,9 @@ instance SymbolToField sym rec typ => IsLabel sym (EntityField rec typ) where class SafeToInsert a where type SafeToInsertErrorMessage a - = 'Text "The PersistEntity " ':<>: ShowType a ':<>: 'Text " does not have a default primary key." + = 'Text "The PersistEntity " ':<>: 'ShowType a ':<>: 'Text " does not have a default primary key." ':$$: 'Text "This means that 'insert' will fail with a database error." - ':$$: 'Text "Please provide a default= clause inthe entity definition," + ':$$: 'Text "Please provide a default= clause in the entity definition," ':$$: 'Text "or use 'insertKey' instead to provide one." instance (TypeError (FunctionErrorMessage a b)) => SafeToInsert (a -> b) diff --git a/persistent/Database/Persist/Class/PersistField.hs b/persistent/Database/Persist/Class/PersistField.hs index 560df6e77..6ef4d574d 100644 --- a/persistent/Database/Persist/Class/PersistField.hs +++ b/persistent/Database/Persist/Class/PersistField.hs @@ -29,7 +29,7 @@ import qualified Data.Text.Encoding.Error as TERR import qualified Data.Text.Lazy as TL import qualified Data.Vector as V import Data.Word (Word, Word8, Word16, Word32, Word64) -import Numeric.Natural (Natural) +import Numeric.Natural import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text (renderHtml) import GHC.TypeLits @@ -44,6 +44,7 @@ import Data.Time (defaultTimeLocale) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) #endif +import Prelude -- | This class teaches Persistent how to take a custom type and marshal it to and from a 'PersistValue', allowing it to be stored in a database. -- diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs index f1baea5e5..061341b83 100644 --- a/persistent/Database/Persist/Sql/Run.hs +++ b/persistent/Database/Persist/Sql/Run.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} + module Database.Persist.Sql.Run where import Control.Monad.IO.Unlift diff --git a/persistent/Database/Persist/SqlBackend/SqlPoolHooks.hs b/persistent/Database/Persist/SqlBackend/SqlPoolHooks.hs index c180a1d1a..f0295ca04 100644 --- a/persistent/Database/Persist/SqlBackend/SqlPoolHooks.hs +++ b/persistent/Database/Persist/SqlBackend/SqlPoolHooks.hs @@ -11,6 +11,8 @@ module Database.Persist.SqlBackend.SqlPoolHooks , modifyRunAfter , setRunAfter , getRunOnException + , modifyRunOnException + , setRunOnException ) where @@ -83,9 +85,15 @@ setRunAfter hooks f = hooks { runAfter = f } getRunOnException :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> SomeException -> m ()) getRunOnException = runOnException +-- | +-- +-- @since 2.14.5.0 modifyRunOnException :: SqlPoolHooks m backend -> ((backend -> Maybe IsolationLevel -> SomeException -> m ()) -> (backend -> Maybe IsolationLevel -> SomeException -> m ())) -> SqlPoolHooks m backend modifyRunOnException hooks f = hooks { runOnException = f $ runOnException hooks } +-- | +-- +-- @since 2.14.5.0 setRunOnException :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> SomeException -> m ()) -> SqlPoolHooks m backend setRunOnException hooks f = hooks { runOnException = f } diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 6f542e69d..0ff48e9a5 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -156,7 +156,7 @@ test-suite test hs-source-dirs: test/ - ghc-options: -Wall + ghc-options: -Wall -Wno-incomplete-uni-patterns default-extensions: FlexibleContexts , MultiParamTypeClasses diff --git a/persistent/test/Database/Persist/PersistValueSpec.hs b/persistent/test/Database/Persist/PersistValueSpec.hs index a8ded1d27..c2c718d7d 100644 --- a/persistent/test/Database/Persist/PersistValueSpec.hs +++ b/persistent/test/Database/Persist/PersistValueSpec.hs @@ -2,15 +2,12 @@ module Database.Persist.PersistValueSpec where import Test.Hspec import Database.Persist.PersistValue -import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.Text as T -import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Data.Aeson import qualified Data.ByteString.Char8 as BS8 - spec :: Spec spec = describe "PersistValueSpec" $ do describe "PersistValue" $ do diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index a987d29a6..82d337d5c 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -507,9 +507,9 @@ User UniqueEmail emailFirst emailSecond |] - let [user] = parse lowerCaseSettings definitions + let user = head $ parse lowerCaseSettings definitions uniques = entityUniques (unboundEntityDef user) - [dbNames] = fmap snd . uniqueFields <$> uniques + dbNames = head $ fmap snd . uniqueFields <$> uniques errMsg = unwords [ "Unknown column in \"UniqueEmail\" constraint: \"emailSecond\"" , "possible fields: [\"name\",\"emailFirst\"]" @@ -523,7 +523,7 @@ User age Text Unique some |] - let [user] = parse lowerCaseSettings definitions + let user = head $ parse lowerCaseSettings definitions evaluate (unboundPrimarySpec user) `shouldErrorWithMessage` "invalid unique constraint on table[\"User\"] expecting an uppercase constraint name xs=[\"some\"]" @@ -548,10 +548,10 @@ Notification let flippedFK (EntityNameHS entName) (ConstraintNameHS conName) = conName <> entName - [_user, notification] = - parse (setPsToFKName flippedFK lowerCaseSettings) validDefinitions - [notificationForeignDef] = - unboundForeignDef <$> unboundForeignDefs notification + (_user, notification) = + listToTwoTuple $ parse (setPsToFKName flippedFK lowerCaseSettings) validDefinitions + notificationForeignDef = + head $ unboundForeignDef <$> unboundForeignDefs notification foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "fk_noti_user_notification" @@ -571,7 +571,8 @@ Notification sentToSecond Text Foreign User |] - let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let (_user, notification) = + listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]" @@ -591,7 +592,8 @@ Notification sentToSecond Text Foreign User fk_noti_user |] - let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let (_user, notification) = + listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` "No fields on foreign reference." @@ -611,7 +613,8 @@ Notification sentToSecond Text Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst |] - let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let (_user, notification) = + listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] Found 2 foreign fields but 1 parent fields" @@ -631,7 +634,7 @@ Notification sentToSecond Text Foreign User OnDeleteCascade OnDeleteCascade |] - let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let (_user, notification) = listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] found more than one OnDelete actions" @@ -651,16 +654,16 @@ Notification sentToSecond Text Foreign User OnUpdateCascade OnUpdateCascade |] - let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let (_user, notification) = listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] found more than one OnUpdate actions" it "should allow you to enable snake cased foriegn keys via a preset configuration function" $ do - let [_user, notification] = - parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) validDefinitions - [notificationForeignDef] = - unboundForeignDef <$> unboundForeignDefs notification + let (_user, notification) = + listToTwoTuple $ parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) validDefinitions + notificationForeignDef = + head $ unboundForeignDef <$> unboundForeignDefs notification foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "notification_fk_noti_user" @@ -676,7 +679,7 @@ CustomerTransfer currencyCode CurrencyCode uuid TransferUuid |] - let [customerTransfer] = parse lowerCaseSettings tickedDefinition + let customerTransfer = head $ parse lowerCaseSettings tickedDefinition let expectedType = FTTypeCon Nothing "MoneyAmount" `FTApp` FTTypePromoted "Customer" `FTApp` FTTypePromoted "Debit" @@ -696,7 +699,7 @@ WithFinite one (Finite 1) twenty (Labelled "twenty") |] - let [withFinite] = parse lowerCaseSettings tickedDefinition + let withFinite = head $ parse lowerCaseSettings tickedDefinition (simplifyField <$> unboundEntityFields withFinite) `shouldBe` [ (FieldNameHS "one", FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1))) @@ -1131,7 +1134,7 @@ Baz , " Extra2" , " something" ] - let [subject] = parse lowerCaseSettings lines + let subject = head $ parse lowerCaseSettings lines it "produces the right name" $ do getUnboundEntityNameHS subject `shouldBe` EntityNameHS "Foo" describe "unboundEntityFields" $ do @@ -1155,7 +1158,7 @@ Baz , ("Extra2", [["something"]]) ] describe "works with extra blocks" $ do - let [_, lowerCaseTable, idTable] = + let (_, lowerCaseTable, idTable) = case parse lowerCaseSettings $ T.unlines [ "" , "IdTable" @@ -1178,7 +1181,7 @@ Baz , "" ] of [a, b, c] -> - [a, b, c] :: [UnboundEntityDef] + ( a, b, c ) xs -> error $ "Expected 3 elements in list, got: " @@ -1227,3 +1230,7 @@ shouldErrorWithMessage action expectedMsg = do msg `shouldBe` expectedMsg _ -> expectationFailure "Expected `error` to have been called" + +listToTwoTuple :: HasCallStack => [a] -> (a, a) +listToTwoTuple [a, b] = (a, b) +listToTwoTuple xs = error $ "Expected two items in list exactly, got: " <> show (length xs) diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 0ea783206..2fd4ffb69 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -32,7 +32,7 @@ import Data.Functor.Identity (Identity(..)) import Data.Int import qualified Data.List as List import Data.Proxy -import Data.Text (Text, pack) +import Data.Text (pack) import Data.Time import GHC.Generics (Generic) import System.Environment @@ -205,9 +205,9 @@ spec = describe "THSpec" $ do JsonEncodingSpec.spec CommentSpec.spec CompositeKeyStyleSpec.spec + RequireOnlyPersistImportSpec.spec + describe "TestDefaultKeyCol" $ do - let EntityIdField FieldDef{..} = - entityId (entityDef (Proxy @TestDefaultKeyCol)) it "should be a BackendKey SqlBackend" $ do -- the purpose of this test is to verify that a custom Id column of -- the form: