groundhog-postgresql 0.5.1 → 0.6.0

raw patch · 5 files changed

+79/−53 lines, 5 filesdep ~groundhogPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: groundhog

API changes (from Hackage documentation)

Files

• Database/Groundhog/Postgresql.hs +48/−28
• Database/Groundhog/Postgresql/Array.hs +14/−14
• Database/Groundhog/Postgresql/Geometry.hs +8/−8
• changelog +7/−1
• groundhog-postgresql.cabal +2/−2

@@ -10,6 +10,8 @@     , explicitType     , castType     , distinctOn+    -- other+    , showSqlType     ) where  import Database.Groundhog@@ -30,7 +32,7 @@ import Database.PostgreSQL.Simple.Ok (Ok (..)) import qualified Database.PostgreSQL.LibPQ as LibPQ -import Control.Arrow ((***))+import Control.Arrow ((***), second) import Control.Exception (throw) import Control.Monad (forM, liftM, liftM2, (>=>)) import Control.Monad.IO.Class (MonadIO(..))@@ -111,6 +113,7 @@     case x of       Nothing  -> return Nothing       Just src -> return (fst $ fromPurePersistValues proxy src)+  getMigrationPack = fmap (migrationPack . fromJust) getCurrentSchema  withPostgresqlPool :: (MonadBaseControl IO m, MonadIO m)                    => String -- ^ connection string@@ -166,7 +169,7 @@ insert' v = do   -- constructor number and the rest of the field values   vals <- toEntityPersistValues' v-  let e = entityDef v+  let e = entityDef proxy v   let constructorNum = fromPrimitivePersistValue proxy (head vals)    liftM fst $ if isSimple (constructors e)@@ -192,7 +195,7 @@ insert_' v = do   -- constructor number and the rest of the field values   vals <- toEntityPersistValues' v-  let e = entityDef v+  let e = entityDef proxy v   let constructorNum = fromPrimitivePersistValue proxy (head vals)    if isSimple (constructors e)@@ -212,7 +215,7 @@   query = "INSERT INTO " <> tName <> columnsValues <> returning   (fields, returning) = case constrAutoKeyName c of     Just idName -> (fields', returning') where-      fields' = if withId then (idName, dbType (0 :: Int64)):constrParams c else constrParams c+      fields' = if withId then (idName, dbType proxy (0 :: Int64)):constrParams c else constrParams c       returning' = if withRet then " RETURNING(" <> escapeS (fromString idName) <> ")" else mempty     _           -> (constrParams c, mempty)   columnsValues = case foldr (flatten escapeS) [] fields of@@ -225,7 +228,7 @@   let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))   k <- queryRaw' ("INSERT INTO " <> escapeS mainName <> " DEFAULT VALUES RETURNING(id)") [] getKey   let valuesName = mainName <> delim' <> "values"-  let fields = [("ord", dbType (0 :: Int)), ("value", dbType (undefined :: a))]+  let fields = [("ord", dbType proxy (0 :: Int)), ("value", dbType proxy (undefined :: a))]   let query = "INSERT INTO " <> escapeS valuesName <> "(id," <> renderFields escapeS fields <> ")VALUES(?," <> renderFields (const $ fromChar '?') fields <> ")"   let go :: Int -> [a] -> DbPersist Postgresql m ()       go n (x:xs) = do@@ -240,7 +243,7 @@ getList' k = do   let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))   let valuesName = mainName <> delim' <> "values"-  let value = ("value", dbType (undefined :: a))+  let value = ("value", dbType proxy (undefined :: a))   let query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord"   queryRaw' query [toPrimitivePersistValue proxy k] $ mapAllRows (liftM fst . fromPersistValues) @@ -278,8 +281,7 @@  migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> Migration (DbPersist Postgresql m) migrate' v = do-  schema <- lift getCurrentSchema-  let migPack = migrationPack $ fromJust schema+  migPack <- lift $ getMigrationPack   migrateRecursively (migrateSchema migPack) (migrateEntity migPack) (migrateList migPack) v  migrationPack :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => String -> GM.MigrationPack (DbPersist Postgresql m)@@ -296,9 +298,11 @@   mainTableId   defaultPriority   (\uniques refs -> ([], map AddUnique uniques ++ map AddReference refs))+  showSqlType   showColumn   showAlterDb   NoAction+  NoAction  showColumn :: Column -> String showColumn (Column n nu t def) = concat@@ -390,12 +394,28 @@              uniqConstraints <- queryRaw' constraintQuery [toPrimitivePersistValue proxy ("UNIQUE" :: String), toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)       uniqPrimary <- queryRaw' constraintQuery [toPrimitivePersistValue proxy ("PRIMARY KEY" :: String), toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)-      uniqIndexes <- queryRaw' "SELECT ic.relname, a.attname FROM pg_catalog.pg_attribute a INNER JOIN pg_catalog.pg_class ic ON ic.oid = a.attrelid INNER JOIN pg_catalog.pg_index i ON i.indexrelid = ic.oid INNER JOIN pg_catalog.pg_class tc ON i.indrelid = tc.oid INNER JOIN pg_namespace sch ON sch.oid = tc.relnamespace WHERE sch.nspname = coalesce(?, current_schema()) AND tc.relname = ? AND a.attnum > 0 AND NOT a.attisdropped AND ic.oid NOT IN (SELECT conindid FROM pg_catalog.pg_constraint) AND NOT i.indisprimary AND i.indisunique ORDER BY ic.relname, a.attnum" [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)-      let mkUniqs typ = map (\us -> UniqueDef' (fst $ head us) typ (map snd us)) . groupBy ((==) `on` fst)+      let indexQuery = "SELECT ic.relname,\+\    ta.attname, pg_get_indexdef(i.indexrelid, ia.attnum, true)\+\  FROM pg_catalog.pg_index i\+\  INNER JOIN pg_catalog.pg_class ic ON ic.oid = i.indexrelid\+\  INNER JOIN pg_catalog.pg_class tc ON i.indrelid = tc.oid\+\  INNER JOIN pg_catalog.pg_attribute ia ON ia.attrelid=ic.oid\+\  LEFT JOIN pg_catalog.pg_attribute ta ON ta.attrelid=tc.oid AND NOT ta.attisdropped AND ta.attnum = i.indkey[ia.attnum-1]\+\  INNER JOIN pg_namespace sch ON sch.oid = tc.relnamespace\+\  WHERE sch.nspname = coalesce(?, current_schema())\+\    AND tc.relname = ?\+\    AND ic.oid NOT IN (SELECT conindid FROM pg_catalog.pg_constraint)\+\    AND NOT i.indisprimary\+\    AND i.indisunique\+\  ORDER BY ic.relname, ia.attnum"+      uniqIndexes <- queryRaw' indexQuery [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)+      let mkUniqs typ = map (\us -> UniqueDef (fst $ head us) typ (map snd us)) . groupBy ((==) `on` fst)           isAutoincremented = case filter (\c -> colName c `elem` map snd uniqPrimary) cols of                                 [c] -> colType c `elem` [DbInt32, DbInt64] && maybe False ("nextval" `isPrefixOf`) (colDefault c)                                 _ -> False-      let uniqs = mkUniqs UniqueConstraint uniqConstraints ++ mkUniqs UniqueIndex uniqIndexes ++ mkUniqs (UniquePrimary isAutoincremented) uniqPrimary+      let uniqs = mkUniqs UniqueConstraint (map (second Left) uniqConstraints)+               ++ mkUniqs UniqueIndex (map (second $ \(col, expr) -> maybe (Right expr) Left col) uniqIndexes)+               ++ mkUniqs (UniquePrimary isAutoincremented) (map (second Left) uniqPrimary)       references <- analyzeTableReferences schema name       return $ Just $ TableInfo cols uniqs references     Nothing -> return Nothing@@ -414,10 +434,11 @@ \  INNER JOIN pg_class cl_parent ON cl_parent.oid = c.confrelid\ \  INNER JOIN pg_namespace sch_parent ON sch_parent.oid = cl_parent.relnamespace\ \  INNER JOIN pg_attribute a_child ON a_child.attnum = c.conkey AND a_child.attrelid = c.conrelid\-\  INNER JOIN pg_class cl_child ON cl_child.oid = c.conrelid AND cl_child.relname = ?\-\  INNER JOIN pg_namespace sch_child ON sch_child.oid = cl_child.relnamespace AND sch_child.nspname = coalesce(?, current_schema())\+\  INNER JOIN pg_class cl_child ON cl_child.oid = c.conrelid\+\  INNER JOIN pg_namespace sch_child ON sch_child.oid = cl_child.relnamespace\+\  WHERE sch_child.nspname = coalesce(?, current_schema()) AND cl_child.relname = ?\ \  ORDER BY c.conname"-  x <- queryRaw' sql [toPrimitivePersistValue proxy tName, toPrimitivePersistValue proxy schema] $ mapAllRows (return . fst . fromPurePersistValues proxy)+  x <- queryRaw' sql [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy tName] $ mapAllRows (return . fst . fromPurePersistValues proxy)   -- (refName, ((parentTableSchema, parentTable, onDelete, onUpdate), (childColumn, parentColumn)))   let mkReference xs = (Just refName, Reference parentSchema parentTable pairs (mkAction onDelete) (mkAction onUpdate)) where         pairs = map (snd . snd) xs@@ -458,31 +479,31 @@   , escape name   ])] showAlterTable table (AlterColumn col alts) = map (showAlterColumn table $ colName col) alts-showAlterTable table (AddUnique (UniqueDef' uName UniqueConstraint cols)) = [(False, defaultPriority, concat+showAlterTable table (AddUnique (UniqueDef uName UniqueConstraint cols)) = [(False, defaultPriority, concat   [ "ALTER TABLE "   , table   , " ADD"   , maybe "" ((" CONSTRAINT " ++) . escape) uName   , " UNIQUE("-  , intercalate "," $ map escape cols+  , intercalate "," $ map (either escape id) cols   , ")"   ])]-showAlterTable table (AddUnique (UniqueDef' uName UniqueIndex cols)) = [(False, defaultPriority, concat+showAlterTable table (AddUnique (UniqueDef uName UniqueIndex cols)) = [(False, defaultPriority, concat   [ "CREATE UNIQUE INDEX "-  , maybe (error $ "showAlterTable: index for table " ++ table ++ " does not have a name") escape uName+  , maybe "" escape uName   , " ON "   , table   , "("-  , intercalate "," $ map escape cols+  , intercalate "," $ map (either escape id) cols   , ")"   ])]-showAlterTable table (AddUnique (UniqueDef' uName (UniquePrimary _) cols)) = [(False, defaultPriority, concat+showAlterTable table (AddUnique (UniqueDef uName (UniquePrimary _) cols)) = [(False, defaultPriority, concat   [ "ALTER TABLE "   , table   , " ADD"   , maybe "" ((" CONSTRAINT " ++) . escape) uName   , " PRIMARY KEY("-  , intercalate "," $ map escape cols+  , intercalate "," $ map (either escape id) cols   , ")"   ])] showAlterTable table (DropConstraint uName) = [(False, defaultPriority, concat@@ -583,7 +604,7 @@   _ | array_ndims > 0 -> dbOther $ arr ++ concat (replicate array_ndims "[]") where     arr = fromMaybe (error "readSqlType: array with elem type Nothing") array_elem   a -> dbOther a) where-    dbOther = DbOther . OtherTypeDef . const+    dbOther t = DbOther $ OtherTypeDef [Left t]     wrap x = "(" ++ x ++ ")"     mkDate t name = maybe t (dbOther . (name++) . wrap . show) datetime_precision'     defDateTimePrec = 6@@ -601,12 +622,11 @@   DbDayTime -> "TIMESTAMP"   DbDayTimeZoned -> "TIMESTAMP WITH TIME ZONE"   DbBlob -> "BYTEA"-  DbOther (OtherTypeDef f) -> f showSqlType-  DbAutoKey -> showSqlType DbInt64+  DbOther (OtherTypeDef ts) -> concatMap (either id showSqlType) ts -compareUniqs :: UniqueDef' -> UniqueDef' -> Bool-compareUniqs (UniqueDef' _ (UniquePrimary _) cols1) (UniqueDef' _ (UniquePrimary _) cols2) = haveSameElems (==) cols1 cols2-compareUniqs (UniqueDef' name1 type1 cols1) (UniqueDef' name2 type2 cols2) = fromMaybe True (liftM2 (==) name1 name2) && type1 == type2 && haveSameElems (==) cols1 cols2+compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool+compareUniqs (UniqueDef _ (UniquePrimary _) cols1) (UniqueDef _ (UniquePrimary _) cols2) = haveSameElems (==) cols1 cols2+compareUniqs (UniqueDef name1 type1 cols1) (UniqueDef name2 type2 cols2) = fromMaybe True (liftM2 (==) name1 name2) && type1 == type2 && haveSameElems (==) cols1 cols2  compareRefs :: String -> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool compareRefs currentSchema (_, Reference sch1 tbl1 pairs1 onDel1 onUpd1) (_, Reference sch2 tbl2 pairs2 onDel2 onUpd2) =@@ -761,7 +781,7 @@ -- Also a value entered as an external string (geometry, arrays and other complex types have this representation) may need an explicit type.  explicitType :: (Expression Postgresql r a, PersistField a) => a -> Expr Postgresql r a explicitType a = castType a t where-  t = case dbType a of+  t = case dbType proxy a of     DbTypePrimitive t' _ _ _ -> showSqlType t'     _ -> error "explicitType: type is not primitive" 

@@ -45,32 +45,32 @@ -- | Represents PostgreSQL arrays
 newtype Array a = Array [a] deriving (Eq, Show)
 
-instance (ArrayElem a, PersistField a) => PersistField (Array a) where
+instance (ArrayElem a, PrimitivePersistField a) => PersistField (Array a) where
   persistName a = "Array" ++ delim : persistName ((undefined :: Array a -> a) a)
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  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
+  dbType p a = DbTypePrimitive (arrayType p a) False Nothing Nothing
 
+arrayType :: (DbDescriptor db, ArrayElem a, PrimitivePersistField a) => proxy db -> Array a -> DbTypePrimitive
+arrayType p a = DbOther $ OtherTypeDef $ [Right elemType, Left "[]"] where
+  elemType = case dbType p ((undefined :: Array a -> a) a) of
+    DbTypePrimitive t _ _ _ -> t
+    t -> error $ "arrayType " ++ 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
-  toElem :: DbDescriptor db => proxy db -> a -> PersistValue
   parseElem :: DbDescriptor db => proxy db -> Parser a
 
 instance ArrayElem a => ArrayElem (Array a) where
-  toElem p (Array xs) = PersistCustom ("ARRAY[" <> query <> fromChar ']') (vals []) where
-    RenderS query vals = commasJoin $ map (renderPersistValue . toElem p) xs
   parseElem = parseArr
 
 instance PrimitivePersistField a => ArrayElem a where
-  toElem = toPrimitivePersistValue
-  parseElem p = parseString >>= (return . fromPrimitivePersistValue p . PersistByteString)
+  parseElem p = fmap (fromPrimitivePersistValue p . PersistByteString) parseString
 
-instance (ArrayElem a, PersistField a) => PrimitivePersistField (Array a) where
-  toPrimitivePersistValue = toElem
+instance (ArrayElem a, PrimitivePersistField a) => PrimitivePersistField (Array a) where
+  toPrimitivePersistValue p (Array xs) = PersistCustom arr (vals []) where
+    arr = "ARRAY[" <> query <> "]::" <> fromString typ
+    RenderS query vals = commasJoin $ map (renderPersistValue . toPrimitivePersistValue p) xs
+    typ = showSqlType $ arrayType p $ Array xs
   fromPrimitivePersistValue p a = parseHelper parser a where
     dimensions = char '[' *> takeWhile1 (/= '=') *> char '='
     parser = optional dimensions *> parseArr p

@@ -45,7 +45,7 @@ import Database.Groundhog.Instances ()
 
 import Control.Applicative
-import Data.Attoparsec.Char8
+import Data.Attoparsec.ByteString.Char8
 
 data Point = Point Double Double deriving (Eq, Show)
 -- | It is not fully implemented in PostgreSQL yet. It is kept just to match all geometric types.
@@ -80,7 +80,7 @@   persistName _ = "Point"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "point") False Nothing Nothing
+  dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "point"]) False Nothing Nothing
 
 instance PrimitivePersistField Line where
   toPrimitivePersistValue _ (Line (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2))
