diff --git a/Database/Groundhog/Postgresql.hs b/Database/Groundhog/Postgresql.hs --- a/Database/Groundhog/Postgresql.hs +++ b/Database/Groundhog/Postgresql.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, MultiParamTypeClasses, TemplateHaskell #-} module Database.Groundhog.Postgresql ( withPostgresqlPool , withPostgresqlConn @@ -18,7 +18,6 @@ import qualified Database.Groundhog.Generic.PersistBackendHelpers as H import qualified Database.PostgreSQL.Simple as PG -import qualified Database.PostgreSQL.Simple.BuiltinTypes as PG import qualified Database.PostgreSQL.Simple.Internal as PG import qualified Database.PostgreSQL.Simple.ToField as PGTF import qualified Database.PostgreSQL.Simple.FromField as PGFF @@ -28,18 +27,18 @@ import Control.Arrow ((***)) import Control.Exception (throw) -import Control.Monad (forM, liftM, liftM2) +import Control.Monad (forM, liftM, liftM2, (>=>)) import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Logger (MonadLogger, logDebugS) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Reader (ask) import Data.ByteString.Char8 (pack, unpack, copy) -import Data.Char (toUpper) -import Data.Either (partitionEithers) +import Data.Char (isAlphaNum, isSpace, toUpper) import Data.Function (on) import Data.Int (Int64) import Data.IORef -import Data.List (groupBy, intercalate) +import Data.List (groupBy, intercalate, stripPrefix) import Data.Maybe (fromJust, fromMaybe) import Data.Monoid import Data.Pool @@ -56,8 +55,7 @@ instance SqlDb Postgresql where append a b = Expr $ operator 50 "||" a b -instance (MonadBaseControl IO m, MonadIO m) => PersistBackend (DbPersist Postgresql m) where - {-# SPECIALIZE instance PersistBackend (DbPersist Postgresql IO) #-} +instance (MonadBaseControl IO m, MonadIO m, MonadLogger m) => PersistBackend (DbPersist Postgresql m) where type PhantomDb (DbPersist Postgresql m) = Postgresql insert v = insert' v insert_ v = insert_' v @@ -82,7 +80,7 @@ insertList l = insertList' l getList k = getList' k -instance (MonadBaseControl IO m, MonadIO m) => SchemaAnalyzer (DbPersist Postgresql m) where +instance (MonadBaseControl IO m, MonadIO m, MonadLogger m) => SchemaAnalyzer (DbPersist Postgresql m) where listTables schema = queryRaw' "SELECT table_name FROM information_schema.tables WHERE table_schema=coalesce(?,current_schema())" [toPrimitivePersistValue proxy schema] (mapAllRows $ return . fst . fromPurePersistValues proxy) listTableTriggers schema name = queryRaw' "SELECT trigger_name FROM information_schema.triggers WHERE event_object_schema=coalesce(?,current_schema()) AND event_object_table=?" [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy) analyzeTable = analyzeTable' @@ -143,8 +141,7 @@ close' :: Postgresql -> IO () close' (Postgresql conn) = PG.close conn -{-# SPECIALIZE insert' :: PersistEntity v => v -> DbPersist Postgresql IO (AutoKey v) #-} -insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Postgresql m (AutoKey v) +insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> DbPersist Postgresql m (AutoKey v) insert' v = do -- constructor number and the rest of the field values vals <- toEntityPersistValues' v @@ -170,8 +167,7 @@ executeRaw' cQuery (vals' []) pureFromPersistValue [rowid] -{-# SPECIALIZE insert_' :: PersistEntity v => v -> DbPersist Postgresql IO () #-} -insert_' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Postgresql m () +insert_' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> DbPersist Postgresql m () insert_' v = do -- constructor number and the rest of the field values vals <- toEntityPersistValues' v @@ -201,7 +197,7 @@ fieldNames = renderFields escapeS fields RenderS placeholders vals' = commasJoin $ map renderPersistValue vals -insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => [a] -> DbPersist Postgresql m Int64 +insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistField a) => [a] -> DbPersist Postgresql m Int64 insertList' (l :: [a]) = do let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a)) k <- queryRaw' ("INSERT INTO " <> escapeS mainName <> " DEFAULT VALUES RETURNING(id)") [] getKey @@ -217,7 +213,7 @@ go 0 l return $ fromPrimitivePersistValue proxy k -getList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => Int64 -> DbPersist Postgresql m [a] +getList' :: forall m a.(MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistField a) => Int64 -> DbPersist Postgresql m [a] getList' k = do let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a)) let valuesName = mainName <> delim' <> "values" @@ -232,9 +228,9 @@ ---------- -executeRaw' :: MonadIO m => Utf8 -> [PersistValue] -> DbPersist Postgresql m () +executeRaw' :: (MonadIO m, MonadLogger m) => Utf8 -> [PersistValue] -> DbPersist Postgresql m () executeRaw' query vals = do - --liftIO $ print $ fromUtf8 query "" + $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals Postgresql conn <- DbPersist ask let stmt = getStatement query liftIO $ do @@ -252,34 +248,34 @@ delim' :: Utf8 delim' = fromChar delim -toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, PersistEntity v) => v -> DbPersist Postgresql m [PersistValue] +toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, PersistEntity v, MonadLogger m) => v -> DbPersist Postgresql m [PersistValue] toEntityPersistValues' = liftM ($ []) . toEntityPersistValues --- MIGRATION -migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> Migration (DbPersist Postgresql m) +migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> Migration (DbPersist Postgresql m) migrate' v = do x <- lift $ queryRaw' "SELECT current_schema()" [] id let schema = fst $ fromPurePersistValues proxy $ fromJust x migrateRecursively (migrateEntity $ migrationPack schema) (migrateList $ migrationPack schema) v -migrationPack :: (MonadBaseControl IO m, MonadIO m) => String -> GM.MigrationPack (DbPersist Postgresql m) +migrationPack :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => String -> GM.MigrationPack (DbPersist Postgresql m) migrationPack currentSchema = GM.MigrationPack compareTypes (compareRefs currentSchema) compareUniqs + compareDefaults migTriggerOnDelete migTriggerOnUpdate GM.defaultMigConstr escape - DbInt64 "SERIAL PRIMARY KEY UNIQUE" - "INT8" mainTableId defaultPriority (\uniques refs -> ([], map AddUnique uniques ++ map AddReference refs)) showColumn showAlterDb + NoAction showColumn :: Column -> String showColumn (Column n nu t def) = concat @@ -293,7 +289,7 @@ Just s -> " DEFAULT " ++ s ] -migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist Postgresql m (Bool, [AlterDB]) +migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> [(String, String)] -> DbPersist Postgresql m (Bool, [AlterDB]) migTriggerOnDelete schema name deletes = do let funcName = name let trigName = name @@ -326,7 +322,7 @@ -- | Table name and a list of field names and according delete statements -- assume that this function is called only for ephemeral fields -migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist Postgresql m [(Bool, [AlterDB])] +migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> [(String, String)] -> DbPersist Postgresql m [(Bool, [AlterDB])] migTriggerOnUpdate schema name dels = forM dels $ \(fieldName, del) -> do let funcName = name ++ delim : fieldName let trigName = name ++ delim : fieldName @@ -351,7 +347,7 @@ else [DropTrigger schema trigName schema name, addTrigger]) return (trigExisted, funcMig ++ trigMig) -analyzeTable' :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> DbPersist Postgresql m (Either [String] (Maybe TableInfo)) +analyzeTable' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> DbPersist Postgresql m (Maybe TableInfo) analyzeTable' schema name = do table <- queryRaw' "SELECT * FROM information_schema.tables WHERE table_schema = coalesce(?, current_schema()) AND table_name = ?" [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] id case table of @@ -368,8 +364,6 @@ \ ORDER BY c.ordinal_position" cols <- queryRaw' colQuery [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . getColumn name . fst . fromPurePersistValues proxy) - let (col_errs, cols') = partitionEithers cols - let constraintQuery = "SELECT u.constraint_name, u.column_name FROM information_schema.table_constraints tc INNER JOIN information_schema.constraint_column_usage u ON tc.constraint_catalog=u.constraint_catalog AND tc.constraint_schema=u.constraint_schema AND tc.constraint_name=u.constraint_name WHERE tc.constraint_type=? AND tc.table_schema=coalesce(?,current_schema()) AND u.table_name=? ORDER BY u.constraint_name, u.column_name" uniqConstraints <- queryRaw' constraintQuery [toPrimitivePersistValue proxy ("UNIQUE" :: String), toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy) @@ -378,16 +372,14 @@ let mkUniqs typ = map (\us -> UniqueDef' (fst $ head us) typ (map snd us)) . groupBy ((==) `on` fst) let uniqs = mkUniqs UniqueConstraint uniqConstraints ++ mkUniqs UniqueIndex uniqIndexes ++ mkUniqs UniquePrimary uniqPrimary references <- analyzeTableReferences schema name - return $ case col_errs of - [] -> Right $ Just $ TableInfo cols' uniqs references - errs -> Left errs - Nothing -> return $ Right Nothing + return $ Just $ TableInfo cols uniqs references + Nothing -> return Nothing -getColumn :: String -> ((String, String, String, Maybe String), (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String), (Int, Maybe String)) -> Either String Column -getColumn _ ((column_name, is_nullable, udt_name, d), modifiers, arr_info) = Right $ Column column_name (is_nullable == "YES") t d where +getColumn :: String -> ((String, String, String, Maybe String), (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String), (Int, Maybe String)) -> Column +getColumn _ ((column_name, is_nullable, udt_name, d), modifiers, arr_info) = Column column_name (is_nullable == "YES") t d where t = readSqlType udt_name modifiers arr_info -analyzeTableReferences :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> DbPersist Postgresql m [(Maybe String, Reference)] +analyzeTableReferences :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> DbPersist Postgresql m [(Maybe String, Reference)] analyzeTableReferences schema tName = do let sql = "SELECT c.conname, sch_parent.nspname, cl_parent.relname, c. confdeltype, c.confupdtype, a_child.attname AS child, a_parent.attname AS parent FROM\ \ (SELECT r.conrelid, r.confrelid, unnest(r.conkey) AS conkey, unnest(r.confkey) AS confkey, r.conname, r.confupdtype, r.confdeltype\ @@ -546,7 +538,7 @@ ]) -- | udt_name, character_maximum_length, numeric_precision, numeric_scale, datetime_precision, interval_type -readSqlType :: String -> (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String) -> (Int, Maybe String) -> DbType +readSqlType :: String -> (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String) -> (Int, Maybe String) -> DbTypePrimitive readSqlType typ (character_maximum_length, numeric_precision, numeric_scale, datetime_precision, _) (array_ndims, array_elem) = (case typ of "int4" -> DbInt32 "int8" -> DbInt64 @@ -570,22 +562,20 @@ defDateTimePrec = 6 datetime_precision' = datetime_precision >>= \p -> if p == defDateTimePrec then Nothing else Just p -showSqlType :: DbType -> String -showSqlType DbString = "VARCHAR" -showSqlType DbInt32 = "INT4" -showSqlType DbInt64 = "INT8" -showSqlType DbReal = "DOUBLE PRECISION" -showSqlType DbBool = "BOOLEAN" -showSqlType DbDay = "DATE" -showSqlType DbTime = "TIME" -showSqlType DbDayTime = "TIMESTAMP" -showSqlType DbDayTimeZoned = "TIMESTAMP WITH TIME ZONE" -showSqlType DbBlob = "BYTEA" -showSqlType (DbOther (OtherTypeDef f)) = f showSqlType -showSqlType (DbMaybe t) = showSqlType t -showSqlType (DbList _ _) = showSqlType DbInt64 -showSqlType (DbEntity Nothing _ _ _) = showSqlType DbInt64 -showSqlType t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t +showSqlType :: DbTypePrimitive -> String +showSqlType t = case t of + DbString -> "VARCHAR" + DbInt32 -> "INT4" + DbInt64 -> "INT8" + DbReal -> "DOUBLE PRECISION" + DbBool -> "BOOLEAN" + DbDay -> "DATE" + DbTime -> "TIME" + DbDayTime -> "TIMESTAMP" + DbDayTimeZoned -> "TIMESTAMP WITH TIME ZONE" + DbBlob -> "BYTEA" + DbOther (OtherTypeDef f) -> f showSqlType + DbAutoKey -> showSqlType DbInt64 compareUniqs :: UniqueDef' -> UniqueDef' -> Bool compareUniqs (UniqueDef' _ UniquePrimary cols1) (UniqueDef' _ UniquePrimary cols2) = haveSameElems (==) cols1 cols2 @@ -602,10 +592,15 @@ && fromMaybe NoAction onUpd1 == fromMaybe NoAction onUpd2 where unescape name = if head name == '"' && last name == '"' then tail $ init name else name -compareTypes :: DbType -> DbType -> Bool +compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool compareTypes type1 type2 = f type1 == f type2 where f = map toUpper . showSqlType +compareDefaults :: String -> String -> Bool +compareDefaults def1 def2 = Just def2 `elem` [Just def1, stripType def1, stripType def1 >>= stripParens] where + stripType = fmap reverse . stripPrefix "::" . dropWhile (\c -> isAlphaNum c || isSpace c) . reverse + stripParens = stripPrefix "(" >=> fmap reverse . stripPrefix ")" . reverse + defaultPriority, referencePriority, functionPriority, triggerPriority :: Int defaultPriority = 0 referencePriority = 1 @@ -624,11 +619,12 @@ getStatement :: Utf8 -> PG.Query getStatement sql = PG.Query $ fromUtf8 sql -queryRawTyped' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a +queryRawTyped' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Utf8 -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a queryRawTyped' query _ vals f = queryRaw' query vals f -queryRaw' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a +queryRaw' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a queryRaw' query vals f = do + $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals Postgresql conn <- DbPersist ask rawquery <- liftIO $ PG.formatQuery conn (getStatement query) (map P vals) -- Take raw connection @@ -657,16 +653,7 @@ cols <- LibPQ.nfields ret getters <- forM [0..cols-1] $ \col -> do oid <- LibPQ.ftype ret col - case PG.oid2builtin oid of - -- TODO: this is a temporary hack until postgresql-simple supports arrays and has more builtin types. Restore fail clause then. - Nothing -> return $ getGetter PG.Unknown $ - PG.Field ret col oid - {- fail $ "Postgresql.withStmt': could not " ++ - "recognize " ++ show oid ++ " of column " ++ - show (let LibPQ.Col i = col in i) ++ - " (counting from zero)" -} - Just bt -> return $ getGetter bt $ - PG.Field ret col oid + return $ getGetter oid $ PG.Field ret col oid -- Ready to go! rowRef <- newIORef (LibPQ.Row 0) rowCount <- LibPQ.ntuples ret @@ -708,35 +695,34 @@ convertPV :: PGFF.FromField a => (a -> b) -> Getter b convertPV f = (fmap f .) . PGFF.fromField --- FIXME: check if those are correct and complete. -getGetter :: PG.BuiltinType -> Getter PersistValue -getGetter PG.Bool = convertPV PersistBool -getGetter PG.ByteA = convertPV (PersistByteString . unBinary) -getGetter PG.Char = convertPV PersistString -getGetter PG.Name = convertPV PersistString -getGetter PG.Int8 = convertPV PersistInt64 -getGetter PG.Int2 = convertPV PersistInt64 -getGetter PG.Int4 = convertPV PersistInt64 -getGetter PG.Text = convertPV PersistString -getGetter PG.Xml = convertPV PersistString -getGetter PG.Float4 = convertPV PersistDouble -getGetter PG.Float8 = convertPV PersistDouble -getGetter PG.AbsTime = convertPV PersistUTCTime -getGetter PG.RelTime = convertPV PersistUTCTime ---getGetter PG.Money = convertPV PersistString -getGetter PG.BpChar = convertPV PersistString -getGetter PG.VarChar = convertPV PersistString -getGetter PG.Date = convertPV PersistDay -getGetter PG.Time = convertPV PersistTimeOfDay -getGetter PG.Timestamp = convertPV (PersistUTCTime . localTimeToUTC utc) -getGetter PG.TimestampTZ = convertPV (PersistZonedTime . ZT) -getGetter PG.Bit = convertPV PersistInt64 -getGetter PG.VarBit = convertPV PersistInt64 -getGetter PG.Numeric = convertPV (PersistDouble . fromRational) -getGetter PG.Void = \_ _ -> return PersistNull -getGetter _ = \f dat -> fmap (PersistByteString . unBinary) $ case dat of - Nothing -> PGFF.returnError PGFF.UnexpectedNull f "" - Just str -> return $ PG.Binary $ copy $ str +getGetter :: PG.Oid -> Getter PersistValue +getGetter (PG.Oid oid) = case oid of + 16 -> convertPV PersistBool + 17 -> convertPV (PersistByteString . unBinary) + 18 -> convertPV PersistString + 19 -> convertPV PersistString + 20 -> convertPV PersistInt64 + 21 -> convertPV PersistInt64 + 23 -> convertPV PersistInt64 + 25 -> convertPV PersistString + 142 -> convertPV PersistString + 700 -> convertPV PersistDouble + 701 -> convertPV PersistDouble + 702 -> convertPV PersistUTCTime + 703 -> convertPV PersistUTCTime + 1042 -> convertPV PersistString + 1043 -> convertPV PersistString + 1082 -> convertPV PersistDay + 1083 -> convertPV PersistTimeOfDay + 1114 -> convertPV (PersistUTCTime . localTimeToUTC utc) + 1184 -> convertPV (PersistZonedTime . ZT) + 1560 -> convertPV PersistInt64 + 1562 -> convertPV PersistInt64 + 1700 -> convertPV (PersistDouble . fromRational) + 2278 -> \_ _ -> return PersistNull + _ -> \f dat -> fmap PersistByteString $ case dat of + Nothing -> PGFF.returnError PGFF.UnexpectedNull f "" + Just str -> return $ copy $ str unBinary :: PG.Binary a -> a unBinary (PG.Binary x) = x diff --git a/Database/Groundhog/Postgresql/Array.hs b/Database/Groundhog/Postgresql/Array.hs --- a/Database/Groundhog/Postgresql/Array.hs +++ b/Database/Groundhog/Postgresql/Array.hs @@ -49,8 +49,11 @@ persistName a = "Array" ++ delim : persistName ((undefined :: Array a -> a) a) toPersistValues = primToPersistValue fromPersistValues = primFromPersistValue - dbType a = DbOther $ OtherTypeDef $ \f -> f elemType ++ "[]" where - elemType = dbType ((undefined :: Array a -> a) a) + dbType a = DbTypePrimitive typ False Nothing Nothing where + typ = DbOther $ OtherTypeDef $ \f -> f elemType ++ "[]" + elemType = case dbType ((undefined :: Array a -> a) a) of + DbTypePrimitive t _ _ _ -> t + t -> error $ "dbType " ++ persistName a ++ ": expected DbTypePrimitive, got " ++ show t class ArrayElem a where -- this function is added to avoid GHC bug 7126 which appears when PrimitivePersistField is added as class constraint @@ -71,14 +74,6 @@ fromPrimitivePersistValue p a = parseHelper parser a where dimensions = char '[' *> takeWhile1 (/= '=') *> char '=' parser = optional dimensions *> parseArr p - -instance (ArrayElem a, PersistField a) => SinglePersistField (Array a) where - toSinglePersistValue = primToSinglePersistValue - fromSinglePersistValue = primFromSinglePersistValue - -instance (ArrayElem a, PersistField a) => PurePersistField (Array a) where - toPurePersistValues = primToPurePersistValues - fromPurePersistValues = primFromPurePersistValues parseString :: Parser ByteString parseString = (char '"' *> jstring_) diff --git a/Database/Groundhog/Postgresql/Geometry.hs b/Database/Groundhog/Postgresql/Geometry.hs --- a/Database/Groundhog/Postgresql/Geometry.hs +++ b/Database/Groundhog/Postgresql/Geometry.hs @@ -41,77 +41,45 @@ points :: Parser [Point] points = point `sepBy1` char ',' -instance PersistField Point where - persistName _ = "Point" - toPersistValues = primToPersistValue - fromPersistValues = primFromPersistValue - dbType _ = DbOther $ OtherTypeDef $ const "point" - instance PrimitivePersistField Point where toPrimitivePersistValue _ (Point x y) = PersistString $ show (x, y) fromPrimitivePersistValue _ = parseHelper point -instance SinglePersistField Point where - toSinglePersistValue = primToSinglePersistValue - fromSinglePersistValue = primFromSinglePersistValue - -instance PurePersistField Point where - toPurePersistValues = primToPurePersistValues - fromPurePersistValues = primFromPurePersistValues - -instance PersistField Line where - persistName _ = "Line" +instance PersistField Point where + persistName _ = "Point" toPersistValues = primToPersistValue fromPersistValues = primFromPersistValue - dbType _ = DbOther $ OtherTypeDef $ const "line" + dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "point") False Nothing Nothing instance PrimitivePersistField Line where toPrimitivePersistValue _ (Line (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2)) fromPrimitivePersistValue _ = error "fromPrimitivePersistValue Line is not supported yet" -instance SinglePersistField Line where - toSinglePersistValue = primToSinglePersistValue - fromSinglePersistValue = primFromSinglePersistValue - -instance PurePersistField Line where - toPurePersistValues = primToPurePersistValues - fromPurePersistValues = primFromPurePersistValues - -instance PersistField Lseg where - persistName _ = "Lseg" +instance PersistField Line where + persistName _ = "Line" toPersistValues = primToPersistValue fromPersistValues = primFromPersistValue - dbType _ = DbOther $ OtherTypeDef $ const "lseg" + dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "line") False Nothing Nothing instance PrimitivePersistField Lseg where toPrimitivePersistValue _ (Lseg (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2)) fromPrimitivePersistValue _ = parseHelper $ pair Lseg '[' ']' point -instance SinglePersistField Lseg where - toSinglePersistValue = primToSinglePersistValue - fromSinglePersistValue = primFromSinglePersistValue - -instance PurePersistField Lseg where - toPurePersistValues = primToPurePersistValues - fromPurePersistValues = primFromPurePersistValues - -instance PersistField Box where - persistName _ = "Box" +instance PersistField Lseg where + persistName _ = "Lseg" toPersistValues = primToPersistValue fromPersistValues = primFromPersistValue - dbType _ = DbOther $ OtherTypeDef $ const "box" + dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "lseg") False Nothing Nothing instance PrimitivePersistField Box where toPrimitivePersistValue _ (Box (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2)) fromPrimitivePersistValue _ = parseHelper $ Box <$> (point <* char ',') <*> point -instance SinglePersistField Box where - toSinglePersistValue = primToSinglePersistValue - fromSinglePersistValue = primFromSinglePersistValue - -instance PurePersistField Box where - toPurePersistValues = primToPurePersistValues - fromPurePersistValues = primFromPurePersistValues +instance PersistField Box where + persistName _ = "Box" + toPersistValues = primToPersistValue + fromPersistValues = primFromPersistValue + dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "box") False Nothing Nothing showPath :: Char -> Char -> [Point] -> ShowS showPath open close [] s = open : close : s @@ -123,12 +91,6 @@ showPoint :: Point -> ShowS showPoint (Point x y) = shows (x, y) -instance PersistField Path where - persistName _ = "Path" - toPersistValues = primToPersistValue - fromPersistValues = primFromPersistValue - dbType _ = DbOther $ OtherTypeDef $ const "path" - instance PrimitivePersistField Path where toPrimitivePersistValue _ path = PersistString $ case path of ClosedPath ps -> showPath '(' ')' ps "" @@ -136,46 +98,28 @@ fromPrimitivePersistValue _ = parseHelper $ path' ClosedPath '(' ')' <|> path' OpenPath '[' ']' where path' f open close = f <$> (char open *> points <* char close) -instance SinglePersistField Path where - toSinglePersistValue = primToSinglePersistValue - fromSinglePersistValue = primFromSinglePersistValue - -instance PurePersistField Path where - toPurePersistValues = primToPurePersistValues - fromPurePersistValues = primFromPurePersistValues - -instance PersistField Polygon where - persistName _ = "Polygon" +instance PersistField Path where + persistName _ = "Path" toPersistValues = primToPersistValue fromPersistValues = primFromPersistValue - dbType _ = DbOther $ OtherTypeDef $ const "polygon" + dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "path") False Nothing Nothing instance PrimitivePersistField Polygon where toPrimitivePersistValue _ (Polygon ps) = PersistString $ showPath '(' ')' ps "" fromPrimitivePersistValue _ = parseHelper $ Polygon <$> (char '(' *> points <* char ')') -instance SinglePersistField Polygon where - toSinglePersistValue = primToSinglePersistValue - fromSinglePersistValue = primFromSinglePersistValue - -instance PurePersistField Polygon where - toPurePersistValues = primToPurePersistValues - fromPurePersistValues = primFromPurePersistValues - -instance PersistField Circle where - persistName _ = "Circle" +instance PersistField Polygon where + persistName _ = "Polygon" toPersistValues = primToPersistValue fromPersistValues = primFromPersistValue - dbType _ = DbOther $ OtherTypeDef $ const "circle" + dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "polygon") False Nothing Nothing instance PrimitivePersistField Circle where toPrimitivePersistValue _ (Circle (Point x1 y1) r) = PersistString $ show ((x1, y1), r) fromPrimitivePersistValue _ = parseHelper $ Circle <$> (char '<' *> point) <* char ',' <*> double <* char '>' -instance SinglePersistField Circle where - toSinglePersistValue = primToSinglePersistValue - fromSinglePersistValue = primFromSinglePersistValue - -instance PurePersistField Circle where - toPurePersistValues = primToPurePersistValues - fromPurePersistValues = primFromPurePersistValues +instance PersistField Circle where + persistName _ = "Circle" + toPersistValues = primToPersistValue + fromPersistValues = primFromPersistValue + dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "circle") False Nothing Nothing diff --git a/groundhog-postgresql.cabal b/groundhog-postgresql.cabal --- a/groundhog-postgresql.cabal +++ b/groundhog-postgresql.cabal @@ -1,5 +1,5 @@ name: groundhog-postgresql -version: 0.3.1 +version: 0.4.0 license: BSD3 license-file: LICENSE author: Boris Lykah @@ -14,16 +14,17 @@ library build-depends: base >= 4 && < 5 , postgresql-simple >= 0.3 && < 0.4 - , postgresql-libpq >= 0.6.1 && < 0.9 + , postgresql-libpq >= 0.6.1 , bytestring >= 0.9 - , blaze-builder >= 0.3.0.0 && < 0.4 - , transformers >= 0.2.1 && < 0.4 - , groundhog >= 0.3.0 && < 0.4.0 - , monad-control >= 0.3 && < 0.4 + , blaze-builder >= 0.3.0.0 + , transformers >= 0.2.1 + , groundhog >= 0.4.0 && < 0.5.0 + , monad-control >= 0.3 + , monad-logger >= 0.3 , containers >= 0.2 - , text >= 0.8 && < 0.12 + , text >= 0.8 , attoparsec >= 0.8.5.3 - , resource-pool >= 0.2.1 && < 0.3 + , resource-pool >= 0.2.1 , time >= 1.1 exposed-modules: Database.Groundhog.Postgresql Database.Groundhog.Postgresql.Array