groundhog-postgresql 0.2.0 → 0.3.0

raw patch · 5 files changed

+605/−272 lines, 5 filesdep +attoparsecdep +blaze-builderdep +resource-pooldep −pool-conduitdep ~groundhogPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, blaze-builder, resource-pool

Dependencies removed: pool-conduit

Dependency ranges changed: groundhog

API changes (from Hackage documentation)

Files

• Database/Groundhog/Generic/Sql/String.hs +0/−40
• Database/Groundhog/Postgresql.hs +292/−228
• Database/Groundhog/Postgresql/Array.hs +181/−0
• Database/Groundhog/Postgresql/Geometry.hs +125/−0
• groundhog-postgresql.cabal +7/−4

@@ -1,40 +0,0 @@-module Database.Groundhog.Generic.Sql.String-    ( module Database.Groundhog.Generic.Sql-    , StringS (..)-    ) where--import Database.Groundhog.Core-import Database.Groundhog.Generic.Sql-import Data.Monoid-import Data.String--newtype StringS = StringS { fromStringS :: ShowS }--instance Monoid StringS where-  mempty = StringS id-  (StringS s1) `mappend` (StringS s2) = StringS (s1 . s2)--instance IsString StringS where-  fromString s = StringS (s++)--instance StringLike StringS where-  fromChar c = StringS (c:)--{-# SPECIALIZE (<>) :: RenderS StringS -> RenderS StringS -> RenderS StringS #-}--{-# SPECIALIZE renderArith :: (PersistEntity v, Constructor c, DbDescriptor db) => Proxy db -> (StringS -> StringS) -> Arith v c a -> RenderS StringS #-}--{-# SPECIALIZE renderCond :: (PersistEntity v, Constructor c, DbDescriptor db)-  => Proxy db-  -> (StringS -> StringS)-  -> (StringS -> StringS -> StringS)-  -> (StringS -> StringS -> StringS)-  -> Cond v c -> Maybe (RenderS StringS) #-}--{-# SPECIALIZE renderOrders :: (PersistEntity v, Constructor c) => (StringS -> StringS) -> [Order v c] -> StringS #-}--{-# SPECIALIZE renderUpdates :: (PersistEntity v, Constructor c, DbDescriptor db) => Proxy db -> (StringS -> StringS) -> [Update v c] -> Maybe (RenderS StringS) #-}--{-# SPECIALIZE renderFields :: (StringS -> StringS) -> [(String, DbType)] -> StringS #-}--{-# SPECIALIZE renderChain :: (StringS -> StringS) -> FieldChain -> [StringS] -> [StringS] #-}

@@ -1,11 +1,11 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, MultiParamTypeClasses #-} module Database.Groundhog.Postgresql     ( withPostgresqlPool     , withPostgresqlConn-    , runPostgresqlPool-    , runPostgresqlConn+    , runDbConn     , Postgresql     , module Database.Groundhog+    , module Database.Groundhog.Generic.Sql.Functions     ) where  import Database.Groundhog@@ -13,7 +13,8 @@ import Database.Groundhog.Generic import Database.Groundhog.Generic.Migration hiding (MigrationPack(..)) import qualified Database.Groundhog.Generic.Migration as GM-import Database.Groundhog.Generic.Sql.String+import Database.Groundhog.Generic.Sql+import Database.Groundhog.Generic.Sql.Functions import qualified Database.Groundhog.Generic.PersistBackendHelpers as H  import qualified Database.PostgreSQL.Simple as PG@@ -29,34 +30,40 @@ import Control.Exception (throw) import Control.Monad (forM, liftM, liftM2) import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Reader (ask) import Data.ByteString.Char8 (ByteString, pack, unpack, copy)+import Data.Char (toUpper) import Data.Either (partitionEithers) import Data.Function (on) import Data.Int (Int64) import Data.IORef import Data.List (groupBy, intercalate)+import Data.Maybe (fromJust, fromMaybe) import Data.Monoid-import Data.Conduit.Pool-import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import Data.Pool import Data.Time.LocalTime (localTimeToUTC, utc)-import System.IO.Unsafe (unsafePerformIO)  -- typical operations for connection: OPEN, BEGIN, COMMIT, ROLLBACK, CLOSE newtype Postgresql = Postgresql PG.Connection  instance DbDescriptor Postgresql where   type AutoKeyType Postgresql = Int64+  type QueryRaw Postgresql = Snippet Postgresql+  backendName _ = "postgresql" +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) #-}   type PhantomDb (DbPersist Postgresql m) = Postgresql   insert v = insert' v+  insert_ v = insert_' v   insertBy u v = H.insertBy escapeS queryRawTyped' u v   insertByAll v = H.insertByAll escapeS queryRawTyped' v-  replace k v = H.replace escapeS queryRawTyped' executeRaw' insertIntoConstructorTable k v+  replace k v = H.replace escapeS queryRawTyped' executeRaw' (insertIntoConstructorTable False) k v   select options = H.select escapeS queryRawTyped' "" renderCond' options   selectAll = H.selectAll escapeS queryRawTyped'   get k = H.get escapeS queryRawTyped' k@@ -75,35 +82,58 @@   insertList l = insertList' l   getList k = getList' k +instance (MonadBaseControl IO m, MonadIO 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'+  analyzeTrigger schema name = do+    x <- queryRaw' "SELECT action_statement FROM information_schema.triggers WHERE trigger_schema=coalesce(?,current_schema()) AND trigger_name=?" [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] id+    case x of+      Nothing  -> return Nothing+      Just src -> return (fst $ fromPurePersistValues proxy src)+  analyzeFunction schema name = do+    x <- queryRaw' "SELECT p.prosrc FROM pg_catalog.pg_namespace n INNER JOIN pg_catalog.pg_proc p ON p.pronamespace = n.oid WHERE n.nspname = coalesce(?,current_schema()) AND p.proname = ?" [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] id+    case x of+      Nothing  -> return Nothing+      Just src -> return (fst $ fromPurePersistValues proxy src)+ --{-# SPECIALIZE withPostgresqlPool :: String -> Int -> (Pool Postgresql -> IO a) -> IO a #-} withPostgresqlPool :: (MonadBaseControl IO m, MonadIO m)-               => String+               => String -- ^ connection string                -> Int -- ^ number of connections to open                -> (Pool Postgresql -> m a)                -> m a withPostgresqlPool s connCount f = liftIO (createPool (open' s) close' 1 20 connCount) >>= f  {-# SPECIALIZE withPostgresqlConn :: String -> (Postgresql -> IO a) -> IO a #-}-{-# INLINE withPostgresqlConn #-} withPostgresqlConn :: (MonadBaseControl IO m, MonadIO m)-               => String+               => String -- ^ connection string                -> (Postgresql -> m a)                -> m a withPostgresqlConn s = bracket (liftIO $ open' s) (liftIO . close') -{-# SPECIALIZE runPostgresqlPool :: DbPersist Postgresql IO a -> Pool Postgresql -> IO a #-}-runPostgresqlPool :: (MonadBaseControl IO m, MonadIO m) => DbPersist Postgresql m a -> Pool Postgresql -> m a-runPostgresqlPool f pconn = withResource pconn $ runPostgresqlConn f+instance Savepoint Postgresql where+  withConnSavepoint name m (Postgresql c) = do+    let name' = fromString name+    liftIO $ PG.execute_ c $ "SAVEPOINT " <> name'+    x <- onException m (liftIO $ PG.execute_ c $ "ROLLBACK TO SAVEPOINT " <> name')+    liftIO $ PG.execute_ c $ "RELEASE SAVEPOINT" <> name'+    return x -{-# SPECIALIZE runPostgresqlConn :: DbPersist Postgresql IO a -> Postgresql -> IO a #-}-{-# INLINE runPostgresqlConn #-}-runPostgresqlConn :: (MonadBaseControl IO m, MonadIO m) => DbPersist Postgresql m a -> Postgresql -> m a-runPostgresqlConn f conn@(Postgresql c) = do-  liftIO $ PG.begin c-  x <- onException (runDbPersist f conn) (liftIO $ PG.rollback c)-  liftIO $ PG.commit c-  return x+instance ConnectionManager Postgresql Postgresql where+  withConn f conn@(Postgresql c) = do+    liftIO $ PG.begin c+    x <- onException (f conn) (liftIO $ PG.rollback c)+    liftIO $ PG.commit c+    return x+  withConnNoTransaction f conn = f conn +instance ConnectionManager (Pool Postgresql) Postgresql where+  withConn f pconn = withResource pconn (withConn f)+  withConnNoTransaction f pconn = withResource pconn (withConnNoTransaction f)++instance SingleConnectionManager Postgresql Postgresql+ open' :: String -> IO Postgresql open' s = do   conn <- PG.connectPostgreSQL $ pack s@@ -114,43 +144,62 @@ close' (Postgresql conn) = PG.close conn  {-# SPECIALIZE insert' :: PersistEntity v => v -> DbPersist Postgresql IO (AutoKey v) #-}-{-# INLINE insert' #-} insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Postgresql m (AutoKey v) insert' v = do   -- constructor number and the rest of the field values   vals <- toEntityPersistValues' v   let e = entityDef v-  let name = persistName v   let constructorNum = fromPrimitivePersistValue proxy (head vals)    liftM fst $ if isSimple (constructors e)     then do       let constr = head $ constructors e-      let query = insertIntoConstructorTable False name constr+      let RenderS query vals' = insertIntoConstructorTable True False (tableName escapeS e constr) constr (tail vals)       case constrAutoKeyName constr of-        Nothing -> executeRaw' query (tail vals) >> pureFromPersistValue []+        Nothing -> executeRaw' query (vals' []) >> pureFromPersistValue []         Just _  -> do-          x <- queryRaw' query (tail vals) id+          x <- queryRaw' query (vals' []) id           case x of             Just xs -> pureFromPersistValue xs             Nothing -> pureFromPersistValue []     else do       let constr = constructors e !! constructorNum-      let cName = name ++ [delim] ++ constrName constr-      let query = "INSERT INTO " <> escapeS (fromString name) <> "(discr)VALUES(?)RETURNING(id)"+      let query = "INSERT INTO " <> mainTableName escapeS e <> "(discr)VALUES(?)RETURNING(id)"       rowid <- queryRaw' query (take 1 vals) getKey-      let cQuery = insertIntoConstructorTable True cName constr-      executeRaw' cQuery $ rowid:(tail vals)+      let RenderS cQuery vals' = insertIntoConstructorTable False True (tableName escapeS e constr) constr (rowid:tail vals)+      executeRaw' cQuery (vals' [])       pureFromPersistValue [rowid] -insertIntoConstructorTable :: Bool -> String -> ConstructorDef -> StringS-insertIntoConstructorTable withId tName c = "INSERT INTO " <> escapeS (fromString tName) <> "(" <> fieldNames <> ")VALUES(" <> placeholders <> ")" <> returning where+{-# SPECIALIZE insert_' :: PersistEntity v => v -> DbPersist Postgresql IO () #-}+insert_' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Postgresql m ()+insert_' v = do+  -- constructor number and the rest of the field values+  vals <- toEntityPersistValues' v+  let e = entityDef v+  let constructorNum = fromPrimitivePersistValue proxy (head vals)++  if isSimple (constructors e)+    then do+      let constr = head $ constructors e+      let RenderS query vals' = insertIntoConstructorTable False False (tableName escapeS e constr) constr (tail vals)+      executeRaw' query (vals' [])+    else do+      let constr = constructors e !! constructorNum+      let query = "INSERT INTO " <> mainTableName escapeS e <> "(discr)VALUES(?)RETURNING(id)"+      rowid <- queryRaw' query (take 1 vals) getKey+      let RenderS cQuery vals' = insertIntoConstructorTable False True (tableName escapeS e constr) constr (rowid:tail vals)+      executeRaw' cQuery (vals' [])++insertIntoConstructorTable :: Bool -> Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r+insertIntoConstructorTable withRet withId tName c vals = RenderS query vals' where+  query = "INSERT INTO " <> tName <> "(" <> fieldNames <> ")VALUES(" <> placeholders <> ")" <> returning   (fields, returning) = case constrAutoKeyName c of-    Just idName | withId    -> ((idName, dbType (0 :: Int64)):constrParams c, mempty)-                | otherwise -> (constrParams c, "RETURNING(" <> escapeS (fromString idName) <> ")")-    _                       -> (constrParams c, mempty)+    Just idName -> (fields', returning') where+      fields' = if withId then (idName, dbType (0 :: Int64)):constrParams c else constrParams c+      returning' = if withRet then "RETURNING(" <> escapeS (fromString idName) <> ")" else mempty+    _           -> (constrParams c, mempty)   fieldNames   = renderFields escapeS fields-  placeholders = renderFields (const $ fromChar '?') 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' (l :: [a]) = do@@ -183,24 +232,24 @@  ---------- -executeRaw' :: MonadIO m => StringS -> [PersistValue] -> DbPersist Postgresql m ()+executeRaw' :: MonadIO m => Utf8 -> [PersistValue] -> DbPersist Postgresql m () executeRaw' query vals = do-  --liftIO $ print $ fromStringS query ""+  --liftIO $ print $ fromUtf8 query ""   Postgresql conn <- DbPersist ask   let stmt = getStatement query   liftIO $ do     _ <- PG.execute conn stmt (map P vals)     return () -renderCond' :: (PersistEntity v, Constructor c) => Cond v c -> Maybe (RenderS StringS)-renderCond' = renderCond proxy escapeS renderEquals renderNotEquals where+renderCond' :: Cond Postgresql r -> Maybe (RenderS Postgresql r)+renderCond' = renderCond escapeS renderEquals renderNotEquals where   renderEquals a b = a <> " IS NOT DISTINCT FROM " <> b   renderNotEquals a b = a <> " IS DISTINCT FROM " <> b -escapeS :: StringS -> StringS+escapeS :: Utf8 -> Utf8 escapeS a = let q = fromChar '"' in q <> a <> q -delim' :: StringS+delim' :: Utf8 delim' = fromChar delim  toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, PersistEntity v) => v -> DbPersist Postgresql m [PersistValue]@@ -209,18 +258,21 @@ --- MIGRATION  migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> Migration (DbPersist Postgresql m)-migrate' = migrateRecursively (migrateEntity migrationPack) (migrateList migrationPack)+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) => GM.MigrationPack (DbPersist Postgresql m)-migrationPack = GM.MigrationPack+migrationPack :: (MonadBaseControl IO m, MonadIO m) => String -> GM.MigrationPack (DbPersist Postgresql m)+migrationPack currentSchema = GM.MigrationPack   compareTypes-  compareRefs+  (compareRefs currentSchema)   compareUniqs-  checkTable   migTriggerOnDelete   migTriggerOnUpdate   GM.defaultMigConstr   escape+  DbInt64   "SERIAL PRIMARY KEY UNIQUE"   "INT8"   mainTableId@@ -241,240 +293,249 @@         Just s  -> " DEFAULT " ++ s     ] -checkFunction :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Postgresql m (Maybe String)-checkFunction name = do-  x <- queryRaw' "SELECT p.prosrc FROM pg_catalog.pg_namespace n INNER JOIN pg_catalog.pg_proc p ON p.pronamespace = n.oid WHERE n.nspname = 'public' AND p.proname = ?" [toPrimitivePersistValue proxy name] id-  case x of-    Nothing  -> return Nothing-    Just src -> return (fst $ fromPurePersistValues proxy src)--checkTrigger :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Postgresql m (Maybe String)-checkTrigger name = do-  x <- queryRaw' "SELECT action_statement FROM information_schema.triggers WHERE trigger_name = ?" [toPrimitivePersistValue proxy name] id-  case x of-    Nothing  -> return Nothing-    Just src -> return (fst $ fromPurePersistValues proxy src)---- it handles only delete operations. So far when list or tuple replace is not allowed, it is ok-migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m) => String -> [(String, String)] -> DbPersist Postgresql m (Bool, [AlterDB])-migTriggerOnDelete name deletes = do+migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist Postgresql m (Bool, [AlterDB])+migTriggerOnDelete schema name deletes = do   let funcName = name   let trigName = name-  func <- checkFunction funcName-  trig <- checkTrigger trigName+  func <- analyzeFunction schema funcName+  trig <- analyzeTrigger schema trigName   let funcBody = "BEGIN " ++ concatMap snd deletes ++ "RETURN NEW;END;"-      addFunction = CreateOrReplaceFunction $ "CREATE OR REPLACE FUNCTION " ++ escape funcName ++ "() RETURNS trigger AS $$" ++ funcBody ++ "$$ LANGUAGE plpgsql"+      addFunction = CreateOrReplaceFunction $ "CREATE OR REPLACE FUNCTION " ++ withSchema schema funcName ++ "() RETURNS trigger AS $$" ++ funcBody ++ "$$ LANGUAGE plpgsql"       funcMig = case func of         Nothing | null deletes -> []         Nothing   -> [addFunction]         Just body -> if null deletes -- remove old trigger if a datatype earlier had fields of ephemeral types-          then [DropFunction funcName]+          then [DropFunction schema funcName]           else if body == funcBody             then []             -- this can happen when an ephemeral field was added or removed.-            else [DropFunction funcName, addFunction]+            else [DropFunction schema funcName, addFunction] -      trigBody = "EXECUTE PROCEDURE " ++ escape funcName ++ "()"-      addTrigger = AddTriggerOnDelete trigName name trigBody+      trigBody = "EXECUTE PROCEDURE " ++ withSchema schema funcName ++ "()"+      addTrigger = AddTriggerOnDelete schema trigName schema name trigBody       (trigExisted, trigMig) = case trig of         Nothing | null deletes -> (False, [])         Nothing   -> (False, [addTrigger])         Just body -> (True, if null deletes -- remove old trigger if a datatype earlier had fields of ephemeral types-          then [DropTrigger trigName name]+          then [DropTrigger schema trigName schema name]           else if body == trigBody             then []             -- this can happen when an ephemeral field was added or removed.-            else [DropTrigger trigName name, addTrigger])+            else [DropTrigger schema trigName schema name, addTrigger])   return (trigExisted, funcMig ++ trigMig)        -- | 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) => String -> String -> String -> DbPersist Postgresql m (Bool, [AlterDB])-migTriggerOnUpdate name fieldName del = do+migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO 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-  func <- checkFunction funcName-  trig <- checkTrigger trigName+  func <- analyzeFunction schema funcName+  trig <- analyzeTrigger schema trigName   let funcBody = "BEGIN " ++ del ++ "RETURN NEW;END;"-      addFunction = CreateOrReplaceFunction $ "CREATE OR REPLACE FUNCTION " ++ escape funcName ++ "() RETURNS trigger AS $$" ++ funcBody ++ "$$ LANGUAGE plpgsql"+      addFunction = CreateOrReplaceFunction $ "CREATE OR REPLACE FUNCTION " ++ withSchema schema funcName ++ "() RETURNS trigger AS $$" ++ funcBody ++ "$$ LANGUAGE plpgsql"       funcMig = case func of         Nothing   -> [addFunction]         Just body -> if body == funcBody             then []             -- this can happen when an ephemeral field was added or removed.-            else [DropFunction funcName, addFunction]+            else [DropFunction schema funcName, addFunction] -      trigBody = "EXECUTE PROCEDURE " ++ escape funcName ++ "()"-      addTrigger = AddTriggerOnUpdate trigName name fieldName trigBody+      trigBody = "EXECUTE PROCEDURE " ++ withSchema schema funcName ++ "()"+      addTrigger = AddTriggerOnUpdate schema trigName schema name (Just fieldName) trigBody       (trigExisted, trigMig) = case trig of         Nothing   -> (False, [addTrigger])         Just body -> (True, if body == trigBody             then []             -- this can happen when an ephemeral field was added or removed.-            else [DropTrigger trigName name, addTrigger])+            else [DropTrigger schema trigName schema name, addTrigger])   return (trigExisted, funcMig ++ trigMig)   -checkTable :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Postgresql m (Maybe (Either [String] TableInfo))-checkTable name = do-  table <- queryRaw' "SELECT * FROM information_schema.tables WHERE table_name=?" [toPrimitivePersistValue proxy name] id+analyzeTable' :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> DbPersist Postgresql m (Either [String] (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     Just _ -> do       -- omit primary keys-      cols <- queryRaw' "SELECT c.column_name, c.is_nullable, c.udt_name, c.character_maximum_length, c.numeric_precision, c.numeric_scale, c.datetime_precision, c.interval_type, c.column_default FROM information_schema.columns c WHERE c.table_name=? AND c.column_name NOT IN (SELECT c.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 INNER JOIN information_schema.columns c ON u.table_catalog=c.table_catalog AND u.table_schema=c.table_schema AND u.table_name=c.table_name AND u.column_name=c.column_name WHERE tc.constraint_type='PRIMARY KEY' AND tc.table_name=?) ORDER BY c.ordinal_position" [toPrimitivePersistValue proxy name, toPrimitivePersistValue proxy name] (mapAllRows $ return . getColumn name . fst . fromPurePersistValues proxy)+      let colQuery = "SELECT c.column_name, c.is_nullable, c.udt_name, c.column_default, c.character_maximum_length, c.numeric_precision, c.numeric_scale, c.datetime_precision, c.interval_type, a.attndims AS array_dims, te.typname AS array_elem\+\  FROM pg_catalog.pg_attribute a\+\  INNER JOIN pg_catalog.pg_class cl ON cl.oid = a.attrelid\+\  INNER JOIN pg_catalog.pg_namespace n ON n.oid = cl.relnamespace\+\  INNER JOIN information_schema.columns c ON c.column_name = a.attname AND c.table_name = cl.relname AND c.table_schema = n.nspname\+\  INNER JOIN pg_catalog.pg_type t ON t.oid = a.atttypid\+\  LEFT JOIN pg_catalog.pg_type te ON te.oid = t.typelem\+\  WHERE c.table_schema = coalesce(?, current_schema()) AND c.table_name=?\+\  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       -      uniqConstraints <- queryRaw' "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 u.table_name=? AND tc.constraint_type='UNIQUE' ORDER BY u.constraint_name, u.column_name" [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 WHERE 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 name] (mapAllRows $ return . fst . fromPurePersistValues proxy)+      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)+      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 uniqs = mkUniqs UniqueConstraint uniqConstraints ++ mkUniqs UniqueIndex uniqIndexes-      references <- checkTableReferences name-      primaryKeyResult <- checkPrimaryKey name-      let (primaryKey, uniqs') = case primaryKeyResult of-            (Left primaryKeyName) -> (primaryKeyName, uniqs)-            (Right u) -> (Nothing, u:uniqs)-      return $ Just $ case col_errs of-        []   -> Right $ TableInfo primaryKey cols' uniqs' references+      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 Nothing--checkPrimaryKey :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Postgresql m (Either (Maybe String) UniqueDef')-checkPrimaryKey name = do-  uniqRows <- queryRaw' "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='PRIMARY KEY' AND tc.table_name=?" [toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)-  let mkUniq us = UniqueDef' (fst $ head us) UniqueConstraint (map snd us)-  return $ case uniqRows of-    [] -> Left Nothing-    [(_, primaryKeyName)] -> Left $ Just primaryKeyName-    us -> Right $ mkUniq us+    Nothing -> return $ Right Nothing -getColumn :: String -> (String, String, String, (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String), Maybe String) -> Either String Column-getColumn _ (column_name, is_nullable, udt_name, modifiers, d) = Right $ Column column_name (is_nullable == "YES") t d where-  t = readSqlType udt_name modifiers+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+  t = readSqlType udt_name modifiers arr_info -checkTableReferences :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Postgresql m [(Maybe String, Reference)]-checkTableReferences tableName = do-  let sql = "SELECT c.conname, c.foreign_table || '', a_child.attname AS child, a_parent.attname AS parent FROM (SELECT r.confrelid::regclass AS foreign_table, r.conrelid, r.confrelid, unnest(r.conkey) AS conkey, unnest(r.confkey) AS confkey, r.conname FROM pg_catalog.pg_constraint r WHERE r.conrelid = ?::regclass AND r.contype = 'f') AS c INNER JOIN pg_attribute a_parent ON a_parent.attnum = c.confkey AND a_parent.attrelid = c.confrelid INNER JOIN pg_attribute a_child ON a_child.attnum = c.conkey AND a_child.attrelid = c.conrelid ORDER BY c.conname"-  x <- queryRaw' sql [toPrimitivePersistValue proxy $ escape tableName] $ mapAllRows (return . fst . fromPurePersistValues proxy)-  -- (refName, (parentTable, (childColumn, parentColumn)))-  let mkReference xs = (Just refName, (parentTable, map (snd . snd) xs)) where-        (refName, (parentTable, _)) = head xs+analyzeTableReferences :: (MonadBaseControl IO m, MonadIO 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\+\    FROM pg_catalog.pg_constraint r WHERE r.contype = 'f'\+\  ) AS c\+\  INNER JOIN pg_attribute a_parent ON a_parent.attnum = c.confkey AND a_parent.attrelid = c.confrelid\+\  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())\+\  ORDER BY c.conname"+  x <- queryRaw' sql [toPrimitivePersistValue proxy tName, toPrimitivePersistValue proxy schema] $ 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+        (refName, ((parentSchema, parentTable, onDelete, onUpdate), _)) = head xs+        mkAction c = Just $ case c of+          "a" -> NoAction+          "r" -> Restrict+          "c" -> Cascade+          "n" -> SetNull+          "d" -> SetDefault+          _ -> error $ "unknown reference action type: " ++ c       references = map mkReference $ groupBy ((==) `on` fst) x   return references  showAlterDb :: AlterDB -> SingleMigration showAlterDb (AddTable s) = Right [(False, defaultPriority, s)]-showAlterDb (AlterTable t _ _ _ alts) = Right $ map (showAlterTable t) alts-showAlterDb (DropTrigger trigName tName) = Right [(False, triggerPriority, "DROP TRIGGER " ++ escape trigName ++ " ON " ++ escape tName)]-showAlterDb (AddTriggerOnDelete trigName tName body) = Right [(False, triggerPriority, "CREATE TRIGGER " ++ escape trigName ++ " AFTER DELETE ON " ++ escape tName ++ " FOR EACH ROW " ++ body)]-showAlterDb (AddTriggerOnUpdate trigName tName fName body) = Right [(False, triggerPriority, "CREATE TRIGGER " ++ escape trigName ++ " AFTER UPDATE OF " ++ escape fName ++ " ON " ++ escape tName ++ " FOR EACH ROW " ++ body)]+showAlterDb (AlterTable sch t _ _ _ alts) = Right $ concatMap (showAlterTable $ withSchema sch t) alts+showAlterDb (DropTrigger schTrg trigName schTbl tName) = Right [(False, triggerPriority, "DROP TRIGGER " ++ withSchema schTrg trigName ++ " ON " ++ withSchema schTbl tName)]+showAlterDb (AddTriggerOnDelete schTrg trigName schTbl tName body) = Right [(False, triggerPriority, "CREATE TRIGGER " ++ withSchema schTrg trigName ++ " AFTER DELETE ON " ++ withSchema schTbl tName ++ " FOR EACH ROW " ++ body)]+showAlterDb (AddTriggerOnUpdate schTrg trigName schTbl tName fName body) = Right [(False, triggerPriority, "CREATE TRIGGER " ++ withSchema schTrg trigName ++ " AFTER UPDATE OF " ++ fName' ++ " ON " ++ withSchema schTbl tName ++ " FOR EACH ROW " ++ body)] where+    fName' = maybe (error $ "showAlterDb: AddTriggerOnUpdate does not have fieldName for trigger " ++ trigName) escape fName showAlterDb (CreateOrReplaceFunction s) = Right [(False, functionPriority, s)]-showAlterDb (DropFunction funcName) = Right [(False, functionPriority, "DROP FUNCTION " ++ escape funcName ++ "()")]-                 -showAlterTable :: String -> AlterTable -> (Bool, Int, String)-showAlterTable table (AlterColumn alt) = showAlterColumn table alt-showAlterTable table (AddUnique (UniqueDef' uName UniqueConstraint cols)) = (False, defaultPriority, concat+showAlterDb (DropFunction sch funcName) = Right [(False, functionPriority, "DROP FUNCTION " ++ withSchema sch funcName ++ "()")]++showAlterTable :: String -> AlterTable -> [(Bool, Int, String)]+showAlterTable table (AddColumn col) = [(False, defaultPriority, concat   [ "ALTER TABLE "-  , escape table-  , " ADD CONSTRAINT "-  , escape uName+  , table+  , " ADD COLUMN "+  , showColumn col+  ])]+showAlterTable table (DropColumn name) = [(True, defaultPriority, concat+  [ "ALTER TABLE "+  , table+  , " DROP COLUMN "+  , escape name+  ])]+showAlterTable table (AlterColumn col alts) = map (showAlterColumn table $ colName col) alts+showAlterTable table (AddUnique (UniqueDef' uName UniqueConstraint cols)) = [(False, defaultPriority, concat+  [ "ALTER TABLE "+  , table+  , " ADD"+  , maybe "" ((" CONSTRAINT " ++) . escape) uName   , " UNIQUE("   , intercalate "," $ map escape cols   , ")"-  ])-showAlterTable table (AddUnique (UniqueDef' uName UniqueIndex cols)) = (False, defaultPriority, concat+  ])]+showAlterTable table (AddUnique (UniqueDef' uName UniqueIndex cols)) = [(False, defaultPriority, concat   [ "CREATE UNIQUE INDEX "-  , escape uName+  , maybe (error $ "showAlterTable: index for table " ++ table ++ " does not have a name") escape uName   , " ON "-  , escape table+  , table   , "("   , intercalate "," $ map escape cols   , ")"-  ])-showAlterTable table (DropConstraint uName) = (False, defaultPriority, concat+  ])]+showAlterTable table (AddUnique (UniqueDef' uName UniquePrimary cols)) = [(False, defaultPriority, concat   [ "ALTER TABLE "-  , escape table+  , table+  , " ADD"+  , maybe "" ((" CONSTRAINT " ++) . escape) uName+  , " PRIMARY KEY("+  , intercalate "," $ map escape cols+  , ")"+  ])]+showAlterTable table (DropConstraint uName) = [(False, defaultPriority, concat+  [ "ALTER TABLE "+  , table   , " DROP CONSTRAINT "   , escape uName-  ])-showAlterTable _ (DropIndex uName) = (False, defaultPriority, concat+  ])]+showAlterTable _ (DropIndex uName) = [(False, defaultPriority, concat   [ "DROP INDEX "   , escape uName-  ])-showAlterTable table (AddReference (tName, columns)) = (False, referencePriority, concat+  ])]+showAlterTable table (AddReference (Reference schema tName columns onDelete onUpdate)) = [(False, referencePriority, concat   [ "ALTER TABLE "-  , escape table+  , table   , " ADD FOREIGN KEY("   , our   , ") REFERENCES "-  , escape tName+  , maybe "" (\x -> escape x ++ ".") schema ++ escape tName   , "("   , foreign   , ")"-  ]) where+  , maybe "" ((" ON DELETE " ++) . showReferenceAction) onDelete+  , maybe "" ((" ON UPDATE " ++) . showReferenceAction) onUpdate+  ])] where   (our, foreign) = f *** f $ unzip columns   f = intercalate ", " . map escape-showAlterTable table (DropReference name) = (False, defaultPriority,-    "ALTER TABLE " ++ escape table ++ " DROP CONSTRAINT " ++ name)+showAlterTable table (DropReference name) = [(False, defaultPriority,+    "ALTER TABLE " ++ table ++ " DROP CONSTRAINT " ++ name)] -showAlterColumn :: String -> AlterColumn' -> (Bool, Int, String)-showAlterColumn table (n, Type t) = (False, defaultPriority, concat+showAlterColumn :: String -> String -> AlterColumn -> (Bool, Int, String)+showAlterColumn table n (Type t) = (False, defaultPriority, concat   [ "ALTER TABLE "-  , escape table+  , table   , " ALTER COLUMN "   , escape n   , " TYPE "   , showSqlType t   ])-showAlterColumn table (n, IsNull) = (False, defaultPriority, concat+showAlterColumn table n IsNull = (False, defaultPriority, concat   [ "ALTER TABLE "-  , escape table+  , table   , " ALTER COLUMN "   , escape n   , " DROP NOT NULL"   ])-showAlterColumn table (n, NotNull) = (False, defaultPriority, concat+showAlterColumn table n NotNull = (False, defaultPriority, concat   [ "ALTER TABLE "-  , escape table+  , table   , " ALTER COLUMN "   , escape n   , " SET NOT NULL"   ])-showAlterColumn table (_, Add col) = (False, defaultPriority, concat-  [ "ALTER TABLE "-  , escape table-  , " ADD COLUMN "-  , showColumn col-  ])-showAlterColumn table (n, Drop) = (True, defaultPriority, concat-  [ "ALTER TABLE "-  , escape table-  , " DROP COLUMN "-  , escape n-  ])-showAlterColumn table (n, AddPrimaryKey) = (False, defaultPriority, concat-  [ "ALTER TABLE "-  , escape table-  , " ADD COLUMN "-  , escape n-  , " SERIAL PRIMARY KEY UNIQUE"-  ])-showAlterColumn table (n, Default s) = (False, defaultPriority, concat++showAlterColumn table n (Default s) = (False, defaultPriority, concat   [ "ALTER TABLE "-  , escape table+  , table   , " ALTER COLUMN "   , escape n   , " SET DEFAULT "   , s   ])-showAlterColumn table (n, NoDefault) = (False, defaultPriority, concat+showAlterColumn table n NoDefault = (False, defaultPriority, concat   [ "ALTER TABLE "-  , escape table+  , table   , " ALTER COLUMN "   , escape n   , " DROP DEFAULT"   ])-showAlterColumn table (n, UpdateValue s) = (False, defaultPriority, concat+showAlterColumn table n (UpdateValue s) = (False, defaultPriority, concat   [ "UPDATE "-  , escape table+  , table   , " SET "   , escape n   , "="@@ -485,12 +546,12 @@   ])  -- | 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) -> DbType-readSqlType typ (character_maximum_length, numeric_precision, numeric_scale, datetime_precision, _) = (case typ of+readSqlType :: String -> (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String) -> (Int, Maybe String) -> DbType+readSqlType typ (character_maximum_length, numeric_precision, numeric_scale, datetime_precision, _) (array_ndims, array_elem) = (case typ of   "int4" -> DbInt32   "int8" -> DbInt64-  "varchar" -> maybe DbString (DbOther . ("varchar"++) . wrap . show) character_maximum_length-  "numeric" -> DbOther $ "numeric" ++ maybe "" wrap attrs where+  "varchar" -> maybe DbString (dbOther . ("varchar"++) . wrap . show) character_maximum_length+  "numeric" -> dbOther $ "numeric" ++ maybe "" wrap attrs where     attrs = liftM2 (\a b -> if b == 0 then show a else show a ++ ", " ++ show b) numeric_precision numeric_scale   "date" -> DbDay   "bool" -> DbBool@@ -500,9 +561,12 @@   "float4" -> DbReal   "float8" -> DbReal   "bytea" -> DbBlob-  a -> DbOther a) where+  _ | 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     wrap x = "(" ++ x ++ ")"-    mkDate t name = maybe t (DbOther . (name++) . wrap . show) datetime_precision'+    mkDate t name = maybe t (dbOther . (name++) . wrap . show) datetime_precision'     defDateTimePrec = 6     datetime_precision' = datetime_precision >>= \p -> if p == defDateTimePrec then Nothing else Just p @@ -517,38 +581,35 @@ showSqlType DbDayTime = "TIMESTAMP" showSqlType DbDayTimeZoned = "TIMESTAMP WITH TIME ZONE" showSqlType DbBlob = "BYTEA"-showSqlType (DbOther name) = name+showSqlType (DbOther (OtherTypeDef f)) = f showSqlType showSqlType (DbMaybe t) = showSqlType t showSqlType (DbList _ _) = showSqlType DbInt64-showSqlType (DbEntity Nothing _) = showSqlType DbInt64+showSqlType (DbEntity Nothing _ _ _) = showSqlType DbInt64 showSqlType t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t  compareUniqs :: UniqueDef' -> UniqueDef' -> Bool-compareUniqs (UniqueDef' name1 typ1 cols1) (UniqueDef' name2 typ2 cols2) = name1 == name2 && typ1 == typ2 && haveSameElems (==) cols1 cols2+compareUniqs (UniqueDef' _ UniquePrimary cols1) (UniqueDef' _ UniquePrimary cols2) = haveSameElems (==) cols1 cols2+-- only one of the uniques is primary+compareUniqs (UniqueDef' _ type1 _) (UniqueDef' _ type2 _) | UniquePrimary `elem` [type1, type2] = False+compareUniqs (UniqueDef' name1 type1 cols1) (UniqueDef' name2 type2 cols2) = fromMaybe True (liftM2 (==) name1 name2) && type1 == type2 && haveSameElems (==) cols1 cols2 -compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool-compareRefs (_, (tbl1, pairs1)) (_, (tbl2, pairs2)) = unescape tbl1 == unescape tbl2 && haveSameElems (==) pairs1 pairs2 where-  unescape name = if head name == '"' && last name == '"' then tail $ init name else name+compareRefs :: String -> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool+compareRefs currentSchema (_, Reference sch1 tbl1 pairs1 onDel1 onUpd1) (_, Reference sch2 tbl2 pairs2 onDel2 onUpd2) =+     fromMaybe currentSchema sch1 == fromMaybe currentSchema sch2+  && unescape tbl1 == unescape tbl2+  && haveSameElems (==) pairs1 pairs2+  && fromMaybe NoAction onDel1 == fromMaybe NoAction onDel2+  && 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 type1 type2 = showSqlType (simplifyType type1) == showSqlType (simplifyType type2)---- | Converts complex datatypes that reference other data to id type DbInt64. Does not handle DbEmbedded-simplifyType :: DbType -> DbType-simplifyType (DbEntity Nothing _) = DbInt64-simplifyType (DbList _ _) = DbInt64-simplifyType x = x+compareTypes type1 type2 = f type1 == f type2 where+  f = map toUpper . showSqlType -defaultPriority :: Int+defaultPriority, referencePriority, functionPriority, triggerPriority :: Int defaultPriority = 0--referencePriority :: Int referencePriority = 1--functionPriority :: Int functionPriority = 2--triggerPriority :: Int triggerPriority = 3  mainTableId :: String@@ -560,13 +621,13 @@ escape :: String -> String escape s = '\"' : s ++ "\""   -getStatement :: StringS -> PG.Query-getStatement sql = PG.Query $ T.encodeUtf8 $ T.pack $ fromStringS sql ""+getStatement :: Utf8 -> PG.Query+getStatement sql = PG.Query $ fromUtf8 sql -queryRawTyped' :: (MonadBaseControl IO m, MonadIO m) => StringS -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a+queryRawTyped' :: (MonadBaseControl IO m, MonadIO 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) => StringS -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a+queryRaw' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a queryRaw' query vals f = do   Postgresql conn <- DbPersist ask   rawquery <- liftIO $ PG.formatQuery conn (getStatement query) (map P vals)@@ -590,17 +651,20 @@             merr <- LibPQ.errorMessage rawconn             fail $ "Postgresql.withStmt': bad result status " ++                    show status ++ " (" ++ show msg ++ ")" ++-                   maybe "" ((". Error message: "++) . unpack) merr+                   maybe "" ((". Error message: " ++) . unpack) merr          -- Get number and type of columns         cols <- LibPQ.nfields ret         getters <- forM [0..cols-1] $ \col -> do           oid <- LibPQ.ftype ret col           case PG.oid2builtin oid of-            Nothing -> fail $ "Postgresql.withStmt': could not " ++-                              "recognize Oid of column " +++            -- 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 $ PG.builtin2typname PG.Unknown+             {- fail $ "Postgresql.withStmt': could not " +++                              "recognize " ++ show oid ++ " of column " ++                               show (let LibPQ.Col i = col in i) ++-                              " (counting from zero)"+                              " (counting from zero)" -}             Just bt -> return $ getGetter bt $                        PG.Field ret col $                        PG.builtin2typname bt@@ -621,21 +685,22 @@             Errors (exc:_) -> throw exc             Errors [] -> error "Got an Errors, but no exceptions"             Ok v  -> return v-    + -- | Avoid orphan instances. newtype P = P PersistValue  instance PGTF.ToField P where-    toField (P (PersistString t))        = PGTF.toField t-    toField (P (PersistByteString bs)) = PGTF.toField (PG.Binary bs)-    toField (P (PersistInt64 i))       = PGTF.toField i-    toField (P (PersistDouble d))      = PGTF.toField d-    toField (P (PersistBool b))        = PGTF.toField b-    toField (P (PersistDay d))         = PGTF.toField d-    toField (P (PersistTimeOfDay t))   = PGTF.toField t-    toField (P (PersistUTCTime t))     = PGTF.toField t-    toField (P (PersistZonedTime (ZT t))) = PGTF.toField t-    toField (P PersistNull)            = PGTF.toField PG.Null+  toField (P (PersistString t))         = PGTF.toField t+  toField (P (PersistByteString bs))    = PGTF.toField (PG.Binary bs)+  toField (P (PersistInt64 i))          = PGTF.toField i+  toField (P (PersistDouble d))         = PGTF.toField d+  toField (P (PersistBool b))           = PGTF.toField b+  toField (P (PersistDay d))            = PGTF.toField d+  toField (P (PersistTimeOfDay t))      = PGTF.toField t+  toField (P (PersistUTCTime t))        = PGTF.toField t+  toField (P (PersistZonedTime (ZT t))) = PGTF.toField t+  toField (P PersistNull)               = PGTF.toField PG.Null+  toField (P (PersistCustom _ _))       = error "toField: unexpected PersistCustom"  type Getter a = PG.Field -> Maybe ByteString -> Ok a @@ -670,14 +735,13 @@ getGetter PG.Void                  = \_ _ -> Ok PersistNull getGetter _ = \f dat -> fmap (PersistByteString . unBinary) $ case dat of   Nothing -> PGFF.returnError PGFF.UnexpectedNull f ""-  Just str -> case PGFF.format f of-    LibPQ.Text -> case unsafePerformIO (LibPQ.unescapeBytea str) of-      Nothing  -> PGFF.returnError PGFF.ConversionFailed f "unescapeBytea failed"-      Just str' -> return $ PG.Binary str'-    LibPQ.Binary -> return $ PG.Binary $ copy $ str+  Just str -> return $ PG.Binary $ copy $ str  unBinary :: PG.Binary a -> a unBinary (PG.Binary x) = x  proxy :: Proxy Postgresql proxy = error "Proxy Postgresql"++withSchema :: Maybe String -> String -> String+withSchema sch name = maybe "" (\x -> escape x ++ ".") sch ++ escape name

@@ -0,0 +1,181 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, OverloadedStrings, UndecidableInstances, OverlappingInstances, BangPatterns #-}
+
+-- | See detailed documentation for PostgreSQL arrays at http://www.postgresql.org/docs/9.2/static/arrays.html and http://www.postgresql.org/docs/9.2/static/functions-array.html
+module Database.Groundhog.Postgresql.Array
+  (
+    Array(..)
+  , (!)
+  , (!:)
+  , append
+  , prepend
+  , arrayCat
+  , arrayDims
+  , arrayNDims
+  , arrayLower
+  , arrayUpper
+  , arrayLength
+  , arrayToString
+  , stringToArray
+  , any
+  , all
+  , (@>)
+  , (<@)
+  , overlaps
+  ) where
+
+import Database.Groundhog.Core
+import Database.Groundhog.Generic
+import Database.Groundhog.Generic.Sql hiding (append)
+import Database.Groundhog.Postgresql hiding (append)
+
+import Blaze.ByteString.Builder (fromByteString, toByteString)
+import Blaze.ByteString.Builder.Word (fromWord8)
+import Control.Applicative
+import Data.Attoparsec.Char8
+import qualified Data.Attoparsec as A
+import qualified Data.Attoparsec.Zepto as Z
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as B
+import Data.Monoid
+import Data.Word
+import Prelude hiding (all, any)
+
+-- | Represents PostgreSQL arrays
+newtype Array a = Array [a] deriving (Eq, Show)
+
+instance (ArrayElem a, PersistField a) => PersistField (Array a) where
+  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)
+
+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)
+
+instance (ArrayElem a, PersistField a) => PrimitivePersistField (Array a) where
+  toPrimitivePersistValue = toElem
+  fromPrimitivePersistValue p a = parseHelper parser a where
+    dimensions = char '[' *> takeWhile1 (/= '=') *> char '='
+    parser = optional dimensions *> parseArr p
+
+parseString :: Parser ByteString
+parseString = (char '"' *> jstring_)
+          <|> takeWhile1 (\c -> c /= ',' && c /= '}')
+          
+-- Borrowed from aeson
+jstring_ :: Parser ByteString
+jstring_ = {-# SCC "jstring_" #-} do
+  s <- A.scan False $ \s c -> if s then Just False
+                                   else if c == doubleQuote
+                                        then Nothing
+                                        else Just (c == backslash)
+  _ <- A.word8 doubleQuote
+  if backslash `B.elem` s
+    then case Z.parse unescape s of
+           Right r  -> return r
+           Left err -> fail err
+    else return s
+{-# INLINE jstring_ #-}
+
+-- Borrowed from aeson
+unescape :: Z.Parser ByteString
+unescape = toByteString <$> go mempty where
+  go acc = do
+    h <- Z.takeWhile (/=backslash)
+    let rest = do
+          start <- Z.take 2
+          let !slash = B.unsafeHead start
+              !t = B.unsafeIndex start 1
+              escape = if t == doubleQuote || t == backslash
+                then t
+                else 255
+          if slash /= backslash || escape == 255
+            then fail "invalid array escape sequence"
+            else do
+            let cont m = go (acc `mappend` fromByteString h `mappend` m)
+                {-# INLINE cont #-}
+            cont (fromWord8 escape)
+    done <- Z.atEnd
+    if done
+      then return (acc `mappend` fromByteString h)
+      else rest
+
+doubleQuote, backslash :: Word8
+doubleQuote = 34
+backslash = 92
+  
+parseArr :: (DbDescriptor db, ArrayElem a) => Proxy db -> Parser (Array a)
+parseArr p = Array <$> (char '{' *> parseElem p `sepBy` char ',' <* char '}')
+
+(!) :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b Int) => a -> b -> Expr Postgresql r elem
+(!) arr i = Expr $ Snippet $ \esc _ -> [renderExpr esc (toExpr arr) <> "[" <> renderExpr esc (toExpr i) <> "]"]
+
+(!:) :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r i1 Int, ExpressionOf Postgresql r i2 Int) => a -> (i1, i2) -> Expr Postgresql r (Array elem)
+(!:) arr (i1, i2) = Expr $ Snippet $ \esc _ -> [renderExpr esc (toExpr arr) <> "[" <> renderExpr esc (toExpr i1) <> ":" <> renderExpr esc (toExpr i2) <> "]"]
+
+prepend :: (ExpressionOf Postgresql r a elem, ExpressionOf Postgresql r b (Array elem)) => a -> b -> Expr Postgresql r (Array elem)
+prepend a b = Expr $ operator 50 "||" a b
+
+append :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b elem) => a -> b -> Expr Postgresql r (Array elem)
+append a b = Expr $ operator 50 "||" a b
+
+arrayCat :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b (Array elem)) => a -> b -> Expr Postgresql r (Array elem)
+arrayCat a b = Expr $ operator 50 "||" a b
+
+arrayDims :: (ExpressionOf Postgresql r a (Array elem)) => a -> Expr Postgresql r String
+arrayDims arr = Expr $ function "array_dims" [toExpr arr]
+
+arrayNDims :: (ExpressionOf Postgresql r a (Array elem)) => a -> Expr Postgresql r Int
+arrayNDims arr = Expr $ function "array_ndims" [toExpr arr]
+
+arrayLower :: (ExpressionOf Postgresql r a (Array elem)) => a -> Int -> Expr Postgresql r Int
+arrayLower arr dim = Expr $ function "array_lower" [toExpr arr, toExpr dim]
+
+arrayUpper :: (ExpressionOf Postgresql r a (Array elem)) => a -> Int -> Expr Postgresql r Int
+arrayUpper arr dim = Expr $ function "array_upper" [toExpr arr, toExpr dim]
+
+arrayLength :: (ExpressionOf Postgresql r a (Array elem)) => a -> Int -> Expr Postgresql r Int
+arrayLength arr dim = Expr $ function "array_length" [toExpr arr, toExpr dim]
+
+-- | Concatenates array elements using supplied delimiter. array_to_string(ARRAY[1, 2, 3], '~^~') = 1~^~2~^~3
+arrayToString :: (ExpressionOf Postgresql r a (Array elem)) => a -> String -> Expr Postgresql r String
+arrayToString arr sep = Expr $ function "array_to_string" [toExpr arr, toExpr sep]
+
+-- | Splits string into array elements using supplied delimiter. string_to_array('xx~^~yy~^~zz', '~^~') = {xx,yy,zz}
+stringToArray :: (ExpressionOf Postgresql r a String) => a -> String -> Expr Postgresql r (Array String)
+stringToArray arr sep = Expr $ function "string_to_array" [toExpr arr, toExpr sep]
+
+any :: (ExpressionOf Postgresql r a elem, ExpressionOf Postgresql r b (Array elem)) => a -> b -> Cond Postgresql r
+any a arr = CondRaw $ Snippet $ \esc _ -> [renderExprPriority esc 37 (toExpr a) <> "=ANY" <> fromChar '(' <> renderExpr esc (toExpr arr) <> fromChar ')']
+
+all :: (ExpressionOf Postgresql r a elem, ExpressionOf Postgresql r b (Array elem)) => a -> b -> Cond Postgresql r
+all a arr = CondRaw $ Snippet $ \esc _ -> [renderExprPriority esc 37 (toExpr a) <> "=ALL" <> fromChar '(' <> renderExpr esc (toExpr arr) <> fromChar ')']
+
+-- | Contains. ARRAY[1,4,3] @> ARRAY[3,1] = t
+(@>) :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b (Array elem)) => a -> b -> Cond Postgresql r
+(@>) a b = CondRaw $ operator 50 "@>" a b
+
+-- | Is contained by. ARRAY[2,7] <@ ARRAY[1,7,4,2,6] = t
+(<@) :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b (Array elem)) => a -> b -> Cond Postgresql r
+(<@) a b = CondRaw $ operator 50 "<@" a b
+
+-- | Overlap (have elements in common). ARRAY[1,4,3] && ARRAY[2,1] = t
+overlaps :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b (Array elem)) => a -> b -> Cond Postgresql r
+overlaps a b = CondRaw $ operator 50 "&&" a b
+
+parseHelper :: Parser a -> PersistValue -> a
+parseHelper p (PersistByteString bs) = either error id $ parseOnly p bs
+parseHelper _ a = error $ "parseHelper: expected PersistByteString, got " ++ show a