@@ -90,7 +90,7 @@   persistName _ = "Line"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "line") False Nothing Nothing
+  dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "line"]) False Nothing Nothing
 
 instance PrimitivePersistField Lseg where
   toPrimitivePersistValue _ (Lseg (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2))
@@ -100,7 +100,7 @@   persistName _ = "Lseg"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "lseg") False Nothing Nothing
+  dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "lseg"]) False Nothing Nothing
 
 instance PrimitivePersistField Box where
   toPrimitivePersistValue _ (Box (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2))
@@ -110,7 +110,7 @@   persistName _ = "Box"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "box") False Nothing Nothing
+  dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "box"]) False Nothing Nothing
 
 showPath :: Char -> Char -> [Point] -> ShowS
 showPath open close []     s = open : close : s
@@ -133,7 +133,7 @@   persistName _ = "Path"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "path") False Nothing Nothing
+  dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "path"]) False Nothing Nothing
 
 instance PrimitivePersistField Polygon where
   toPrimitivePersistValue _ (Polygon ps) = PersistString $ showPath '(' ')' ps ""
@@ -143,7 +143,7 @@   persistName _ = "Polygon"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "polygon") False Nothing Nothing
+  dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "polygon"]) False Nothing Nothing
 
 instance PrimitivePersistField Circle where
   toPrimitivePersistValue _ (Circle (Point x1 y1) r) = PersistString $ show ((x1, y1), r)
