diff --git a/Database/Groundhog/Core.hs b/Database/Groundhog/Core.hs --- a/Database/Groundhog/Core.hs +++ b/Database/Groundhog/Core.hs @@ -51,6 +51,7 @@ , Constructor(..) , IsUniqueKey(..) , UniqueDef(..) + , UniqueType(..) -- * Migration , SingleMigration , NamedMigrations @@ -96,7 +97,7 @@ -- | Constructs the value from the list of 'PersistValue' fromEntityPersistValues :: PersistBackend m => [PersistValue] -> m (v, [PersistValue]) -- | Returns constructor number and a list of uniques names and corresponding field values - getUniques :: DbDescriptor db => Proxy db -> v -> (Int, [(String, [PersistValue])]) + getUniques :: DbDescriptor db => Proxy db -> v -> (Int, [(String, [PersistValue] -> [PersistValue])]) -- | Is internally used by FieldLike Field instance -- We could avoid this function if class FieldLike allowed FieldLike Fields Data or FieldLike (Fields Data). However that would require additional extensions in user-space code entityFieldChain :: Field v c a -> FieldChain @@ -332,13 +333,16 @@ extractUnique :: uKey ~ Key v u => v -> uKey uniqueNum :: uKey -> Int --- | Unique name and list of the field names that form a unique combination. --- Only fields of 'PrimitivePersistField' types can be used in a unique definition +-- | Unique name and list of the field names that form a unique combination data UniqueDef = UniqueDef { uniqueName :: String + , uniqueType :: UniqueType , uniqueFields :: [(String, DbType)] -} deriving (Show, Eq) +} deriving (Show, Eq) +-- | Defines how to treat the unique set of fields for a datatype +data UniqueType = UniqueConstraint | UniqueIndex deriving (Show, Eq) + -- | A DB data type. Naming attempts to reflect the underlying Haskell -- datatypes, eg DbString instead of DbVarchar. Different databases may -- have different translations for these types. @@ -351,12 +355,13 @@ | DbTime | DbDayTime | DbDayTimeZoned - | DbBlob -- ByteString --- More complex types + | DbBlob -- ^ ByteString + | DbOther String -- ^ Name for a database type + -- More complex types | DbMaybe DbType - | DbList String DbType -- list name and type of its argument + | DbList String DbType -- ^ List table name and type of its argument | DbEmbedded EmbeddedDef - -- Nothing means autokey, Just contains a unique key definition and a name of unique constraint. + -- | Nothing means autokey, Just contains a unique key definition and a name of unique constraint. | DbEntity (Maybe (EmbeddedDef, String)) EntityDef deriving (Eq, Show) diff --git a/Database/Groundhog/Expression.hs b/Database/Groundhog/Expression.hs --- a/Database/Groundhog/Expression.hs +++ b/Database/Groundhog/Expression.hs @@ -22,25 +22,25 @@ -- | Instances of this type can be converted to 'Expr'. It is useful for uniform manipulation over fields and plain values class Expression a v c where - wrap :: a -> Expr v c a + toExpression :: a -> Expr v c a instance PurePersistField a => Expression a v c where - wrap = ExprPure + toExpression = ExprPure instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (Arith v c a) v' c' where - wrap = ExprArith + toExpression = ExprArith instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (Field v c a) v' c' where - wrap = ExprField + toExpression = ExprField instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (SubField v c a) v' c' where - wrap = ExprField + toExpression = ExprField instance (PersistEntity v, Constructor c, PersistField (Key v' BackendSpecific), FieldLike (AutoKeyField v c) (RestrictionHolder v c) a', v ~ v', c ~ c') => Expression (AutoKeyField v c) v' c' where - wrap = ExprField + toExpression = ExprField instance (PersistEntity v, Constructor c, FieldLike (u (UniqueMarker v)) (RestrictionHolder v c) a', c' ~ UniqueConstr (Key v' (Unique u)), v ~ v', IsUniqueKey (Key v' (Unique u)), c ~ c') => Expression (u (UniqueMarker v)) v' c' where - wrap = ExprField + toExpression = ExprField -- Let's call "plain type" the types that uniquely define type of a Field it is compared to. -- Example: Int -> Field v c Int, but Entity -> Field v c (Entity / Key Entity) @@ -94,7 +94,7 @@ , FieldLike f (RestrictionHolder v c) a' , Unifiable f b) => f -> b -> Update v c -f =. b = Update f (wrap b) +f =. b = Update f (toExpression b) -- | Boolean \"and\" operator. (&&.) :: Cond v c -> Cond v c -> Cond v c @@ -121,9 +121,9 @@ => a -> b -> Cond v c infix 4 ==., <., <=., >., >=. -a ==. b = Compare Eq (wrap a) (wrap b) -a /=. b = Compare Ne (wrap a) (wrap b) -a <. b = Compare Lt (wrap a) (wrap b) -a <=. b = Compare Le (wrap a) (wrap b) -a >. b = Compare Gt (wrap a) (wrap b) -a >=. b = Compare Ge (wrap a) (wrap b) +a ==. b = Compare Eq (toExpression a) (toExpression b) +a /=. b = Compare Ne (toExpression a) (toExpression b) +a <. b = Compare Lt (toExpression a) (toExpression b) +a <=. b = Compare Le (toExpression a) (toExpression b) +a >. b = Compare Gt (toExpression a) (toExpression b) +a >=. b = Compare Ge (toExpression a) (toExpression b) diff --git a/Database/Groundhog/Generic.hs b/Database/Groundhog/Generic.hs --- a/Database/Groundhog/Generic.hs +++ b/Database/Groundhog/Generic.hs @@ -149,6 +149,7 @@ data PSEmbeddedFieldDef = PSEmbeddedFieldDef { psEmbeddedFieldName :: String -- bar , psDbEmbeddedFieldName :: Maybe String -- SQLbar + , psDbEmbeddedTypeName :: Maybe String -- inet, NUMERIC(5, 2), VARCHAR(50) , psSubEmbedded :: Maybe [PSEmbeddedFieldDef] } deriving Show @@ -161,7 +162,11 @@ go [] fs = fs go st [] = error $ "applyEmbeddedDbTypeSettings: embedded datatype does not have following fields: " ++ show st go st (f@(fName, fType):fs) = case find fName st of - Just (rest, PSEmbeddedFieldDef _ dbName subs) -> (fromMaybe fName dbName, maybe id applyEmbeddedDbTypeSettings subs fType):go rest fs + Just (rest, PSEmbeddedFieldDef _ dbName dbTypeName subs) -> (fromMaybe fName dbName, typ'):go rest fs where + typ' = case (subs, dbTypeName) of + (Just e, _) -> applyEmbeddedDbTypeSettings e fType + (_, Just typeName) -> DbOther typeName + _ -> fType Nothing -> f:go st fs find :: String -> [PSEmbeddedFieldDef] -> Maybe ([PSEmbeddedFieldDef], PSEmbeddedFieldDef) find _ [] = Nothing diff --git a/Database/Groundhog/Generic/Migration.hs b/Database/Groundhog/Generic/Migration.hs --- a/Database/Groundhog/Generic/Migration.hs +++ b/Database/Groundhog/Generic/Migration.hs @@ -25,76 +25,77 @@ import Control.Monad (liftM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (StateT (..), gets, modify) +import Data.Function (on) import qualified Data.Map as Map import Data.List (group, intercalate) import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybeToList) -- Describes a database column. Field cType always contains DbType that maps to one column (no DbEmbedded) -data Column typ = Column +data Column = Column { colName :: String , colNull :: Bool - , colType :: typ + , colType :: DbType , colDefault :: Maybe String } deriving (Eq, Show) -- | Foreign table name and names of the corresponding columns type Reference = (String, [(String, String)]) -data TableInfo typ = TableInfo { +data TableInfo = TableInfo { tablePrimaryKeyName :: Maybe String - , tableColumns :: [Column typ] + , tableColumns :: [Column] , tableUniques :: [UniqueDef'] -- | constraint name and reference , tableReferences :: [(Maybe String, Reference)] } deriving Show -data AlterColumn = Type DbType | IsNull | NotNull | Add (Column DbType) | Drop | AddPrimaryKey +data AlterColumn = Type DbType | IsNull | NotNull | Add Column | Drop | AddPrimaryKey | Default String | NoDefault | UpdateValue String deriving Show type AlterColumn' = (String, AlterColumn) -data AlterTable = AddUniqueConstraint String [String] +data AlterTable = AddUnique UniqueDef' | DropConstraint String + | DropIndex String | AddReference Reference | DropReference String | AlterColumn AlterColumn' deriving Show -data AlterDB typ = AddTable String - -- | Table name, create statement, structure of table from DB, structure of table from datatype, alters - | AlterTable String String (TableInfo typ) (TableInfo DbType) [AlterTable] - -- | Trigger name, table name - | DropTrigger String String - -- | Trigger name, table name, body - | AddTriggerOnDelete String String String - -- | Trigger name, table name, field name, body - | AddTriggerOnUpdate String String String String - | CreateOrReplaceFunction String - | DropFunction String +data AlterDB = AddTable String + -- | Table name, create statement, structure of table from DB, structure of table from datatype, alters + | AlterTable String String TableInfo TableInfo [AlterTable] + -- | Trigger name, table name + | DropTrigger String String + -- | Trigger name, table name, body + | AddTriggerOnDelete String String String + -- | Trigger name, table name, field name, body + | AddTriggerOnUpdate String String String String + | CreateOrReplaceFunction String + | DropFunction String deriving Show -data UniqueDef' = UniqueDef' String [String] deriving Show +data UniqueDef' = UniqueDef' String UniqueType [String] deriving Show -data MigrationPack m typ = MigrationPack { - compareColumns :: Column typ -> Column DbType -> Bool +data MigrationPack m = MigrationPack { + compareTypes :: DbType -> DbType -> Bool , compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool , compareUniqs :: UniqueDef' -> UniqueDef' -> Bool - , checkTable :: String -> m (Maybe (Either [String] (TableInfo typ))) - , migTriggerOnDelete :: String -> [(String, String)] -> m (Bool, [AlterDB typ]) - , migTriggerOnUpdate :: String -> String -> String -> m (Bool, [AlterDB typ]) - , migConstr :: MigrationPack m typ -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration) + , checkTable :: String -> m (Maybe (Either [String] TableInfo)) + , migTriggerOnDelete :: String -> [(String, String)] -> m (Bool, [AlterDB]) + , migTriggerOnUpdate :: String -> String -> String -> m (Bool, [AlterDB]) + , migConstr :: MigrationPack m -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration) , escape :: String -> String , primaryKeyType :: String , foreignKeyType :: String , mainTableId :: String , defaultPriority :: Int - , convertType :: DbType -> typ -- | Sql pieces for the create table statement that add constraints and alterations for running after the table is created , addUniquesReferences :: [UniqueDef'] -> [Reference] -> ([String], [AlterTable]) - , showColumn :: Column DbType -> String - , showAlterDb :: AlterDB typ -> SingleMigration + , showColumn :: Column -> String + , showAlterDb :: AlterDB -> SingleMigration } -mkColumns :: (DbType -> typ) -> String -> DbType -> ([Column typ], [Reference]) +mkColumns :: (DbType -> DbType) -> String -> DbType -> ([Column], [Reference]) mkColumns mkType columnName dbtype = go "" (columnName, dbtype) where go prefix (fname, typ) = (case typ of DbEmbedded (EmbeddedDef False ts) -> concatMap' (go $ prefix ++ fname ++ [delim]) ts @@ -108,7 +109,7 @@ cDef = case constructors e of [cDef'] -> cDef' _ -> error "mkColumns: datatype with unique key cannot have more than one constructor" - UniqueDef _ uFields = findOne "unique" id uniqueName uName $ constrUniques cDef + UniqueDef _ _ uFields = findOne "unique" id uniqueName uName $ constrUniques cDef fields = map (\(fName, _) -> findOne "field" id fst fName $ constrParams cDef) uFields (foreignColumns, _) = concatMap' (go "") fields t@(DbEntity Nothing e) -> ([Column name False (mkType t) Nothing], refs) where @@ -146,7 +147,7 @@ _ -> return () allSubtypes = map snd . concatMap constrParams . constructors -migrateEntity :: (Monad m, Show typ) => MigrationPack m typ -> EntityDef -> m SingleMigration +migrateEntity :: Monad m => MigrationPack m -> EntityDef -> m SingleMigration migrateEntity m@MigrationPack{..} e = do let name = entityName e let constrs = constructors e @@ -158,7 +159,7 @@ x <- checkTable name -- check whether the table was created for multiple constructors before case x of - Just (Right old) | haveSameElems compareColumns (tableColumns old) mainTableColumns -> do + Just (Right old) | haveSameElems (compareColumns m) (tableColumns old) mainTableColumns -> do return $ Left ["Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " ++ name] Just (Left errs) -> return (Left errs) _ -> liftM snd $ migConstr m True name $ head constrs @@ -174,7 +175,7 @@ then mergeMigrations $ Right [(False, defaultPriority, mainTableQuery)]:map snd res else Left $ map (\(_, c) -> "Orphan constructor table found: " ++ constrTable c) orphans Just (Right (TableInfo (Just _) columns [] [])) -> do - if haveSameElems compareColumns columns mainTableColumns + if haveSameElems (compareColumns m) columns mainTableColumns then do -- the datatype had also many constructors before -- check whether any new constructors appeared and increment older discriminators, which were shifted by newer constructors inserted not in the end @@ -189,7 +190,7 @@ return $ Left ["Unexpected structure of main table for Datatype: " ++ name ++ ". Table info: " ++ show structure] Just (Left errs) -> return (Left errs) -migrateList :: (Monad m, Show typ) => MigrationPack m typ -> DbType -> m SingleMigration +migrateList :: Monad m => MigrationPack m -> DbType -> m SingleMigration migrateList m@MigrationPack{..} (DbList mainName t) = do let valuesName = mainName ++ delim : "values" let (valueCols, valueRefs) = mkColumns id "value" t @@ -206,11 +207,10 @@ (_, triggerValues) <- migTriggerOnDelete valuesName $ mkDeletes m valueCols return $ case (mainStructure, valuesStructure) of (Nothing, Nothing) -> let - oldValuesStructure = expectedValuesStructure {tableColumns = map (\c -> c {colType = convertType (colType c)}) valueColumns} - rest = [AlterTable valuesName valuesQuery oldValuesStructure expectedValuesStructure addInAlters] + rest = [AlterTable valuesName valuesQuery expectedValuesStructure expectedValuesStructure addInAlters] in mergeMigrations $ map showAlterDb $ [AddTable mainQuery, AddTable valuesQuery] ++ rest ++ triggerMain ++ triggerValues (Just (Right mainStructure'), Just (Right valuesStructure')) -> let - f name a@(TableInfo id1 cols1 uniqs1 refs1) b@(TableInfo id2 cols2 uniqs2 refs2) = if id1 == id2 && haveSameElems compareColumns cols1 cols2 && haveSameElems compareUniqs uniqs1 uniqs2 && haveSameElems compareRefs refs1 refs2 + f name a@(TableInfo id1 cols1 uniqs1 refs1) b@(TableInfo id2 cols2 uniqs2 refs2) = if id1 == id2 && haveSameElems (compareColumns m) cols1 cols2 && haveSameElems compareUniqs uniqs1 uniqs2 && haveSameElems compareRefs refs1 refs2 then [] else ["List table " ++ name ++ " error. Expected: " ++ show b ++ ". Found: " ++ show a] errors = f mainName mainStructure' expectedMainStructure ++ f valuesName valuesStructure' expectedValuesStructure @@ -223,14 +223,13 @@ migrateList _ t = fail $ "migrateList: expected DbList, got " ++ show t -- from database, from datatype -getAlters :: (Eq typ, Show typ) => - MigrationPack m typ - -> TableInfo typ - -> TableInfo DbType +getAlters :: MigrationPack m + -> TableInfo + -> TableInfo -> [AlterTable] getAlters m@MigrationPack{..} (TableInfo oldId oldColumns oldUniques oldRefs) (TableInfo newId newColumns newUniques newRefs) = map AlterColumn colAlters ++ tableAlters where - (oldOnlyColumns, newOnlyColumns, commonColumns) = matchElements compareColumns oldColumns newColumns + (oldOnlyColumns, newOnlyColumns, commonColumns) = matchElements ((==) `on` colName) oldColumns newColumns (oldOnlyUniques, newOnlyUniques, commonUniques) = matchElements compareUniqs oldUniques newUniques primaryKeyAlters = case (oldId, newId) of (Nothing, Just newName) -> [(newName, AddPrimaryKey)] @@ -241,14 +240,14 @@ colAlters = map (\x -> (colName x, Drop)) oldOnlyColumns ++ map (\x -> (colName x, Add x)) newOnlyColumns ++ concatMap (migrateColumn m) commonColumns ++ primaryKeyAlters tableAlters = - map (\(UniqueDef' name _) -> DropConstraint name) oldOnlyUniques - ++ map (\(UniqueDef' name cols) -> AddUniqueConstraint name cols) newOnlyUniques + map (\(UniqueDef' name typ _) -> case typ of UniqueConstraint -> DropConstraint name; UniqueIndex -> DropIndex name) oldOnlyUniques + ++ map AddUnique newOnlyUniques ++ concatMap migrateUniq commonUniques ++ map (DropReference . fromMaybe (error "getAlters: old reference does not have name") . fst) oldOnlyRefs ++ map (AddReference . snd) newOnlyRefs -- from database, from datatype -migrateColumn :: Eq typ => MigrationPack m typ -> (Column typ, Column DbType) -> [AlterColumn'] +migrateColumn :: MigrationPack m -> (Column, Column) -> [AlterColumn'] migrateColumn MigrationPack{..} (Column name1 isNull1 type1 def1, Column _ isNull2 type2 def2) = modDef ++ modNull ++ modType where modNull = case (isNull1, isNull2) of (False, True) -> [(name1, IsNull)] @@ -256,18 +255,18 @@ Nothing -> [(name1, NotNull)] Just s -> [(name1, UpdateValue s), (name1, NotNull)] _ -> [] - modType = if type1 == convertType type2 then [] else [(name1, Type type2)] + modType = if compareTypes type1 type2 then [] else [(name1, Type type2)] modDef = if def1 == def2 then [] else [(name1, maybe NoDefault Default def2)] -- from database, from datatype migrateUniq :: (UniqueDef', UniqueDef') -> [AlterTable] -migrateUniq (UniqueDef' name1 cols1, UniqueDef' name2 cols2) = if haveSameElems (==) cols1 cols2 +migrateUniq (UniqueDef' name1 _ cols1, u2@(UniqueDef' _ typ2 cols2)) = if haveSameElems (==) cols1 cols2 then [] - else [DropConstraint name1, AddUniqueConstraint name2 cols2] + else [if typ2 == UniqueConstraint then DropConstraint name1 else DropIndex name1, AddUnique u2] -defaultMigConstr :: (Monad m, Eq typ, Show typ) => MigrationPack m typ -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration) +defaultMigConstr :: Monad m => MigrationPack m -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration) defaultMigConstr migPack@MigrationPack{..} simple name constr = do let cName = if simple then name else name ++ [delim] ++ constrName constr let mkColumns' xs = concat *** concat $ unzip $ map (uncurry $ mkColumns id) xs @@ -283,7 +282,7 @@ mainRef = maybe "" (\x -> " REFERENCES " ++ escape x ++ " ON DELETE CASCADE ") mainTableName autoKey = fmap (\x -> escape x ++ " " ++ primaryKeyType ++ mainRef) $ constrAutoKeyName constr - uniques = map (\(UniqueDef uName cols) -> UniqueDef' uName (map colName $ fst $ mkColumns' cols)) $ constrUniques constr + uniques = map (\(UniqueDef uName uType cols) -> UniqueDef' uName uType (map colName $ fst $ mkColumns' cols)) $ constrUniques constr (addInCreate, addInAlters) = addUniquesReferences uniques refs -- refs instead of refs' because the reference to the main table id is hardcoded in mainRef items = maybeToList autoKey ++ map showColumn columns ++ addInCreate @@ -292,8 +291,7 @@ expectedTableStructure = TableInfo (constrAutoKeyName constr) columns uniques (map (\r -> (Nothing, r)) refs') (migErrs, constrExisted, mig) = case tableStructure of Nothing -> let - oldTableStructure = expectedTableStructure {tableColumns = map (\c -> c {colType = convertType (colType c)}) columns} - rest = AlterTable cName addTable oldTableStructure expectedTableStructure addInAlters + rest = AlterTable cName addTable expectedTableStructure expectedTableStructure addInAlters in ([], False, [AddTable addTable, rest]) Just (Right oldTableStructure) -> let alters = getAlters migPack oldTableStructure expectedTableStructure @@ -309,10 +307,14 @@ -- on delete removes all ephemeral data -- returns column name and delete statement for the referenced table -mkDeletes :: MigrationPack m typ -> [Column DbType] -> [(String, String)] +mkDeletes :: MigrationPack m -> [Column] -> [(String, String)] mkDeletes MigrationPack{..} columns = mapMaybe delField columns where delField (Column name _ t _) = fmap delStatement $ ephemeralName t where delStatement ref = (name, "DELETE FROM " ++ escape ref ++ " WHERE id=old." ++ escape name ++ ";") ephemeralName (DbMaybe x) = ephemeralName x ephemeralName (DbList name _) = Just name ephemeralName _ = Nothing + +compareColumns :: MigrationPack m -> Column -> Column -> Bool +compareColumns MigrationPack{..} (Column name1 isNull1 type1 def1) (Column name2 isNull2 type2 def2) = + name1 == name2 && isNull1 == isNull2 && compareTypes type1 type2 && def1 == def2 diff --git a/Database/Groundhog/Generic/PersistBackendHelpers.hs b/Database/Groundhog/Generic/PersistBackendHelpers.hs --- a/Database/Groundhog/Generic/PersistBackendHelpers.hs +++ b/Database/Groundhog/Generic/PersistBackendHelpers.hs @@ -250,12 +250,11 @@ let (constructorNum, uniques) = getUniques proxy v let uniqueDefs = constrUniques $ constructors e !! constructorNum - let cond = intercalateS " OR " $ map (intercalateS " AND " . map (\(fname, _) -> escape (fromString fname) <> "=?")) $ map (\(UniqueDef _ fields) -> fields) uniqueDefs + let cond = intercalateS " OR " $ map (intercalateS " AND " . map (\(fname, _) -> escape (fromString fname) <> "=?")) $ map (\(UniqueDef _ _ fields) -> fields) uniqueDefs let ifAbsent tname constr = do let query = "SELECT " <> maybe "1" id (constrId escape constr) <> " FROM " <> escape (fromString tname) <> " WHERE " <> cond --- x <- queryFunc query [DbInt64] (foldr ((.) . snd) id uniques []) id - x <- queryFunc query [DbInt64] (concatMap snd uniques) id + x <- queryFunc query [DbInt64] (foldr ((.) . snd) id uniques []) id case x of Nothing -> liftM Right $ Core.insert v Just [k] -> return $ Left $ fst $ fromPurePersistValues proxy [k] diff --git a/Database/Groundhog/Instances.hs b/Database/Groundhog/Instances.hs --- a/Database/Groundhog/Instances.hs +++ b/Database/Groundhog/Instances.hs @@ -198,6 +198,7 @@ instance PrimitivePersistField Double where toPrimitivePersistValue _ a = PersistDouble a fromPrimitivePersistValue _ (PersistDouble a) = a + fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a fromPrimitivePersistValue _ x = readHelper x ("Expected Double, received: " ++ show x) instance PrimitivePersistField Bool where @@ -479,7 +480,7 @@ instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), r ~ RestrictionHolder v (UniqueConstr (Key v (Unique u)))) => Projection (u (UniqueMarker v)) r (Key v (Unique u)) where projectionFieldChains u = (chains++) where - UniqueDef _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u) + UniqueDef _ _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u) chains = map (\f -> (f, [])) uFields constr = head $ constructors (entityDef ((undefined :: u (UniqueMarker v) -> v) u)) projectionResult _ = pureFromPersistValue @@ -533,6 +534,6 @@ instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), Projection (u (UniqueMarker v)) r a') => FieldLike (u (UniqueMarker v)) r a' where fieldChain u = chain where - UniqueDef _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u) + UniqueDef _ _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u) chain = (("will_be_ignored", DbEmbedded $ EmbeddedDef True $ uFields), []) constr = head $ constructors (entityDef ((undefined :: u (UniqueMarker v) -> v) u)) diff --git a/examples/compositeKeys.hs b/examples/compositeKeys.hs deleted file mode 100644 --- a/examples/compositeKeys.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances, StandaloneDeriving #-} -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Database.Groundhog.TH -import Database.Groundhog.Sqlite - --- artistName is a unique key -data Artist = Artist { artistName :: String, artistSurname :: String } deriving (Eq, Show) - -mkPersist defaultCodegenConfig [groundhog| -definitions: - - entity: Artist - autoKey: - constrName: AutoKey - default: false # Defines if this key is used when an entity is stored directly, for example, data Ref = Ref SomeEntity - keys: - - name: ArtistFullName - default: true - constructors: - - name: Artist - uniques: - - name: ArtistFullName - fields: [artistName, artistSurname] -|] - -data Album = Album { albumName :: String} deriving (Eq, Show) --- many-to-many relation -data ArtistAlbum = ArtistAlbum {artist :: Key Artist (Unique ArtistFullName), album :: Key Album BackendSpecific } -deriving instance Eq ArtistAlbum -deriving instance Show ArtistAlbum --- We cannot use regular deriving because when it works, the Key Eq and Show instances for (Key Album BackendSpecific) are not created yet -data Track = Track { albumTrack :: Key Album BackendSpecific, trackName :: String } -deriving instance Eq Track -deriving instance Show Track - -mkPersist defaultCodegenConfig [groundhog| -definitions: -- entity: Album -- entity: Track -# keys of many-to-many relation form a unique key -- entity: ArtistAlbum - autoKey: null - keys: - - name: ArtistAlbumKey - default: true - constructors: - - name: ArtistAlbum - fields: - - name: artist - embeddedType: [] - uniques: - - name: ArtistAlbumKey - fields: [artist, album] -|] - -main :: IO () -main = withSqliteConn ":memory:" $ runSqliteConn $ do - let artists = [Artist "John" "Lennon", Artist "George" "Harrison"] - imagineAlbum = Album "Imagine" - runMigration defaultMigrationLogger $ do - migrate (undefined :: ArtistAlbum) - migrate (undefined :: Track) - mapM_ insert artists - - imagineKey <- insert imagineAlbum - let tracks = map (Track imagineKey) ["Imagine", "Crippled Inside", "Jealous Guy", "It's So Hard", "I Don't Want to Be a Soldier, Mama, I Don't Want to Die", "Gimme Some Truth", "Oh My Love", "How Do You Sleep?", "How?", "Oh Yoko!"] - mapM_ insert tracks - mapM_ (\artist -> insert $ ArtistAlbum (extractUnique artist) imagineKey) artists - -- print first 3 tracks from any album with John Lennon - [albumKey'] <- project AlbumField $ (ArtistField ==. ArtistFullNameKey "John" "Lennon") `limitTo` 1 - -- order by primary key - tracks' <- select $ (AlbumTrackField ==. albumKey') `orderBy` [Asc AutoKeyField] `limitTo` 3 - liftIO $ print tracks' - diff --git a/examples/dbSpecificTypes.hs b/examples/dbSpecificTypes.hs new file mode 100644 --- /dev/null +++ b/examples/dbSpecificTypes.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances #-} +import Control.Monad.IO.Class (liftIO) +import Data.ByteString.Char8 (unpack) +import Database.Groundhog.Core +import Database.Groundhog.Generic +import Database.Groundhog.TH +import Database.Groundhog.Postgresql + +data Point = Point { pointX :: Int, pointY :: Int } deriving Show + +-- PostgreSQL keeps point in format "(x,y)". This instance relies on the correspondence between Haskell tuple format and PostgreSQL point format. +instance PrimitivePersistField Point where + toPrimitivePersistValue _ (Point x y) = PersistString $ show (x, y) + fromPrimitivePersistValue _ (PersistString a) = let (x, y) = read a in Point x y + fromPrimitivePersistValue _ (PersistByteString a) = let (x, y) = read (unpack a) in Point x y + +instance PersistField Point where + persistName _ = "Point" + toPersistValues = primToPersistValue + fromPersistValues = primFromPersistValue + dbType _ = DbOther "point" + +data MobilePhone = MobilePhone {number :: String, prepaidMoney :: String, location :: Point, ipAddress :: String} deriving Show + +mkPersist defaultCodegenConfig [groundhog| +- entity: MobilePhone + constructors: + - name: MobilePhone + fields: + - name: number + type: varchar(13) + - name: prepaidMoney + type: money +# We don't need to put "typeName: point" for location because the dbType definition already has the required type + - name: ipAddress + type: inet +|] + +main = withPostgresqlConn "dbname=test user=test password=test host=localhost" . runPostgresqlConn $ do + let phone = MobilePhone "+1900 654 321" "100.456" (Point 4 6) "127.0.0.1" + runMigration defaultMigrationLogger (migrate phone) + k <- insert phone + -- This will output the mobile phone data with money rounded to two fractional digits + get k >>= liftIO . print + liftIO $ putStrLn "This insert will make PostgreSQL throw an exception:" + -- PGRES_FATAL_ERROR: ERROR: value too long for type character varying(13) + insert $ phone {number = "Phone number is too long now"} diff --git a/groundhog.cabal b/groundhog.cabal --- a/groundhog.cabal +++ b/groundhog.cabal @@ -1,5 +1,5 @@ name: groundhog -version: 0.1.0.2 +version: 0.2.0 license: BSD3 license-file: LICENSE author: Boris Lykah