@@ -0,0 +1,125 @@+module Database.Groundhog.Postgresql.Geometry
+  (
+    Point(..)
+  , Line(..)
+  , Lseg(..)
+  , Box(..)
+  , Path(..)
+  , Polygon(..)
+  , Circle(..)
+  ) where
+
+import Database.Groundhog.Core
+import Database.Groundhog.Generic
+import Database.Groundhog.Instances ()
+
+import Control.Applicative
+import Data.Attoparsec.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.
+data Line = Line Point Point deriving (Eq, Show)
+data Lseg = Lseg Point Point deriving (Eq, Show)
+data Box = Box Point Point deriving (Eq, Show)
+data Path = ClosedPath [Point]
+          | OpenPath [Point] deriving (Eq, Show)
+data Polygon = Polygon [Point] deriving (Eq, Show)
+data Circle = Circle Point Double deriving (Eq, Show)
+
+-- select o.oprname, o.oprkind, tl.typname as oprleft, tr.typname as oprright, tres.typname as oprresult, o.oprcode, ocom.oprname as oprcom, oneg.oprname as oprnegate from pg_operator o inner join pg_type tl on o.oprleft = tl.oid inner join pg_type tr on o.oprright = tr.oid inner join pg_type tres on o.oprresult = tres.oid left join pg_operator ocom on o.oprcom = ocom.oid left join pg_operator oneg on o.oprnegate = oneg.oid where tl.typname in ('point', 'line', 'lseg', 'box', 'path', 'polygon', 'circle') order by o.oprname, oprleft;
+
+parseHelper :: Parser a -> PersistValue -> a
+parseHelper p (PersistByteString bs) = either error id $ parseOnly p bs
+parseHelper _ a = error $ "parseHelper: expected PersistByteString, got " ++ show a
+
+pair :: (a -> a -> b) -> Char -> Char -> Parser a -> Parser b
+pair f open close p = f <$> (char open *> p <* char ',') <*> p <* char close
+
+point :: Parser Point
+point = pair Point '(' ')' double
+
+points :: Parser [Point]
+points = point `sepBy1` char ','
+
+instance PrimitivePersistField Point where
+  toPrimitivePersistValue _ (Point x y) = PersistString $ show (x, y)
+  fromPrimitivePersistValue _ = parseHelper point
+
+instance PersistField Point where
+  persistName _ = "Point"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbOther $ OtherTypeDef $ const "point"
+
+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 PersistField Line where
+  persistName _ = "Line"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbOther $ OtherTypeDef $ const "line"
+
+instance PrimitivePersistField Lseg where
+  toPrimitivePersistValue _ (Lseg (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2))
+  fromPrimitivePersistValue _ = parseHelper $ pair Lseg '[' ']' point
+
+instance PersistField Lseg where
+  persistName _ = "Lseg"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbOther $ OtherTypeDef $ const "lseg"
+
+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 PersistField Box where
+  persistName _ = "Box"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbOther $ OtherTypeDef $ const "box"
+
+showPath :: Char -> Char -> [Point] -> ShowS
+showPath open close []     s = open : close : s
+showPath open close (x:xs) s = open : showPoint x (showl xs)
+  where
+    showl []     = close : s
+    showl (y:ys) = ',' : showPoint y (showl ys)
+
+showPoint :: Point -> ShowS
+showPoint (Point x y) = shows (x, y)
+
+instance PrimitivePersistField Path where
+  toPrimitivePersistValue _ path = PersistString $ case path of
+    ClosedPath ps -> showPath '(' ')' ps ""
+    OpenPath ps -> showPath '[' ']' ps ""
+  fromPrimitivePersistValue _ = parseHelper $ path' ClosedPath '(' ')' <|> path' OpenPath '[' ']' where
+    path' f open close = f <$> (char open *> points <* char close)
+
+instance PersistField Path where
+  persistName _ = "Path"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbOther $ OtherTypeDef $ const "path"
+
+instance PrimitivePersistField Polygon where
+  toPrimitivePersistValue _ (Polygon ps) = PersistString $ showPath '(' ')' ps ""
+  fromPrimitivePersistValue _ = parseHelper $ Polygon <$> (char '(' *> points <* char ')')
+
+instance PersistField Polygon where
+  persistName _ = "Polygon"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbOther $ OtherTypeDef $ const "polygon"
+
+instance PrimitivePersistField Circle where
+  toPrimitivePersistValue _ (Circle (Point x1 y1) r) = PersistString $ show ((x1, y1), r)
+  fromPrimitivePersistValue _ = parseHelper $ Circle <$> (char '<' *> point) <* char ',' <*> double <* char '>'
+
+instance PersistField Circle where
+  persistName _ = "Circle"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbOther $ OtherTypeDef $ const "circle"

@@ -1,5 +1,5 @@ name:            groundhog-postgresql-version:         0.2.0+version:         0.3.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>@@ -16,13 +16,16 @@                    , postgresql-simple       >= 0.2       && < 0.3                    , postgresql-libpq        >= 0.6.1     && < 0.9                    , bytestring              >= 0.9+                   , blaze-builder           >= 0.3.0.0   && < 0.4                    , transformers            >= 0.2.1     && < 0.4-                   , groundhog               >= 0.2.0     && < 0.3.0+                   , groundhog               >= 0.3.0     && < 0.4.0                    , monad-control           >= 0.3       && < 0.4                    , containers              >= 0.2                    , text                    >= 0.8       && < 0.12-                   , pool-conduit            >= 0.1       && < 0.2+                   , attoparsec              >= 0.8.5.3+                   , resource-pool           >= 0.2.1     && < 0.3                    , time                    >= 1.1     exposed-modules: Database.Groundhog.Postgresql-    other-modules:   Database.Groundhog.Generic.Sql.String+                     Database.Groundhog.Postgresql.Array+                     Database.Groundhog.Postgresql.Geometry     ghc-options:     -Wall -fno-warn-unused-do-bind