@@ -153,7 +153,7 @@   persistName _ = "Circle"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "circle") False Nothing Nothing
+  dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "circle"]) False Nothing Nothing
 
 class BoxLineLseg a
 instance BoxLineLseg Box

@@ -1,6 +1,12 @@+0.6.0+* Entity and fields descriptions are parameterized so that they can be promoted+* Entity and fields descriptions are dependent on database proxy. It allows to use different types depending on a database, for example, the same type can be array[] in PostgreSQL and varchar elsewhere+* Migration support for indexes on expressions+* Array literals don't need explicit casting anymore+ 0.5.1 * DISTINCT ON select option-* Add getCurrentSchema function into SchemaAnalyzer+* Added getCurrentSchema function into SchemaAnalyzer  0.5.0 * Simplified Geometry and Array function type signatures

@@ -1,5 +1,5 @@ name:            groundhog-postgresql-version:         0.5.1+version:         0.6.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>@@ -21,7 +21,7 @@                    , bytestring               >= 0.9                    , blaze-builder            >= 0.3.0.0   && < 0.4                    , transformers             >= 0.2.1     && < 0.5-                   , groundhog                >= 0.5.0     && < 0.6.0+                   , groundhog                >= 0.6       && < 0.7                    , monad-control            >= 0.3       && < 0.4                    , monad-logger             >= 0.3                    , containers               >= 0.2