diff --git a/Database/Groundhog.hs b/Database/Groundhog.hs --- a/Database/Groundhog.hs +++ b/Database/Groundhog.hs @@ -3,13 +3,14 @@ -- See . module Database.Groundhog ( - -- * Main definitions + -- * Core datatypes and functions PersistBackend(..) , DbPersist(..) , Key , DefaultKey , AutoKey , Unique + , UniqueMarker , BackendSpecific , extractUnique , Cond(..) @@ -35,8 +36,6 @@ , runMigration , runMigrationUnsafe , printMigration - , silentMigrationLogger - , defaultMigrationLogger ) where import Database.Groundhog.Core diff --git a/Database/Groundhog/Core.hs b/Database/Groundhog/Core.hs --- a/Database/Groundhog/Core.hs +++ b/Database/Groundhog/Core.hs @@ -457,10 +457,10 @@ -- | The reference contains either EntityDef of the parent table and name of the unique constraint. Or for tables not mapped by Groundhog schema name, table name, and list of columns -- Reference to the autogenerated key of a mapped entity = (Left (entityDef, Nothing), onDelete, onUpdate) -- Reference to a unique key of a mapped entity = (Left (entityDef, Just uniqueKeyName), onDelete, onUpdate) --- Reference to a table that is not mapped = (Right (schema, tableName, columns), onDelete, onUpdate) -type ParentTableReference = (Either (EntityDef, Maybe String) (Maybe String, String, [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) +-- Reference to a table that is not mapped = (Right ((schema, tableName), columns), onDelete, onUpdate) +type ParentTableReference = (Either (EntityDef, Maybe String) ((Maybe String, String), [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) --- | Stores a database type. It needs to be formatted by backend. For example, @[Right DbInt64, Left "[]"]@ should become integer[] in PostgreSQL +-- | Stores a database type. The list contains two kinds of tokens for the type string. Backend will choose a string representation for DbTypePrimitive's, and the string literals will go to the type as-is. As the final step, these tokens are concatenated. For example, @[Left \"varchar(50)\"]@ will become a string with max length and @[Right DbInt64, Left \"[]\"]@ will become integer[] in PostgreSQL. newtype OtherTypeDef' str = OtherTypeDef ([Either str (DbTypePrimitive' str)]) deriving (Eq, Show) type OtherTypeDef = OtherTypeDef' String diff --git a/Database/Groundhog/Generic.hs b/Database/Groundhog/Generic.hs --- a/Database/Groundhog/Generic.hs +++ b/Database/Groundhog/Generic.hs @@ -6,16 +6,14 @@ -- * Migration createMigration , executeMigration + , executeMigrationSilent , executeMigrationUnsafe - , getQueries , runMigration + , runMigrationSilent , runMigrationUnsafe + , getQueries , printMigration , mergeMigrations - , silentMigrationLogger - , defaultMigrationLogger - , failMessage - , failMessageNamed -- * Helpers for running Groundhog actions , HasConn , runDb @@ -39,6 +37,8 @@ , fromPersistValuesUnique , toSinglePersistValueAutoKey , fromSinglePersistValueAutoKey + , failMessage + , failMessageNamed -- * Other , bracket , finally @@ -60,7 +60,7 @@ import Database.Groundhog.Core import Control.Applicative ((<|>)) -import Control.Monad (liftM, forM_, (>=>)) +import Control.Monad (liftM, forM_, unless, (>=>)) import Control.Monad.Logger (MonadLogger, NoLoggingT(..)) import Control.Monad.Trans.State (StateT(..)) import Control.Monad.Trans.Control (MonadBaseControl, control, restoreM) @@ -71,9 +71,10 @@ import Data.Function (on) import Data.List (partition, sortBy) import qualified Data.Map as Map +import System.IO (hPutStrLn, stderr) -- | Produce the migrations but not execute them. Fails when an unsafe migration occurs. -createMigration :: PersistBackend m => Migration m -> m NamedMigrations +createMigration :: Monad m => Migration m -> m NamedMigrations createMigration m = liftM snd $ runStateT m Map.empty -- | Returns either a list of errors in migration or a list of queries @@ -89,21 +90,27 @@ migs' = sortBy (compare `on` \(_, i, _) -> i) migs unsafe = filter (\(isUnsafe, _, _) -> isUnsafe) migs' -executeMigration' :: (PersistBackend m, MonadIO m) => Bool -> (String -> IO ()) -> NamedMigrations -> m () -executeMigration' runUnsafe logger m = do +executeMigration' :: (PersistBackend m, MonadIO m) => Bool -> Bool -> NamedMigrations -> m () +executeMigration' runUnsafe silent m = do let migs = getQueries runUnsafe $ mergeMigrations $ Map.elems m case migs of Left errs -> fail $ unlines errs - Right qs -> mapM_ (executeMigrate logger) qs + Right qs -> forM_ qs $ \q -> do + unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ q + executeRaw False q [] --- | Execute the migrations and log them. -executeMigration :: (PersistBackend m, MonadIO m) => (String -> IO ()) -> NamedMigrations -> m () -executeMigration = executeMigration' False +-- | Execute the migrations with printing to stderr. Fails when an unsafe migration occurs. +executeMigration :: (PersistBackend m, MonadIO m) => NamedMigrations -> m () +executeMigration = executeMigration' False False --- | Execute migrations and log them. Executes the unsafe migrations without warnings -executeMigrationUnsafe :: (PersistBackend m, MonadIO m) => (String -> IO ()) -> NamedMigrations -> m () -executeMigrationUnsafe = executeMigration' True +-- | Execute the migrations. Fails when an unsafe migration occurs. +executeMigrationSilent :: (PersistBackend m, MonadIO m) => NamedMigrations -> m () +executeMigrationSilent = executeMigration' False True +-- | Execute migrations. Executes the unsafe migrations without warnings and prints them to stderr +executeMigrationUnsafe :: (PersistBackend m, MonadIO m) => NamedMigrations -> m () +executeMigrationUnsafe = executeMigration' True False + -- | Pretty print the migrations printMigration :: MonadIO m => NamedMigrations -> m () printMigration migs = liftIO $ forM_ (Map.assocs migs) $ \(k, v) -> do @@ -114,35 +121,26 @@ let showSql (isUnsafe, _, sql) = (if isUnsafe then "Unsafe:\t" else "Safe:\t") ++ sql mapM_ (putStrLn . ("\t" ++) . showSql) sqls --- | Run migrations and log them. Fails when an unsafe migration occurs. -runMigration :: (PersistBackend m, MonadIO m) => (String -> IO ()) -> Migration m -> m () -runMigration logger m = createMigration m >>= executeMigration logger - --- | Run migrations and log them. Executes the unsafe migrations without warnings -runMigrationUnsafe :: (PersistBackend m, MonadIO m) => (String -> IO ()) -> Migration m -> m () -runMigrationUnsafe logger m = createMigration m >>= executeMigrationUnsafe logger - -executeMigrate :: (PersistBackend m, MonadIO m) => (String -> IO ()) -> String -> m () -executeMigrate logger query = do - liftIO $ logger query - executeRaw False query [] - return () +-- | Creates migrations and executes them with printing to stderr. Fails when an unsafe migration occurs. +-- > runMigration m = createMigration m >>= executeMigration +runMigration :: (PersistBackend m, MonadIO m) => Migration m -> m () +runMigration m = createMigration m >>= executeMigration --- | No-op -silentMigrationLogger :: String -> IO () -silentMigrationLogger _ = return () +-- | Creates migrations and silently executes them. Fails when an unsafe migration occurs. +-- > runMigration m = createMigration m >>= executeMigrationSilent +runMigrationSilent :: (PersistBackend m, MonadIO m) => Migration m -> m () +runMigrationSilent m = createMigration m >>= executeMigrationSilent --- | Prints the queries to stdout -defaultMigrationLogger :: String -> IO () -defaultMigrationLogger query = putStrLn $ "Migrating: " ++ query +-- | Creates migrations and executes them with printing to stderr. Executes the unsafe migrations without warnings +-- > runMigrationUnsafe m = createMigration m >>= executeMigrationUnsafe +runMigrationUnsafe :: (PersistBackend m, MonadIO m) => Migration m -> m () +runMigrationUnsafe m = createMigration m >>= executeMigrationUnsafe -- | Joins the migrations. The result is either all error messages or all queries mergeMigrations :: [SingleMigration] -> SingleMigration -mergeMigrations ms = - let (errors, statements) = partitionEithers ms - in if null errors - then Right (concat statements) - else Left (concat errors) +mergeMigrations ms = case partitionEithers ms of + ([], statements) -> Right $ concat statements + (errors, _) -> Left $ concat errors failMessage :: PersistField a => a -> [PersistValue] -> String failMessage a = failMessageNamed (persistName a) @@ -179,8 +177,8 @@ , psExprName :: Maybe str -- BarField , psEmbeddedDef :: Maybe [PSFieldDef str] , psDefaultValue :: Maybe str - , psReferenceParent :: Maybe (Maybe (Maybe str, str, [str]), Maybe ReferenceActionType, Maybe ReferenceActionType) -} deriving Show + , psReferenceParent :: Maybe (Maybe ((Maybe str, str), [str]), Maybe ReferenceActionType, Maybe ReferenceActionType) +} deriving (Eq, Show) applyDbTypeSettings :: PSFieldDef String -> DbType -> DbType applyDbTypeSettings (PSFieldDef _ _ dbTypeName _ Nothing def psRef) typ = case typ of @@ -200,7 +198,7 @@ Just name' -> (True, (name', applyDbTypeSettings fDef fType):fields') _ -> let (flag, fields') = go st fs in (flag, field:fields') -applyReferencesSettings :: Maybe (Maybe (Maybe String, String, [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) -> Maybe ParentTableReference -> Maybe ParentTableReference +applyReferencesSettings :: Maybe (Maybe ((Maybe String, String), [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) -> Maybe ParentTableReference -> Maybe ParentTableReference applyReferencesSettings Nothing ref = ref applyReferencesSettings (Just (parent, onDel, onUpd)) (Just (parent', onDel', onUpd')) = Just (maybe parent' Right parent, onDel <|> onDel', onUpd <|> onUpd') applyReferencesSettings (Just (Just parent, onDel, onUpd)) Nothing = Just (Right parent, onDel, onUpd) @@ -312,7 +310,7 @@ class (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadReader cm m, ConnectionManager cm conn) => HasConn m cm conn instance (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadReader cm m, ConnectionManager cm conn) => HasConn m cm conn --- | It helps to run database operations within your application monad. +-- | It helps to run database operations within an application monad. runDb :: HasConn m cm conn => DbPersist conn m a -> m a runDb f = ask >>= withConn (runDbPersist f) 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 @@ -3,6 +3,7 @@ module Database.Groundhog.Generic.Migration ( Column(..) , Reference(..) + , QualifiedName , TableInfo(..) , UniqueDefInfo , AlterColumn(..) @@ -28,7 +29,7 @@ import Control.Arrow ((***), (&&&)) import Control.Monad (liftM, when) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State (StateT (..), gets, modify) +import Control.Monad.Trans.State (gets, modify) import Data.Either (lefts) import Data.Function (on) import qualified Data.Map as Map @@ -43,13 +44,15 @@ } deriving (Eq, Show) data Reference = Reference { - referencedTableSchema :: Maybe String - , referencedTableName :: String + referencedTableName :: QualifiedName , referencedColumns :: [(String, String)] -- ^ child column, parent column , referenceOnDelete :: Maybe ReferenceActionType , referenceOnUpdate :: Maybe ReferenceActionType } deriving Show +-- | Schema-qualified name of a table of another database object +type QualifiedName = (Maybe String, String) + -- | Either column name or expression type UniqueDefInfo = UniqueDef' String (Either String String) data TableInfo = TableInfo { @@ -72,18 +75,18 @@ | AlterColumn Column [AlterColumn] deriving Show data AlterDB = AddTable String - -- | Table schema, table name, create statement, structure of table from DB, structure of table from datatype, alters - | AlterTable (Maybe String) String String TableInfo TableInfo [AlterTable] - -- | Trigger schema, trigger name, table schema, table name - | DropTrigger (Maybe String) String (Maybe String) String - -- | Trigger schema, trigger name, table schema, table name, body - | AddTriggerOnDelete (Maybe String) String (Maybe String) String String - -- | Trigger schema, trigger name, table schema, table name, field name, body - | AddTriggerOnUpdate (Maybe String) String (Maybe String) String (Maybe String) String + -- | Qualified table name, create statement, structure of table from DB, structure of table from datatype, alters + | AlterTable QualifiedName String TableInfo TableInfo [AlterTable] + -- | Qualified trigger name, qualified table name + | DropTrigger QualifiedName QualifiedName + -- | Qualified trigger name, qualified table name, body + | AddTriggerOnDelete QualifiedName QualifiedName String + -- | Qualified trigger name, qualified table name, field name, body + | AddTriggerOnUpdate QualifiedName QualifiedName (Maybe String) String -- | Statement which creates the function | CreateOrReplaceFunction String - -- | Function schema, function name - | DropFunction (Maybe String) String + -- | Qualified function name + | DropFunction QualifiedName -- | Schema name, if not exists | CreateSchema String Bool deriving Show @@ -93,8 +96,8 @@ , compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool , compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool , compareDefaults :: String -> String -> Bool - , migTriggerOnDelete :: Maybe String -> String -> [(String, String)] -> m (Bool, [AlterDB]) - , migTriggerOnUpdate :: Maybe String -> String -> [(String, String)] -> m [(Bool, [AlterDB])] + , migTriggerOnDelete :: QualifiedName -> [(String, String)] -> m (Bool, [AlterDB]) + , migTriggerOnUpdate :: QualifiedName -> [(String, String)] -> m [(Bool, [AlterDB])] , migConstr :: MigrationPack m -> EntityDef -> ConstructorDef -> m (Bool, SingleMigration) , escape :: String -> String , autoincrementedKeyTypeName :: String @@ -120,22 +123,22 @@ mkReferences :: DbTypePrimitive -> (String, DbType) -> [Reference] mkReferences autoKeyType field = concat $ traverseDbType f field where f (DbEmbedded _ ref) cols = maybe [] (return . mkReference cols) ref - f (DbList lName _) cols = [mkReference cols (Right (Nothing, lName, ["id"]), Nothing, Nothing)] + f (DbList lName _) cols = [mkReference cols (Right ((Nothing, lName), ["id"]), Nothing, Nothing)] f (DbTypePrimitive _ _ _ ref) cols = maybe [] (return . mkReference cols) ref mkReference :: [String] -> ParentTableReference -> Reference mkReference cols (parent, onDel, onUpd) = case parent of - Left (e, Nothing) -> Reference (entitySchema e) (entityName e) (zipWith' (,) cols [keyName]) onDel onUpd where + Left (e, Nothing) -> Reference (entitySchema e, entityName e) (zipWith' (,) cols [keyName]) onDel onUpd where keyName = case constructors e of [cDef] -> fromMaybe (error "mkReferences: autokey name is Nothing") $ constrAutoKeyName cDef _ -> "id" - Left (e, (Just uName)) -> Reference (entitySchema e) (entityName e) (zipWith' (,) cols (map colName parentColumns)) onDel onUpd where + Left (e, (Just uName)) -> Reference (entitySchema e, entityName e) (zipWith' (,) cols (map colName parentColumns)) onDel onUpd where cDef = case constructors e of [cDef'] -> cDef' _ -> error "mkReferences: datatype with unique key cannot have more than one constructor" uDef = findOne "unique" uniqueDefName (Just uName) $ constrUniques cDef fields = map (\(fName, _) -> findOne "field" fst fName $ constrParams cDef) $ getUniqueFields uDef parentColumns = foldr (mkColumns autoKeyType) [] fields - Right (sch, table, parentColumns) -> Reference sch table (zipWith' (,) cols parentColumns) onDel onUpd + Right (parentTable, parentColumns) -> Reference parentTable (zipWith' (,) cols parentColumns) onDel onUpd zipWith' _ [] [] = [] zipWith' g (x:xs) (y:ys) = g x y: zipWith' g xs ys zipWith' _ _ _ = error "mkReferences: the lists have different length" @@ -159,7 +162,7 @@ -> (EntityDef -> m SingleMigration) -- ^ migrate entity -> (DbType -> m SingleMigration) -- ^ migrate list -> v -- ^ initial entity - -> StateT NamedMigrations m () + -> Migration m migrateRecursively migS migE migL v = result where result = migEntity $ entityDef proxy v proxy = (undefined :: t m a -> proxy (PhantomDb m)) result @@ -197,14 +200,14 @@ if isSimple constrs then do - x <- analyzeTable (entitySchema e) name + x <- analyzeTable (entitySchema e, name) -- check whether the table was created for multiple constructors before case x of Just old | null $ getAlters m old expectedMainStructure -> return $ Left ["Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " ++ name] _ -> liftM snd $ migConstr m e $ head constrs else do - mainStructure <- analyzeTable (entitySchema e) name + mainStructure <- analyzeTable (entitySchema e, name) let constrTable c = name ++ [delim] ++ constrName c res <- mapM (migConstr m e) constrs return $ case mainStructure of @@ -230,7 +233,7 @@ autoKeyType <- fmap getAutoKeyType phantomDb let valuesName = mainName ++ delim : "values" (valueCols, valueRefs) = (($ []) . mkColumns autoKeyType) &&& mkReferences autoKeyType $ ("value", t) - refs' = Reference Nothing mainName [("id", "id")] (Just Cascade) Nothing : valueRefs + refs' = Reference (Nothing, mainName) [("id", "id")] (Just Cascade) Nothing : valueRefs expectedMainStructure = TableInfo [Column "id" False autoKeyType Nothing] [UniqueDef Nothing (UniquePrimary True) [Left "id"]] [] mainQuery = "CREATE TABLE " ++ escape mainName ++ " (id " ++ autoincrementedKeyTypeName ++ ")" (addInCreate, addInAlters) = addUniquesReferences [] refs' @@ -238,13 +241,13 @@ valueColumns = Column "id" False autoKeyType Nothing : Column "ord" False DbInt32 Nothing : valueCols valuesQuery = "CREATE TABLE " ++ escape valuesName ++ " (" ++ intercalate ", " (map showColumn valueColumns ++ addInCreate) ++ ")" -- TODO: handle case when outer entity has a schema - mainStructure <- analyzeTable Nothing mainName - valuesStructure <- analyzeTable Nothing valuesName + mainStructure <- analyzeTable (Nothing, mainName) + valuesStructure <- analyzeTable (Nothing, valuesName) let triggerMain = [] - (_, triggerValues) <- migTriggerOnDelete Nothing valuesName $ mkDeletes escape ("value", t) + (_, triggerValues) <- migTriggerOnDelete (Nothing, valuesName) $ mkDeletes escape ("value", t) return $ case (mainStructure, valuesStructure) of (Nothing, Nothing) -> let - rest = [AlterTable Nothing valuesName valuesQuery expectedValuesStructure expectedValuesStructure addInAlters] + rest = [AlterTable (Nothing, valuesName) valuesQuery expectedValuesStructure expectedValuesStructure addInAlters] in mergeMigrations $ map showAlterDb $ [AddTable mainQuery, AddTable valuesQuery] ++ rest ++ triggerMain ++ triggerValues (Just mainStructure', Just valuesStructure') -> let f name a b = if null $ getAlters m a b @@ -311,13 +314,12 @@ defaultMigConstr m@MigrationPack{..} e constr = do let simple = isSimple $ constructors e name = entityName e - schema = entitySchema e - cName = if simple then name else name ++ [delim] ++ constrName constr + qualifiedCName = (entitySchema e, if simple then name else name ++ [delim] ++ constrName constr) autoKeyType <- fmap getAutoKeyType phantomDb - tableStructure <- analyzeTable schema cName + tableStructure <- analyzeTable qualifiedCName let dels = concatMap (mkDeletes escape) $ constrParams constr - (triggerExisted, delTrigger) <- migTriggerOnDelete schema cName dels - updTriggers <- liftM (concatMap snd) $ migTriggerOnUpdate schema cName dels + (triggerExisted, delTrigger) <- migTriggerOnDelete qualifiedCName dels + updTriggers <- liftM (concatMap snd) $ migTriggerOnUpdate qualifiedCName dels let (expectedTableStructure, (addTable, addInAlters)) = (case constrAutoKeyName constr of Nothing -> (TableInfo columns uniques (mkRefs refs), f [] columns uniques refs) @@ -326,7 +328,7 @@ then (TableInfo (keyColumn:columns) (uniques ++ [UniqueDef Nothing (UniquePrimary True) [Left keyName]]) (mkRefs refs) , f [escape keyName ++ " " ++ autoincrementedKeyTypeName] columns uniques refs) else let columns' = keyColumn:columns - refs' = refs ++ [Reference schema name [(keyName, mainTableId)] (Just Cascade) Nothing] + refs' = refs ++ [Reference (entitySchema e, name) [(keyName, mainTableId)] (Just Cascade) Nothing] uniques' = uniques ++ [UniqueDef Nothing UniqueConstraint [Left keyName]] in (TableInfo columns' uniques' (mkRefs refs'), f [] columns' uniques' refs')) where (columns, refs) = foldr (mkColumns autoKeyType) [] &&& concatMap (mkReferences autoKeyType) $ constrParams constr @@ -339,18 +341,18 @@ (migErrs, constrExisted, mig) = case tableStructure of Nothing -> let - rest = AlterTable schema cName addTable expectedTableStructure expectedTableStructure addInAlters + rest = AlterTable qualifiedCName addTable expectedTableStructure expectedTableStructure addInAlters in ([], False, [AddTable addTable, rest]) Just oldTableStructure -> let alters = getAlters m oldTableStructure expectedTableStructure alterTable = if null alters then [] - else [AlterTable schema cName addTable oldTableStructure expectedTableStructure alters] + else [AlterTable qualifiedCName addTable oldTableStructure expectedTableStructure alters] in ([], True, alterTable) -- this can happen when an ephemeral field was added. Consider doing something else except throwing an error allErrs = if constrExisted == triggerExisted || (constrExisted && null dels) then migErrs - else ["Both trigger and constructor table must exist: " ++ cName] ++ migErrs + else ["Both trigger and constructor table must exist: " ++ show qualifiedCName] ++ migErrs return $ (constrExisted, if null allErrs then mergeMigrations $ map showAlterDb $ mig ++ delTrigger ++ updTriggers else Left allErrs) @@ -384,16 +386,12 @@ getCurrentSchema :: m (Maybe String) listTables :: Maybe String -- ^ Schema name -> m [String] - listTableTriggers :: Maybe String -- ^ Schema name - -> String -- ^ Table name + listTableTriggers :: QualifiedName -- ^ Qualified table name -> m [String] - analyzeTable :: Maybe String -- ^ Schema name - -> String -- ^ Table name + analyzeTable :: QualifiedName -- ^ Qualified table name -> m (Maybe TableInfo) - analyzeTrigger :: Maybe String -- ^ Schema name - -> String -- ^ Trigger name + analyzeTrigger :: QualifiedName -- ^ Qualified trigger name -> m (Maybe String) - analyzeFunction :: Maybe String -- ^ Schema name - -> String -- ^ Function name - -> m (Maybe String) + analyzeFunction :: QualifiedName -- ^ Qualified function name + -> m (Maybe (Maybe [DbTypePrimitive], Maybe DbTypePrimitive, String)) -- ^ Argument types, return type, and body getMigrationPack :: m (MigrationPack m) diff --git a/Database/Groundhog/Instances.hs b/Database/Groundhog/Instances.hs --- a/Database/Groundhog/Instances.hs +++ b/Database/Groundhog/Instances.hs @@ -14,6 +14,7 @@ import Data.Bits (bitSize) #endif import Data.ByteString.Char8 (ByteString, unpack) +import qualified Data.ByteString.Lazy.Char8 as Lazy import Data.Int (Int8, Int16, Int32, Int64) import Data.Time (Day, TimeOfDay, UTCTime) import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, utc, utcToZonedTime) @@ -121,6 +122,11 @@ fromPrimitivePersistValue _ (PersistByteString a) = a fromPrimitivePersistValue p x = T.encodeUtf8 . T.pack $ fromPrimitivePersistValue p x +instance PrimitivePersistField Lazy.ByteString where + toPrimitivePersistValue _ s = PersistByteString $ Lazy.toStrict s + fromPrimitivePersistValue _ (PersistByteString a) = Lazy.fromStrict a + fromPrimitivePersistValue p x = Lazy.fromStrict . T.encodeUtf8 . T.pack $ fromPrimitivePersistValue p x + instance PrimitivePersistField Int where toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a) fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a @@ -229,13 +235,22 @@ instance NeverNull String instance NeverNull T.Text instance NeverNull ByteString +instance NeverNull Lazy.ByteString instance NeverNull Int +instance NeverNull Int8 +instance NeverNull Int16 +instance NeverNull Int32 instance NeverNull Int64 +instance NeverNull Word8 +instance NeverNull Word16 +instance NeverNull Word32 +instance NeverNull Word64 instance NeverNull Double instance NeverNull Bool instance NeverNull Day instance NeverNull TimeOfDay instance NeverNull UTCTime +instance NeverNull ZonedTime instance PrimitivePersistField (Key v u) => NeverNull (Key v u) instance NeverNull (KeyForBackend db v) @@ -255,6 +270,12 @@ fromPersistValues = primFromPersistValue dbType _ _ = DbTypePrimitive DbBlob False Nothing Nothing +instance PersistField Lazy.ByteString where + persistName _ = "ByteString" + toPersistValues = primToPersistValue + fromPersistValues = primFromPersistValue + dbType _ _ = DbTypePrimitive DbBlob False Nothing Nothing + instance PersistField String where persistName _ = "String" toPersistValues = primToPersistValue @@ -373,7 +394,9 @@ fromPersistValues xs = fromPersistValues xs >>= \(x, xs') -> return (Just x, xs') dbType db a = case dbType db ((undefined :: Maybe a -> a) a) of DbTypePrimitive t _ def ref -> DbTypePrimitive t True def ref - t -> error $ "dbType " ++ persistName a ++ ": expected DbTypePrimitive, got " ++ show t + DbEmbedded (EmbeddedDef concatName [(field, DbTypePrimitive t _ def ref')]) ref -> + DbEmbedded (EmbeddedDef concatName [(field, DbTypePrimitive t True def ref')]) ref + t -> error $ "dbType " ++ persistName a ++ ": expected DbTypePrimitive or DbEmbedded with one field, got " ++ show t instance (PersistField a) => PersistField [a] where persistName a = "List" ++ delim : delim : persistName ((undefined :: [] a -> a) a) diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +0.7.0 +* Removed logger argument from executeMigration and runMigration +* PersistField instance for lazy ByteString + 0.6.0 * Entities without keys. It can be useful for many-to-many tables which hold keys but are not referenced * Entity and fields descriptions are parameterized so that they can be promoted diff --git a/groundhog.cabal b/groundhog.cabal --- a/groundhog.cabal +++ b/groundhog.cabal @@ -1,11 +1,11 @@ name: groundhog -version: 0.6.0 +version: 0.7.0 license: BSD3 license-file: LICENSE author: Boris Lykah maintainer: Boris Lykah synopsis: Type-safe datatype-database mapping library. -description: This library maps your datatypes to a relational model, in a way similar to what ORM libraries do in OOP. The schema can be configured flexibly which makes integration with existing databases easy. Groundhog supports schema migrations, composite keys, advanced expressions in queries, and much more. See tutorial and examples on GitHub. +description: This library maps your datatypes to a relational model, in a way similar to what ORM libraries do in object-oriented programming. The mapping can be configured to work with almost any schema. Groundhog supports schema migrations, composite keys, advanced expressions in queries, and much more. See tutorial and examples on GitHub. category: Database stability: Stable cabal-version: >= 1.6