{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveAnyClass #-} module Database.Beam.Test.Schema ( EmployeeT(..), DepartmentT(..) , RoleT(..), FunnyT (..) , EmployeeDb(..) , PrimaryKey(..) , DummyBackend , employeeDbSettings , tests ) where import Database.Beam import Database.Beam.Schema.Tables import Database.Beam.Backend import Database.Beam.Backend.SQL.AST import Data.Monoid import Data.Proxy import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime) import Test.Tasty import Test.Tasty.HUnit tests :: TestTree tests = testGroup "Schema Tests" [ basicSchemaGeneration , ruleBasedRenaming , parametricBeamSchemaGeneration , parametricAndFixedNestedBeamsAreEquivalent -- , automaticNestedFieldsAreUnset -- , nullableForeignKeysGivenMaybeType , underscoresAreHandledGracefully ] -- , dbSchemaGeneration ] -- , dbSchemaModification ] data DummyBackend instance BeamBackend DummyBackend where -- Pretty much everything we can shove in a database satisfies show type BackendFromField DummyBackend = Show data EmployeeT f = EmployeeT { _employeeFirstName :: Columnar f Text , _employeeLastName :: Columnar f Text , _employeePhoneNumber :: Columnar f Text , _employeeAge :: Columnar f Int , _employeeSalary :: Columnar f Double , _employeeHireDate :: Columnar f UTCTime , _employeeLeaveDate :: Columnar f (Maybe UTCTime) , _employeeCreated :: Columnar f UTCTime } deriving Generic instance Beamable EmployeeT instance Table EmployeeT where data PrimaryKey EmployeeT f = EmployeeId (Columnar f Text) (Columnar f Text) (Columnar f UTCTime) deriving Generic primaryKey e = EmployeeId (_employeeFirstName e) (_employeeLastName e) (_employeeCreated e) instance Beamable (PrimaryKey EmployeeT) deriving instance Show (TableSettings EmployeeT) deriving instance Eq (TableSettings EmployeeT) deriving instance (Show (Columnar f Text), Show (Columnar f UTCTime)) => Show (PrimaryKey EmployeeT f) deriving instance (Eq (Columnar f Text), Eq (Columnar f UTCTime)) => Eq (PrimaryKey EmployeeT f) -- * Verify that the schema is generated properly employeeTableSchema :: TableSettings EmployeeT employeeTableSchema = defTblFieldSettings expectedEmployeeTableSchema :: TableSettings EmployeeT expectedEmployeeTableSchema = EmployeeT { _employeeFirstName = TableField "first_name" , _employeeLastName = TableField "last_name" , _employeePhoneNumber = TableField "phone_number" , _employeeAge = TableField "age" , _employeeSalary = TableField "salary" , _employeeHireDate = TableField "hire_date" , _employeeLeaveDate = TableField "leave_date" , _employeeCreated = TableField "created" } basicSchemaGeneration :: TestTree basicSchemaGeneration = testCase "Basic Schema Generation" $ do _employeeFirstName employeeTableSchema @?= _employeeFirstName expectedEmployeeTableSchema _employeeLastName employeeTableSchema @?= _employeeLastName expectedEmployeeTableSchema _employeePhoneNumber employeeTableSchema @?= _employeePhoneNumber expectedEmployeeTableSchema _employeeAge employeeTableSchema @?= _employeeAge expectedEmployeeTableSchema _employeeSalary employeeTableSchema @?= _employeeSalary expectedEmployeeTableSchema _employeeHireDate employeeTableSchema @?= _employeeHireDate expectedEmployeeTableSchema _employeeLeaveDate employeeTableSchema @?= _employeeLeaveDate expectedEmployeeTableSchema _employeeCreated employeeTableSchema @?= _employeeCreated expectedEmployeeTableSchema -- * Ensure that automatic fields are unset when nesting data RoleT f = RoleT { _roleForEmployee :: PrimaryKey EmployeeT f , _roleName :: Columnar f Text , _roleStarted :: Columnar f UTCTime } deriving Generic instance Beamable RoleT instance Table RoleT where data PrimaryKey RoleT f = RoleId (PrimaryKey EmployeeT f) (Columnar f UTCTime) deriving Generic primaryKey (RoleT e _ s) = RoleId e s instance Beamable (PrimaryKey RoleT) deriving instance Show (TableSettings (PrimaryKey RoleT)) deriving instance Eq (TableSettings (PrimaryKey RoleT)) roleTableSchema :: TableSettings RoleT roleTableSchema = defTblFieldSettings -- * Ensure that fields of a nullable primary key are given the proper Maybe type data DepartmentT f = DepartmentT { _departmentName :: Columnar f Text , _departmentHead :: PrimaryKey EmployeeT (Nullable f) -- ^ Departments may currently lack a department head } deriving Generic instance Beamable DepartmentT instance Table DepartmentT where data PrimaryKey DepartmentT f = DepartmentId (Columnar f Text) deriving Generic primaryKey (DepartmentT name _) = DepartmentId name instance Beamable (PrimaryKey DepartmentT) deriving instance Show (TableSettings DepartmentT) deriving instance Eq (TableSettings DepartmentT) departmentTableSchema :: TableSettings DepartmentT departmentTableSchema = defTblFieldSettings -- nullableForeignKeysGivenMaybeType :: TestTree -- nullableForeignKeysGivenMaybeType = -- testCase "Nullable foreign keys are given maybe type" $ -- do _departmentHead departmentTableSchema @?= -- EmployeeId (TableField "head__first_name" (DummyField True False (DummyFieldMaybe DummyFieldText))) -- (TableField "head__last_name" (DummyField True False (DummyFieldMaybe DummyFieldText))) -- (TableField "head__created" (DummyField True False (DummyFieldMaybe DummyFieldUTCTime))) -- * Ensure that fields with underscores are handled properly data FunnyT f = FunnyT { funny_field1 :: Columnar f Text , funny_field_2 :: Columnar f Text , funny_first_name :: Columnar f Text , _funny_lastName :: Columnar f Text , _funny_middle_Name :: Columnar f Text , ___ :: Columnar f Int } deriving Generic instance Beamable FunnyT instance Table FunnyT where data PrimaryKey FunnyT f = FunnyId (Columnar f Text) deriving Generic primaryKey = FunnyId . funny_field1 instance Beamable (PrimaryKey FunnyT) funnyTableSchema :: TableSettings FunnyT funnyTableSchema = defTblFieldSettings underscoresAreHandledGracefully :: TestTree underscoresAreHandledGracefully = testCase "Underscores in field names are handled gracefully" $ do let fieldNames = allBeamValues (\(Columnar' f) -> _fieldName f) funnyTableSchema fieldNames @?= [ "funny_field1" , "funny_field_2" , "funny_first_name" , "funny_lastName" , "funny_middle_Name" , "___" ] ruleBasedRenaming :: TestTree ruleBasedRenaming = testCase "Rule based renaming works correctly" $ do let (DatabaseEntity (DatabaseTable _ funny)) = _funny employeeDbSettingsRuleMods (DatabaseEntity (DatabaseTable _ departments)) = _departments employeeDbSettingsRuleMods funnyFieldNames = allBeamValues (\(Columnar' f) -> _fieldName f) funny deptFieldNames = allBeamValues (\(Columnar' f) -> _fieldName f) departments funnyFieldNames @?= [ "pfx_funny_field1" , "pfx_funny_field_2" , "pfx_funny_first_name" , "pfx_funny_lastName" , "pfx_funny_middle_Name" , "___" ] deptFieldNames @?= [ "name", "head__first_name", "head__last_name", "head__created" ] -- * Ensure it is possible to use nested paremetric beams parametricBeamSchemaGeneration :: TestTree parametricBeamSchemaGeneration = testCase "Parametric schema generation" $ do let (DatabaseEntity (DatabaseTable _ deptVehiculesA)) = _departmentVehiculesA employeeDbSettings deptVehiculesFieldNamesA = allBeamValues (\(Columnar' f) -> _fieldName f) deptVehiculesA deptVehiculesFieldNamesA @?= [ "departament__name" , "relates_to__id" , "relates_to__type" , "relates_to__of_wheels" , "meta_info__price" ] -- * Ensure it doesn't matter whether we abstract over a beam's parameters, or if we them fixed. parametricAndFixedNestedBeamsAreEquivalent :: TestTree parametricAndFixedNestedBeamsAreEquivalent = testCase "Parametric and fixed nested beams are equivalent" $ do let (DatabaseEntity (DatabaseTable _ deptVehiculesA)) = _departmentVehiculesA employeeDbSettings (DatabaseEntity (DatabaseTable _ deptVehiculesB)) = _departmentVehiculesB employeeDbSettings deptVehiculesFieldNamesA = allBeamValues (\(Columnar' f) -> _fieldName f) deptVehiculesA deptVehiculesFieldNamesB = allBeamValues (\(Columnar' f) -> _fieldName f) deptVehiculesB deptVehiculesFieldNamesB @?= deptVehiculesFieldNamesA -- `ADepartmentVehiculeT` and `BDepartmentVehiculeT` are equivalent, but one was using params while -- the other had its sub-beams fixed. type ADepartmentVehicule = ADepartmentVehiculeT Identity type ADepartmentVehiculeT = DepartamentRelatedT VehiculeInformationT VehiculeT data DepartamentRelatedT metaInfo prop f = DepartamentProperty { _aDepartament :: PrimaryKey DepartmentT f , _aRelatesTo :: prop f -- checking we can nest both, nullable and non-nullable beams. , _aMetaInfo :: metaInfo (Nullable f) } deriving Generic type BDepartmentVehicule = BDepartmentVehiculeT Identity data BDepartmentVehiculeT f = BDepartmentVehicule { _bDepartament :: PrimaryKey DepartmentT f , _bRelatesTo :: VehiculeT f , _bMetaInfo :: VehiculeInformationT (Nullable f) } deriving Generic -- -- ["departament__name","relates_to__id","relates_to__type","relates_to__of_wheels","meta_info__price"] instance (Beamable metaInfo, Beamable prop) => Beamable (DepartamentRelatedT metaInfo prop) instance (Table metaInfo, Table prop) => Table (DepartamentRelatedT metaInfo prop) where data PrimaryKey (DepartamentRelatedT metaInfo prop) f = DepReKeyA (PrimaryKey DepartmentT f) (PrimaryKey prop f) deriving(Generic) primaryKey = DepReKeyA <$> _aDepartament <*> (primaryKey._aRelatesTo) instance (Table metaInfo, Table prop) => Beamable (PrimaryKey (DepartamentRelatedT metaInfo prop)) data VehiculeT f = VehiculeT { _vehiculeId :: C f Text , _vehiculeType :: C f Text , _numberOfWheels :: C f Int } deriving Generic instance Beamable VehiculeT instance Beamable (PrimaryKey VehiculeT) instance Table VehiculeT where data PrimaryKey VehiculeT f = VehiculeId (C f Text) deriving(Generic) primaryKey = VehiculeId <$> _vehiculeId data VehiculeInformationT f = VehiculeInformationT { _price :: C f Double } deriving Generic instance Beamable VehiculeInformationT instance Beamable (PrimaryKey VehiculeInformationT) instance Table VehiculeInformationT where data PrimaryKey VehiculeInformationT f = VehiculeInformationKey deriving(Generic) primaryKey _ = VehiculeInformationKey instance Beamable BDepartmentVehiculeT instance Beamable (PrimaryKey BDepartmentVehiculeT) instance Table BDepartmentVehiculeT where data PrimaryKey BDepartmentVehiculeT f = DepReKeyB (PrimaryKey DepartmentT f) (PrimaryKey VehiculeT f) deriving(Generic) primaryKey = DepReKeyB <$> _bDepartament <*> (primaryKey._bRelatesTo) -- * Database schema is derived correctly data EmployeeDb f = EmployeeDb { _employees :: f (TableEntity EmployeeT) , _departments :: f (TableEntity DepartmentT) , _roles :: f (TableEntity RoleT) , _funny :: f (TableEntity FunnyT) , _departmentVehiculesA :: f (TableEntity ADepartmentVehiculeT) , _departmentVehiculesB :: f (TableEntity BDepartmentVehiculeT) } deriving Generic instance Database be EmployeeDb employeeDbSettings :: DatabaseSettings be EmployeeDb employeeDbSettings = defaultDbSettings employeeDbSettingsRuleMods :: DatabaseSettings be EmployeeDb employeeDbSettingsRuleMods = defaultDbSettings `withDbModification` renamingFields (\field -> case T.stripPrefix "funny" field of Nothing -> field Just fieldNm -> "pfx_" <> field) -- employeeDbSettingsModified :: DatabaseSettings EmployeeDb -- employeeDbSettingsModified = -- defaultDbSettings `withDbModifications` -- (modifyingDb { _employees = tableModification (\_ -> "emps") tableFieldsModification -- , _departments = tableModification (\_ -> "depts") -- (tableFieldsModification -- { _departmentName = fieldModification (\_ -> "depts_name") id }) }) -- dbSchemaGeneration :: TestTree -- dbSchemaGeneration = -- testCase "Database schema generation" $ -- do let names = allTables (\(DatabaseTable _ nm _) -> nm) employeeDbSettings -- names @?= [ "employees" -- , "departments" -- , "roles" -- , "funny" ] -- dbSchemaModification :: TestTree -- dbSchemaModification = -- testCase "Database schema modification" $ -- do let names = allTables (\(DatabaseTable _ nm _ ) -> nm) employeeDbSettingsModified -- names @?= [ "emps" -- , "depts" -- , "roles" -- , "funny" ] -- let DatabaseTable _ _ departmentT = _departments employeeDbSettingsModified -- departmentT @?= DepartmentT (TableField "depts_name" (DummyField False False DummyFieldText)) -- (EmployeeId (TableField "head__first_name" (DummyField True False (DummyFieldMaybe DummyFieldText))) -- (TableField "head__last_name" (DummyField True False (DummyFieldMaybe DummyFieldText))) -- (TableField "head__created" (DummyField True False (DummyFieldMaybe DummyFieldUTCTime))))