diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index af8b007f5..9a0c09228 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -70,6 +70,7 @@ jobs: uses: supercharge/redis-github-action@1.1.0 - run: cabal v2-update - run: cabal v2-freeze $CONFIG + - run: cat cabal.project.freeze - uses: actions/cache@v2 with: path: | @@ -77,7 +78,7 @@ jobs: key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} restore-keys: | ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} - # ${{ runner.os }}-${{ matrix.ghc }}- + ${{ runner.os }}-${{ matrix.ghc }}- - run: cabal v2-build all --disable-optimization --only-dependencies $CONFIG - run: cabal v2-build all --disable-optimization $CONFIG - run: cabal v2-test all --disable-optimization $CONFIG diff --git a/.gitignore b/.gitignore index dfdf38bbb..ae521ad58 100644 --- a/.gitignore +++ b/.gitignore @@ -51,3 +51,4 @@ persistent-test/db/ .hspec-failures stack.yaml.lock +*.yaml.lock diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs index 25cb38b70..96ef4b3d6 100644 --- a/persistent-mongoDB/Database/Persist/MongoDB.hs +++ b/persistent-mongoDB/Database/Persist/MongoDB.hs @@ -156,6 +156,7 @@ import Database.MongoDB.Query (Database) import Database.Persist import qualified Database.Persist.Sql as Sql +import Database.Persist.EntityDef.Internal (toEmbedEntityDef) instance HasPersistBackend DB.MongoContext where type BaseBackend DB.MongoContext = DB.MongoContext @@ -448,13 +449,13 @@ entityToInsertDoc (Entity key record) = keyToMongoDoc key ++ toInsertDoc record collectionName :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => record -> Text -collectionName = unEntityNameDB . entityDB . entityDef . Just +collectionName = unEntityNameDB . getEntityDBName . entityDef . Just -- | convert a PersistEntity into document fields. -- unlike 'toInsertDoc', nulls are included. recordToDocument :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => record -> DB.Document -recordToDocument record = zipToDoc (map fieldDB $ entityFields entity) (toPersistFields record) +recordToDocument record = zipToDoc (map fieldDB $ getEntityFields entity) (toPersistFields record) where entity = entityDef $ Just record @@ -658,7 +659,7 @@ collectionNameFromKey = collectionName . recordTypeFromKey projectionFromEntityDef :: EntityDef -> DB.Projector projectionFromEntityDef eDef = - map toField (entityFields eDef) + map toField (getEntityFields eDef) where toField :: FieldDef -> DB.Field toField fDef = (unFieldNameDB (fieldDB fDef)) DB.=: (1 :: Int) @@ -920,7 +921,7 @@ fromPersistValuesThrow :: (Trans.MonadIO m, PersistEntity record, PersistEntityB fromPersistValuesThrow entDef doc = case eitherFromPersistValues entDef doc of Left t -> Trans.liftIO . throwIO $ PersistMarshalError $ - unEntityNameHS (entityHaskell entDef) `mappend` ": " `mappend` t + unEntityNameHS (getEntityHaskellName entDef) `mappend` ": " `mappend` t Right entity -> return entity mapLeft :: (a -> c) -> Either a b -> Either c b diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 5de7eaac2..34229e070 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -141,7 +141,7 @@ open' ci logFunc = do , connCommit = const $ MySQL.commit conn , connRollback = const $ MySQL.rollback conn , connEscapeFieldName = T.pack . escapeF - , connEscapeTableName = T.pack . escapeE . entityDB + , connEscapeTableName = T.pack . escapeE . getEntityDBName , connEscapeRawName = T.pack . escapeDBName . T.unpack , connNoLimit = "LIMIT 18446744073709551615" -- This noLimit is suggested by MySQL's own docs, see @@ -174,7 +174,7 @@ insertSql' ent vals = (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeFT) sql = T.concat [ "INSERT INTO " - , escapeET $ entityDB ent + , escapeET $ getEntityDBName ent , "(" , T.intercalate "," fieldNames , ") VALUES(" @@ -339,7 +339,7 @@ migrate' :: MySQL.ConnectInfo -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' connectInfo allDefs getter val = do - let name = entityDB val + let name = getEntityDBName val let (newcols, udefs, fdefs) = mysqlMkColumns allDefs val old <- getColumns connectInfo getter val newcols let udspair = map udToPair udefs @@ -360,7 +360,7 @@ migrate' connectInfo allDefs getter val = do let refTarget = addReference allDefs refConstraintName refTblName cname (crFieldCascade cRef) - guard $ cname /= fieldDB (entityId val) + guard $ cname /= fieldDB (getEntityId val) return $ AlterColumn name refTarget @@ -434,35 +434,60 @@ migrate' connectInfo allDefs getter val = do addTable :: [Column] -> EntityDef -> AlterDB addTable cols entity = AddTable $ concat - -- Lower case e: see Database.Persist.Sql.Migration - [ "CREATe TABLE " - , escapeE name - , "(" - , idtxt - , if null nonIdCols then [] else "," - , intercalate "," $ map showColumn nonIdCols - , ")" - ] - where - nonIdCols = - filter (\c -> cName c /= fieldDB (entityId entity) ) cols - name = entityDB entity - idtxt = case entityPrimary entity of - Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeF . fieldDB) $ compositeFields pdef, ")"] - Nothing -> - let defText = defaultAttribute $ fieldAttrs $ entityId entity - sType = fieldSqlType $ entityId entity - autoIncrementText = case (sType, defText) of - (SqlInt64, Nothing) -> " AUTO_INCREMENT" - _ -> "" - maxlen = findMaxLenOfField (entityId entity) - in concat - [ escapeF $ fieldDB $ entityId entity - , " " <> showSqlType sType maxlen False - , " NOT NULL" - , autoIncrementText - , " PRIMARY KEY" - ] + -- Lower case e: see Database.Persist.Sql.Migration + [ "CREATe TABLE " + , escapeE name + , "(" + , idtxt + , if null nonIdCols then [] else "," + , intercalate "," $ map showColumn nonIdCols + , ")" + ] + where + nonIdCols = + filter (\c -> cName c /= fieldDB (getEntityId entity) ) cols + name = + getEntityDBName entity + idtxt = + case entityPrimary entity of + Just pdef -> + concat + [ " PRIMARY KEY (" + , intercalate "," + $ map (escapeF . fieldDB) $ compositeFields pdef + , ")" + ] + Nothing -> + let + idField = + getEntityId entity + defText = + defaultAttribute $ fieldAttrs idField + sType = + fieldSqlType idField + autoIncrementText = + case (sType, defText) of + (SqlInt64, Nothing) -> " AUTO_INCREMENT" + _ -> "" + maxlen = + findMaxLenOfField idField + in + concat + [ escapeF $ fieldDB $ getEntityId entity + , " " <> showSqlType sType maxlen False + , " NOT NULL" + , autoIncrementText + , " PRIMARY KEY" + , case defText of + Nothing -> + "" + Just def -> + concat + [ " DEFAULT (" + , T.unpack def + , ")" + ] + ] -- | Find out the type of a column. findTypeOfColumn :: [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType) @@ -474,8 +499,8 @@ findTypeOfColumn allDefs name col = ) ((,) col) $ do - entDef <- find ((== name) . entityDB) allDefs - fieldDef <- find ((== col) . fieldDB) (entityFields entDef) + entDef <- find ((== name) . getEntityDBName) allDefs + fieldDef <- find ((== col) . fieldDB) (getEntityFields entDef) return (fieldType fieldDef) -- | Find out the maxlen of a column (default to 200) @@ -483,8 +508,8 @@ findMaxLenOfColumn :: [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB findMaxLenOfColumn allDefs name col = maybe (col, 200) ((,) col) $ do - entDef <- find ((== name) . entityDB) allDefs - fieldDef <- find ((== col) . fieldDB) (entityFields entDef) + entDef <- find ((== name) . getEntityDBName) allDefs + fieldDef <- find ((== col) . fieldDB) (getEntityFields entDef) findMaxLenOfField fieldDef -- | Find out the maxlen of a field @@ -518,8 +543,8 @@ addReference allDefs fkeyname reftable cname fc = ++ " (allDefs = " ++ show allDefs ++ ")" referencedColumns = fromMaybe errorMessage $ do - entDef <- find ((== reftable) . entityDB) allDefs - return $ map fieldDB $ entityKeyFields entDef + entDef <- find ((== reftable) . getEntityDBName) allDefs + return $ map fieldDB $ getEntityKeyFields entDef data AlterColumn = Change Column | Add' Column @@ -607,15 +632,15 @@ getColumns connectInfo getter def cols = do Nothing -> rs (Just r) -> (unFieldNameDB $ cName c, r) : rs vals = [ PersistText $ pack $ MySQL.connectDatabase connectInfo - , PersistText $ unEntityNameDB $ entityDB def - -- , PersistText $ unDBName $ fieldDB $ entityId def + , PersistText $ unEntityNameDB $ getEntityDBName def + -- , PersistText $ unDBName $ fieldDB $ getEntityId def ] helperClmns = CL.mapM getIt .| CL.consume where getIt row = fmap (either Left (Right . Left)) . liftIO . - getColumn connectInfo getter (entityDB def) row $ ref + getColumn connectInfo getter (getEntityDBName def) row $ ref where ref = case row of (PersistText cname : _) -> (Map.lookup cname refMap) _ -> Nothing @@ -823,7 +848,7 @@ getAlters getAlters allDefs edef (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) where - tblName = entityDB edef + tblName = getEntityDBName edef getAltersC [] old = concatMap dropColumn old getAltersC (new:news) old = let (alters, old') = findAlters edef allDefs new old @@ -886,8 +911,8 @@ findAlters edef allDefs col@(Column name isNull type_ def gen _defConstraintName refAdd = case (ref == ref', ref) of (False, Just ColumnReference {crTableName=tname, crConstraintName=cname, crFieldCascade = cfc }) - | tname /= entityDB edef - , unConstraintNameDB cname /= unFieldNameDB (fieldDB (entityId edef)) + | tname /= getEntityDBName edef + , unConstraintNameDB cname /= unFieldNameDB (fieldDB (getEntityId edef)) -> [addReference allDefs cname tname name cfc] _ -> [] @@ -1197,7 +1222,7 @@ mockMigrate :: MySQL.ConnectInfo -> EntityDef -> IO (Either [Text] [(Bool, Text)]) mockMigrate _connectInfo allDefs _getter val = do - let name = entityDB val + let name = getEntityDBName val let (newcols, udefs, fdefs) = mysqlMkColumns allDefs val let udspair = map udToPair udefs case () of @@ -1259,7 +1284,7 @@ mockMigration mig = do , connCommit = undefined , connRollback = undefined , connEscapeFieldName = T.pack . escapeDBName . T.unpack . unFieldNameDB - , connEscapeTableName = T.pack . escapeDBName . T.unpack . unEntityNameDB . entityDB + , connEscapeTableName = T.pack . escapeDBName . T.unpack . unEntityNameDB . getEntityDBName , connEscapeRawName = T.pack . escapeDBName . T.unpack , connNoLimit = undefined , connRDBMS = undefined @@ -1459,8 +1484,8 @@ mkBulkInsertQuery records fieldValues updates = firstField = case entityFieldNames of [] -> error "The entity you're trying to insert does not have any fields." (field:_) -> field - entityFieldNames = map fieldDbToText (entityFields entityDef') - tableName = T.pack . escapeE . entityDB $ entityDef' + entityFieldNames = map fieldDbToText (getEntityFields entityDef') + tableName = T.pack . escapeE . getEntityDBName $ entityDef' copyUnlessValues = map snd fieldsToMaybeCopy recordValues = concatMap (map toPersistValue . toPersistFields) records recordPlaceholders = Util.commaSeparated $ map (Util.parenWrapped . Util.commaSeparated . map (const "?") . toPersistFields) records @@ -1496,7 +1521,7 @@ mkBulkInsertQuery records fieldValues updates = putManySql :: EntityDef -> Int -> Text putManySql ent n = putManySql' fields ent n where - fields = entityFields ent + fields = getEntityFields ent repsertManySql :: EntityDef -> Int -> Text repsertManySql ent n = putManySql' fields ent n @@ -1509,7 +1534,7 @@ putManySql' (filter isFieldNotGenerated -> fields) ent n = q fieldDbToText = (T.pack . escapeF) . fieldDB mkAssignment f = T.concat [f, "=VALUES(", f, ")"] - table = (T.pack . escapeE) . entityDB $ ent + table = (T.pack . escapeE) . getEntityDBName $ ent columns = Util.commaSeparated $ map fieldDbToText fields placeholders = map (const "?") fields updates = map (mkAssignment . fieldDbToText) fields diff --git a/persistent-mysql/persistent-mysql.cabal b/persistent-mysql/persistent-mysql.cabal index d9e6708f3..ff5e4441f 100644 --- a/persistent-mysql/persistent-mysql.cabal +++ b/persistent-mysql/persistent-mysql.cabal @@ -54,28 +54,34 @@ test-suite test type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test - other-modules: MyInit - InsertDuplicateUpdate - CustomConstraintTest + other-modules: + MyInit + InsertDuplicateUpdate + CustomConstraintTest + ImplicitUuidSpec ghc-options: -Wall - build-depends: base >= 4.9 && < 5 - , persistent - , persistent-mysql - , persistent-qq - , persistent-test - , bytestring - , containers - , fast-logger - , hspec >= 2.4 - , HUnit - , monad-logger - , mysql - , QuickCheck - , quickcheck-instances - , resourcet - , text - , time - , transformers - , unliftio-core + build-depends: + base >= 4.9 && < 5 + , aeson + , bytestring + , containers + , fast-logger + , hspec >= 2.4 + , http-api-data + , HUnit + , monad-logger + , mysql + , path-pieces + , persistent + , persistent-mysql + , persistent-qq + , persistent-test + , QuickCheck + , quickcheck-instances + , resourcet + , text + , time + , transformers + , unliftio-core default-language: Haskell2010 diff --git a/persistent-mysql/test/ImplicitUuidSpec.hs b/persistent-mysql/test/ImplicitUuidSpec.hs new file mode 100644 index 000000000..bdc1e4f14 --- /dev/null +++ b/persistent-mysql/test/ImplicitUuidSpec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module ImplicitUuidSpec where + +import MyInit + +import Data.Proxy +import Database.Persist.MySQL + +import Database.Persist.ImplicitIdDef +import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) + +share + [ mkPersist (sqlSettingsUuid "UUID()") + , mkEntityDefList "entities" + ] + [persistLowerCase| + +WithDefUuid + name Text + + deriving Eq Show Ord + +|] + +implicitUuidMigrate :: Migration +implicitUuidMigrate = do + migrateModels entities + +wipe :: IO () +wipe = db $ do + rawExecute "DROP TABLE IF EXISTS with_def_uuid;" [] + runMigration implicitUuidMigrate + +itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) +itDb msg action = it msg $ db $ void action + +pass :: IO () +pass = pure () + +spec :: Spec +spec = fdescribe "ImplicitUuidSpec" $ before_ wipe $ do + describe "WithDefUuidKey" $ do + it "works on UUIDs" $ do + let withDefUuidKey = WithDefUuidKey (UUID "Hello") + pass + describe "getEntityId" $ do + let idField = getEntityId (entityDef (Proxy @WithDefUuid)) + it "has a SqlString SqlType" $ asIO $ do + fieldSqlType idField `shouldBe` SqlString + it "has a UUID type" $ asIO $ do + fieldType idField `shouldBe` fieldTypeFromTypeable @UUID + it "is an implicit ID column" $ asIO $ do + fieldIsImplicitIdColumn idField `shouldBe` True + + describe "insert" $ do + itDb "successfully has a default" $ do + let matt = WithDefUuid + { withDefUuidName = + "Matt" + } + k <- insert matt + mrec <- get k + uuids <- selectList @WithDefUuid [] [] + liftIO $ do + -- MySQL's insert functionality is currently broken. The @k@ + -- here is derived from @SELECT LAST_INSERT_ID()@ which only + -- works on auto incrementing IDs. + -- + -- See #1251 for more details. + mrec `shouldBe` Nothing + + map entityVal uuids `shouldSatisfy` (matt `elem`) diff --git a/persistent-mysql/test/MyInit.hs b/persistent-mysql/test/MyInit.hs index deb7ffdbf..ddd50c83f 100644 --- a/persistent-mysql/test/MyInit.hs +++ b/persistent-mysql/test/MyInit.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module MyInit ( (@/=), (@==), (==@) @@ -26,12 +29,14 @@ module MyInit ( , MonadUnliftIO , liftIO , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase + , mkEntityDefList, sqlSettingsUuid , Int32, Int64 , Text , module Control.Monad.Trans.Reader , module Control.Monad , module Database.Persist.Sql , BS.ByteString + , migrateModels , SomeException , MonadFail , TestFn(..) @@ -40,44 +45,71 @@ module MyInit ( , truncateUTCTime , arbText , liftA2 + , LoggingT, ResourceT, UUID(..) ) where import Init - ( TestFn(..), truncateTimeOfDay, truncateUTCTime - , truncateToMicro, arbText, GenerateKey(..) - , (@/=), (@==), (==@) - , assertNotEqual, assertNotEmpty, assertEmpty, asIO - , isTravis, RunDb, MonadFail - ) + ( GenerateKey(..) + , MonadFail + , RunDb + , TestFn(..) + , arbText + , asIO + , assertEmpty + , assertNotEmpty + , assertNotEqual + , isTravis + , truncateTimeOfDay + , truncateToMicro + , truncateUTCTime + , (==@) + , (@/=) + , (@==) + ) -- re-exports import Control.Applicative (liftA2) import Control.Exception (SomeException) -import Control.Monad (void, replicateM, liftM, when, forM_) +import Control.Monad (forM_, liftM, replicateM, void, when) import Control.Monad.Trans.Reader -import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) +import Data.Aeson (FromJSON, ToJSON, Value(..)) import Database.Persist.Sql.Raw.QQ +import Database.Persist.TH + ( MkPersistSettings(..) + , migrateModels + , setImplicitIdDef + , mkEntityDefList + , mkMigrate + , mkPersist + , persistLowerCase + , persistUpperCase + , share + , sqlSettings + ) import Test.Hspec import Test.QuickCheck.Instances () +import Web.Internal.HttpApiData +import Web.PathPieces +import Database.Persist.ImplicitIdDef -- testing -import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) +import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import Control.Monad (unless, (>=>)) -import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.IO.Class +import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Logger import Control.Monad.Trans.Resource (ResourceT, runResourceT) import qualified Data.ByteString as BS import Data.Int (Int32, Int64) import Data.Text (Text) +import qualified Data.Text.Encoding as TE import qualified Database.MySQL.Base as MySQL import System.Log.FastLogger (fromLogStr) import Database.Persist import Database.Persist.MySQL import Database.Persist.Sql -import Database.Persist.TH () _debugOn :: Bool _debugOn = False @@ -122,3 +154,22 @@ runConn f = do db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion db actions = do runResourceT $ runConn $ actions >> transactionUndo + +newtype UUID = UUID { unUUID :: Text } + deriving stock + (Show, Eq, Ord, Read) + deriving newtype + ( ToJSON, FromJSON + , PersistField, PersistFieldSql + , FromHttpApiData, ToHttpApiData, PathPiece + ) + +sqlSettingsUuid :: Text -> MkPersistSettings +sqlSettingsUuid defExpr = + let + uuidDef = + setImplicitIdDefMaxLen 100 $ mkImplicitIdDef @UUID defExpr + settings = + setImplicitIdDef uuidDef sqlSettings + in + settings diff --git a/persistent-mysql/test/main.hs b/persistent-mysql/test/main.hs index 56e165d8f..26ab9dc66 100644 --- a/persistent-mysql/test/main.hs +++ b/persistent-mysql/test/main.hs @@ -54,6 +54,7 @@ import qualified CustomConstraintTest import qualified LongIdentifierTest import qualified GeneratedColumnTestSQL import qualified ForeignKey +import qualified ImplicitUuidSpec type Tuple a b = (a, b) @@ -109,98 +110,99 @@ setup migration = do main :: IO () main = do - runConn $ do - mapM_ setup - [ PersistentTest.testMigrate - , PersistentTest.noPrefixMigrate - , PersistentTest.customPrefixMigrate - , EmbedTest.embedMigrate - , EmbedOrderTest.embedOrderMigrate - , LargeNumberTest.numberMigrate - , UniqueTest.uniqueMigrate - , MaxLenTest.maxlenMigrate - , Recursive.recursiveMigrate - , CompositeTest.compositeMigrate - , PersistUniqueTest.migration - , RenameTest.migration - , CustomPersistFieldTest.customFieldMigrate - , InsertDuplicateUpdate.duplicateMigrate - , MigrationIdempotencyTest.migration - , CustomPrimaryKeyReferenceTest.migration - , MigrationColumnLengthTest.migration - , TransactionLevelTest.migration - -- , LongIdentifierTest.migration - , ForeignKey.compositeMigrate - ] - PersistentTest.cleanDB - ForeignKey.cleanDB + runConn $ do + mapM_ setup + [ PersistentTest.testMigrate + , PersistentTest.noPrefixMigrate + , PersistentTest.customPrefixMigrate + , EmbedTest.embedMigrate + , EmbedOrderTest.embedOrderMigrate + , LargeNumberTest.numberMigrate + , UniqueTest.uniqueMigrate + , MaxLenTest.maxlenMigrate + , Recursive.recursiveMigrate + , CompositeTest.compositeMigrate + , PersistUniqueTest.migration + , RenameTest.migration + , CustomPersistFieldTest.customFieldMigrate + , InsertDuplicateUpdate.duplicateMigrate + , MigrationIdempotencyTest.migration + , CustomPrimaryKeyReferenceTest.migration + , MigrationColumnLengthTest.migration + , TransactionLevelTest.migration + -- , LongIdentifierTest.migration + , ForeignKey.compositeMigrate + ] + PersistentTest.cleanDB + ForeignKey.cleanDB - hspec $ do - xdescribe "This is pending on MySQL because you can't have DEFAULT CURRENT_DATE" $ do - RenameTest.specsWith db - DataTypeTest.specsWith - db - (Just (runMigrationSilent dataTypeMigrate)) - [ TestFn "text" dataTypeTableText - , TestFn "textMaxLen" dataTypeTableTextMaxLen - , TestFn "bytes" dataTypeTableBytes - , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple - , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen - , TestFn "int" dataTypeTableInt - , TestFn "intList" dataTypeTableIntList - , TestFn "intMap" dataTypeTableIntMap - , TestFn "bool" dataTypeTableBool - , TestFn "day" dataTypeTableDay - , TestFn "time" (roundTime . dataTypeTableTime) - , TestFn "utc" (roundUTCTime . dataTypeTableUtc) - , TestFn "timeFrac" (dataTypeTableTimeFrac) - , TestFn "utcFrac" (dataTypeTableUtcFrac) - ] - [ ("pico", dataTypeTablePico) ] - dataTypeTableDouble - HtmlTest.specsWith - db - (Just (runMigrationSilent HtmlTest.htmlMigrate)) - EmbedTest.specsWith db - EmbedOrderTest.specsWith db - LargeNumberTest.specsWith db - UniqueTest.specsWith db - MaxLenTest.specsWith db - Recursive.specsWith db - SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) - MigrationOnlyTest.specsWith db - (Just - $ runMigrationSilent MigrationOnlyTest.migrateAll1 - >> runMigrationSilent MigrationOnlyTest.migrateAll2 - ) - PersistentTest.specsWith db - PersistentTest.filterOrSpecs db - ReadWriteTest.specsWith db - RawSqlTest.specsWith db - UpsertTest.specsWith - db - UpsertTest.Don'tUpdateNull - UpsertTest.UpsertPreserveOldKey + hspec $ do + ImplicitUuidSpec.spec + xdescribe "This is pending on MySQL because you can't have DEFAULT CURRENT_DATE" $ do + RenameTest.specsWith db + DataTypeTest.specsWith + db + (Just (runMigrationSilent dataTypeMigrate)) + [ TestFn "text" dataTypeTableText + , TestFn "textMaxLen" dataTypeTableTextMaxLen + , TestFn "bytes" dataTypeTableBytes + , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple + , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen + , TestFn "int" dataTypeTableInt + , TestFn "intList" dataTypeTableIntList + , TestFn "intMap" dataTypeTableIntMap + , TestFn "bool" dataTypeTableBool + , TestFn "day" dataTypeTableDay + , TestFn "time" (roundTime . dataTypeTableTime) + , TestFn "utc" (roundUTCTime . dataTypeTableUtc) + , TestFn "timeFrac" (dataTypeTableTimeFrac) + , TestFn "utcFrac" (dataTypeTableUtcFrac) + ] + [ ("pico", dataTypeTablePico) ] + dataTypeTableDouble + HtmlTest.specsWith + db + (Just (runMigrationSilent HtmlTest.htmlMigrate)) + EmbedTest.specsWith db + EmbedOrderTest.specsWith db + LargeNumberTest.specsWith db + UniqueTest.specsWith db + MaxLenTest.specsWith db + Recursive.specsWith db + SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) + MigrationOnlyTest.specsWith db + (Just + $ runMigrationSilent MigrationOnlyTest.migrateAll1 + >> runMigrationSilent MigrationOnlyTest.migrateAll2 + ) + PersistentTest.specsWith db + PersistentTest.filterOrSpecs db + ReadWriteTest.specsWith db + RawSqlTest.specsWith db + UpsertTest.specsWith + db + UpsertTest.Don'tUpdateNull + UpsertTest.UpsertPreserveOldKey - ForeignKey.specsWith db - MpsNoPrefixTest.specsWith db - MpsCustomPrefixTest.specsWith db - EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) - CompositeTest.specsWith db - PersistUniqueTest.specsWith db - CustomPersistFieldTest.specsWith db - CustomPrimaryKeyReferenceTest.specsWith db - InsertDuplicateUpdate.specs - MigrationColumnLengthTest.specsWith db - EquivalentTypeTest.specsWith db - TransactionLevelTest.specsWith db + ForeignKey.specsWith db + MpsNoPrefixTest.specsWith db + MpsCustomPrefixTest.specsWith db + EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) + CompositeTest.specsWith db + PersistUniqueTest.specsWith db + CustomPersistFieldTest.specsWith db + CustomPrimaryKeyReferenceTest.specsWith db + InsertDuplicateUpdate.specs + MigrationColumnLengthTest.specsWith db + EquivalentTypeTest.specsWith db + TransactionLevelTest.specsWith db - MigrationIdempotencyTest.specsWith db - CustomConstraintTest.specs db - -- TODO: implement automatic truncation for too long foreign keys, so we can run this test. - xdescribe "The migration for this test currently fails because of MySQL's 64 character limit for identifiers. See https://github.com/yesodweb/persistent/issues/1000 for details" $ - LongIdentifierTest.specsWith db - GeneratedColumnTestSQL.specsWith db + MigrationIdempotencyTest.specsWith db + CustomConstraintTest.specs db + -- TODO: implement automatic truncation for too long foreign keys, so we can run this test. + xdescribe "The migration for this test currently fails because of MySQL's 64 character limit for identifiers. See https://github.com/yesodweb/persistent/issues/1000 for details" $ + LongIdentifierTest.specsWith db + GeneratedColumnTestSQL.specsWith db roundFn :: RealFrac a => a -> Integer roundFn = round diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 6313b6802..e783a1234 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -370,7 +370,7 @@ createBackend logFunc serverVersion smap conn = , connCommit = const $ PG.commit conn , connRollback = const $ PG.rollback conn , connEscapeFieldName = escapeF - , connEscapeTableName = escapeE . entityDB + , connEscapeTableName = escapeE . getEntityDBName , connEscapeRawName = escape , connNoLimit = "LIMIT ALL" , connRDBMS = "postgresql" @@ -392,13 +392,13 @@ insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = case entityPrimary ent of Just _pdef -> ISRManyKeys sql vals - Nothing -> ISRSingle (sql <> " RETURNING " <> escapeF (fieldDB (entityId ent))) + Nothing -> ISRSingle (sql <> " RETURNING " <> escapeF (fieldDB (getEntityId ent))) where (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeF) sql = T.concat [ "INSERT INTO " - , escapeE $ entityDB ent - , if null (entityFields ent) + , escapeE $ getEntityDBName ent + , if null (getEntityFields ent) then " DEFAULT VALUES" else T.concat [ "(" @@ -413,7 +413,7 @@ upsertSql' :: EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text upsertSql' ent uniqs updateVal = T.concat [ "INSERT INTO " - , escapeE (entityDB ent) + , escapeE (getEntityDBName ent) , "(" , T.intercalate "," fieldNames , ") VALUES (" @@ -432,7 +432,7 @@ upsertSql' ent uniqs updateVal = wher = T.intercalate " AND " $ map (singleClause . snd) $ NEL.toList uniqs singleClause :: FieldNameDB -> Text - singleClause field = escapeE (entityDB ent) <> "." <> (escapeF field) <> " =?" + singleClause field = escapeE (getEntityDBName ent) <> "." <> (escapeF field) <> " =?" -- | SQL for inserting multiple rows at once and returning their primary keys. insertManySql' :: EntityDef -> [[PersistValue]] -> InsertSqlResult @@ -442,7 +442,7 @@ insertManySql' ent valss = (fieldNames, placeholders)= unzip (Util.mkInsertPlaceholders ent escapeF) sql = T.concat [ "INSERT INTO " - , escapeE (entityDB ent) + , escapeE (getEntityDBName ent) , "(" , T.intercalate "," fieldNames , ") VALUES (" @@ -789,7 +789,7 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do return $ Right $ migrationText exists' old'' (errs, _) -> return $ Left errs where - name = entityDB entity + name = getEntityDBName entity (newcols', udefs, fdefs) = postgresMkColumns allDefs entity migrationText exists' old'' | not exists' = @@ -827,7 +827,7 @@ mkForeignAlt -> Maybe AlterDB mkForeignAlt entity fdef = pure $ AlterColumn tableName_ addReference where - tableName_ = entityDB entity + tableName_ = getEntityDBName entity addReference = AddReference (foreignRefTableDBName fdef) @@ -860,10 +860,10 @@ addTable cols entity = Just _ -> cols _ -> - filter (\c -> cName c /= fieldDB (entityId entity) ) cols + filter (\c -> cName c /= fieldDB (getEntityId entity) ) cols name = - entityDB entity + getEntityDBName entity idtxt = case entityPrimary entity of Just pdef -> @@ -873,10 +873,10 @@ addTable cols entity = , ")" ] Nothing -> - let defText = defaultAttribute $ fieldAttrs $ entityId entity - sType = fieldSqlType $ entityId entity + let defText = defaultAttribute $ fieldAttrs $ getEntityId entity + sType = fieldSqlType $ getEntityId entity in T.concat - [ escapeF $ fieldDB (entityId entity) + [ escapeF $ fieldDB (getEntityId entity) , maySerial sType defText , " PRIMARY KEY UNIQUE" , mayDefault defText @@ -947,7 +947,7 @@ getColumns getter def cols = do stmt <- getter sqlv let vals = - [ PersistText $ unEntityNameDB $ entityDB def + [ PersistText $ unEntityNameDB $ getEntityDBName def ] columns <- with (stmtQuery stmt vals) (\src -> runConduit $ src .| processColumns .| CL.consume) let sqlc = T.concat @@ -994,7 +994,7 @@ getColumns getter def cols = do $ groupBy ((==) `on` fst) rows processColumns = CL.mapM $ \x'@((PersistText cname) : _) -> do - col <- liftIO $ getColumn getter (entityDB def) x' (Map.lookup cname refMap) + col <- liftIO $ getColumn getter (getEntityDBName def) x' (Map.lookup cname refMap) pure $ case col of Left e -> Left e Right c -> Right $ Left c @@ -1248,12 +1248,12 @@ findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName refAdd Nothing = [] refAdd (Just colRef) = - case find ((== crTableName colRef) . entityDB) defs of + case find ((== crTableName colRef) . getEntityDBName) defs of Just refdef - | _oldName /= fieldDB (entityId edef) + | _oldName /= fieldDB (getEntityId edef) -> [AddReference - (entityDB edef) + (getEntityDBName edef) (crConstraintName colRef) [name] (Util.dbIdColumnsEsc escapeF refdef) @@ -1269,7 +1269,7 @@ findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName else refDrop ref' ++ refAdd ref modNull = case (isNull, isNull') of (True, False) -> do - guard $ name /= fieldDB (entityId edef) + guard $ name /= fieldDB (getEntityId edef) pure (IsNull col) (False, True) -> let up = case def of @@ -1328,18 +1328,18 @@ getAddReference -> ColumnReference -> Maybe AlterDB getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crConstraintName=constraintName} = do - guard $ cname /= fieldDB (entityId entity) + guard $ cname /= fieldDB (getEntityId entity) pure $ AlterColumn table (AddReference s constraintName [cname] id_ (crFieldCascade cr) ) where - table = entityDB entity + table = getEntityDBName entity id_ = fromMaybe (error $ "Could not find ID of entity " ++ show s) $ do - entDef <- find ((== s) . entityDB) allDefs + entDef <- find ((== s) . getEntityDBName) allDefs return $ Util.dbIdColumnsEsc escapeF entDef showColumn :: Column -> Text @@ -1672,7 +1672,7 @@ mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do ([], old'') -> return $ Right $ migrationText False old'' (errs, _) -> return $ Left errs where - name = entityDB entity + name = getEntityDBName entity migrationText exists' old'' = if not exists' then createText newcols fdefs udspair @@ -1724,7 +1724,7 @@ mockMigration mig = do , connCommit = undefined , connRollback = undefined , connEscapeFieldName = escapeF - , connEscapeTableName = escapeE . entityDB + , connEscapeTableName = escapeE . getEntityDBName , connEscapeRawName = escape , connNoLimit = undefined , connRDBMS = undefined @@ -1738,14 +1738,14 @@ mockMigration mig = do putManySql :: EntityDef -> Int -> Text putManySql ent n = putManySql' conflictColumns fields ent n where - fields = entityFields ent - conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (entityUniques ent) + fields = getEntityFields ent + conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (getEntityUniques ent) repsertManySql :: EntityDef -> Int -> Text repsertManySql ent n = putManySql' conflictColumns fields ent n where fields = keyAndEntityFields ent - conflictColumns = escapeF . fieldDB <$> entityKeyFields ent + conflictColumns = escapeF . fieldDB <$> getEntityKeyFields ent -- | This type is used to determine how to update rows using Postgres' -- @INSERT ... ON CONFLICT KEY UPDATE@ functionality, exposed via @@ -1858,7 +1858,7 @@ upsertManyWhere [] _ _ _ = return () upsertManyWhere records fieldValues updates filters = do conn <- asks projectBackend let uniqDef = -- onlyOneUniqueDef (Nothing :: Maybe record) - case entityUniques (entityDef (Nothing :: Maybe record)) of + case getEntityUniques (entityDef (Nothing :: Maybe record)) of [uniq] -> uniq _ -> error "impossible due to OnlyOneUniqueKey constraint" -- TODO: use onlyOneUniqueDef when it's exported @@ -1928,8 +1928,8 @@ mkBulkUpsertQuery records conn fieldValues updates filters uniqDef = firstField = case entityFieldNames of [] -> error "The entity you're trying to insert does not have any fields." (field:_) -> field - entityFieldNames = map fieldDbToText (entityFields entityDef') - nameOfTable = escapeE . entityDB $ entityDef' + entityFieldNames = map fieldDbToText (getEntityFields entityDef') + nameOfTable = escapeE . getEntityDBName $ entityDef' copyUnlessValues = map snd fieldsToMaybeCopy recordValues = concatMap (map toPersistValue . toPersistFields) records recordPlaceholders = @@ -1991,7 +1991,7 @@ putManySql' conflictColumns (filter isFieldNotGenerated -> fields) ent n = q fieldDbToText = escapeF . fieldDB mkAssignment f = T.concat [f, "=EXCLUDED.", f] - table = escapeE . entityDB $ ent + table = escapeE . getEntityDBName $ ent columns = Util.commaSeparated $ map fieldDbToText fields placeholders = map (const "?") fields updates = map (mkAssignment . fieldDbToText) fields diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index f73a5888c..96176a24b 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -54,6 +54,7 @@ test-suite test CustomConstraintTest PgIntervalTest UpsertWhere + ImplicitUuidSpec ghc-options: -Wall build-depends: base >= 4.9 && < 5 @@ -76,6 +77,8 @@ test-suite test , text , time , transformers + , path-pieces + , http-api-data , unliftio-core , unliftio , unordered-containers diff --git a/persistent-postgresql/test/ImplicitUuidSpec.hs b/persistent-postgresql/test/ImplicitUuidSpec.hs new file mode 100644 index 000000000..0520d516d --- /dev/null +++ b/persistent-postgresql/test/ImplicitUuidSpec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module ImplicitUuidSpec where + +import PgInit + +import Data.Proxy +import Database.Persist.Postgresql + +import Database.Persist.ImplicitIdDef +import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) + +share + [ mkPersist (sqlSettingsUuid "uuid_generate_v1mc()") + , mkEntityDefList "entities" + ] + [persistLowerCase| + +WithDefUuid + name Text sqltype=varchar(80) + + deriving Eq Show Ord + +|] + +implicitUuidMigrate :: Migration +implicitUuidMigrate = do + runSqlCommand $ rawExecute "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\"" [] + migrateModels entities + +wipe :: IO () +wipe = runConnAssert $ do + rawExecute "DROP TABLE with_def_uuid;" [] + runMigration implicitUuidMigrate + +itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) +itDb msg action = it msg $ runConnAssert $ void action + +pass :: IO () +pass = pure () + +spec :: Spec +spec = fdescribe "ImplicitUuidSpec" $ before_ wipe $ do + describe "WithDefUuidKey" $ do + it "works on UUIDs" $ do + let withDefUuidKey = WithDefUuidKey (UUID "Hello") + pass + describe "getEntityId" $ do + let idField = getEntityId (entityDef (Proxy @WithDefUuid)) + it "has a UUID SqlType" $ asIO $ do + fieldSqlType idField `shouldBe` SqlOther "UUID" + it "has a UUID type" $ asIO $ do + fieldType idField `shouldBe` fieldTypeFromTypeable @UUID + it "is an implicit ID column" $ asIO $ do + fieldIsImplicitIdColumn idField `shouldBe` True + + describe "insert" $ do + itDb "successfully has a default" $ do + let matt = WithDefUuid + { withDefUuidName = + "Matt" + } + k <- insert matt + mrec <- get k + mrec `shouldBe` Just matt diff --git a/persistent-postgresql/test/PgInit.hs b/persistent-postgresql/test/PgInit.hs index 122b65228..0faf89ac0 100644 --- a/persistent-postgresql/test/PgInit.hs +++ b/persistent-postgresql/test/PgInit.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -28,12 +30,16 @@ module PgInit , BS.ByteString , Int32, Int64 , liftIO - , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase + , mkPersist, migrateModels, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase + , mkEntityDefList + , setImplicitIdDef , SomeException , Text , TestFn(..) , LoggingT , ResourceT + , UUID(..) + , sqlSettingsUuid ) where import Init @@ -54,38 +60,55 @@ import Init , (==@) , (@/=) , (@==) + , UUID(..) + , sqlSettingsUuid ) -- re-exports import Control.Exception (SomeException) import Control.Monad (forM_, liftM, replicateM, void, when) import Control.Monad.Trans.Reader -import Data.Aeson (Value(..)) +import Data.Aeson (ToJSON, FromJSON, Value(..)) import Database.Persist.Postgresql.JSON () import Database.Persist.Sql.Raw.QQ import Database.Persist.SqlBackend -import Database.Persist.Postgresql.JSON() import Database.Persist.TH ( MkPersistSettings(..) , mkMigrate + , migrateModels , mkPersist , persistLowerCase , persistUpperCase , share , sqlSettings + , setImplicitIdDef + , mkEntityDefList ) import Test.Hspec - (Spec, afterAll_, before, beforeAll, describe, fdescribe, fit, it, - before_, SpecWith, Arg, hspec) + ( Arg + , Spec + , SpecWith + , afterAll_ + , before + , beforeAll + , before_ + , describe + , fdescribe + , fit + , hspec + , it + ) import Test.Hspec.Expectations.Lifted import Test.QuickCheck.Instances () import UnliftIO -import Database.Persist.SqlBackend +import qualified Data.Text.Encoding as TE -- testing import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import Test.QuickCheck +import Web.PathPieces +import Web.Internal.HttpApiData import Control.Monad (unless, (>=>)) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Logger diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index 60543a349..ecd91a77b 100644 --- a/persistent-postgresql/test/main.hs +++ b/persistent-postgresql/test/main.hs @@ -20,6 +20,7 @@ import qualified Data.Text as T import Data.Time import Test.QuickCheck +import qualified ImplicitUuidSpec import qualified ArrayAggTest import qualified CompositeTest import qualified ForeignKey @@ -130,74 +131,76 @@ main = do , MigrationTest.migrationMigrate , PgIntervalTest.pgIntervalMigrate , UpsertWhere.upsertWhereMigrate + , ImplicitUuidSpec.implicitUuidMigrate ] PersistentTest.cleanDB ForeignKey.cleanDB hspec $ do - RenameTest.specsWith runConnAssert - DataTypeTest.specsWith runConnAssert - (Just (runMigrationSilent dataTypeMigrate)) - [ TestFn "text" dataTypeTableText - , TestFn "textMaxLen" dataTypeTableTextMaxLen - , TestFn "bytes" dataTypeTableBytes - , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple - , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen - , TestFn "int" dataTypeTableInt - , TestFn "intList" dataTypeTableIntList - , TestFn "intMap" dataTypeTableIntMap - , TestFn "bool" dataTypeTableBool - , TestFn "day" dataTypeTableDay - , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime) - , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc) - , TestFn "jsonb" dataTypeTableJsonb - ] - [ ("pico", dataTypeTablePico) ] - dataTypeTableDouble - HtmlTest.specsWith - runConnAssert - (Just (runMigrationSilent HtmlTest.htmlMigrate)) + ImplicitUuidSpec.spec + RenameTest.specsWith runConnAssert + DataTypeTest.specsWith runConnAssert + (Just (runMigrationSilent dataTypeMigrate)) + [ TestFn "text" dataTypeTableText + , TestFn "textMaxLen" dataTypeTableTextMaxLen + , TestFn "bytes" dataTypeTableBytes + , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple + , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen + , TestFn "int" dataTypeTableInt + , TestFn "intList" dataTypeTableIntList + , TestFn "intMap" dataTypeTableIntMap + , TestFn "bool" dataTypeTableBool + , TestFn "day" dataTypeTableDay + , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime) + , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc) + , TestFn "jsonb" dataTypeTableJsonb + ] + [ ("pico", dataTypeTablePico) ] + dataTypeTableDouble + HtmlTest.specsWith + runConnAssert + (Just (runMigrationSilent HtmlTest.htmlMigrate)) - EmbedTest.specsWith runConnAssert - EmbedOrderTest.specsWith runConnAssert - LargeNumberTest.specsWith runConnAssert - ForeignKey.specsWith runConnAssert - UniqueTest.specsWith runConnAssert - MaxLenTest.specsWith runConnAssert - Recursive.specsWith runConnAssert - SumTypeTest.specsWith runConnAssert (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) - MigrationTest.specsWith runConnAssert - MigrationOnlyTest.specsWith runConnAssert + EmbedTest.specsWith runConnAssert + EmbedOrderTest.specsWith runConnAssert + LargeNumberTest.specsWith runConnAssert + ForeignKey.specsWith runConnAssert + UniqueTest.specsWith runConnAssert + MaxLenTest.specsWith runConnAssert + Recursive.specsWith runConnAssert + SumTypeTest.specsWith runConnAssert (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) + MigrationTest.specsWith runConnAssert + MigrationOnlyTest.specsWith runConnAssert - (Just - $ runMigrationSilent MigrationOnlyTest.migrateAll1 - >> runMigrationSilent MigrationOnlyTest.migrateAll2 - ) - PersistentTest.specsWith runConnAssert - ReadWriteTest.specsWith runConnAssert - PersistentTest.filterOrSpecs runConnAssert - RawSqlTest.specsWith runConnAssert - UpsertTest.specsWith - runConnAssert - UpsertTest.Don'tUpdateNull - UpsertTest.UpsertPreserveOldKey + (Just + $ runMigrationSilent MigrationOnlyTest.migrateAll1 + >> runMigrationSilent MigrationOnlyTest.migrateAll2 + ) + PersistentTest.specsWith runConnAssert + ReadWriteTest.specsWith runConnAssert + PersistentTest.filterOrSpecs runConnAssert + RawSqlTest.specsWith runConnAssert + UpsertTest.specsWith + runConnAssert + UpsertTest.Don'tUpdateNull + UpsertTest.UpsertPreserveOldKey - MpsNoPrefixTest.specsWith runConnAssert - MpsCustomPrefixTest.specsWith runConnAssert - EmptyEntityTest.specsWith runConnAssert (Just (runMigrationSilent EmptyEntityTest.migration)) - CompositeTest.specsWith runConnAssert - TreeTest.specsWith runConnAssert - PersistUniqueTest.specsWith runConnAssert - PrimaryTest.specsWith runConnAssert - CustomPersistFieldTest.specsWith runConnAssert - CustomPrimaryKeyReferenceTest.specsWith runConnAssert - MigrationColumnLengthTest.specsWith runConnAssert - EquivalentTypeTestPostgres.specs - TransactionLevelTest.specsWith runConnAssert - LongIdentifierTest.specsWith runConnAssertUseConf -- Have at least one test use the conf variant of connecting to Postgres, to improve test coverage. - JSONTest.specs - CustomConstraintTest.specs - UpsertWhere.specs - PgIntervalTest.specs - ArrayAggTest.specs - GeneratedColumnTestSQL.specsWith runConnAssert + MpsNoPrefixTest.specsWith runConnAssert + MpsCustomPrefixTest.specsWith runConnAssert + EmptyEntityTest.specsWith runConnAssert (Just (runMigrationSilent EmptyEntityTest.migration)) + CompositeTest.specsWith runConnAssert + TreeTest.specsWith runConnAssert + PersistUniqueTest.specsWith runConnAssert + PrimaryTest.specsWith runConnAssert + CustomPersistFieldTest.specsWith runConnAssert + CustomPrimaryKeyReferenceTest.specsWith runConnAssert + MigrationColumnLengthTest.specsWith runConnAssert + EquivalentTypeTestPostgres.specs + TransactionLevelTest.specsWith runConnAssert + LongIdentifierTest.specsWith runConnAssertUseConf -- Have at least one test use the conf variant of connecting to Postgres, to improve test coverage. + JSONTest.specs + CustomConstraintTest.specs + UpsertWhere.specs + PgIntervalTest.specs + ArrayAggTest.specs + GeneratedColumnTestSQL.specsWith runConnAssert diff --git a/persistent-qq/test/PersistentTestModels.hs b/persistent-qq/test/PersistentTestModels.hs index 30216c6a2..db6af42c9 100644 --- a/persistent-qq/test/PersistentTestModels.hs +++ b/persistent-qq/test/PersistentTestModels.hs @@ -144,7 +144,7 @@ instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where entityDef = revFields . entityDef . unRfoProxy where - revFields ed = ed { entityFields = reverse (entityFields ed) } + revFields = overEntityFields reverse unRfoProxy :: proxy (ReverseFieldOrder a) -> Proxy a unRfoProxy _ = Proxy diff --git a/persistent-redis/Database/Persist/Redis/Internal.hs b/persistent-redis/Database/Persist/Redis/Internal.hs index ce0c83c1e..8f4ab66d4 100644 --- a/persistent-redis/Database/Persist/Redis/Internal.hs +++ b/persistent-redis/Database/Persist/Redis/Internal.hs @@ -14,6 +14,7 @@ import Data.Text (Text, unpack) import qualified Data.Text as T import Control.Monad.Fail (MonadFail) +import Database.Persist.EntityDef.Internal import Database.Persist.Class import Database.Persist.Types import Database.Persist.Redis.Parser diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 5b636f541..0e4d58867 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -282,7 +282,7 @@ wrapConnectionInfo connInfo conn logFunc = do , connCommit = helper "COMMIT" , connRollback = ignoreExceptions . helper "ROLLBACK" , connEscapeFieldName = escape . unFieldNameDB - , connEscapeTableName = escape . unEntityNameDB . entityDB + , connEscapeTableName = escape . unEntityNameDB . getEntityDBName , connEscapeRawName = escape , connNoLimit = "LIMIT -1" , connRDBMS = "sqlite" @@ -341,7 +341,7 @@ insertSql' ent vals = ISRManyKeys sql vals where sql = T.concat [ "INSERT INTO " - , escapeE $ entityDB ent + , escapeE $ getEntityDBName ent , "(" , T.intercalate "," $ map (escapeF . fieldDB) cols , ") VALUES(" @@ -353,14 +353,14 @@ insertSql' ent vals = where sel = T.concat [ "SELECT " - , escapeF $ fieldDB (entityId ent) + , escapeF $ fieldDB (getEntityId ent) , " FROM " - , escapeE $ entityDB ent + , escapeE $ getEntityDBName ent , " WHERE _ROWID_=last_insert_rowid()" ] ins = T.concat [ "INSERT INTO " - , escapeE $ entityDB ent + , escapeE $ getEntityDBName ent , if null cols then " VALUES(null)" else T.concat @@ -375,7 +375,7 @@ insertSql' ent vals = notGenerated = isNothing . fieldGenerated cols = - filter notGenerated $ entityFields ent + filter notGenerated $ getEntityFields ent execute' :: Sqlite.Connection -> Sqlite.Statement -> [PersistValue] -> IO Int64 execute' conn stmt vals = flip finally (liftIO $ Sqlite.reset conn stmt) $ do @@ -441,7 +441,7 @@ migrate' allDefs getter val = do return $ Right sql where def = val - table = entityDB def + table = getEntityDBName def go = do x <- CL.head case x of @@ -473,7 +473,7 @@ mockMigration mig = do , connCommit = helper "COMMIT" , connRollback = ignoreExceptions . helper "ROLLBACK" , connEscapeFieldName = escape . unFieldNameDB - , connEscapeTableName = escape . unEntityNameDB . entityDB + , connEscapeTableName = escape . unEntityNameDB . getEntityDBName , connEscapeRawName = escape , connNoLimit = "LIMIT -1" , connRDBMS = "sqlite" @@ -497,7 +497,7 @@ safeToRemove :: EntityDef -> FieldNameDB -> Bool safeToRemove def (FieldNameDB colName) = any (elem FieldAttrSafeToRemove . fieldAttrs) $ filter ((== FieldNameDB colName) . fieldDB) - $ entityFields def + $ getEntityFields def getCopyTable :: [EntityDef] -> (Text -> IO Statement) @@ -525,12 +525,12 @@ getCopyTable allDefs getter def = do names <- getCols return $ name : names Just y -> error $ "Invalid result from PRAGMA table_info: " ++ show y - table = entityDB def + table = getEntityDBName def tableTmp = EntityNameDB $ unEntityNameDB table <> "_backup" (cols, uniqs, fdef) = sqliteMkColumns allDefs def cols' = filter (not . safeToRemove def . cName) cols newSql = mkCreateTable False def (cols', uniqs, fdef) - tmpSql = mkCreateTable True def { entityDB = tableTmp } (cols', uniqs, []) + tmpSql = mkCreateTable True (setEntityDBName tableTmp def) (cols', uniqs, []) dropTmp = "DROP TABLE " <> escapeE tableTmp dropOld = "DROP TABLE " <> escapeE table copyToTemp common = T.concat @@ -560,7 +560,7 @@ mkCreateTable isTemp entity (cols, uniqs, fdefs) = [ "CREATE" , if isTemp then " TEMP" else "" , " TABLE " - , escapeE $ entityDB entity + , escapeE $ getEntityDBName entity , "(" ] @@ -580,15 +580,15 @@ mkCreateTable isTemp entity (cols, uniqs, fdefs) = ] Nothing -> - [ escapeF $ fieldDB (entityId entity) + [ escapeF $ fieldDB (getEntityId entity) , " " - , showSqlType $ fieldSqlType $ entityId entity + , showSqlType $ fieldSqlType $ getEntityId entity , " PRIMARY KEY" - , mayDefault $ defaultAttribute $ fieldAttrs $ entityId entity + , mayDefault $ defaultAttribute $ fieldAttrs $ getEntityId entity , T.concat $ map (sqlColumn isTemp) nonIdCols ] - nonIdCols = filter (\c -> cName c /= fieldDB (entityId entity)) cols + nonIdCols = filter (\c -> cName c /= fieldDB (getEntityId entity)) cols mayDefault :: Maybe Text -> Text mayDefault def = case def of @@ -674,14 +674,14 @@ escape s = putManySql :: EntityDef -> Int -> Text putManySql ent n = putManySql' conflictColumns fields ent n where - fields = entityFields ent - conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (entityUniques ent) + fields = getEntityFields ent + conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (getEntityUniques ent) repsertManySql :: EntityDef -> Int -> Text repsertManySql ent n = putManySql' conflictColumns fields ent n where fields = keyAndEntityFields ent - conflictColumns = escapeF . fieldDB <$> entityKeyFields ent + conflictColumns = escapeF . fieldDB <$> getEntityKeyFields ent putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text putManySql' conflictColumns fields ent n = q @@ -689,7 +689,7 @@ putManySql' conflictColumns fields ent n = q fieldDbToText = escapeF . fieldDB mkAssignment f = T.concat [f, "=EXCLUDED.", f] - table = escapeE . entityDB $ ent + table = escapeE . getEntityDBName $ ent columns = Util.commaSeparated $ map fieldDbToText fields placeholders = map (const "?") fields updates = map (mkAssignment . fieldDbToText) fields diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal index a03d8ea55..afcf75d7a 100644 --- a/persistent-test/persistent-test.cabal +++ b/persistent-test/persistent-test.cabal @@ -60,7 +60,6 @@ library build-depends: base >= 4.9 && < 5 - , persistent >= 2.13 && < 2.14 , aeson >= 1.0 , blaze-html >= 0.9 , bytestring >= 0.10 @@ -69,11 +68,13 @@ library , exceptions >= 0.8 , hspec >= 2.4 , hspec-expectations + , http-api-data , HUnit , monad-control , monad-logger >= 0.3.25 , mtl , path-pieces >= 0.2 + , persistent >= 2.13 && < 2.14 , QuickCheck >= 2.9 , quickcheck-instances >= 0.3 , random >= 1.1 diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs index 863661478..fa1250604 100644 --- a/persistent-test/src/ForeignKey.hs +++ b/persistent-test/src/ForeignKey.hs @@ -8,6 +8,8 @@ import Data.Proxy import qualified Data.List as List import Init +import Database.Persist.EntityDef.Internal (entityExtra) + -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate"] [persistLowerCase| SimpleCascadeChild @@ -204,7 +206,7 @@ specsWith runDb = describe "foreign keys options" $ do , fcOnDelete = Just Cascade } Just refField = - List.find isRefCol (entityFields ed) + List.find isRefCol (getEntityFields ed) it "parses into fieldCascade" $ do fieldCascade refField `shouldBe` expected diff --git a/persistent-test/src/Init.hs b/persistent-test/src/Init.hs index 471be0a49..62bb4fc84 100644 --- a/persistent-test/src/Init.hs +++ b/persistent-test/src/Init.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -42,14 +44,16 @@ module Init ( , liftA2 , changeBackend , Proxy(..) + , UUID(..) + , sqlSettingsUuid ) where #if !MIN_VERSION_monad_logger(0,3,30) -- Needed for GHC versions 7.10.3. Can drop when we drop support for GHC -- 7.10.3 +import qualified Control.Monad.Fail as MonadFail import Control.Monad.IO.Class import Control.Monad.Logger -import qualified Control.Monad.Fail as MonadFail #endif -- needed for backwards compatibility @@ -64,21 +68,35 @@ import Control.Monad.Trans.Resource.Internal -- re-exports import Control.Applicative (liftA2, (<|>)) import Control.Exception (SomeException) -import Control.Monad (void, replicateM, liftM, when, forM_) +import Control.Monad (forM_, liftM, replicateM, void, when) import Control.Monad.Fail (MonadFail) import Control.Monad.Reader -import Data.Char (generalCategory, GeneralCategory(..)) -import Data.Fixed (Pico,Micro) +import Data.Char (GeneralCategory(..), generalCategory) +import Data.Fixed (Micro, Pico) +import Data.Proxy import qualified Data.Text as T import Data.Time import Test.Hspec import Test.QuickCheck.Instances () -import Data.Proxy -import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) +import Data.Aeson (FromJSON, ToJSON, Value(..)) +import qualified Data.Text.Encoding as TE +import Database.Persist.ImplicitIdDef (mkImplicitIdDef) +import Database.Persist.TH + ( MkPersistSettings(..) + , mkMigrate + , mkPersist + , persistLowerCase + , persistUpperCase + , setImplicitIdDef + , share + , sqlSettings + ) +import Web.Internal.HttpApiData +import Web.PathPieces -- testing -import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) +import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import Test.QuickCheck import Control.Monad (unless, (>=>)) @@ -247,3 +265,34 @@ instance MonadBaseControl b m => MonadBaseControl b (ResourceT m) where f $ runInBase . (\(ResourceT r) -> r reader') restoreM = ResourceT . const . restoreM #endif + +-- * For implicit ID spec + +newtype UUID = UUID { unUUID :: Text } + deriving stock + (Show, Eq, Ord, Read) + deriving newtype + (ToJSON, FromJSON, FromHttpApiData, ToHttpApiData, PathPiece) + +instance PersistFieldSql UUID where + sqlType _ = SqlOther "UUID" + +instance PersistField UUID where + toPersistValue (UUID txt) = + PersistLiteral_ Escaped (TE.encodeUtf8 txt) + fromPersistValue pv = + case pv of + PersistLiteral_ Escaped bs -> + Right $ UUID (TE.decodeUtf8 bs) + _ -> + Left "Nope" + +sqlSettingsUuid :: Text -> MkPersistSettings +sqlSettingsUuid defExpr = + let + uuidDef = + mkImplicitIdDef @UUID defExpr + settings = + setImplicitIdDef uuidDef sqlSettings + in + settings diff --git a/persistent-test/src/PersistentTest.hs b/persistent-test/src/PersistentTest.hs index 09833ea8c..93553b7fc 100644 --- a/persistent-test/src/PersistentTest.hs +++ b/persistent-test/src/PersistentTest.hs @@ -632,11 +632,11 @@ specsWith runDb = describe "persistent" $ do describe "documentation syntax" $ do let edef = entityDef (Proxy :: Proxy Relationship) it "provides comments on entity def" $ do - entityComments edef + getEntityComments edef `shouldBe` Just "This is a doc comment for a relationship.\nYou need to put the pipe character for each line of documentation.\nBut you can resume the doc comments afterwards.\n" it "provides comments on the field" $ do - let [nameField, _] = entityFields edef + let [nameField, _] = getEntityFields edef fieldComments nameField `shouldBe` Just "Fields should be documentable.\n" diff --git a/persistent-test/src/PersistentTestModels.hs b/persistent-test/src/PersistentTestModels.hs index ee9c340fa..80d698f3a 100644 --- a/persistent-test/src/PersistentTestModels.hs +++ b/persistent-test/src/PersistentTestModels.hs @@ -225,7 +225,7 @@ instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where where unRfoProxy :: proxy (ReverseFieldOrder a) -> Proxy a unRfoProxy _ = Proxy - revFields ed = ed { entityFields = reverse (entityFields ed) } + revFields = overEntityFields reverse toPersistFields = reverse . toPersistFields . unRFO newtype EntityField (ReverseFieldOrder a) b = EFRFO {unEFRFO :: EntityField a b} diff --git a/persistent-test/src/RenameTest.hs b/persistent-test/src/RenameTest.hs index 5491b8aa3..9e2a35443 100644 --- a/persistent-test/src/RenameTest.hs +++ b/persistent-test/src/RenameTest.hs @@ -75,7 +75,7 @@ specsWith specsWith runDb = describe "rename specs" $ do describe "LowerCaseTable" $ do it "LowerCaseTable has the right sql name" $ do - fieldDB (entityId (entityDef (Proxy @LowerCaseTable))) + fieldDB (getEntityId (entityDef (Proxy @LowerCaseTable))) `shouldBe` FieldNameDB "my_id" @@ -92,7 +92,7 @@ specsWith runDb = describe "rename specs" $ do key' @== key it "extra blocks" $ - entityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?= + getEntityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?= Map.fromList [ ("ExtraBlock", map T.words ["foo bar", "baz", "bin"]) , ("ExtraBlock2", map T.words ["something"]) diff --git a/persistent-test/src/TreeTest.hs b/persistent-test/src/TreeTest.hs index 226468ccd..e97119c67 100644 --- a/persistent-test/src/TreeTest.hs +++ b/persistent-test/src/TreeTest.hs @@ -41,14 +41,14 @@ specsWith runDb = describe "tree" $ do gp <- getJust kgp treeFkparent gp @== Nothing describe "entityDef" $ do - let EntityDef{..} = entityDef (Proxy :: Proxy Tree) + let ed = entityDef (Proxy :: Proxy Tree) it "has the right haskell name" $ do - entityHaskell `shouldBe` EntityNameHS "Tree" + getEntityHaskellName ed `shouldBe` EntityNameHS "Tree" it "has the right DB name" $ do - entityDB `shouldBe` EntityNameDB "trees" + getEntityDBName ed `shouldBe` EntityNameDB "trees" describe "foreign ref" $ do - let [ForeignDef{..}] = entityForeigns (entityDef (Proxy :: Proxy Tree)) + let [ForeignDef{..}] = getEntityForeignDefs (entityDef (Proxy :: Proxy Tree)) it "has the right haskell name" $ do foreignRefTableHaskell `shouldBe` EntityNameHS "Tree" diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 6082996bd..97f8dc9d7 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -31,6 +31,24 @@ * Previously hidden modules are now exposed under the `Internal` namespace. * The `connLimitOffset` function used to have a `Bool` parameter. This parameter is unused and has been removed. +* [#1234](https://github.com/yesodweb/persistent/pull/1234) + * You can now customize the default implied ID column. See the documentation + in `Database.Persist.ImplicitIdDef` for more details. + * Moved the various `Name` types into `Database.Persist.Names` + * Removed the `hasCompositeKey` function. See `hasCompositePrimaryKey` and + `hasNaturalKey` as replacements. + * The `EntityDef` constructor and field labels are not exported by default. + Get those from `Database.Persist.EntityDef.Internal`, but you should + migrate to the getters/setters in `Database.Persist.EntityDef` as you can. + * Added the `Database.Persist.FieldDef` and + `Database.Persist.FieldDef.Internal` modules. + * The `PersistSettings` type was made abstract. Please migrate to the + getters/setters defined in that `Database.Persist.Quasi`, or use + `Database.Persist.Quasi.Internal` if you don't mind the possibility of + breaking changes. + * Add the `runSqlCommand` function for running arbitrary SQL during + migrations. + * Add `migrateModels` function for a TH-free migration facility. ## 2.12.1.1 diff --git a/persistent/Database/Persist.hs b/persistent/Database/Persist.hs index e9846d4cc..7d1495961 100644 --- a/persistent/Database/Persist.hs +++ b/persistent/Database/Persist.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} + module Database.Persist ( module Database.Persist.Class , module Database.Persist.Types diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs index edde12c87..b50095444 100644 --- a/persistent/Database/Persist/Class/PersistEntity.hs +++ b/persistent/Database/Persist/Class/PersistEntity.hs @@ -51,6 +51,7 @@ import GHC.TypeLits import Database.Persist.Class.PersistField import Database.Persist.Types.Base +import Database.Persist.Names -- | Persistent serialized Haskell records to the database. -- A Database 'Entity' (A row in SQL, a document in MongoDB, etc) diff --git a/persistent/Database/Persist/Class/PersistUnique.hs b/persistent/Database/Persist/Class/PersistUnique.hs index fb87c1657..f2597f12b 100644 --- a/persistent/Database/Persist/Class/PersistUnique.hs +++ b/persistent/Database/Persist/Class/PersistUnique.hs @@ -39,6 +39,7 @@ import GHC.TypeLits (ErrorMessage(..)) import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistStore import Database.Persist.Types +import Database.Persist.EntityDef -- | Queries against 'Unique' keys (other than the id 'Key'). -- @@ -302,7 +303,7 @@ onlyOneUniqueDef => proxy record -> UniqueDef onlyOneUniqueDef prxy = - case entityUniques (entityDef prxy) of + case getEntityUniques (entityDef prxy) of [uniq] -> uniq _ -> error "impossible due to OnlyOneUniqueKey constraint" @@ -351,7 +352,7 @@ atLeastOneUniqueDef => proxy record -> NonEmpty UniqueDef atLeastOneUniqueDef prxy = - case entityUniques (entityDef prxy) of + case getEntityUniques (entityDef prxy) of (x:xs) -> x :| xs _ -> error "impossible due to AtLeastOneUniqueKey record constraint" diff --git a/persistent/Database/Persist/EntityDef.hs b/persistent/Database/Persist/EntityDef.hs new file mode 100644 index 000000000..1d80d9592 --- /dev/null +++ b/persistent/Database/Persist/EntityDef.hs @@ -0,0 +1,136 @@ +-- | An 'EntityDef' represents metadata about a type that @persistent@ uses to +-- store the type in the database, as well as generate Haskell code from it. +-- +-- @since 2.13.0.0 +module Database.Persist.EntityDef + ( -- * The 'EntityDef' type + EntityDef + -- * Construction + -- * Accessors + , getEntityHaskellName + , getEntityDBName + , getEntityFields + , getEntityForeignDefs + , getEntityUniques + , getEntityId + , getEntityKeyFields + , getEntityComments + , getEntityExtra + , isEntitySum + , entityPrimary + , entitiesPrimary + , keyAndEntityFields + -- * Setters + , setEntityId + , setEntityDBName + , overEntityFields + ) where + +import Data.Text (Text) +import Data.Map (Map) + +import Database.Persist.EntityDef.Internal + +import Database.Persist.Types.Base + ( UniqueDef + , ForeignDef + , FieldDef + , entityKeyFields + ) +import Database.Persist.Names + +-- | 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'. +-- +-- @since 2.13.0.0 +getEntityUniques + :: EntityDef + -> [UniqueDef] +getEntityUniques = entityUniques + +-- | Retrieve the Haskell name of the given entity. +-- +-- @since 2.13.0.0 +getEntityHaskellName + :: EntityDef + -> EntityNameHS +getEntityHaskellName = entityHaskell + +-- | Return the database name for the given entity. +-- +-- @since 2.13.0.0 +getEntityDBName + :: EntityDef + -> EntityNameDB +getEntityDBName = entityDB + +getEntityExtra :: EntityDef -> Map Text [[Text]] +getEntityExtra = entityExtra + +-- | +-- +-- @since 2.13.0.0 +setEntityDBName :: EntityNameDB -> EntityDef -> EntityDef +setEntityDBName db ed = ed { entityDB = db } + +getEntityComments :: EntityDef -> Maybe Text +getEntityComments = entityComments + +-- | +-- +-- @since 2.13.0.0 +getEntityForeignDefs + :: EntityDef + -> [ForeignDef] +getEntityForeignDefs = entityForeigns + +-- | Retrieve the list of 'FieldDef' that makes up the fields of the entity. +-- +-- This does not return the fields for an @Id@ column or an implicit @id@. It +-- will return the key columns if you used the @Primary@ syntax for defining the +-- primary key. +-- +-- @since 2.13.0.0 +getEntityFields + :: EntityDef + -> [FieldDef] +getEntityFields = entityFields + +-- | +-- +-- @since 2.13.0.0 +isEntitySum + :: EntityDef + -> Bool +isEntitySum = entitySum + +-- | +-- +-- @since 2.13.0.0 +getEntityId + :: EntityDef + -> FieldDef +getEntityId = entityId + +setEntityId + :: FieldDef + -> EntityDef + -> EntityDef +setEntityId fd ed = ed { entityId = fd } + +getEntityKeyFields + :: EntityDef + -> [FieldDef] +getEntityKeyFields = entityKeyFields + +setEntityFields :: [FieldDef] -> EntityDef -> EntityDef +setEntityFields fd ed = ed { entityFields = fd } + +overEntityFields + :: ([FieldDef] -> [FieldDef]) + -> EntityDef + -> EntityDef +overEntityFields f ed = + setEntityFields (f (getEntityFields ed)) ed diff --git a/persistent/Database/Persist/EntityDef/Internal.hs b/persistent/Database/Persist/EntityDef/Internal.hs new file mode 100644 index 000000000..38af021bc --- /dev/null +++ b/persistent/Database/Persist/EntityDef/Internal.hs @@ -0,0 +1,17 @@ +-- | The 'EntityDef' type, fields, and constructor are exported from this +-- module. Breaking changes to the 'EntityDef' type are not reflected in +-- the major version of the API. Please import from +-- "Database.Persist.EntityDef" instead. +-- +-- If you need this module, please file a GitHub issue why. +-- +-- @since 2.13.0.0 +module Database.Persist.EntityDef.Internal + ( EntityDef(..) + , entityPrimary + , entitiesPrimary + , keyAndEntityFields + , toEmbedEntityDef + ) where + +import Database.Persist.Types.Base diff --git a/persistent/Database/Persist/FieldDef.hs b/persistent/Database/Persist/FieldDef.hs new file mode 100644 index 000000000..d06d4ef0d --- /dev/null +++ b/persistent/Database/Persist/FieldDef.hs @@ -0,0 +1,17 @@ +-- | +-- +-- @since 2.13.0.0 +module Database.Persist.FieldDef + ( -- * The 'FieldDef' type + FieldDef + -- ** Helpers + , isFieldNotGenerated + -- * 'FieldCascade' + , FieldCascade(..) + , renderFieldCascade + , renderCascadeAction + , noCascade + , CascadeAction(..) + ) where + +import Database.Persist.FieldDef.Internal diff --git a/persistent/Database/Persist/FieldDef/Internal.hs b/persistent/Database/Persist/FieldDef/Internal.hs new file mode 100644 index 000000000..433806d37 --- /dev/null +++ b/persistent/Database/Persist/FieldDef/Internal.hs @@ -0,0 +1,14 @@ +-- | TODO: standard Internal moduel boilerplate +-- +-- @since 2.13.0.0 +module Database.Persist.FieldDef.Internal + ( FieldDef(..) + , isFieldNotGenerated + , FieldCascade(..) + , renderFieldCascade + , renderCascadeAction + , noCascade + , CascadeAction(..) + ) where + +import Database.Persist.Types.Base diff --git a/persistent/Database/Persist/ImplicitIdDef.hs b/persistent/Database/Persist/ImplicitIdDef.hs new file mode 100644 index 000000000..e82f5c871 --- /dev/null +++ b/persistent/Database/Persist/ImplicitIdDef.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | This module contains types and functions for creating an 'ImplicitIdDef', +-- which allows you to customize the implied ID column that @persistent@ +-- generates. +-- +-- If this module doesn't suit your needs, you may want to import +-- "Database.Persist.ImplicitIdDef.Internal" instead. If you do so, please file +-- an issue on GitHub so we can support your needs. Breaking changes to that +-- module will *not* be accompanied with a major version bump. +-- +-- @since 2.13.0.0 +module Database.Persist.ImplicitIdDef + ( -- * The Type + ImplicitIdDef + -- * Construction + , mkImplicitIdDef + -- * Autoincrementing Integer Key + , autoIncrementingInteger + -- * Getters + -- * Setters + , setImplicitIdDefMaxLen + , unsafeClearDefaultImplicitId + ) where + +import Language.Haskell.TH + +import Database.Persist.ImplicitIdDef.Internal +import Database.Persist.Types.Base + ( FieldType(..) + , SqlType(..) + ) +import Database.Persist.Class (BackendKey) +import Database.Persist.Names + +-- | This is the default variant. Setting the implicit ID definition to this +-- value should not have any change at all on how entities are defined by +-- default. +-- +-- @since 2.13.0.0 +autoIncrementingInteger :: ImplicitIdDef +autoIncrementingInteger = + ImplicitIdDef + { iidFieldType = \entName -> + FTTypeCon Nothing $ unEntityNameHS entName `mappend` "Id" + , iidFieldSqlType = + SqlInt64 + , iidType = \isMpsGeneric mpsBackendType -> + ConT ''BackendKey `AppT` + if isMpsGeneric + then VarT (mkName "backend") + else mpsBackendType + , iidDefault = + Nothing + , iidMaxLen = + Nothing + } diff --git a/persistent/Database/Persist/ImplicitIdDef/Internal.hs b/persistent/Database/Persist/ImplicitIdDef/Internal.hs new file mode 100644 index 000000000..1aa002e40 --- /dev/null +++ b/persistent/Database/Persist/ImplicitIdDef/Internal.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + +-- | WARNING: This is an @Internal@ module. As such, breaking changes to the API +-- of this module will not have a corresponding major version bump. +-- +-- Please depend on "Database.Persist.ImplicitIdDef" instead. If you can't use +-- that module, please file an issue on GitHub with your desired use case. +-- +-- @since 2.13.0.0 +module Database.Persist.ImplicitIdDef.Internal where + +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as Text +import Language.Haskell.TH (Type) +import LiftType +import Type.Reflection +import Data.Typeable (eqT) +import Data.Foldable (asum) + +import Database.Persist.Class.PersistField (PersistField) +import Database.Persist.Names +import Database.Persist.Sql.Class +import Database.Persist.Types + +-- | A specification for how the implied ID columns are created. +-- +-- By default, @persistent@ will give each table a default column named @id@ +-- (customizable by 'PersistSettings'), and the column type will be whatever +-- you'd expect from @'BackendKey' yourBackendType@. For The 'SqlBackend' type, +-- this is an auto incrementing integer primary key. +-- +-- You might want to give a different example. A common use case in postgresql +-- is to use the UUID type, and automatically generate them using a SQL +-- function. +-- +-- Previously, you'd need to add a custom @Id@ annotation for each model. +-- +-- > User +-- > Id UUID default="uuid_generate_v1mc()" +-- > name Text +-- > +-- > Dog +-- > Id UUID default="uuid_generate_v1mc()" +-- > name Text +-- > user UserId +-- +-- Now, you can simply create an 'ImplicitIdDef' that corresponds to this +-- declaration. +-- +-- @ +-- newtype UUID = UUID 'ByteString' +-- +-- instance 'PersistField' UUID where +-- 'toPersistValue' (UUID bs) = +-- 'PersistLiteral_' 'Escaped' bs +-- 'fromPersistValue' pv = +-- case pv of +-- PersistLiteral_ Escaped bs -> +-- Right (UUID bs) +-- _ -> +-- Left "nope" +-- +-- instance 'PersistFieldSql' UUID where +-- 'sqlType' _ = 'SqlOther' "UUID" +-- @ +-- +-- With this instance at the ready, we can now create our implicit definition: +-- +-- @ +-- uuidDef :: ImplicitIdDef +-- uuidDef = mkImplicitIdDef \@UUID "uuid_generate_v1mc()" +-- @ +-- +-- And we can use 'setImplicitIdDef' to use this with the 'MkPersistSettings' +-- for our block. +-- +-- @ +-- mkPersist (setImplicitIdDef uuidDef sqlSettings) [persistLowerCase| ... |] +-- @ +-- +-- TODO: either explain interaction with mkMigrate or fix it. see issue #1249 +-- for more details. +-- +-- @since 2.13.0.0 +data ImplicitIdDef = ImplicitIdDef + { iidFieldType :: EntityNameHS -> FieldType + -- ^ The field type. Accepts the 'EntityNameHS' if you want to refer to it. + -- By default, @Id@ is appended to the end of the Haskell name. + -- + -- @since 2.13.0.0 + , iidFieldSqlType :: SqlType + -- ^ The 'SqlType' for the default column. By default, this is 'SqlInt64' to + -- correspond with an autoincrementing integer primary key. + -- + -- @since 2.13.0.0 + , iidType :: Bool -> Type -> Type + -- ^ The Bool argument is whether or not the 'MkPersistBackend' type has the + -- 'mpsGeneric' field set. + -- + -- The 'Type' is the 'mpsBackend' value. + -- + -- The default uses @'BackendKey' 'SqlBackend'@ (or a generic equivalent). + -- + -- @since 2.13.0.0 + , iidDefault :: Maybe Text + -- ^ The default expression for the field. Note that setting this to + -- 'Nothing' is unsafe. see + -- https://github.com/yesodweb/persistent/issues/1247 for more information. + -- + -- With some cases - like the Postgresql @SERIAL@ type - this is safe, since + -- there's an implied default. + -- + -- @since 2.13.0.0 + , iidMaxLen :: Maybe Integer + -- ^ Specify the maximum length for a key column. This is necessary for + -- @VARCHAR@ columns, like @UUID@ in MySQL. MySQL will throw a runtime error + -- if a text or binary column is used in an index without a length + -- specification. + -- + -- @since 2.13.0.0 + } + +-- | Create an 'ImplicitIdDef' based on the 'Typeable' and 'PersistFieldSql' +-- constraints in scope. +-- +-- This function uses the @TypeApplications@ syntax. Let's look at an example +-- that works with Postgres UUIDs. +-- +-- > newtype UUID = UUID Text +-- > deriving newtype PersistField +-- > +-- > instance PersistFieldSql UUID where +-- > sqlType _ = SqlOther "UUID" +-- > +-- > idDef :: ImplicitIdDef +-- > idDef = mkImplicitIdDefTypeable @UUID "uuid_generate_v1mc()" +-- +-- This 'ImplicitIdDef' will generate default UUID columns, and the database +-- will call the @uuid_generate_v1mc()@ function to generate the value for new +-- rows being inserted. +-- +-- If the type @t@ is 'Text' or 'String' then a @max_len@ attribute of 200 is +-- set. To customize this, use 'setImplicitIdDefMaxLen'. +-- +-- @since 2.13.0.0 +mkImplicitIdDef + :: forall t. (Typeable t, PersistFieldSql t) + => Text + -- ^ The default expression to use for columns. Should be valid SQL in the + -- language you're using. + -> ImplicitIdDef +mkImplicitIdDef def = + ImplicitIdDef + { iidFieldType = \_ -> + fieldTypeFromTypeable @t + , iidFieldSqlType = + sqlType (Proxy @t) + , iidType = + \_ _ -> liftType @t + , iidDefault = + Just def + , iidMaxLen = + -- this follows a special casing behavior that @persistent@ has done + -- for a while now. this keeps folks code from breaking and probably + -- is mostly what people want. + asum + [ 200 <$ eqT @t @Text + , 200 <$ eqT @t @String + ] + } + +-- | Set the maximum length of the implied ID column. This is required for +-- any type where the associated 'SqlType' is a @TEXT@ or @VARCHAR@ sort of +-- thing. +-- +-- @since 2.13.0.0 +setImplicitIdDefMaxLen + :: Integer + -> ImplicitIdDef + -> ImplicitIdDef +setImplicitIdDefMaxLen i iid = iid { iidMaxLen = Just i } + +-- | This function converts a 'Typeable' type into a @persistent@ +-- representation of the type of a field - 'FieldTyp'. +-- +-- @since 2.13.0.0 +fieldTypeFromTypeable :: forall t. (PersistField t, Typeable t) => FieldType +fieldTypeFromTypeable = go (typeRep @t) + where + go :: forall k (a :: k). TypeRep a -> FieldType + go tr = + case tr of + Con tyCon -> + FTTypeCon Nothing $ Text.pack $ tyConName tyCon + App trA trB -> + FTApp (go trA) (go trB) + Fun _ _ -> + error "No functions in field defs." + +-- | Remove the default attribute of the 'ImplicitIdDef' column. This will +-- require you to provide an ID for the model with every insert, using +-- 'insertKey' instead of 'insert', unless the type has some means of getting +-- around that in the migrations. +-- +-- As an example, the Postgresql @SERIAL@ type expands to an autoincrementing +-- integer. Postgres will implicitly create the relevant series and set the +-- default to be @NEXTVAL('series_name')@. A default is therefore unnecessary to +-- use for this type. +-- +-- However, for a @UUID@, postgres *does not* have an implicit default. You must +-- either specify a default UUID generation function, or insert them yourself +-- (again, using 'insertKey'). +-- +-- This function will be deprecated in the future when omiting the default +-- implicit ID column is more fully supported. +-- +-- @since 2.13.0.0 +unsafeClearDefaultImplicitId :: ImplicitIdDef -> ImplicitIdDef +unsafeClearDefaultImplicitId iid = iid { iidDefault = Nothing } diff --git a/persistent/Database/Persist/Names.hs b/persistent/Database/Persist/Names.hs new file mode 100644 index 000000000..e075ff604 --- /dev/null +++ b/persistent/Database/Persist/Names.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveLift #-} + +-- | This module contains types and functions for working with and +-- disambiguating database and Haskell names. +-- +-- @since 2.13.0.0 +module Database.Persist.Names where + +import Data.Text (Text) +import Language.Haskell.TH.Syntax (Lift) +-- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` +-- instance on pre-1.2.4 versions of `text` +import Instances.TH.Lift () + +-- | Convenience operations for working with '-NameDB' types. +-- +-- @since 2.12.0.0 +class DatabaseName a where + escapeWith :: (Text -> str) -> (a -> str) + +-- | An 'EntityNameDB' represents the datastore-side name that @persistent@ +-- will use for an entity. +-- +-- @since 2.12.0.0 +newtype FieldNameDB = FieldNameDB { unFieldNameDB :: Text } + deriving (Show, Eq, Read, Ord, Lift) + +-- | @since 2.12.0.0 +instance DatabaseName FieldNameDB where + escapeWith f (FieldNameDB n) = f n + +-- | A 'FieldNameHS' represents the Haskell-side name that @persistent@ +-- will use for a field. +-- +-- @since 2.12.0.0 +newtype FieldNameHS = FieldNameHS { unFieldNameHS :: Text } + deriving (Show, Eq, Read, Ord, Lift) + +-- | An 'EntityNameHS' represents the Haskell-side name that @persistent@ +-- will use for an entity. +-- +-- @since 2.12.0.0 +newtype EntityNameHS = EntityNameHS { unEntityNameHS :: Text } + deriving (Show, Eq, Read, Ord, Lift) + +-- | An 'EntityNameDB' represents the datastore-side name that @persistent@ +-- will use for an entity. +-- +-- @since 2.12.0.0 +newtype EntityNameDB = EntityNameDB { unEntityNameDB :: Text } + deriving (Show, Eq, Read, Ord, Lift) + +instance DatabaseName EntityNameDB where + escapeWith f (EntityNameDB n) = f n + +-- | A 'ConstraintNameDB' represents the datastore-side name that @persistent@ +-- will use for a constraint. +-- +-- @since 2.12.0.0 +newtype ConstraintNameDB = ConstraintNameDB { unConstraintNameDB :: Text } + deriving (Show, Eq, Read, Ord, Lift) + +-- | @since 2.12.0.0 +instance DatabaseName ConstraintNameDB where + escapeWith f (ConstraintNameDB n) = f n + +-- | An 'ConstraintNameHS' represents the Haskell-side name that @persistent@ +-- will use for a constraint. +-- +-- @since 2.12.0.0 +newtype ConstraintNameHS = ConstraintNameHS { unConstraintNameHS :: Text } + deriving (Show, Eq, Read, Ord, Lift) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index fdc98d9e2..2bd030221 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} {-| This module defines the Persistent entity syntax used in the quasiquoter to generate persistent entities. @@ -415,10 +413,53 @@ Unfortunately, we can't use this to create Haddocks for you, because Text -> Text +getPsToDBName = psToDBName + +-- | Set the name modification function that translates the QuasiQuoted names +-- for use in the database. +-- +-- @since 2.13.0.0 +setPsToDBName :: (Text -> Text) -> PersistSettings -> PersistSettings +setPsToDBName f ps = ps { psToDBName = f } + +-- | Retrieve whether or not the 'PersistSettings' will generate code with +-- strict fields. +-- +-- @since 2.13.0.0 +getPsStrictFields :: PersistSettings -> Bool +getPsStrictFields = psStrictFields + +-- | Set whether or not the 'PersistSettings' will make fields strict. +-- +-- @since 2.13.0.0 +setPsStrictFields :: Bool -> PersistSettings -> PersistSettings +setPsStrictFields a ps = ps { psStrictFields = a } + +-- | Retrievce the default name of the @id@ column. +-- +-- @since 2.13.0.0 +getPsIdName :: PersistSettings -> Text +getPsIdName = psIdName + +-- | Set the default name of the @id@ column. +-- +-- @since 2.13.0.0 +setPsIdName :: Text -> PersistSettings -> PersistSettings +setPsIdName n ps = ps { psIdName = n } diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 255065d36..27ab77d45 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -48,6 +48,7 @@ import Data.Text (Text) import qualified Data.Text as T import Database.Persist.Types import Text.Read (readEither) +import Database.Persist.EntityDef.Internal data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show @@ -100,6 +101,7 @@ parseFieldType t0 = data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) + -- ^ Modify the Haskell-style name into a database-style name. , psStrictFields :: !Bool -- ^ Whether fields are by default strict. Default value: @True@. -- @@ -315,7 +317,8 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts fixForeignKeys (UnboundEntityDef foreigns ent) = ent { entityForeigns = map (fixForeignKey ent) foreigns } - -- check the count and the sqltypes match and update the foreignFields with the names of the referenced columns + -- check the count and the sqltypes match and update the foreignFields with + -- the names of the referenced columns fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef fixForeignKey ent (UnboundForeignDef foreignFieldTexts parentFieldTexts fdef) = case mfdefs of @@ -393,10 +396,11 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length pdef) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef -data UnboundEntityDef = UnboundEntityDef - { _unboundForeignDefs :: [UnboundForeignDef] - , unboundEntityDef :: EntityDef - } +data UnboundEntityDef + = UnboundEntityDef + { _unboundForeignDefs :: [UnboundForeignDef] + , unboundEntityDef :: EntityDef + } overUnboundEntityDef :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef @@ -410,29 +414,30 @@ lookupPrefix :: Text -> [Text] -> Maybe Text lookupPrefix prefix = msum . map (T.stripPrefix prefix) -- | Construct an entity definition. -mkEntityDef :: PersistSettings - -> Text -- ^ name - -> [Attr] -- ^ entity attributes - -> [Line] -- ^ indented lines - -> UnboundEntityDef +mkEntityDef + :: PersistSettings + -> Text -- ^ name + -> [Attr] -- ^ entity attributes + -> [Line] -- ^ indented lines + -> UnboundEntityDef mkEntityDef ps name entattribs lines = - UnboundEntityDef foreigns $ - EntityDef - { entityHaskell = EntityNameHS name' - , entityDB = EntityNameDB $ getDbName ps name' entattribs - -- idField is the user-specified Id - -- otherwise useAutoIdField - -- but, adjust it if the user specified a Primary - , entityId = setComposite primaryComposite $ fromMaybe autoIdField idField - , entityAttrs = entattribs - , entityFields = cols - , entityUniques = uniqs - , entityForeigns = [] - , entityDerives = concat $ mapMaybe takeDerives textAttribs - , entityExtra = extras - , entitySum = isSum - , entityComments = Nothing - } + UnboundEntityDef foreigns $ + EntityDef + { entityHaskell = entName + , entityDB = EntityNameDB $ getDbName ps name' entattribs + -- idField is the user-specified Id + -- otherwise useAutoIdField + -- but, adjust it if the user specified a Primary + , entityId = setComposite primaryComposite $ fromMaybe autoIdField idField + , entityAttrs = entattribs + , entityFields = cols + , entityUniques = uniqs + , entityForeigns = [] + , entityDerives = concat $ mapMaybe takeDerives textAttribs + , entityExtra = extras + , entitySum = isSum + , entityComments = Nothing + } where entName = EntityNameHS name' (isSum, name') = @@ -445,10 +450,6 @@ mkEntityDef ps name entattribs lines = textAttribs = fmap tokenText <$> attribs - attribPrefix = flip lookupKeyVal entattribs - idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql=" - | otherwise = Nothing - (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> let (i, p, u, f) = takeConstraint ps name' cols attr squish xs m = xs `mappend` maybeToList m @@ -468,7 +469,7 @@ mkEntityDef ps name entattribs lines = Nothing -> (acc, []) - autoIdField = mkAutoIdField ps entName (FieldNameDB `fmap` idName) idSqlType + autoIdField = mkAutoIdField ps entName idSqlType idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite setComposite Nothing fd = fd @@ -487,14 +488,14 @@ just1 (Just x) (Just y) = error $ "expected only one of: " `mappend` show x `mappend` " " `mappend` show y just1 x y = x `mplus` y -mkAutoIdField :: PersistSettings -> EntityNameHS -> Maybe FieldNameDB -> SqlType -> FieldDef -mkAutoIdField ps entName idName idSqlType = +mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef +mkAutoIdField ps entName idSqlType = FieldDef { fieldHaskell = FieldNameHS "Id" -- this should be modeled as a Maybe -- but that sucks for non-ID field -- TODO: use a sumtype FieldDef | IdFieldDef - , fieldDB = fromMaybe (FieldNameDB $ psIdName ps) idName + , fieldDB = FieldNameDB $ psIdName ps , fieldType = FTTypeCon Nothing $ keyConName $ unEntityNameHS entName , fieldSqlType = idSqlType -- the primary field is actually a reference to the entity @@ -504,6 +505,7 @@ mkAutoIdField ps entName idName idSqlType = , fieldComments = Nothing , fieldCascade = noCascade , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = True } defaultReferenceTypeCon :: FieldType @@ -562,6 +564,7 @@ takeCols onErr ps (n':typ:rest') , fieldComments = Nothing , fieldCascade = cascade_ , fieldGenerated = generated_ + , fieldIsImplicitIdColumn = False } where fieldAttrs_ = parseFieldAttrs attrs_ diff --git a/persistent/Database/Persist/Sql/Class.hs b/persistent/Database/Persist/Sql/Class.hs index 9a4aa9a71..9b9044a9f 100644 --- a/persistent/Database/Persist/Sql/Class.hs +++ b/persistent/Database/Persist/Sql/Class.hs @@ -74,8 +74,8 @@ instance $ map fieldDB -- Hacky for a composite key because -- it selects the same field multiple times - $ entityKeyFields entDef ++ entityFields entDef - name = escapeWith escape (entityDB entDef) + $ getEntityKeyFields entDef ++ getEntityFields entDef + name = escapeWith escape (getEntityDBName entDef) entDef = entityDef (Nothing :: Maybe record) rawSqlColCountReason a = case fst (rawSqlCols (error "RawSql") a) of @@ -85,7 +85,7 @@ instance (rowKey, rowVal) -> Entity <$> keyFromValues rowKey <*> fromPersistValues rowVal where - nKeyFields = length $ entityKeyFields entDef + nKeyFields = length $ getEntityKeyFields entDef entDef = entityDef (Nothing :: Maybe record) -- | This newtype wrapper is useful when selecting an entity out of the @@ -156,7 +156,7 @@ instance $ map fieldDB -- Hacky for a composite key because -- it selects the same field multiple times - $ entityKeyFields entDef ++ entityFields entDef + $ getEntityKeyFields entDef ++ getEntityFields entDef name = pack $ symbolVal (Proxy :: Proxy prefix) entDef = entityDef (Nothing :: Maybe record) rawSqlColCountReason a = @@ -167,7 +167,7 @@ instance (rowKey, rowVal) -> fmap EntityWithPrefix $ Entity <$> keyFromValues rowKey <*> fromPersistValues rowVal where - nKeyFields = length $ entityKeyFields entDef + nKeyFields = length $ getEntityKeyFields entDef entDef = entityDef (Nothing :: Maybe record) -- | @since 1.0.1 diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index 94649b02a..15b6222ac 100644 --- a/persistent/Database/Persist/Sql/Internal.hs +++ b/persistent/Database/Persist/Sql/Internal.hs @@ -21,6 +21,7 @@ import qualified Data.Text as T import Database.Persist.Quasi import Database.Persist.Sql.Types import Database.Persist.Types +import Database.Persist.Names import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) -- | Record of functions to override the default behavior in 'mkColumns'. It is @@ -81,15 +82,15 @@ mkColumns -> BackendSpecificOverrides -> ([Column], [UniqueDef], [ForeignDef]) mkColumns allDefs t overrides = - (cols, entityUniques t, entityForeigns t) + (cols, getEntityUniques t, getEntityForeignDefs t) where cols :: [Column] - cols = map goId idCol `mappend` map go (entityFields t) + cols = map goId idCol `mappend` map go (getEntityFields t) idCol :: [FieldDef] idCol = case entityPrimary t of Just _ -> [] - Nothing -> [entityId t] + Nothing -> [getEntityId t] goId :: FieldDef -> Column goId fd = @@ -130,14 +131,13 @@ mkColumns allDefs t overrides = } tableName :: EntityNameDB - tableName = entityDB t - + tableName = getEntityDBName t go :: FieldDef -> Column go fd = Column { cName = fieldDB fd - , cNull = nullable (fieldAttrs fd) /= NotNullable || entitySum t + , cNull = nullable (fieldAttrs fd) /= NotNullable || isEntitySum t , cSqlType = fieldSqlType fd , cDefault = defaultAttribute $ fieldAttrs fd , cGenerated = fieldGenerated fd @@ -195,5 +195,5 @@ refName (EntityNameDB table) (FieldNameDB column) = resolveTableName :: [EntityDef] -> EntityNameHS -> EntityNameDB resolveTableName [] (EntityNameHS t) = error $ "Table not found: " `Data.Monoid.mappend` T.unpack t resolveTableName (e:es) hn - | entityHaskell e == hn = entityDB e + | getEntityHaskellName e == hn = getEntityDBName e | otherwise = resolveTableName es hn diff --git a/persistent/Database/Persist/Sql/Migration.hs b/persistent/Database/Persist/Sql/Migration.hs index 6e2ecd090..e431253c3 100644 --- a/persistent/Database/Persist/Sql/Migration.hs +++ b/persistent/Database/Persist/Sql/Migration.hs @@ -15,6 +15,7 @@ module Database.Persist.Sql.Migration , reportError , addMigrations , addMigration + , runSqlCommand ) where @@ -209,3 +210,14 @@ addMigrations :: CautiousMigration -> Migration addMigrations = lift . tell + +-- | Run an action against the database during a migration. Can be useful for eg +-- creating Postgres extensions: +-- +-- @ +-- runSqlCommand $ 'rawExecute' "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\";" [] +-- @ +-- +-- @since 2.13.0.0 +runSqlCommand :: SqlPersistT IO () -> Migration +runSqlCommand = lift . lift diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index 24f6f8f9a..e88816eb3 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -157,7 +157,7 @@ instance PersistQueryRead SqlBackend where _ -> return xs Just pdef -> let pks = map fieldHaskell $ compositeFields pdef - keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) xs + keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ getEntityFields t) xs in return keyvals case keyFromValues keyvals of Right k -> return k diff --git a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs index 906e2972b..3a6cb03a9 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs @@ -19,7 +19,7 @@ module Database.Persist.Sql.Orphan.PersistStore import GHC.Generics (Generic) import Control.Exception (throwIO) import Control.Monad.IO.Class -import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT) +import Control.Monad.Trans.Reader (ReaderT, ask) import Data.Acquire (with) import qualified Data.Aeson as A import Data.ByteString.Char8 (readInteger) @@ -90,7 +90,7 @@ getTableName rec = withCompatibleBackend $ do -- | useful for a backend to implement tableName by adding escaping tableDBName :: (PersistEntity record) => record -> EntityNameDB -tableDBName rec = entityDB $ entityDef (Just rec) +tableDBName rec = getEntityDBName $ entityDef (Just rec) -- | get the SQL string for the field that an EntityField represents -- Useful for raw SQL queries @@ -198,7 +198,7 @@ instance PersistStoreWrite SqlBackend where Nothing -> error $ "ISRManyKeys is used when Primary is defined " ++ show sql Just pdef -> let pks = map fieldHaskell $ compositeFields pdef - keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) fs + keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ getEntityFields t) fs in case keyFromValues keyvals of Right k -> return k Left e -> error $ "ISRManyKeys: unexpected keyvals result: " `mappend` unpack e @@ -225,7 +225,7 @@ instance PersistStoreWrite SqlBackend where ent = entityDef vals valss = map mkInsertValues vals - insertMany_ vals0 = runChunked (length $ entityFields t) insertMany_' vals0 + insertMany_ vals0 = runChunked (length $ getEntityFields t) insertMany_' vals0 where t = entityDef vals0 insertMany_' vals = do @@ -235,9 +235,9 @@ instance PersistStoreWrite SqlBackend where [ "INSERT INTO " , connEscapeTableName conn t , "(" - , T.intercalate "," $ map (connEscapeFieldName conn . fieldDB) $ entityFields t + , T.intercalate "," $ map (connEscapeFieldName conn . fieldDB) $ getEntityFields t , ") VALUES (" - , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," $ map (const "?") (entityFields t) + , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," $ map (const "?") (getEntityFields t) , ")" ] rawExecute sql (concat valss) @@ -250,7 +250,7 @@ instance PersistStoreWrite SqlBackend where [ "UPDATE " , connEscapeTableName conn t , " SET " - , T.intercalate "," (map (go conn . fieldDB) $ entityFields t) + , T.intercalate "," (map (go conn . fieldDB) $ getEntityFields t) , " WHERE " , wher ] diff --git a/persistent/Database/Persist/Sql/Util.hs b/persistent/Database/Persist/Sql/Util.hs index 3643cae23..505ef4f64 100644 --- a/persistent/Database/Persist/Sql/Util.hs +++ b/persistent/Database/Persist/Sql/Util.hs @@ -4,9 +4,8 @@ module Database.Persist.Sql.Util , keyAndEntityColumnNames , entityColumnCount , isIdField - , hasCompositeKey - , hasCompositePrimaryKey , hasNaturalKey + , hasCompositePrimaryKey , dbIdColumns , dbIdColumnsEsc , dbColumns @@ -28,8 +27,8 @@ import qualified Data.Text as T import Database.Persist ( Entity(Entity), EntityDef, EntityField, FieldNameHS(FieldNameHS) , PersistEntity(..), PersistValue - , keyFromValues, fromPersistValues, fieldDB, entityId, entityPrimary - , entityFields, entityKeyFields, fieldHaskell, compositeFields, persistFieldDef + , keyFromValues, fromPersistValues, fieldDB, getEntityId, entityPrimary + , getEntityFields, getEntityKeyFields, fieldHaskell, compositeFields, persistFieldDef , keyAndEntityFields, toPersistValue, FieldNameDB, Update(..), PersistUpdate(..) , FieldDef(..) ) @@ -39,22 +38,16 @@ import Database.Persist.SqlBackend.Internal(SqlBackend(..)) entityColumnNames :: EntityDef -> SqlBackend -> [Sql] entityColumnNames ent conn = - (if hasCompositeKey ent - then [] else [connEscapeFieldName conn . fieldDB $ entityId ent]) - <> map (connEscapeFieldName conn . fieldDB) (entityFields ent) + (if hasNaturalKey ent + then [] else [connEscapeFieldName conn . fieldDB $ getEntityId ent]) + <> map (connEscapeFieldName conn . fieldDB) (getEntityFields ent) keyAndEntityColumnNames :: EntityDef -> SqlBackend -> [Sql] keyAndEntityColumnNames ent conn = map (connEscapeFieldName conn . fieldDB) (keyAndEntityFields ent) entityColumnCount :: EntityDef -> Int -entityColumnCount e = length (entityFields e) - + if hasCompositeKey e then 0 else 1 - -{-# DEPRECATED hasCompositeKey "hasCompositeKey is misleading - it returns True if the entity is defined with the Primary keyword. See issue #685 for discussion. \n If you want the same behavior, use 'hasNaturalKey'. If you want to know if the key has multiple fields, use 'hasCompositePrimaryKey'. This function will be removed in the next major version." #-} --- | Deprecated as of 2.11. See 'hasNaturalKey' or 'hasCompositePrimaryKey' --- for replacements. -hasCompositeKey :: EntityDef -> Bool -hasCompositeKey = Maybe.isJust . entityPrimary +entityColumnCount e = length (getEntityFields e) + + if hasNaturalKey e then 0 else 1 -- | Returns 'True' if the entity has a natural key defined with the -- Primary keyword. @@ -149,15 +142,15 @@ dbIdColumns :: SqlBackend -> EntityDef -> [Text] dbIdColumns conn = dbIdColumnsEsc (connEscapeFieldName conn) dbIdColumnsEsc :: (FieldNameDB -> Text) -> EntityDef -> [Text] -dbIdColumnsEsc esc t = map (esc . fieldDB) $ entityKeyFields t +dbIdColumnsEsc esc t = map (esc . fieldDB) $ getEntityKeyFields t dbColumns :: SqlBackend -> EntityDef -> [Text] dbColumns conn t = case entityPrimary t of Just _ -> flds - Nothing -> escapeColumn (entityId t) : flds + Nothing -> escapeColumn (getEntityId t) : flds where escapeColumn = connEscapeFieldName conn . fieldDB - flds = map escapeColumn (entityFields t) + flds = map escapeColumn (getEntityFields t) parseEntityValues :: PersistEntity record => EntityDef -> [PersistValue] -> Either Text (Entity record) @@ -166,7 +159,7 @@ parseEntityValues t vals = Just pdef -> let pks = map fieldHaskell $ compositeFields pdef keyvals = map snd . filter ((`elem` pks) . fst) - $ zip (map fieldHaskell $ entityFields t) vals + $ zip (map fieldHaskell $ getEntityFields t) vals in fromPersistValuesComposite' keyvals vals Nothing -> fromPersistValues' vals where @@ -237,7 +230,7 @@ mkInsertValues -> [PersistValue] mkInsertValues entity = Maybe.catMaybes - . zipWith redactGeneratedCol (entityFields . entityDef $ Just entity) + . zipWith redactGeneratedCol (getEntityFields . entityDef $ Just entity) . map toPersistValue $ toPersistFields entity where @@ -259,7 +252,7 @@ mkInsertPlaceholders -- ^ An `escape` function -> [(Text, Text)] mkInsertPlaceholders ed escape = - Maybe.mapMaybe redactGeneratedCol (entityFields ed) + Maybe.mapMaybe redactGeneratedCol (getEntityFields ed) where redactGeneratedCol fd = case fieldGenerated fd of Nothing -> diff --git a/persistent/Database/Persist/SqlBackend.hs b/persistent/Database/Persist/SqlBackend.hs index 936502e6f..2c3a2cf0d 100644 --- a/persistent/Database/Persist/SqlBackend.hs +++ b/persistent/Database/Persist/SqlBackend.hs @@ -32,6 +32,7 @@ import qualified Database.Persist.SqlBackend.Internal as SqlBackend (SqlBackend(..)) import Database.Persist.SqlBackend.Internal.MkSqlBackend as Mk (MkSqlBackendArgs(..)) import Database.Persist.Types.Base +import Database.Persist.Names import Database.Persist.SqlBackend.Internal.InsertSqlResult import Data.List.NonEmpty (NonEmpty) diff --git a/persistent/Database/Persist/SqlBackend/Internal.hs b/persistent/Database/Persist/SqlBackend/Internal.hs index b74332a26..ab2958631 100644 --- a/persistent/Database/Persist/SqlBackend/Internal.hs +++ b/persistent/Database/Persist/SqlBackend/Internal.hs @@ -12,6 +12,7 @@ import Data.Acquire import Database.Persist.Class.PersistStore import Conduit import Database.Persist.Types.Base +import Database.Persist.Names import Data.Int import Data.IORef import Control.Monad.Reader diff --git a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs index 4b5045d27..e7c04bb5c 100644 --- a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs +++ b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs @@ -17,6 +17,7 @@ import Database.Persist.SqlBackend.Internal.Statement import Database.Persist.SqlBackend.Internal.InsertSqlResult import Database.Persist.SqlBackend.Internal.IsolationLevel import Database.Persist.Types.Base +import Database.Persist.Names -- | This type shares many of the same field names as the 'SqlBackend' type. -- It's useful for library authors to use this when migrating from using the diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index d7bba56b4..8c10c27c8 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -11,14 +11,13 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} --- {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} - -- | This module provides the tools for defining your database schema and using -- it to generate Haskell data types and migrations. module Database.Persist.TH @@ -42,8 +41,12 @@ module Database.Persist.TH , EntityJSON(..) , mkPersistSettings , sqlSettings + -- ** Implicit ID Columns + , ImplicitIdDef + , setImplicitIdDef -- * Various other TH functions , mkMigrate + , migrateModels , mkSave , mkDeleteCascade , mkEntityDefList @@ -101,6 +104,7 @@ import GHC.TypeLits import Instances.TH.Lift () -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text` +import Data.Foldable (toList) import qualified Data.Set as Set import Language.Haskell.TH.Lib (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) @@ -114,6 +118,11 @@ import Database.Persist.Quasi import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) +import Database.Persist.EntityDef.Internal (EntityDef(..)) +import Database.Persist.ImplicitIdDef (autoIncrementingInteger) +import Database.Persist.ImplicitIdDef.Internal +import Database.Persist.Types.Base (toEmbedEntityDef) + -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist). persistWith :: PersistSettings -> QuasiQuoter @@ -213,16 +222,17 @@ embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts) -- let Haskell tie the knot embedEntityMap = constructEmbedEntityMap entsWithEmbeds entsWithEmbeds = map setEmbedEntity rawEnts - setEmbedEntity ent = ent - { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent - } + setEmbedEntity ent = + overEntityFields + (map (setEmbedField (entityHaskell ent) embedEntityMap)) + ent -- self references are already broken -- look at every emFieldEmbed to see if it refers to an already seen EntityNameHS -- so start with entityHaskell ent and accumulate embeddedHaskell em breakCycleEnt entDef = - let entName = entityHaskell entDef - in entDef { entityFields = map (breakCycleField entName) $ entityFields entDef } + let entName = getEntityHaskellName entDef + in overEntityFields (map (breakCycleField entName)) entDef breakCycleField entName f = case f of FieldDef { fieldReference = EmbedRef em } -> @@ -244,9 +254,10 @@ embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts) where membed = emFieldEmbed emf --- calls parse to Quasi.parse individual entities in isolation +-- | Calls 'parse' to Quasi.parse individual entities in isolation -- afterwards, sets references to other entities --- | @since 2.5.3 +-- +-- @since 2.5.3 parseReferences :: PersistSettings -> Text -> Q Exp parseReferences ps s = lift $ map (mkEntityDefSqlTypeExp embedEntityMap entityMap) noCycleEnts @@ -299,9 +310,9 @@ data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp instance Lift FieldSqlTypeExp where lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) = - [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldCascade fieldComments fieldGenerated|] + [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldCascade fieldComments fieldGenerated fieldIsImplicitIdColumn|] where - FieldDef _x _ _ _ _ _ _ _ _ _ = + FieldDef _x _ _ _ _ _ _ _ _ _ _ = error "need to update this record wildcard match" #if MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift @@ -309,7 +320,7 @@ instance Lift FieldSqlTypeExp where instance Lift EntityDefSqlTypeExp where lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) = - [|ent { entityFields = $(lift $ FieldsSqlTypeExp (entityFields ent) sqlTypeExps) + [|ent { entityFields = $(lift $ FieldsSqlTypeExp (getEntityFields ent) sqlTypeExps) , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp) } |] @@ -393,7 +404,7 @@ setEmbedField entName allEntities field = field mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp mkEntityDefSqlTypeExp emEntities entityMap ent = - EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ entityFields ent) + EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ getEntityFields ent) where getSqlType field = maybe @@ -463,14 +474,40 @@ mkPersist mps ents' = do , symbolToFieldInstances ] where - ents = map fixEntityDef ents' + ents = map (fixEntityDef . setDefaultIdFields mps) ents' entityMap = constructEntityMap ents +setDefaultIdFields :: MkPersistSettings -> EntityDef -> EntityDef +setDefaultIdFields mps ed + | defaultIdType ed || fieldIsImplicitIdColumn (getEntityId ed) = + setEntityId (setToMpsDefault (mpsImplicitIdDef mps) (getEntityId ed)) ed + | otherwise = + ed + where + setToMpsDefault :: ImplicitIdDef -> FieldDef -> FieldDef + setToMpsDefault iid fd = + fd + { fieldType = + iidFieldType iid (getEntityHaskellName ed) + , fieldSqlType = + iidFieldSqlType iid + , fieldAttrs = + let + def = + toList (FieldAttrDefault <$> iidDefault iid) + maxlen = + toList (FieldAttrMaxlen <$> iidMaxLen iid) + in + def <> maxlen <> fieldAttrs fd + , fieldIsImplicitIdColumn = + True + } + -- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'. -- For example, strip out any fields marked as MigrationOnly. fixEntityDef :: EntityDef -> EntityDef -fixEntityDef ed = - ed { entityFields = filter keepField $ entityFields ed } +fixEntityDef = + overEntityFields (filter keepField) where keepField fd = FieldAttrMigrationOnly `notElem` fieldAttrs fd && FieldAttrSafeToRemove `notElem` fieldAttrs fd @@ -478,11 +515,22 @@ fixEntityDef ed = -- | Settings to be passed to the 'mkPersist' function. data MkPersistSettings = MkPersistSettings { mpsBackend :: Type - -- ^ Which database backend we\'re using. + -- ^ Which database backend we\'re using. This type is used for the + -- 'PersistEntityBackend' associated type in the entities that are + -- generated. + -- + -- If the 'mpsGeneric' value is set to 'True', then this type is used for + -- the non-Generic type alias. The data and type will be named: + -- + -- @ + -- data ModelGeneric backend = Model { ... } + -- @ + -- + -- And, for convenience's sake, we provide a type alias: -- - -- When generating data types, each type is given a generic version- which - -- works with any backend- and a type synonym for the commonly used - -- backend. This is where you specify that commonly used backend. + -- @ + -- type Model = ModelGeneric $(the type you give here) + -- @ , mpsGeneric :: Bool -- ^ Create generic types that can be used with multiple backends. Good for -- reusable code, but makes error messages harder to understand. Default: @@ -490,47 +538,71 @@ data MkPersistSettings = MkPersistSettings , mpsPrefixFields :: Bool -- ^ Prefix field names with the model name. Default: True. -- - -- Note: this field is deprecated. Use the mpsFieldLabelModifier and mpsConstraintLabelModifier instead. + -- Note: this field is deprecated. Use the mpsFieldLabelModifier and + -- 'mpsConstraintLabelModifier' instead. , mpsFieldLabelModifier :: Text -> Text -> Text - -- ^ Customise the field accessors and lens names using the entity and field name. - -- Both arguments are upper cased. + -- ^ Customise the field accessors and lens names using the entity and field + -- name. Both arguments are upper cased. -- -- Default: appends entity and field. -- -- Note: this setting is ignored if mpsPrefixFields is set to False. + -- -- @since 2.11.0.0 , mpsConstraintLabelModifier :: Text -> Text -> Text - -- ^ Customise the Constraint names using the entity and field name. The result - -- should be a valid haskell type (start with an upper cased letter). + -- ^ Customise the Constraint names using the entity and field name. The + -- result should be a valid haskell type (start with an upper cased letter). -- -- Default: appends entity and field -- -- Note: this setting is ignored if mpsPrefixFields is set to False. + -- -- @since 2.11.0.0 , mpsEntityJSON :: Maybe EntityJSON -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's -- @Nothing@, no instances will be generated. Default: -- -- @ - -- Just EntityJSON - -- { entityToJSON = 'entityIdToJSON - -- , entityFromJSON = 'entityIdFromJSON + -- Just 'EntityJSON' + -- { 'entityToJSON' = 'entityIdToJSON + -- , 'entityFromJSON' = 'entityIdFromJSON -- } -- @ - , mpsGenerateLenses :: !Bool - -- ^ Instead of generating normal field accessors, generator lens-style accessors. + , mpsGenerateLenses :: Bool + -- ^ Instead of generating normal field accessors, generator lens-style + -- accessors. -- -- Default: False -- -- @since 1.3.1 - , mpsDeriveInstances :: ![Name] - -- ^ Automatically derive these typeclass instances for all record and key types. + , mpsDeriveInstances :: [Name] + -- ^ Automatically derive these typeclass instances for all record and key + -- types. -- -- Default: [] -- -- @since 2.8.1 + , mpsImplicitIdDef :: ImplicitIdDef + -- ^ TODO: document + -- + -- @since 2.13.0.0 } +-- | Set the 'ImplicitIdDef' in the given 'MkPersistSettings'. The default +-- value is 'autoIncrementingInteger'. +-- +-- @since 2.13.0.0 +setImplicitIdDef :: ImplicitIdDef -> MkPersistSettings -> MkPersistSettings +setImplicitIdDef iid mps = + mps { mpsImplicitIdDef = iid } + +getImplicitIdType :: MkPersistSettings -> Type +getImplicitIdType = do + idDef <- mpsImplicitIdDef + isGeneric <- mpsGeneric + backendTy <- mpsBackend + pure $ iidType idDef isGeneric backendTy + data EntityJSON = EntityJSON { entityToJSON :: Name -- ^ Name of the @toJSON@ implementation for @Entity a@. @@ -554,6 +626,8 @@ mkPersistSettings backend = MkPersistSettings } , mpsGenerateLenses = False , mpsDeriveInstances = [] + , mpsImplicitIdDef = + autoIncrementingInteger } -- | Use the 'SqlPersist' backend. @@ -625,14 +699,14 @@ dataTypeDec mps entDef = do cols :: [VarBangType] cols = do - fieldDef <- entityFields entDef + fieldDef <- getEntityFields entDef let recordName = fieldDefToRecordName mps entDef fieldDef strictness = if fieldStrict fieldDef then isStrict else notStrict fieldIdType = maybeIdType mps fieldDef Nothing Nothing in pure (recordName, strictness, fieldIdType) constrs - | entitySum entDef = map sumCon $ entityFields entDef + | entitySum entDef = map sumCon $ getEntityFields entDef | otherwise = [RecC (mkEntityDefName entDef) cols] sumCon fieldDef = NormalC @@ -660,7 +734,7 @@ mkUnique mps entDef (UniqueDef constr _ fields attrs) = NormalC (mkConstraintName constr) types where types = - map (go . flip lookup3 (entityFields entDef) . unFieldNameHS . fst) fields + map (go . flip lookup3 (getEntityFields entDef) . unFieldNameHS . fst) fields force = "!force" `elem` attrs @@ -727,7 +801,9 @@ degen [] = degen x = x mkToPersistFields :: MkPersistSettings -> EntityDef -> Q Dec -mkToPersistFields mps ed@EntityDef { entitySum = isSum, entityFields = fields } = do +mkToPersistFields mps ed = do + let isSum = isEntitySum ed + fields = getEntityFields ed clauses <- if isSum then sequence $ zipWith goSum fields [1..] @@ -743,7 +819,7 @@ mkToPersistFields mps ed@EntityDef { entitySum = isSum, entityFields = fields } let bod = ListE $ map (AppE sp . VarE) xs return $ normalClause [pat] bod - fieldCount = length fields + fieldCount = length (getEntityFields ed) goSum :: FieldDef -> Int -> Q Clause goSum fieldDef idx = do @@ -797,15 +873,13 @@ mapLeft _ (Right r) = Right r mapLeft f (Left l) = Left (f l) mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause] -mkFromPersistValues _ entDef@(EntityDef { entitySum = False }) = - fromValues entDef "fromPersistValues" entE $ entityFields entDef - where - entE = entityDefConE entDef - -mkFromPersistValues mps entDef@(EntityDef { entitySum = True }) = do - nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|] - clauses <- mkClauses [] $ entityFields entDef - return $ clauses `mappend` [normalClause [WildP] nothing] +mkFromPersistValues mps entDef + | isEntitySum entDef = do + nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|] + clauses <- mkClauses [] $ getEntityFields entDef + return $ clauses `mappend` [normalClause [WildP] nothing] + | otherwise = + fromValues entDef "fromPersistValues" entE $ getEntityFields entDef where entName = unEntityNameHS $ entityHaskell entDef mkClauses _ [] = return [] @@ -823,6 +897,8 @@ mkFromPersistValues mps entDef@(EntityDef { entitySum = True }) = do let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmapE (Just fs))]) [] clauses <- mkClauses (field : before) after return $ clause : clauses + entE = entityDefConE entDef + type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t @@ -846,8 +922,8 @@ mkLensClauses mps entDef = do [ConP (keyIdName entDef) []] (lens' `AppE` getId `AppE` setId) if entitySum entDef - then return $ idClause : map (toSumClause lens' keyVar valName xName) (entityFields entDef) - else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (entityFields entDef) + then return $ idClause : map (toSumClause lens' keyVar valName xName) (getEntityFields entDef) + else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (getEntityFields entDef) where toClause lens' getVal dot keyVar valName xName fieldDef = normalClause [ConP (filterConName mps entDef fieldDef) []] @@ -875,7 +951,7 @@ mkLensClauses mps entDef = do -- FIXME It would be nice if the types expressed that the Field is -- a sum type and therefore could result in Maybe. - : if length (entityFields entDef) > 1 then [emptyMatch] else [] + : if length (getEntityFields entDef) > 1 then [emptyMatch] else [] setter = LamE [ ConP 'Entity [VarP keyVar, WildP] , VarP xName @@ -984,30 +1060,42 @@ mkKeyTypeDec mps entDef = do supplement :: [Name] -> [Name] supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps) --- | Returns 'True' if the key definition has more than 1 field. +-- | Returns 'True' if the key definition has less than 2 fields. -- -- @since 2.11.0.0 pkNewtype :: MkPersistSettings -> EntityDef -> Bool pkNewtype mps entDef = length (keyFields mps entDef) < 2 +-- | Kind of a nasty hack. Checks to see if the 'fieldType' matches what the +-- QuasiQuoter produces for an implicit ID and defaultIdType :: EntityDef -> Bool -defaultIdType entDef = fieldType (entityId entDef) == FTTypeCon Nothing (keyIdText entDef) +defaultIdType entDef = + fieldType field == FTTypeCon Nothing (keyIdText entDef) + where + field = getEntityId entDef keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)] -keyFields mps entDef = case entityPrimary entDef of - Just pdef -> map primaryKeyVar (compositeFields pdef) - Nothing -> if defaultIdType entDef - then [idKeyVar backendKeyType] - else [idKeyVar $ ftToType $ fieldType $ entityId entDef] +keyFields mps entDef = + case entityPrimary entDef of + Just pdef -> + map primaryKeyVar (compositeFields pdef) + Nothing -> + pure . idKeyVar $ + if defaultIdType entDef + then + getImplicitIdType mps + else ftToType $ fieldType $ entityId entDef where - backendKeyType - | mpsGeneric mps = ConT ''BackendKey `AppT` backendT - | otherwise = ConT ''BackendKey `AppT` mpsBackend mps - idKeyVar ft = (unKeyName entDef, notStrict, ft) - primaryKeyVar fieldDef = ( keyFieldName mps entDef fieldDef - , notStrict - , ftToType $ fieldType fieldDef - ) + idKeyVar ft = + ( unKeyName entDef + , notStrict + , ft + ) + primaryKeyVar fieldDef = + ( keyFieldName mps entDef fieldDef + , notStrict + , ftToType $ fieldType fieldDef + ) mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec mkKeyToValues mps entDef = do @@ -1105,7 +1193,7 @@ mkEntity entityMap mps entDef = do utv <- mkUniqueToValues $ entityUniques entDef puk <- mkUniqueKeys entDef let primaryField = entityId entDef - fields <- mapM (mkField mps entDef) $ primaryField : entityFields entDef + fields <- mapM (mkField mps entDef) $ primaryField : getEntityFields entDef fkc <- mapM (mkForeignKeysComposite mps entDef) $ entityForeigns entDef toFieldNames <- mkToFieldNames $ entityUniques entDef @@ -1283,7 +1371,7 @@ entityText = unEntityNameHS . entityHaskell mkLenses :: MkPersistSettings -> EntityDef -> Q [Dec] mkLenses mps _ | not (mpsGenerateLenses mps) = return [] mkLenses _ ent | entitySum ent = return [] -mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do +mkLenses mps ent = fmap mconcat $ forM (getEntityFields ent) $ \field -> do let lensName = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field) fieldName = fieldDefToRecordName mps ent field needleN <- newName "needle" @@ -1366,7 +1454,7 @@ maybeTyp may typ | may = ConT ''Maybe `AppT` typ entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues where - columnNames = map (unFieldNameHS . fieldHaskell) (entityFields (entityDef (Just entity))) + columnNames = map (unFieldNameHS . fieldHaskell) (getEntityFields (entityDef (Just entity))) fieldsAsPersistValues = map toPersistValue $ toPersistFields entity entityFromPersistValueHelper :: (PersistEntity record) @@ -1409,7 +1497,7 @@ persistFieldFromEntity mps entDef = do ] where typ = genericDataType mps (entityHaskell entDef) backendT - entFields = entityFields entDef + entFields = getEntityFields entDef columnNames = map (unpack . unFieldNameHS . fieldHaskell) entFields -- | Apply the given list of functions to the same @EntityDef@s. @@ -1444,7 +1532,7 @@ mkDeleteCascade mps defs = do where getDeps :: EntityDef -> [Dep] getDeps def = - concatMap getDeps' $ entityFields $ fixEntityDef def + concatMap getDeps' $ getEntityFields $ fixEntityDef def where getDeps' :: FieldDef -> [Dep] getDeps' field@FieldDef {..} = @@ -1536,7 +1624,7 @@ mkUniqueKeys def = do return $ FunD 'persistUniqueKeys [c] where clause = do - xs <- forM (entityFields def) $ \fieldDef -> do + xs <- forM (getEntityFields def) $ \fieldDef -> do let x = fieldHaskell fieldDef x' <- newName $ '_' : unpack (unFieldNameHS x) return (x, x') @@ -1640,6 +1728,23 @@ derivePersistFieldJSON s = do ] ] +-- | The basic function for migrating models, no Template Haskell required. +-- +-- It's probably best to use this in concert with 'mkEntityDefList', and then +-- call 'migrateModels' with the result from that function. +-- +-- @ +-- share [mkPersist sqlSettings, mkEntityDefList "entities"] [persistLowerCase| ... |] +-- +-- migrateAll = 'migrateModels' entities +-- @ +-- +-- @since 2.13.0.0 +migrateModels :: [EntityDef] -> Migration +migrateModels eds = + forM_ eds $ \ed -> + migrate eds ed + -- | Creates a single function to perform all migrations for the entities -- defined here. One thing to be aware of is dependencies: if you have entities -- with foreign references, make sure to place those definitions after the @@ -1713,8 +1818,11 @@ liftAndFixKeys entityMap EntityDef{..} = |] liftAndFixKey :: EntityMap -> FieldDef -> Q Exp -liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) = - [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments fg|] +liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments fg fieldIsImplicitIdColumn) + | not fieldIsImplicitIdColumn = + [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments fg fieldIsImplicitIdColumn|] + | otherwise = + [|FieldDef a b c sqlTyp e f fieldRef fc mcomments fg fieldIsImplicitIdColumn|] where (fieldRef', sqlTyp') = fromMaybe (fieldRef, lift sqlTyp) $ @@ -1779,7 +1887,7 @@ mkJSON mps def = do obj <- newName "obj" mzeroE <- [|mzero|] - xs <- mapM fieldToJSONValName (entityFields def) + xs <- mapM fieldToJSONValName (getEntityFields def) let conName = mkName $ unpack $ unEntityNameHS $ entityHaskell def typ = genericDataType mps (entityHaskell def) backendT @@ -1787,7 +1895,7 @@ mkJSON mps def = do toJSON' = FunD 'toJSON $ return $ normalClause [ConP conName $ map VarP xs] (objectE `AppE` ListE pairs) - pairs = zipWith toPair (entityFields def) xs + pairs = zipWith toPair (getEntityFields def) xs toPair f x = InfixE (Just (packE `AppE` LitE (StringL $ unpack $ unFieldNameHS $ fieldHaskell f))) dotEqualE @@ -1802,7 +1910,7 @@ mkJSON mps def = do ) , normalClause [WildP] mzeroE ] - pulls = map toPull $ entityFields def + pulls = map toPull $ getEntityFields def toPull f = InfixE (Just $ VarE obj) (if maybeNullable f then dotColonQE else dotColonE) @@ -1840,37 +1948,6 @@ isStrict = Bang NoSourceUnpackedness SourceStrict instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD = InstanceD Nothing --- entityUpdates :: EntityDef -> [(EntityNameHS, FieldType, IsNullable, PersistUpdate)] --- entityUpdates = --- concatMap go . entityFields --- where --- go FieldDef {..} = map (\a -> (fieldHaskell, fieldType, nullable fieldAttrs, a)) [minBound..maxBound] - --- mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec --- mkToUpdate name pairs = do --- pairs' <- mapM go pairs --- return $ FunD (mkName name) $ degen pairs' --- where --- go (constr, pu) = do --- pu' <- lift pu --- return $ normalClause [RecP (mkName constr) []] pu' - - --- mkToFieldName :: String -> [(String, String)] -> Dec --- mkToFieldName func pairs = --- FunD (mkName func) $ degen $ map go pairs --- where --- go (constr, name) = --- normalClause [RecP (mkName constr) []] (LitE $ StringL name) - --- mkToValue :: String -> [String] -> Dec --- mkToValue func = FunD (mkName func) . degen . map go --- where --- go constr = --- let x = mkName "x" --- in normalClause [ConP (mkName constr) [VarP x]] --- (VarE 'toPersistValue `AppE` VarE x) - -- | Check that all of Persistent's required extensions are enabled, or else fail compilation -- -- This function should be called before any code that depends on one of the required extensions being enabled. @@ -2051,7 +2128,7 @@ keyConName :: EntityDef -> Name keyConName entDef = mkName $ T.unpack $ resolveConflict $ keyText entDef where resolveConflict kn = if conflict then kn `mappend` "'" else kn - conflict = any ((== FieldNameHS "key") . fieldHaskell) $ entityFields entDef + conflict = any ((== FieldNameHS "key") . fieldHaskell) $ getEntityFields entDef keyConExp :: EntityDef -> Exp keyConExp = ConE . keyConName diff --git a/persistent/Database/Persist/Types.hs b/persistent/Database/Persist/Types.hs index 4625c2dc1..173d327e8 100644 --- a/persistent/Database/Persist/Types.hs +++ b/persistent/Database/Persist/Types.hs @@ -1,5 +1,8 @@ module Database.Persist.Types ( module Database.Persist.Types.Base + , module Database.Persist.Names + , module Database.Persist.EntityDef + , module Database.Persist.FieldDef , SomePersistField (..) , Update (..) , BackendSpecificUpdate @@ -12,6 +15,42 @@ module Database.Persist.Types , OverflowNatural(..) ) where -import Database.Persist.Types.Base +import Database.Persist.Names import Database.Persist.Class.PersistField import Database.Persist.Class.PersistEntity +import Database.Persist.EntityDef +import Database.Persist.FieldDef + +-- this module is a bit of a kitchen sink of types and concepts. the guts of +-- persistent, just strewn across the table. in 2.13 let's get this cleaned up +-- and a bit more tidy. +import Database.Persist.Types.Base + ( FieldCascade(..) + , ForeignDef(..) + , CascadeAction(..) + , FieldDef(..) + , UniqueDef(..) + , FieldAttr(..) + , IsNullable(..) + , WhyNullable(..) + , ExtraLine + , Checkmark(..) + , FieldType(..) + , PersistException(..) + , ForeignFieldDef + , Attr + , CompositeDef(..) + , SqlType(..) + , ReferenceDef(..) + , noCascade + , parseFieldAttrs + , keyAndEntityFields + , PersistException(..) + , UpdateException(..) + , PersistValue(..) + , PersistFilter(..) + , PersistUpdate(..) + , EmbedEntityDef(..) + , EmbedFieldDef(..) + , LiteralType(..) + ) diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 1f6054bc2..5650e49de 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -1,16 +1,22 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase, PatternSynonyms #-} {-# LANGUAGE DeriveLift #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} -- usage of Error typeclass +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + module Database.Persist.Types.Base ( module Database.Persist.Types.Base + -- * Re-exports , PersistValue(.., PersistLiteral, PersistLiteralEscaped, PersistDbSpecific) , LiteralType(..) ) where import Control.Arrow (second) import Control.Exception (Exception) -import Control.Monad.Trans.Error (Error (..)) import qualified Data.Aeson as A import Data.Bits (shiftL, shiftR) import Data.ByteString (ByteString, foldl') @@ -21,27 +27,36 @@ import Data.Char (isSpace) import qualified Data.HashMap.Strict as HM import Data.Int (Int64) import Data.Map (Map) -import Data.Maybe ( isNothing ) +import Data.Maybe (isNothing) #if !MIN_VERSION_base(4,11,0) -- This can be removed when GHC < 8.2.2 isn't supported anymore import Data.Semigroup ((<>)) #endif import qualified Data.Scientific -import Data.Text (Text, pack) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Text.Encoding.Error (lenientDecode) import Data.Time (Day, TimeOfDay, UTCTime) import qualified Data.Vector as V import Data.Word (Word32) -import Numeric (showHex, readHex) -import Web.PathPieces (PathPiece(..)) -import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData (..), parseUrlPieceMaybe, showTextData, readTextData, parseBoundedTextData) import Language.Haskell.TH.Syntax (Lift(..)) +import Numeric (readHex, showHex) +import Web.HttpApiData + ( FromHttpApiData(..) + , ToHttpApiData(..) + , parseBoundedTextData + , parseUrlPieceMaybe + , readTextData + , showTextData + ) +import Web.PathPieces (PathPiece(..)) -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text` import Instances.TH.Lift () +import Database.Persist.Names + -- | A 'Checkmark' should be used as a field type whenever a -- uniqueness constraint should guarantee that a certain kind of -- record may appear at most once, but other kinds of records may @@ -106,10 +121,10 @@ instance PathPiece Checkmark where fromPathPiece "inactive" = Just Inactive fromPathPiece _ = Nothing -data IsNullable = Nullable !WhyNullable - | NotNullable - deriving (Eq, Show) - +data IsNullable + = Nullable !WhyNullable + | NotNullable + deriving (Eq, Show) -- | The reason why a field is 'nullable' is very important. A -- field that is nullable because of a @Maybe@ tag will have its @@ -120,29 +135,6 @@ data WhyNullable = ByMaybeAttr | ByNullableAttr deriving (Eq, Show) --- | Convenience operations for working with '-NameDB' types. --- --- @since 2.12.0.0 -class DatabaseName a where - escapeWith :: (Text -> str) -> (a -> str) - --- | An 'EntityNameDB' represents the datastore-side name that @persistent@ --- will use for an entity. --- --- @since 2.12.0.0 -newtype EntityNameDB = EntityNameDB { unEntityNameDB :: Text } - deriving (Show, Eq, Read, Ord, Lift) - -instance DatabaseName EntityNameDB where - escapeWith f (EntityNameDB n) = f n - --- | An 'EntityNameHS' represents the Haskell-side name that @persistent@ --- will use for an entity. --- --- @since 2.12.0.0 -newtype EntityNameHS = EntityNameHS { unEntityNameHS :: Text } - deriving (Show, Eq, Read, Ord, Lift) - -- | An 'EntityDef' represents the information that @persistent@ knows -- about an Entity. It uses this information to generate the Haskell -- datatype, the SQL migrations, and other relevant conversions. @@ -268,68 +260,6 @@ data FieldType | FTList FieldType deriving (Show, Eq, Read, Ord, Lift) --- | An 'EntityNameDB' represents the datastore-side name that @persistent@ --- will use for an entity. --- --- @since 2.12.0.0 -newtype FieldNameDB = FieldNameDB { unFieldNameDB :: Text } - deriving (Show, Eq, Read, Ord, Lift) - --- | @since 2.12.0.0 -instance DatabaseName FieldNameDB where - escapeWith f (FieldNameDB n) = f n - --- | A 'FieldNameHS' represents the Haskell-side name that @persistent@ --- will use for a field. --- --- @since 2.12.0.0 -newtype FieldNameHS = FieldNameHS { unFieldNameHS :: Text } - deriving (Show, Eq, Read, Ord, Lift) - --- | A 'FieldDef' represents the inormation that @persistent@ knows about --- a field of a datatype. This includes information used to parse the field --- out of the database and what the field corresponds to. -data FieldDef = FieldDef - { fieldHaskell :: !FieldNameHS - -- ^ The name of the field. Note that this does not corresponds to the - -- record labels generated for the particular entity - record labels - -- are generated with the type name prefixed to the field, so - -- a 'FieldDef' that contains a @'FieldNameHS' "name"@ for a type - -- @User@ will have a record field @userName@. - , fieldDB :: !FieldNameDB - -- ^ The name of the field in the database. For SQL databases, this - -- corresponds to the column name. - , fieldType :: !FieldType - -- ^ The type of the field in Haskell. - , fieldSqlType :: !SqlType - -- ^ The type of the field in a SQL database. - , fieldAttrs :: ![FieldAttr] - -- ^ User annotations for a field. These are provided with the @!@ - -- operator. - , fieldStrict :: !Bool - -- ^ If this is 'True', then the Haskell datatype will have a strict - -- record field. The default value for this is 'True'. - , fieldReference :: !ReferenceDef - , fieldCascade :: !FieldCascade - -- ^ Defines how operations on the field cascade on to the referenced - -- tables. This doesn't have any meaning if the 'fieldReference' is set - -- to 'NoReference' or 'SelfReference'. The cascade option here should - -- be the same as the one obtained in the 'fieldReference'. - -- - -- @since 2.11.0 - , fieldComments :: !(Maybe Text) - -- ^ Optional comments for a 'Field'. There is not currently a way to - -- attach comments to a field in the quasiquoter. - -- - -- @since 2.10.0 - , fieldGenerated :: !(Maybe Text) - -- ^ Whether or not the field is a @GENERATED@ column, and additionally - -- the expression to use for generation. - -- - -- @since 2.11.0.0 - } - deriving (Show, Eq, Read, Ord, Lift) - isFieldNotGenerated :: FieldDef -> Bool isFieldNotGenerated = isNothing . fieldGenerated @@ -386,35 +316,26 @@ toEmbedEntityDef ent = embDef _ -> Nothing } --- | A 'ConstraintNameDB' represents the datastore-side name that @persistent@ --- will use for a constraint. --- --- @since 2.12.0.0 -newtype ConstraintNameDB = ConstraintNameDB { unConstraintNameDB :: Text } - deriving (Show, Eq, Read, Ord, Lift) - --- | @since 2.12.0.0 -instance DatabaseName ConstraintNameDB where - escapeWith f (ConstraintNameDB n) = f n - --- | An 'ConstraintNameHS' represents the Haskell-side name that @persistent@ --- will use for a constraint. +-- | Type for storing the Uniqueness constraint in the Schema. Assume you have +-- the following schema with a uniqueness constraint: -- --- @since 2.12.0.0 -newtype ConstraintNameHS = ConstraintNameHS { unConstraintNameHS :: Text } - deriving (Show, Eq, Read, Ord, Lift) - --- Type for storing the Uniqueness constraint in the Schema. --- Assume you have the following schema with a uniqueness --- constraint: +-- @ -- Person -- name String -- age Int -- UniqueAge age +-- @ -- -- This will be represented as: --- UniqueDef (ConstraintNameHS (packPTH "UniqueAge")) --- (ConstraintNameDB (packPTH "unique_age")) [(FieldNameHS (packPTH "age"), FieldNameDB (packPTH "age"))] [] +-- +-- @ +-- UniqueDef +-- { uniqueHaskell = ConstraintNameHS (packPTH "UniqueAge") +-- , uniqueDBName = ConstraintNameDB (packPTH "unique_age") +-- , uniqueFields = [(FieldNameHS (packPTH "age"), FieldNameDB (packPTH "age"))] +-- , uniqueAttrs = [] +-- } +-- @ -- data UniqueDef = UniqueDef { uniqueHaskell :: !ConstraintNameHS @@ -513,8 +434,6 @@ data PersistException deriving Show instance Exception PersistException -instance Error PersistException where - strMsg = PersistError . pack -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'. @@ -578,6 +497,7 @@ data LiteralType -- 'PersistLiteral_' directly. -- -- @since 2.12.0.0 +pattern PersistDbSpecific :: ByteString -> PersistValue pattern PersistDbSpecific bs <- PersistLiteral_ _ bs where PersistDbSpecific bs = PersistLiteral_ DbSpecific bs @@ -587,6 +507,7 @@ pattern PersistDbSpecific bs <- PersistLiteral_ _ bs where -- 'PersistDbSpecific' for more details. -- -- @since 2.12.0.0 +pattern PersistLiteralEscaped :: ByteString -> PersistValue pattern PersistLiteralEscaped bs <- PersistLiteral_ _ bs where PersistLiteralEscaped bs = PersistLiteral_ Escaped bs @@ -596,6 +517,7 @@ pattern PersistLiteralEscaped bs <- PersistLiteral_ _ bs where -- 'PersistDbSpecific' for more details. -- -- @since 2.12.0.0 +pattern PersistLiteral :: ByteString -> PersistValue pattern PersistLiteral bs <- PersistLiteral_ _ bs where PersistLiteral bs = PersistLiteral_ Unescaped bs @@ -762,6 +684,55 @@ instance Show OnlyUniqueException where instance Exception OnlyUniqueException -data PersistUpdate = Assign | Add | Subtract | Multiply | Divide - | BackendSpecificUpdate T.Text +data PersistUpdate + = Assign | Add | Subtract | Multiply | Divide + | BackendSpecificUpdate T.Text deriving (Read, Show, Lift) + +-- | A 'FieldDef' represents the inormation that @persistent@ knows about +-- a field of a datatype. This includes information used to parse the field +-- out of the database and what the field corresponds to. +data FieldDef = FieldDef + { fieldHaskell :: !FieldNameHS + -- ^ The name of the field. Note that this does not corresponds to the + -- record labels generated for the particular entity - record labels + -- are generated with the type name prefixed to the field, so + -- a 'FieldDef' that contains a @'FieldNameHS' "name"@ for a type + -- @User@ will have a record field @userName@. + , fieldDB :: !FieldNameDB + -- ^ The name of the field in the database. For SQL databases, this + -- corresponds to the column name. + , fieldType :: !FieldType + -- ^ The type of the field in Haskell. + , fieldSqlType :: !SqlType + -- ^ The type of the field in a SQL database. + , fieldAttrs :: ![FieldAttr] + -- ^ User annotations for a field. These are provided with the @!@ + -- operator. + , fieldStrict :: !Bool + -- ^ If this is 'True', then the Haskell datatype will have a strict + -- record field. The default value for this is 'True'. + , fieldReference :: !ReferenceDef + , fieldCascade :: !FieldCascade + -- ^ Defines how operations on the field cascade on to the referenced + -- tables. This doesn't have any meaning if the 'fieldReference' is set + -- to 'NoReference' or 'SelfReference'. The cascade option here should + -- be the same as the one obtained in the 'fieldReference'. + -- + -- @since 2.11.0 + , fieldComments :: !(Maybe Text) + -- ^ Optional comments for a 'Field'. There is not currently a way to + -- attach comments to a field in the quasiquoter. + -- + -- @since 2.10.0 + , fieldGenerated :: !(Maybe Text) + -- ^ Whether or not the field is a @GENERATED@ column, and additionally + -- the expression to use for generation. + -- + -- @since 2.11.0.0 + , fieldIsImplicitIdColumn :: !Bool + -- ^ 'True' if the field is an implicit ID column. 'False' otherwise. + -- + -- @since 2.13.0.0 + } + deriving (Show, Eq, Read, Ord, Lift) diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 9b58142ed..35fbe6d42 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -26,6 +26,7 @@ library , containers >= 0.5 , fast-logger >= 2.4 , http-api-data >= 0.3 + , lift-type >= 0.1.0.0 && < 0.2.0.0 , monad-logger >= 0.3.28 , mtl , path-pieces >= 0.2 @@ -35,12 +36,12 @@ library , silently , template-haskell >= 2.11 && < 2.18 , text >= 1.2 + , th-lift-instances >= 0.1.14 && < 0.2 , time >= 1.6 , transformers >= 0.5 - , unliftio-core , unliftio + , unliftio-core , unordered-containers - , th-lift-instances >= 0.1.14 && < 0.2 , vector default-extensions: @@ -52,6 +53,13 @@ library exposed-modules: Database.Persist Database.Persist.Types + Database.Persist.Names + Database.Persist.EntityDef + Database.Persist.EntityDef.Internal + Database.Persist.FieldDef + Database.Persist.FieldDef.Internal + Database.Persist.ImplicitIdDef + Database.Persist.ImplicitIdDef.Internal Database.Persist.TH Database.Persist.Quasi @@ -150,16 +158,12 @@ test-suite test , TypeFamilies other-modules: - -- Database.Persist.Class.PersistEntity - -- Database.Persist.Class.PersistField - -- Database.Persist.Quasi - -- Database.Persist.Types - -- Database.Persist.Types.Base Database.Persist.THSpec TemplateTestImports Database.Persist.TH.SharedPrimaryKeySpec Database.Persist.TH.SharedPrimaryKeyImportedSpec Database.Persist.TH.OverloadedLabelSpec + Database.Persist.TH.ImplicitIdColSpec default-language: Haskell2010 source-repository head diff --git a/persistent/test/Database/Persist/TH/ImplicitIdColSpec.hs b/persistent/test/Database/Persist/TH/ImplicitIdColSpec.hs new file mode 100644 index 000000000..2909f6693 --- /dev/null +++ b/persistent/test/Database/Persist/TH/ImplicitIdColSpec.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.ImplicitIdColSpec where + +import TemplateTestImports + +import Data.Text (Text) + +import Database.Persist.ImplicitIdDef +import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) + +do + let + uuidDef = + mkImplicitIdDef @Text "uuid_generate_v1mc()" + settings = + setImplicitIdDef uuidDef sqlSettings + + mkPersist settings [persistLowerCase| + + User + name String + age Int + + |] + +pass :: IO () +pass = pure () + +asIO :: IO a -> IO a +asIO = id + +spec :: Spec +spec = describe "ImplicitIdColSpec" $ do + describe "UserKey" $ do + it "has type Text -> Key User" $ do + let userKey = UserKey "Hello" + pass + + describe "getEntityId" $ do + let idField = getEntityId (entityDef (Nothing @User)) + it "has SqlString SqlType" $ asIO $ do + fieldSqlType idField `shouldBe` SqlString + it "has Text FieldType" $ asIO $ do + fieldType idField `shouldBe` fieldTypeFromTypeable @Text diff --git a/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs b/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs index c2a4b4411..314871c65 100644 --- a/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs +++ b/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs @@ -58,5 +58,5 @@ spec = describe "OverloadedLabels" $ do compiles -compiles :: Expectation -compiles = True `shouldBe` True +compiles :: IO () +compiles = pure () diff --git a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs index 436ff3620..e3aa2e7eb 100644 --- a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs +++ b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs @@ -44,11 +44,11 @@ spec = describe "Shared Primary Keys Imported" $ do `shouldBe` sqlType (Proxy @ProfileId) - describe "entityId FieldDef" $ do + describe "getEntityId FieldDef" $ do it "should match underlying primary key" $ do let getSqlType :: PersistEntity a => Proxy a -> SqlType getSqlType = - fieldSqlType . entityId . entityDef + fieldSqlType . getEntityId . entityDef getSqlType (Proxy @User) `shouldBe` getSqlType (Proxy @Profile) diff --git a/persistent/test/Database/Persist/TH/SharedPrimaryKeySpec.hs b/persistent/test/Database/Persist/TH/SharedPrimaryKeySpec.hs index 6fcd39b1f..c65e7e199 100644 --- a/persistent/test/Database/Persist/TH/SharedPrimaryKeySpec.hs +++ b/persistent/test/Database/Persist/TH/SharedPrimaryKeySpec.hs @@ -47,11 +47,11 @@ spec = describe "Shared Primary Keys" $ do `shouldBe` sqlType (Proxy @ProfileId) - describe "entityId FieldDef" $ do + describe "getEntityId FieldDef" $ do it "should match underlying primary key" $ do let getSqlType :: PersistEntity a => Proxy a -> SqlType getSqlType = - fieldSqlType . entityId . entityDef + fieldSqlType . getEntityId . entityDef getSqlType (Proxy @User) `shouldBe` getSqlType (Proxy @Profile) diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index dd8930ba9..89fe8e805 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -41,10 +41,12 @@ import Database.Persist.Sql import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports +import Database.Persist.EntityDef.Internal import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec +import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase| @@ -80,6 +82,10 @@ HasMultipleColPrimaryDef barbaz String Primary foobar barbaz +TestDefaultKeyCol + Id TestDefaultKeyColId + name String + HasIdDef Id Int name String @@ -134,6 +140,20 @@ spec = do OverloadedLabelSpec.spec SharedPrimaryKeySpec.spec SharedPrimaryKeyImportedSpec.spec + ImplicitIdColSpec.spec + describe "TestDefaultKeyCol" $ do + let 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: + -- > ModelName + -- > Id ModelNameId + -- + -- should behave like an implicit id column. + TestDefaultKeyColKey (SqlBackendKey 32) + `shouldBe` + toSqlKey 32 describe "HasDefaultId" $ do let FieldDef{..} = entityId (entityDef (Proxy @HasDefaultId)) @@ -250,6 +270,7 @@ spec = do , fieldComments = Nothing , fieldCascade = noCascade , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = True } , entityAttrs = [] , entityFields = @@ -268,6 +289,7 @@ spec = do FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade } , fieldComments = Nothing , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = False } ] , entityUniques = [] diff --git a/persistent/test/TemplateTestImports.hs b/persistent/test/TemplateTestImports.hs index 6be306b72..820c3aedf 100644 --- a/persistent/test/TemplateTestImports.hs +++ b/persistent/test/TemplateTestImports.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} module TemplateTestImports @@ -8,9 +10,12 @@ module TemplateTestImports import Data.Aeson.TH import Test.QuickCheck -import Test.Hspec as X +import Data.Int as X import Database.Persist.Sql as X import Database.Persist.TH as X +import Test.Hspec as X +import Data.Proxy as X +import Data.Text as X (Text) data Foo = Bar | Baz deriving (Show, Eq) diff --git a/persistent/test/main.hs b/persistent/test/main.hs index 01329e177..99c5d22ea 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -24,6 +24,7 @@ import qualified Data.ByteString.Char8 as BS8 import Database.Persist.Class.PersistField import Database.Persist.Quasi.Internal import Database.Persist.Types +import Database.Persist.EntityDef.Internal import qualified Database.Persist.THSpec as THSpec @@ -101,6 +102,7 @@ main = hspec $ do , fieldCascade = noCascade , fieldComments = Nothing , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = False } it "works if it has a name, type, and cascade" $ do subject ["asdf", "Int", "OnDeleteCascade", "OnUpdateCascade"] @@ -116,6 +118,7 @@ main = hspec $ do , fieldCascade = FieldCascade (Just Cascade) (Just Cascade) , fieldComments = Nothing , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = False } it "never tries to make a refernece" $ do subject ["asdf", "UserId", "OnDeleteCascade"] @@ -131,6 +134,7 @@ main = hspec $ do , fieldCascade = FieldCascade Nothing (Just Cascade) , fieldComments = Nothing , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = False } describe "parseLine" $ do diff --git a/stack.yaml b/stack.yaml index c548c33cf..613ca01e5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -8,3 +8,6 @@ packages: - ./persistent-postgresql - ./persistent-redis - ./persistent-qq + +extra-deps: + - lift-type-0.1.0.0 diff --git a/stack_lts-12.yaml b/stack_lts-12.yaml index 7263f4c8e..8246ca6f0 100644 --- a/stack_lts-12.yaml +++ b/stack_lts-12.yaml @@ -14,3 +14,4 @@ extra-deps: - postgresql-simple-0.6.1 - th-lift-0.8.0.1 - th-lift-instances-0.1.14 +- lift-type-0.1.0.1