groundhog-postgresql 0.11 → 0.12
raw patch · 5 files changed
+1818/−1547 lines, 5 filesdep ~groundhogPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: groundhog
API changes (from Hackage documentation)
- Database.Groundhog.Postgresql.Geometry: data Polygon
+ Database.Groundhog.Postgresql.Geometry: newtype Polygon
Files
- Database/Groundhog/Postgresql.hs +974/−854
- Database/Groundhog/Postgresql/Array.hs +210/−196
- Database/Groundhog/Postgresql/Geometry.hs +504/−419
- Database/Groundhog/Postgresql/HStore.hs +126/−75
- groundhog-postgresql.cabal +4/−3
Database/Groundhog/Postgresql.hs view
@@ -1,854 +1,974 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, MultiParamTypeClasses, TemplateHaskell #-}--module Database.Groundhog.Postgresql- ( withPostgresqlPool- , withPostgresqlConn- , createPostgresqlPool- , runDbConn- , Postgresql(..)- , module Database.Groundhog- , module Database.Groundhog.Generic.Sql.Functions- , explicitType- , castType- , distinctOn- -- other- , showSqlType- ) where--import Database.Groundhog-import Database.Groundhog.Core-import Database.Groundhog.Expression-import Database.Groundhog.Generic-import Database.Groundhog.Generic.Migration hiding (MigrationPack(..))-import qualified Database.Groundhog.Generic.Migration as GM-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-import qualified Database.PostgreSQL.Simple.Internal as PG-import qualified Database.PostgreSQL.Simple.ToField as PGTF-import qualified Database.PostgreSQL.Simple.FromField as PGFF-import qualified Database.PostgreSQL.Simple.Types as PG-import Database.PostgreSQL.Simple.Ok (Ok (..))-import qualified Database.PostgreSQL.LibPQ as LibPQ--import Control.Arrow ((***), second)-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 Control.Monad.Trans.State (mapStateT)-import Data.Acquire (mkAcquire)-import Data.ByteString.Char8 (pack, unpack, copy)-import Data.Char (isAlphaNum, isSpace, toUpper)-import Data.Function (on)-import Data.Int (Int64)-import Data.IORef-import Data.List (groupBy, intercalate, isPrefixOf, stripPrefix)-import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe)-import Data.Pool-import Data.Time.LocalTime (localTimeToUTC, utc)---- work around for no Semigroup instance of PG.Query prior to--- postgresql-simple 0.5.3.0-import qualified Data.ByteString as B---- 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 = mkExpr $ operator 50 "||" a b- signum' x = mkExpr $ function "sign" [toExpr x]- quotRem' x y = (mkExpr $ operator 70 "/" x y, mkExpr $ operator 70 "%" x y)- equalsOperator a b = a <> " IS NOT DISTINCT FROM " <> b- notEqualsOperator a b = a <> " IS DISTINCT FROM " <> b--instance FloatingSqlDb Postgresql where- log' x = mkExpr $ function "ln" [toExpr x]- logBase' b x = log (liftExpr x) / log (liftExpr b)--instance PersistBackendConn Postgresql where- insert v = runDb' $ insert' v- insert_ v = runDb' $ insert_' v- insertBy u v = runDb' $ H.insertBy renderConfig queryRaw' True u v- insertByAll v = runDb' $ H.insertByAll renderConfig queryRaw' True v- replace k v = runDb' $ H.replace renderConfig queryRaw' executeRaw' (insertIntoConstructorTable False) k v- replaceBy k v = runDb' $ H.replaceBy renderConfig executeRaw' k v- select options = runDb' $ H.select renderConfig queryRaw' preColumns "" options- selectStream options = runDb' $ H.selectStream renderConfig queryRaw' preColumns "" options- selectAll = runDb' $ H.selectAll renderConfig queryRaw'- selectAllStream = runDb' $ H.selectAllStream renderConfig queryRaw'- get k = runDb' $ H.get renderConfig queryRaw' k- getBy k = runDb' $ H.getBy renderConfig queryRaw' k- update upds cond = runDb' $ H.update renderConfig executeRaw' upds cond- delete cond = runDb' $ H.delete renderConfig executeRaw' cond- deleteBy k = runDb' $ H.deleteBy renderConfig executeRaw' k- deleteAll v = runDb' $ H.deleteAll renderConfig executeRaw' v- count cond = runDb' $ H.count renderConfig queryRaw' cond- countAll fakeV = runDb' $ H.countAll renderConfig queryRaw' fakeV- project p options = runDb' $ H.project renderConfig queryRaw' preColumns "" p options- projectStream p options = runDb' $ H.projectStream renderConfig queryRaw' preColumns "" p options- migrate fakeV = mapStateT runDb' $ migrate' fakeV-- executeRaw _ query ps = runDb' $ executeRaw' (fromString query) ps- queryRaw _ query ps = runDb' $ queryRaw' (fromString query) ps-- insertList l = runDb' $ insertList' l- getList k = runDb' $ getList' k--instance SchemaAnalyzer Postgresql where- schemaExists schema = runDb' $ queryRaw' "SELECT 1 FROM pg_catalog.pg_namespace WHERE nspname=?" [toPrimitivePersistValue schema] >>= firstRow >>= return . isJust- getCurrentSchema = runDb' $ queryRaw' "SELECT current_schema()" [] >>= firstRow >>= return . (>>= fst . fromPurePersistValues)- listTables schema = runDb' $ queryRaw' "SELECT table_name FROM information_schema.tables WHERE table_schema=coalesce(?,current_schema())" [toPrimitivePersistValue schema] >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList- listTableTriggers name = runDb' $ queryRaw' "SELECT trigger_name FROM information_schema.triggers WHERE event_object_schema=coalesce(?,current_schema()) AND event_object_table=?" (toPurePersistValues name []) >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList- analyzeTable = runDb' . analyzeTable'- analyzeTrigger name = runDb' $ do- x <- queryRaw' "SELECT action_statement FROM information_schema.triggers WHERE trigger_schema=coalesce(?,current_schema()) AND trigger_name=?" (toPurePersistValues name []) >>= firstRow- return $ case x of- Nothing -> Nothing- Just src -> fst $ fromPurePersistValues src- analyzeFunction name = runDb' $ do- let query = "SELECT arg_types.typname, arg_types.typndims, arg_types_te.typname, ret.typname, ret.typndims, ret_te.typname, p.prosrc\-\ FROM pg_catalog.pg_namespace n\-\ INNER JOIN pg_catalog.pg_proc p ON p.pronamespace = n.oid\-\ LEFT JOIN (SELECT oid, unnest(coalesce(proallargtypes, proargtypes)) as arg FROM pg_catalog.pg_proc) as args ON p.oid = args.oid\-\ LEFT JOIN pg_type arg_types ON arg_types.oid = args.arg\-\ LEFT JOIN pg_type arg_types_te ON arg_types_te.oid = arg_types.typelem\-\ INNER JOIN pg_type ret ON p.prorettype = ret.oid\-\ LEFT JOIN pg_type ret_te ON ret_te.oid = ret.typelem\-\ WHERE n.nspname = coalesce(?,current_schema()) AND p.proname = ?"- result <- queryRaw' query (toPurePersistValues name []) >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList- let read' (typ, arr) = readSqlType typ (Nothing, Nothing, Nothing, Nothing, Nothing) arr- return $ case result of- [] -> Nothing- ((_, (ret, src)):_) -> Just $ (Just $ map read' args, Just $ read' ret, src) where- args = mapMaybe (\(typ, arr) -> fmap (\typ' -> (typ', arr)) typ) $ map fst result- getMigrationPack = liftM (migrationPack . fromJust) getCurrentSchema--withPostgresqlPool :: (MonadBaseControl IO m, MonadIO m)- => String -- ^ connection string in keyword\/value format like "host=localhost port=5432 dbname=mydb". For more details and options see http://www.postgresql.org/docs/9.4/static/libpq-connect.html#LIBPQ-PARAMKEYWORDS- -> Int -- ^ number of connections to open- -> (Pool Postgresql -> m a)- -> m a-withPostgresqlPool s connCount f = createPostgresqlPool s connCount >>= f--withPostgresqlConn :: (MonadBaseControl IO m, MonadIO m)- => String -- ^ connection string- -> (Postgresql -> m a)- -> m a-withPostgresqlConn s = bracket (liftIO $ open' s) (liftIO . close')--createPostgresqlPool :: MonadIO m- => String -- ^ connection string- -> Int -- ^ number of connections to open- -> m (Pool Postgresql)-createPostgresqlPool s connCount = liftIO $ createPool (open' s) close' 1 20 connCount---- Not sure of the best way to handle Semigroup/Monoid changes in ghc 8.4--- here. It appears that the long SQL query text interferes with the use--- of CPP here.------ Manually copying over https://github.com/lpsmith/postgresql-simple/commit/44c0bb8dec3b71e8daefe104cf643c0c4fb26768#diff-75d19972de474bc8fa181e4733f3f0d6R94--- but this is not really a good idea.----combine :: PG.Query -> PG.Query -> PG.Query--- combine = (<>)-combine (PG.Query a) (PG.Query b) = PG.Query (B.append a b)---instance Savepoint Postgresql where- withConnSavepoint name m (Postgresql c) = do- let name' = fromString name- liftIO $ PG.execute_ c $ "SAVEPOINT " `combine` name'- x <- onException m (liftIO $ PG.execute_ c $ "ROLLBACK TO SAVEPOINT " `combine` name')- liftIO $ PG.execute_ c $ "RELEASE SAVEPOINT" `combine` name'- return x--instance ConnectionManager 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--instance TryConnectionManager Postgresql where- tryWithConn f g conn@(Postgresql c) = do- liftIO $ PG.begin c- x <- g (f conn)- case x of- Left _ -> liftIO $ PG.rollback c- Right _ -> liftIO $ PG.commit c- return x--instance ExtractConnection Postgresql Postgresql where- extractConn f conn = f conn--instance ExtractConnection (Pool Postgresql) Postgresql where- extractConn f pconn = withResource pconn f--open' :: String -> IO Postgresql-open' s = do- conn <- PG.connectPostgreSQL $ pack s- PG.execute_ conn $ getStatement "SET client_min_messages TO WARNING"- return $ Postgresql conn--close' :: Postgresql -> IO ()-close' (Postgresql conn) = PG.close conn--insert' :: (PersistEntity v) => v -> Action Postgresql (AutoKey v)-insert' v = do- -- constructor number and the rest of the field values- vals <- toEntityPersistValues' v- let e = entityDef proxy v- let constructorNum = fromPrimitivePersistValue (head vals)-- liftM fst $ if isSimple (constructors e)- then do- let constr = head $ constructors e- let RenderS query vals' = insertIntoConstructorTable True False (tableName escapeS e constr) constr (tail vals)- case constrAutoKeyName constr of- Nothing -> executeRaw' query (vals' []) >> pureFromPersistValue []- Just _ -> do- x <- queryRaw' query (vals' []) >>= firstRow- case x of- Just xs -> pureFromPersistValue xs- Nothing -> pureFromPersistValue []- 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' [])- pureFromPersistValue [rowid]--insert_' :: (PersistEntity v) => v -> Action Postgresql ()-insert_' v = do- -- constructor number and the rest of the field values- vals <- toEntityPersistValues' v- let e = entityDef proxy v- let constructorNum = fromPrimitivePersistValue (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 <> columnsValues <> returning- (fields, returning) = case constrAutoKeyName c of- Just idName -> (fields', returning') where- 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- [] -> " DEFAULT VALUES"- xs -> "(" <> commasJoin xs <> ") VALUES(" <> placeholders <> ")"- RenderS placeholders vals' = commasJoin $ map renderPersistValue vals--insertList' :: forall a . PersistField a => [a] -> Action Postgresql 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- let valuesName = mainName <> delim' <> "values"- 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] -> Action Postgresql ()- go n (x:xs) = do- x' <- toPersistValues x- executeRaw' query $ (k:) . (toPrimitivePersistValue n:) . x' $ []- go (n + 1) xs- go _ [] = return ()- go 0 l- return $ fromPrimitivePersistValue k--getList' :: forall a . PersistField a => Int64 -> Action Postgresql [a]-getList' k = do- let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))- let valuesName = mainName <> delim' <> "values"- let value = ("value", dbType proxy (undefined :: a))- let query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord"- queryRaw' query [toPrimitivePersistValue k] >>= mapStream (liftM fst . fromPersistValues) >>= streamToList----TODO: consider removal-getKey :: RowStream [PersistValue] -> Action Postgresql PersistValue-getKey stream = firstRow stream >>= \(Just [k]) -> return k--------------executeRaw' :: Utf8 -> [PersistValue] -> Action Postgresql ()-executeRaw' query vals = do--- $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals- Postgresql conn <- ask- let stmt = getStatement query- liftIO $ do- _ <- PG.execute conn stmt (map P vals)- return ()--renderConfig :: RenderConfig-renderConfig = RenderConfig {- esc = escapeS-}--escapeS :: Utf8 -> Utf8-escapeS a = let q = fromChar '"' in q <> a <> q--delim' :: Utf8-delim' = fromChar delim--toEntityPersistValues' :: PersistEntity v => v -> Action Postgresql [PersistValue]-toEntityPersistValues' = liftM ($ []) . toEntityPersistValues----- MIGRATION--migrate' :: (PersistEntity v) => v -> Migration (Action Postgresql)-migrate' v = do- migPack <- lift $ getMigrationPack- migrateRecursively (migrateSchema migPack) (migrateEntity migPack) (migrateList migPack) v--migrationPack :: String -> GM.MigrationPack Postgresql-migrationPack currentSchema = m where- m = GM.MigrationPack- compareTypes- (compareRefs currentSchema)- compareUniqs- compareDefaults- migTriggerOnDelete- migTriggerOnUpdate- (GM.defaultMigConstr m)- escape- "BIGSERIAL PRIMARY KEY UNIQUE"- 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- [ escape n- , " "- , showSqlType t- , " "- , if nu then "NULL" else "NOT NULL"- , case def of- Nothing -> ""- Just s -> " DEFAULT " ++ s- ]--migTriggerOnDelete :: QualifiedName -> [(String, String)] -> Action Postgresql (Bool, [AlterDB])-migTriggerOnDelete tName deletes = do- let funcName = tName- trigName = tName- func <- analyzeFunction funcName- trig <- analyzeTrigger trigName- let funcBody = "BEGIN " ++ concatMap snd deletes ++ "RETURN NEW;END;"- addFunction = CreateOrReplaceFunction $ "CREATE OR REPLACE FUNCTION " ++ withSchema funcName ++ "() RETURNS trigger AS $$" ++ funcBody ++ "$$ LANGUAGE plpgsql"- funcMig = case func of- Nothing | null deletes -> []- Nothing -> [addFunction]- Just (_, Just (DbOther (OtherTypeDef [Left "trigger"])), body) -> if null deletes -- remove old trigger if a datatype earlier had fields of ephemeral types- then [DropFunction funcName]- else if body == funcBody- then []- -- this can happen when an ephemeral field was added or removed.- else [DropFunction funcName, addFunction]- _ -> [] -- ignore same name functions which don't return a trigger.-- trigBody = "EXECUTE PROCEDURE " ++ withSchema funcName ++ "()"- addTrigger = AddTriggerOnDelete trigName tName 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 tName]- else if body == trigBody- then []- -- this can happen when an ephemeral field was added or removed.- else [DropTrigger trigName tName, 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 :: QualifiedName -> [(String, String)] -> Action Postgresql [(Bool, [AlterDB])]-migTriggerOnUpdate tName dels = forM dels $ \(fieldName, del) -> do- let funcName = second (\name -> name ++ delim : fieldName) tName- let trigName = second (\name -> name ++ delim : fieldName) tName- func <- analyzeFunction funcName- trig <- analyzeTrigger trigName- let funcBody = "BEGIN " ++ del ++ "RETURN NEW;END;"- addFunction = CreateOrReplaceFunction $ "CREATE OR REPLACE FUNCTION " ++ withSchema funcName ++ "() RETURNS trigger AS $$" ++ funcBody ++ "$$ LANGUAGE plpgsql"- funcMig = case func of- Nothing -> [addFunction]- Just (_, Just (DbOther (OtherTypeDef [Left "trigger"])), body) -> if body == funcBody- then []- -- this can happen when an ephemeral field was added or removed.- else [DropFunction funcName, addFunction]- _ -> []-- trigBody = "EXECUTE PROCEDURE " ++ withSchema funcName ++ "()"- addTrigger = AddTriggerOnUpdate trigName tName (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 tName, addTrigger])- return (trigExisted, funcMig ++ trigMig)--analyzeTable' :: QualifiedName -> Action Postgresql (Maybe TableInfo)-analyzeTable' name = do- table <- queryRaw' "SELECT * FROM information_schema.tables WHERE table_schema = coalesce(?, current_schema()) AND table_name = ?" (toPurePersistValues name []) >>= firstRow- case table of- Just _ -> do- 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 (toPurePersistValues name []) >>= mapStream (return . getColumn . fst . fromPurePersistValues) >>= streamToList- 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 (toPurePersistValues ("UNIQUE" :: String, name) []) >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList- uniqPrimary <- queryRaw' constraintQuery (toPurePersistValues ("PRIMARY KEY" :: String, name) []) >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList- -- indexes with system columns like oid are omitted- let indexQuery = "WITH indexes as (\-\SELECT ic.oid, ic.relname,\-\ ta.attnum, ta.attname, pg_get_indexdef(i.indexrelid, ia.attnum, true) as expr\-\ 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 ta.attnum = i.indkey[ia.attnum-1] AND NOT ta.attisdropped\-\ 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)\-\SELECT i.relname, i.attname, i.expr\-\ FROM indexes i\-\ INNER JOIN (SELECT oid FROM indexes\-\ GROUP BY oid\-\ HAVING every(attnum > 0 OR attnum IS NULL)) non_system ON i.oid = non_system.oid"- uniqIndexes <- queryRaw' indexQuery (toPurePersistValues name []) >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList- 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 (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 name- return $ Just $ TableInfo cols uniqs references- Nothing -> return Nothing--getColumn :: ((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 :: QualifiedName -> Action Postgresql [(Maybe String, Reference)]-analyzeTableReferences 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\-\ 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 (toPurePersistValues tName []) >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList- -- (refName, ((parentTableSchema, parentTable, onDelete, onUpdate), (childColumn, parentColumn)))- let mkReference xs = (Just refName, Reference parentTable pairs (mkAction onDelete) (mkAction onUpdate)) where- pairs = map (snd . snd) xs- (refName, ((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 $ concatMap (showAlterTable $ withSchema t) alts-showAlterDb (DropTrigger trigName tName) = Right [(False, triggerPriority, "DROP TRIGGER " ++ withSchema trigName ++ " ON " ++ withSchema tName)]-showAlterDb (AddTriggerOnDelete trigName tName body) = Right [(False, triggerPriority, "CREATE TRIGGER " ++ withSchema trigName ++ " AFTER DELETE ON " ++ withSchema tName ++ " FOR EACH ROW " ++ body)]-showAlterDb (AddTriggerOnUpdate trigName tName fName body) = Right [(False, triggerPriority, "CREATE TRIGGER " ++ withSchema trigName ++ " AFTER UPDATE OF " ++ fName' ++ " ON " ++ withSchema tName ++ " FOR EACH ROW " ++ body)] where- fName' = maybe (error $ "showAlterDb: AddTriggerOnUpdate does not have fieldName for trigger " ++ show trigName) escape fName-showAlterDb (CreateOrReplaceFunction s) = Right [(False, functionPriority, s)]-showAlterDb (DropFunction funcName) = Right [(False, functionPriority, "DROP FUNCTION " ++ withSchema funcName ++ "()")]-showAlterDb (CreateSchema sch ifNotExists) = Right [(False, schemaPriority, "CREATE SCHEMA " ++ ifNotExists' ++ escape sch)] where- ifNotExists' = if ifNotExists then "IF NOT EXISTS " else ""--showAlterTable :: String -> AlterTable -> [(Bool, Int, String)]-showAlterTable table (AddColumn col) = [(False, defaultPriority, concat- [ "ALTER TABLE "- , 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 (either escape id) cols- , ")"- ])]-showAlterTable table (AddUnique (UniqueDef uName UniqueIndex cols)) = [(False, defaultPriority, concat- [ "CREATE UNIQUE INDEX "- , maybe "" escape uName- , " ON "- , table- , "("- , intercalate "," $ map (either escape id) cols- , ")"- ])]-showAlterTable table (AddUnique (UniqueDef uName (UniquePrimary _) cols)) = [(False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " ADD"- , maybe "" ((" CONSTRAINT " ++) . escape) uName- , " PRIMARY KEY("- , intercalate "," $ map (either escape id) cols- , ")"- ])]-showAlterTable table (DropConstraint uName) = [(False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " DROP CONSTRAINT "- , escape uName- ])]-showAlterTable _ (DropIndex uName) = [(False, defaultPriority, concat- [ "DROP INDEX "- , escape uName- ])]-showAlterTable table (AddReference (Reference tName columns onDelete onUpdate)) = [(False, referencePriority, concat- [ "ALTER TABLE "- , table- , " ADD FOREIGN KEY("- , our- , ") REFERENCES "- , withSchema tName- , "("- , foreign- , ")"- , 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 " ++ table ++ " DROP CONSTRAINT " ++ name)]--showAlterColumn :: String -> String -> AlterColumn -> (Bool, Int, String)-showAlterColumn table n (Type t) = (False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " ALTER COLUMN "- , escape n- , " TYPE "- , showSqlType t- ])-showAlterColumn table n IsNull = (False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " ALTER COLUMN "- , escape n- , " DROP NOT NULL"- ])-showAlterColumn table n NotNull = (False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " ALTER COLUMN "- , escape n- , " SET NOT NULL"- ])--showAlterColumn table n (Default s) = (False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " ALTER COLUMN "- , escape n- , " SET DEFAULT "- , s- ])-showAlterColumn table n NoDefault = (False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " ALTER COLUMN "- , escape n- , " DROP DEFAULT"- ])-showAlterColumn table n (UpdateValue s) = (False, defaultPriority, concat- [ "UPDATE "- , table- , " SET "- , escape n- , "="- , s- , " WHERE "- , escape n- , " IS NULL"- ])---- | 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) -> DbTypePrimitive-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- attrs = liftM2 (\a b -> if b == 0 then show a else show a ++ ", " ++ show b) numeric_precision numeric_scale- "date" -> DbDay- "bool" -> DbBool- "time" -> mkDate DbTime "time"- "timestamp" -> mkDate DbDayTime "timestamp"- "timestamptz" -> mkDate DbDayTimeZoned "timestamptz"- "float4" -> DbReal- "float8" -> DbReal- "bytea" -> DbBlob- _ | 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 t = DbOther $ OtherTypeDef [Left t]- wrap x = "(" ++ x ++ ")"- 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--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 ts) -> concatMap (either id showSqlType) ts--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) =- 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 :: 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, schemaPriority, referencePriority, functionPriority, triggerPriority :: Int-defaultPriority = 1-schemaPriority = 0-referencePriority = 2-functionPriority = 3-triggerPriority = 4--mainTableId :: String-mainTableId = "id"----- MAIN---- It is used to escape table names and columns, which can include only symbols allowed in Haskell datatypes and '$' delimiter. We need it mostly to support names that coincide with SQL keywords-escape :: String -> String-escape s = '\"' : s ++ "\""--getStatement :: Utf8 -> PG.Query-getStatement sql = PG.Query $ fromUtf8 sql--queryRaw' :: Utf8 -> [PersistValue] -> Action Postgresql (RowStream [PersistValue])-queryRaw' query vals = do--- $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals- Postgresql conn <- ask- let open = do- rawquery <- PG.formatQuery conn (getStatement query) (map P vals)- -- Take raw connection- (ret, rowRef, rowCount, getters) <- PG.withConnection conn $ \rawconn -> do- -- Execute query- mret <- LibPQ.exec rawconn rawquery- case mret of- Nothing -> do- merr <- LibPQ.errorMessage rawconn- fail $ case merr of- Nothing -> "Postgresql.queryRaw': unknown error"- Just e -> "Postgresql.queryRaw': " ++ unpack e- Just ret -> do- -- Check result status- status <- LibPQ.resultStatus ret- case status of- LibPQ.TuplesOk -> return ()- _ -> do- msg <- LibPQ.resStatus status- merr <- LibPQ.errorMessage rawconn- fail $ "Postgresql.queryRaw': bad result status " ++- show status ++ " (" ++ show msg ++ ")" ++- 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- return $ getGetter oid $ PG.Field ret col oid- -- Ready to go!- rowRef <- newIORef (LibPQ.Row 0)- rowCount <- LibPQ.ntuples ret- return (ret, rowRef, rowCount, getters)-- return $ do- row <- atomicModifyIORef rowRef (\r -> (r+1, r))- if row == rowCount- then return Nothing- else liftM Just $ forM (zip getters [0..]) $ \(getter, col) -> do- mbs <- LibPQ.getvalue' ret row col- case mbs of- Nothing -> return PersistNull- Just bs -> do- ok <- PGFF.runConversion (getter mbs) conn- bs `seq` case ok of- Errors (exc:_) -> throw exc- Errors [] -> error "Got an Errors, but no exceptions"- Ok v -> return v- return $ mkAcquire open (const $ return ())---- | Avoid orphan instances.-newtype P = P PersistValue--instance PGTF.ToField P where- toField (P (PersistString t)) = PGTF.toField t- toField (P (PersistText 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 = PGFF.FieldParser a--convertPV :: PGFF.FromField a => (a -> b) -> Getter b-convertPV f = (fmap f .) . PGFF.fromField--getGetter :: PG.Oid -> Getter PersistValue-getGetter (PG.Oid oid) = case oid of- 16 -> convertPV PersistBool- 17 -> convertPV (PersistByteString . unBinary)- 18 -> convertPV PersistText- 19 -> convertPV PersistText- 20 -> convertPV PersistInt64- 21 -> convertPV PersistInt64- 23 -> convertPV PersistInt64- 25 -> convertPV PersistText- 142 -> convertPV PersistText- 700 -> convertPV PersistDouble- 701 -> convertPV PersistDouble- 702 -> convertPV PersistUTCTime- 703 -> convertPV PersistUTCTime- 1042 -> convertPV PersistText- 1043 -> convertPV PersistText- 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--proxy :: proxy Postgresql-proxy = error "proxy Postgresql"--withSchema :: QualifiedName -> String-withSchema (sch, name) = maybe "" (\x -> escape x ++ ".") sch ++ escape name---- | Put explicit type for expression. It is useful for values which are defaulted to a wrong type.--- For example, a literal Int from a 64bit machine can be defaulted to a 32bit int by Postgresql.--- 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 proxy a of- DbTypePrimitive t' _ _ _ -> showSqlType t'- _ -> error "explicitType: type is not primitive"---- | Casts expression to a type. @castType value \"INT\"@ results in @value::INT@.-castType :: (Expression Postgresql r a, PersistField a) => a -> String -> Expr Postgresql r a-castType a t = mkExpr $ Snippet $ \conf _ -> ["(" <> renderExpr conf (toExpr a) <> ")::" <> fromString t] where---- | Distinct only on certain fields or expressions. For example, @select $ CondEmpty `distinctOn` (lower EmailField, IpField)@.-distinctOn :: (db ~ Postgresql, HasSelectOptions a db r, HasDistinct a ~ HFalse, Projection' p db r p') => a -> p -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a) HTrue-distinctOn opts p = opts' {dbSpecificOptions = ("DISTINCT_ON", clause): dbSpecificOptions opts'} where- opts' = getSelectOptions opts- clause = Snippet $ \conf _ -> [commasJoin $ concatMap (renderExprExtended conf 0) $ projectionExprs p []]--preColumns :: HasSelectOptions opts Postgresql r => opts -> RenderS Postgresql r-preColumns opts = clause where- clause = apply "DISTINCT_ON" (\t -> "DISTINCT ON (" <> t <> ")")- apply k f = case lookup k opts' of- Nothing -> mempty- Just (Snippet snippet) -> f $ head $ snippet renderConfig 0- opts' = dbSpecificOptions $ getSelectOptions opts+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Groundhog.Postgresql+ ( withPostgresqlPool,+ withPostgresqlConn,+ createPostgresqlPool,+ runDbConn,+ Postgresql (..),+ module Database.Groundhog,+ module Database.Groundhog.Generic.Sql.Functions,+ explicitType,+ castType,+ distinctOn,+ -- other+ showSqlType,+ )+where++import Control.Arrow (second, (***))+import Control.Exception (throw)+import Control.Monad (forM, 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 Control.Monad.Trans.State (mapStateT)+import Data.Acquire (mkAcquire)+-- work around for no Semigroup instance of PG.Query prior to+-- postgresql-simple 0.5.3.0+import qualified Data.ByteString as B+import Data.ByteString.Char8 (copy, pack, unpack)+import Data.Char (isAlphaNum, isSpace, toUpper)+import Data.Function (on)+import Data.IORef+import Data.Int (Int64)+import Data.List (groupBy, intercalate, isPrefixOf, stripPrefix)+import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe)+import Data.Pool+import Data.Time.LocalTime (localTimeToUTC, utc)+import Database.Groundhog+import Database.Groundhog.Core+import Database.Groundhog.Expression+import Database.Groundhog.Generic+import Database.Groundhog.Generic.Migration hiding (MigrationPack (..))+import qualified Database.Groundhog.Generic.Migration as GM+import qualified Database.Groundhog.Generic.PersistBackendHelpers as H+import Database.Groundhog.Generic.Sql+import Database.Groundhog.Generic.Sql.Functions+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Database.PostgreSQL.Simple as PG+import qualified Database.PostgreSQL.Simple.FromField as PGFF+import qualified Database.PostgreSQL.Simple.Internal as PG+import Database.PostgreSQL.Simple.Ok (Ok (..))+import qualified Database.PostgreSQL.Simple.ToField as PGTF+import qualified Database.PostgreSQL.Simple.Types as PG++-- 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 = mkExpr $ operator 50 "||" a b+ signum' x = mkExpr $ function "sign" [toExpr x]+ quotRem' x y = (mkExpr $ operator 70 "/" x y, mkExpr $ operator 70 "%" x y)+ equalsOperator a b = a <> " IS NOT DISTINCT FROM " <> b+ notEqualsOperator a b = a <> " IS DISTINCT FROM " <> b++instance FloatingSqlDb Postgresql where+ log' x = mkExpr $ function "ln" [toExpr x]+ logBase' b x = log (liftExpr x) / log (liftExpr b)++instance PersistBackendConn Postgresql where+ insert v = runDb' $ insert' v+ insert_ v = runDb' $ insert_' v+ insertBy u v = runDb' $ H.insertBy renderConfig queryRaw' True u v+ insertByAll v = runDb' $ H.insertByAll renderConfig queryRaw' True v+ replace k v = runDb' $ H.replace renderConfig queryRaw' executeRaw' (insertIntoConstructorTable False) k v+ replaceBy k v = runDb' $ H.replaceBy renderConfig executeRaw' k v+ select options = runDb' $ H.select renderConfig queryRaw' preColumns "" options+ selectStream options = runDb' $ H.selectStream renderConfig queryRaw' preColumns "" options+ selectAll = runDb' $ H.selectAll renderConfig queryRaw'+ selectAllStream = runDb' $ H.selectAllStream renderConfig queryRaw'+ get k = runDb' $ H.get renderConfig queryRaw' k+ getBy k = runDb' $ H.getBy renderConfig queryRaw' k+ update upds cond = runDb' $ H.update renderConfig executeRaw' upds cond+ delete cond = runDb' $ H.delete renderConfig executeRaw' cond+ deleteBy k = runDb' $ H.deleteBy renderConfig executeRaw' k+ deleteAll v = runDb' $ H.deleteAll renderConfig executeRaw' v+ count cond = runDb' $ H.count renderConfig queryRaw' cond+ countAll fakeV = runDb' $ H.countAll renderConfig queryRaw' fakeV+ project p options = runDb' $ H.project renderConfig queryRaw' preColumns "" p options+ projectStream p options = runDb' $ H.projectStream renderConfig queryRaw' preColumns "" p options+ migrate fakeV = mapStateT runDb' $ migrate' fakeV++ executeRaw _ query ps = runDb' $ executeRaw' (fromString query) ps+ queryRaw _ query ps = runDb' $ queryRaw' (fromString query) ps++ insertList l = runDb' $ insertList' l+ getList k = runDb' $ getList' k++instance SchemaAnalyzer Postgresql where+ schemaExists schema = runDb' $ queryRaw' "SELECT 1 FROM pg_catalog.pg_namespace WHERE nspname=?" [toPrimitivePersistValue schema] >>= firstRow >>= pure . isJust+ getCurrentSchema = runDb' $ queryRaw' "SELECT current_schema()" [] >>= firstRow >>= pure . (>>= fst . fromPurePersistValues)+ listTables schema = runDb' $ queryRaw' "SELECT table_name FROM information_schema.tables WHERE table_schema=coalesce(?,current_schema())" [toPrimitivePersistValue schema] >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList+ listTableTriggers name = runDb' $ queryRaw' "SELECT trigger_name FROM information_schema.triggers WHERE event_object_schema=coalesce(?,current_schema()) AND event_object_table=?" (toPurePersistValues name []) >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList+ analyzeTable = runDb' . analyzeTable'+ analyzeTrigger name = runDb' $ do+ x <- queryRaw' "SELECT action_statement FROM information_schema.triggers WHERE trigger_schema=coalesce(?,current_schema()) AND trigger_name=?" (toPurePersistValues name []) >>= firstRow+ pure $ case x of+ Nothing -> Nothing+ Just src -> fst $ fromPurePersistValues src+ analyzeFunction name = runDb' $ do+ let query =+ "SELECT arg_types.typname, arg_types.typndims, arg_types_te.typname, ret.typname, ret.typndims, ret_te.typname, p.prosrc\+ \ FROM pg_catalog.pg_namespace n\+ \ INNER JOIN pg_catalog.pg_proc p ON p.pronamespace = n.oid\+ \ LEFT JOIN (SELECT oid, unnest(coalesce(proallargtypes, proargtypes)) as arg FROM pg_catalog.pg_proc) as args ON p.oid = args.oid\+ \ LEFT JOIN pg_type arg_types ON arg_types.oid = args.arg\+ \ LEFT JOIN pg_type arg_types_te ON arg_types_te.oid = arg_types.typelem\+ \ INNER JOIN pg_type ret ON p.prorettype = ret.oid\+ \ LEFT JOIN pg_type ret_te ON ret_te.oid = ret.typelem\+ \ WHERE n.nspname = coalesce(?,current_schema()) AND p.proname = ?"+ result <- queryRaw' query (toPurePersistValues name []) >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList+ let read' (typ, arr) = readSqlType typ (Nothing, Nothing, Nothing, Nothing, Nothing) arr+ pure $ case result of+ [] -> Nothing+ ((_, (ret, src)) : _) -> Just (Just $ map read' args, Just $ read' ret, src)+ where+ args = mapMaybe (\(typ, arr) -> fmap (\typ' -> (typ', arr)) typ) $ map fst result+ getMigrationPack = fmap (migrationPack . fromJust) getCurrentSchema++withPostgresqlPool ::+ (MonadBaseControl IO m, MonadIO m) =>+ -- | connection string in keyword\/value format like "host=localhost port=5432 dbname=mydb". For more details and options see http://www.postgresql.org/docs/9.4/static/libpq-connect.html#LIBPQ-PARAMKEYWORDS+ String ->+ -- | number of connections to open+ Int ->+ (Pool Postgresql -> m a) ->+ m a+withPostgresqlPool s connCount f = createPostgresqlPool s connCount >>= f++withPostgresqlConn ::+ (MonadBaseControl IO m, MonadIO m) =>+ -- | connection string+ String ->+ (Postgresql -> m a) ->+ m a+withPostgresqlConn s = bracket (liftIO $ open' s) (liftIO . close')++createPostgresqlPool ::+ MonadIO m =>+ -- | connection string+ String ->+ -- | number of connections to open+ Int ->+ m (Pool Postgresql)+createPostgresqlPool s connCount = liftIO $ createPool (open' s) close' 1 20 connCount++-- Not sure of the best way to handle Semigroup/Monoid changes in ghc 8.4+-- here. It appears that the long SQL query text interferes with the use+-- of CPP here.+--+-- Manually copying over https://github.com/lpsmith/postgresql-simple/commit/44c0bb8dec3b71e8daefe104cf643c0c4fb26768#diff-75d19972de474bc8fa181e4733f3f0d6R94+-- but this is not really a good idea.+--+combine :: PG.Query -> PG.Query -> PG.Query+-- combine = (<>)+combine (PG.Query a) (PG.Query b) = PG.Query (B.append a b)++instance Savepoint Postgresql where+ withConnSavepoint name m (Postgresql c) = do+ let name' = fromString name+ _ <- liftIO $ PG.execute_ c $ "SAVEPOINT " `combine` name'+ x <- onException m (liftIO $ PG.execute_ c $ "ROLLBACK TO SAVEPOINT " `combine` name')+ _ <- liftIO $ PG.execute_ c $ "RELEASE SAVEPOINT" `combine` name'+ pure x++instance ConnectionManager Postgresql where+ withConn f conn@(Postgresql c) = do+ liftIO $ PG.begin c+ x <- onException (f conn) (liftIO $ PG.rollback c)+ liftIO $ PG.commit c+ pure x++instance TryConnectionManager Postgresql where+ tryWithConn f g conn@(Postgresql c) = do+ liftIO $ PG.begin c+ x <- g (f conn)+ case x of+ Left _ -> liftIO $ PG.rollback c+ Right _ -> liftIO $ PG.commit c+ pure x++instance ExtractConnection Postgresql Postgresql where+ extractConn f conn = f conn++instance ExtractConnection (Pool Postgresql) Postgresql where+ extractConn f pconn = withResource pconn f++open' :: String -> IO Postgresql+open' s = do+ conn <- PG.connectPostgreSQL $ pack s+ _ <- PG.execute_ conn $ getStatement "SET client_min_messages TO WARNING"+ pure $ Postgresql conn++close' :: Postgresql -> IO ()+close' (Postgresql conn) = PG.close conn++insert' :: (PersistEntity v) => v -> Action Postgresql (AutoKey v)+insert' v = do+ -- constructor number and the rest of the field values+ vals <- toEntityPersistValues' v+ let e = entityDef proxy v+ let constructorNum = fromPrimitivePersistValue (head vals)++ fmap fst $+ if isSimple (constructors e)+ then do+ let constr = head $ constructors e+ let RenderS query vals' = insertIntoConstructorTable True False (tableName escapeS e constr) constr (tail vals)+ case constrAutoKeyName constr of+ Nothing -> executeRaw' query (vals' []) >> pureFromPersistValue []+ Just _ -> do+ x <- queryRaw' query (vals' []) >>= firstRow+ case x of+ Just xs -> pureFromPersistValue xs+ Nothing -> pureFromPersistValue []+ 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' [])+ pureFromPersistValue [rowid]++insert_' :: (PersistEntity v) => v -> Action Postgresql ()+insert_' v = do+ -- constructor number and the rest of the field values+ vals <- toEntityPersistValues' v+ let e = entityDef proxy v+ let constructorNum = fromPrimitivePersistValue (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 <> columnsValues <> returning+ (fields, returning) = case constrAutoKeyName c of+ Just idName -> (fields', returning')+ where+ 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+ [] -> " DEFAULT VALUES"+ xs -> "(" <> commasJoin xs <> ") VALUES(" <> placeholders <> ")"+ RenderS placeholders vals' = commasJoin $ map renderPersistValue vals++insertList' :: forall a. PersistField a => [a] -> Action Postgresql 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+ let valuesName = mainName <> delim' <> "values"+ 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] -> Action Postgresql ()+ go n (x : xs) = do+ x' <- toPersistValues x+ executeRaw' query $ (k :) . (toPrimitivePersistValue n :) . x' $ []+ go (n + 1) xs+ go _ [] = pure ()+ go 0 l+ pure $ fromPrimitivePersistValue k++getList' :: forall a. PersistField a => Int64 -> Action Postgresql [a]+getList' k = do+ let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))+ let valuesName = mainName <> delim' <> "values"+ let value = ("value", dbType proxy (undefined :: a))+ let query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord"+ queryRaw' query [toPrimitivePersistValue k] >>= mapStream (fmap fst . fromPersistValues) >>= streamToList++--TODO: consider removal+getKey :: RowStream [PersistValue] -> Action Postgresql PersistValue+getKey stream = firstRow stream >>= \(Just [k]) -> pure k++----------++executeRaw' :: Utf8 -> [PersistValue] -> Action Postgresql ()+executeRaw' query vals = do+ -- $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals+ Postgresql conn <- ask+ let stmt = getStatement query+ liftIO $ do+ _ <- PG.execute conn stmt (map P vals)+ pure ()++renderConfig :: RenderConfig+renderConfig =+ RenderConfig+ { esc = escapeS+ }++escapeS :: Utf8 -> Utf8+escapeS a = let q = fromChar '"' in q <> a <> q++delim' :: Utf8+delim' = fromChar delim++toEntityPersistValues' :: PersistEntity v => v -> Action Postgresql [PersistValue]+toEntityPersistValues' = fmap ($ []) . toEntityPersistValues++--- MIGRATION++migrate' :: (PersistEntity v) => v -> Migration (Action Postgresql)+migrate' v = do+ migPack <- lift getMigrationPack+ migrateRecursively (migrateSchema migPack) (migrateEntity migPack) (migrateList migPack) v++migrationPack :: String -> GM.MigrationPack Postgresql+migrationPack currentSchema = m+ where+ m =+ GM.MigrationPack+ compareTypes+ (compareRefs currentSchema)+ compareUniqs+ compareDefaults+ migTriggerOnDelete+ migTriggerOnUpdate+ (GM.defaultMigConstr m)+ escape+ "BIGSERIAL PRIMARY KEY UNIQUE"+ 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+ [ escape n,+ " ",+ showSqlType t,+ " ",+ if nu then "NULL" else "NOT NULL",+ case def of+ Nothing -> ""+ Just s -> " DEFAULT " ++ s+ ]++migTriggerOnDelete :: QualifiedName -> [(String, String)] -> Action Postgresql (Bool, [AlterDB])+migTriggerOnDelete tName deletes = do+ let funcName = tName+ trigName = tName+ func <- analyzeFunction funcName+ trig <- analyzeTrigger trigName+ let funcBody = "BEGIN " ++ concatMap snd deletes ++ "RETURN NEW;END;"+ addFunction = CreateOrReplaceFunction $ "CREATE OR REPLACE FUNCTION " ++ withSchema funcName ++ "() RETURNS trigger AS $$" ++ funcBody ++ "$$ LANGUAGE plpgsql"+ funcMig = case func of+ Nothing | null deletes -> []+ Nothing -> [addFunction]+ Just (_, Just (DbOther (OtherTypeDef [Left "trigger"])), body) ->+ if null deletes -- remove old trigger if a datatype earlier had fields of ephemeral types+ then [DropFunction funcName]+ else+ if body == funcBody+ then []+ else -- this can happen when an ephemeral field was added or removed.+ [DropFunction funcName, addFunction]+ _ -> [] -- ignore same name functions which don't return a trigger.+ trigBody = "EXECUTE PROCEDURE " ++ withSchema funcName ++ "()"+ -- starting from version 11 postgresql returns EXECUTE FUNCTION+ trigBody11 = "EXECUTE FUNCTION " ++ withSchema funcName ++ "()"+ addTrigger = AddTriggerOnDelete trigName tName 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 tName]+ else+ if body == trigBody || body == trigBody11+ then []+ else -- this can happen when an ephemeral field was added or removed.+ [DropTrigger trigName tName, addTrigger]+ )+ pure (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 :: QualifiedName -> [(String, String)] -> Action Postgresql [(Bool, [AlterDB])]+migTriggerOnUpdate tName dels = forM dels $ \(fieldName, del) -> do+ let funcName = second (\name -> name ++ delim : fieldName) tName+ let trigName = second (\name -> name ++ delim : fieldName) tName+ func <- analyzeFunction funcName+ trig <- analyzeTrigger trigName+ let funcBody = "BEGIN " ++ del ++ "RETURN NEW;END;"+ addFunction = CreateOrReplaceFunction $ "CREATE OR REPLACE FUNCTION " ++ withSchema funcName ++ "() RETURNS trigger AS $$" ++ funcBody ++ "$$ LANGUAGE plpgsql"+ funcMig = case func of+ Nothing -> [addFunction]+ Just (_, Just (DbOther (OtherTypeDef [Left "trigger"])), body) ->+ if body == funcBody+ then []+ else -- this can happen when an ephemeral field was added or removed.+ [DropFunction funcName, addFunction]+ _ -> []++ trigBody = "EXECUTE PROCEDURE " ++ withSchema funcName ++ "()"+ -- starting from version 11 postgresql returns EXECUTE FUNCTION+ trigBody11 = "EXECUTE FUNCTION " ++ withSchema funcName ++ "()"+ addTrigger = AddTriggerOnUpdate trigName tName (Just fieldName) trigBody+ (trigExisted, trigMig) = case trig of+ Nothing -> (False, [addTrigger])+ Just body ->+ ( True,+ if body == trigBody || body == trigBody11+ then []+ else -- this can happen when an ephemeral field was added or removed.+ [DropTrigger trigName tName, addTrigger]+ )+ pure (trigExisted, funcMig ++ trigMig)++analyzeTable' :: QualifiedName -> Action Postgresql (Maybe TableInfo)+analyzeTable' name = do+ table <- queryRaw' "SELECT * FROM information_schema.tables WHERE table_schema = coalesce(?, current_schema()) AND table_name = ?" (toPurePersistValues name []) >>= firstRow+ case table of+ Just _ -> do+ 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 (toPurePersistValues name []) >>= mapStream (pure . getColumn . fst . fromPurePersistValues) >>= streamToList+ 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 (toPurePersistValues ("UNIQUE" :: String, name) []) >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList+ uniqPrimary <- queryRaw' constraintQuery (toPurePersistValues ("PRIMARY KEY" :: String, name) []) >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList+ -- indexes with system columns like oid are omitted+ let indexQuery =+ "WITH indexes as (\+ \SELECT ic.oid, ic.relname,\+ \ ta.attnum, ta.attname, pg_get_indexdef(i.indexrelid, ia.attnum, true) as expr\+ \ 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 ta.attnum = i.indkey[ia.attnum-1] AND NOT ta.attisdropped\+ \ 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)\+ \SELECT i.relname, i.attname, i.expr\+ \ FROM indexes i\+ \ INNER JOIN (SELECT oid FROM indexes\+ \ GROUP BY oid\+ \ HAVING every(attnum > 0 OR attnum IS NULL)) non_system ON i.oid = non_system.oid"+ uniqIndexes <- queryRaw' indexQuery (toPurePersistValues name []) >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList+ 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 (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 name+ pure $ Just $ TableInfo cols uniqs references+ Nothing -> pure Nothing++getColumn :: ((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 :: QualifiedName -> Action Postgresql [(Maybe String, Reference)]+analyzeTableReferences 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\+ \ 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 (toPurePersistValues tName []) >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList+ -- (refName, ((parentTableSchema, parentTable, onDelete, onUpdate), (childColumn, parentColumn)))+ let mkReference xs = (Just refName, Reference parentTable pairs (mkAction onDelete) (mkAction onUpdate))+ where+ pairs = map (snd . snd) xs+ (refName, ((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+ pure references++showAlterDb :: AlterDB -> SingleMigration+showAlterDb (AddTable s) = Right [(False, defaultPriority, s)]+showAlterDb (AlterTable t _ _ _ alts) = Right $ concatMap (showAlterTable $ withSchema t) alts+showAlterDb (DropTrigger trigName tName) = Right [(False, triggerPriority, "DROP TRIGGER " ++ withSchema trigName ++ " ON " ++ withSchema tName)]+showAlterDb (AddTriggerOnDelete trigName tName body) = Right [(False, triggerPriority, "CREATE TRIGGER " ++ withSchema trigName ++ " AFTER DELETE ON " ++ withSchema tName ++ " FOR EACH ROW " ++ body)]+showAlterDb (AddTriggerOnUpdate trigName tName fName body) = Right [(False, triggerPriority, "CREATE TRIGGER " ++ withSchema trigName ++ " AFTER UPDATE OF " ++ fName' ++ " ON " ++ withSchema tName ++ " FOR EACH ROW " ++ body)]+ where+ fName' = maybe (error $ "showAlterDb: AddTriggerOnUpdate does not have fieldName for trigger " ++ show trigName) escape fName+showAlterDb (CreateOrReplaceFunction s) = Right [(False, functionPriority, s)]+showAlterDb (DropFunction funcName) = Right [(False, functionPriority, "DROP FUNCTION " ++ withSchema funcName ++ "()")]+showAlterDb (CreateSchema sch ifNotExists) = Right [(False, schemaPriority, "CREATE SCHEMA " ++ ifNotExists' ++ escape sch)]+ where+ ifNotExists' = if ifNotExists then "IF NOT EXISTS " else ""++showAlterTable :: String -> AlterTable -> [(Bool, Int, String)]+showAlterTable table (AddColumn col) =+ [ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ 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 (either escape id) cols,+ ")"+ ]+ )+ ]+showAlterTable table (AddUnique (UniqueDef uName UniqueIndex cols)) =+ [ ( False,+ defaultPriority,+ concat+ [ "CREATE UNIQUE INDEX ",+ maybe "" escape uName,+ " ON ",+ table,+ "(",+ intercalate "," $ map (either escape id) cols,+ ")"+ ]+ )+ ]+showAlterTable table (AddUnique (UniqueDef uName (UniquePrimary _) cols)) =+ [ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " ADD",+ maybe "" ((" CONSTRAINT " ++) . escape) uName,+ " PRIMARY KEY(",+ intercalate "," $ map (either escape id) cols,+ ")"+ ]+ )+ ]+showAlterTable table (DropConstraint uName) =+ [ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " DROP CONSTRAINT ",+ escape uName+ ]+ )+ ]+showAlterTable _ (DropIndex uName) =+ [ ( False,+ defaultPriority,+ "DROP INDEX " ++ escape uName+ )+ ]+showAlterTable table (AddReference (Reference tName columns onDelete onUpdate)) =+ [ ( False,+ referencePriority,+ concat+ [ "ALTER TABLE ",+ table,+ " ADD FOREIGN KEY(",+ ourKey,+ ") REFERENCES ",+ withSchema tName,+ "(",+ foreignKey,+ ")",+ maybe "" ((" ON DELETE " ++) . showReferenceAction) onDelete,+ maybe "" ((" ON UPDATE " ++) . showReferenceAction) onUpdate+ ]+ )+ ]+ where+ (ourKey, foreignKey) = f *** f $ unzip columns+ f = intercalate ", " . map escape+showAlterTable table (DropReference name) =+ [ ( False,+ defaultPriority,+ "ALTER TABLE " ++ table ++ " DROP CONSTRAINT " ++ name+ )+ ]++showAlterColumn :: String -> String -> AlterColumn -> (Bool, Int, String)+showAlterColumn table n (Type t) =+ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " ALTER COLUMN ",+ escape n,+ " TYPE ",+ showSqlType t+ ]+ )+showAlterColumn table n IsNull =+ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " ALTER COLUMN ",+ escape n,+ " DROP NOT NULL"+ ]+ )+showAlterColumn table n NotNull =+ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " ALTER COLUMN ",+ escape n,+ " SET NOT NULL"+ ]+ )+showAlterColumn table n (Default s) =+ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " ALTER COLUMN ",+ escape n,+ " SET DEFAULT ",+ s+ ]+ )+showAlterColumn table n NoDefault =+ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " ALTER COLUMN ",+ escape n,+ " DROP DEFAULT"+ ]+ )+showAlterColumn table n (UpdateValue s) =+ ( False,+ defaultPriority,+ concat+ [ "UPDATE ",+ table,+ " SET ",+ escape n,+ "=",+ s,+ " WHERE ",+ escape n,+ " IS NULL"+ ]+ )++-- | 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) -> DbTypePrimitive+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+ attrs = liftM2 (\a b -> if b == 0 then show a else show a ++ ", " ++ show b) numeric_precision numeric_scale+ "date" -> DbDay+ "bool" -> DbBool+ "time" -> mkDate DbTime "time"+ "timestamp" -> mkDate DbDayTime "timestamp"+ "timestamptz" -> mkDate DbDayTimeZoned "timestamptz"+ "float4" -> DbReal+ "float8" -> DbReal+ "bytea" -> DbBlob+ _ | 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 t = DbOther $ OtherTypeDef [Left t]+ wrap x = "(" ++ x ++ ")"+ 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++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 ts) -> concatMap (either id showSqlType) ts++compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool+compareUniqs (UniqueDef _ (UniquePrimary _) cols1) (UniqueDef _ (UniquePrimary _) cols2) = haveSameElems (==) cols1 cols2+compareUniqs (UniqueDef name1 type1 cols1) (UniqueDef name2 type2 cols2) = (Just False /= 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) =+ 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 :: 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, schemaPriority, referencePriority, functionPriority, triggerPriority :: Int+defaultPriority = 1+schemaPriority = 0+referencePriority = 2+functionPriority = 3+triggerPriority = 4++mainTableId :: String+mainTableId = "id"++--- MAIN++-- It is used to escape table names and columns, which can include only symbols allowed in Haskell datatypes and '$' delimiter. We need it mostly to support names that coincide with SQL keywords+escape :: String -> String+escape s = '\"' : s ++ "\""++getStatement :: Utf8 -> PG.Query+getStatement sql = PG.Query $ fromUtf8 sql++queryRaw' :: Utf8 -> [PersistValue] -> Action Postgresql (RowStream [PersistValue])+queryRaw' query vals = do+ -- $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals+ Postgresql conn <- ask+ let open = do+ rawquery <- PG.formatQuery conn (getStatement query) (map P vals)+ -- Take raw connection+ (ret, rowRef, rowCount, getters) <- PG.withConnection conn $ \rawconn -> do+ -- Execute query+ mret <- LibPQ.exec rawconn rawquery+ case mret of+ Nothing -> do+ merr <- LibPQ.errorMessage rawconn+ fail $ case merr of+ Nothing -> "Postgresql.queryRaw': unknown error"+ Just e -> "Postgresql.queryRaw': " ++ unpack e+ Just ret -> do+ -- Check result status+ status <- LibPQ.resultStatus ret+ case status of+ LibPQ.TuplesOk -> pure ()+ _ -> do+ msg <- LibPQ.resStatus status+ merr <- LibPQ.errorMessage rawconn+ fail $+ "Postgresql.queryRaw': bad result status "+ ++ show status+ ++ " ("+ ++ show msg+ ++ ")"+ ++ 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+ pure $ getGetter oid $ PG.Field ret col oid+ -- Ready to go!+ rowRef <- newIORef (LibPQ.Row 0)+ rowCount <- LibPQ.ntuples ret+ pure (ret, rowRef, rowCount, getters)++ pure $ do+ row <- atomicModifyIORef rowRef (\r -> (r + 1, r))+ if row == rowCount+ then pure Nothing+ else fmap Just $+ forM (zip getters [0 ..]) $ \(getter, col) -> do+ mbs <- LibPQ.getvalue' ret row col+ case mbs of+ Nothing -> pure PersistNull+ Just bs -> do+ ok <- PGFF.runConversion (getter mbs) conn+ bs `seq` case ok of+ Errors (exc : _) -> throw exc+ Errors [] -> error "Got an Errors, but no exceptions"+ Ok v -> pure v+ pure $ mkAcquire open (const $ pure ())++-- | Avoid orphan instances.+newtype P = P PersistValue++instance PGTF.ToField P where+ toField (P (PersistString t)) = PGTF.toField t+ toField (P (PersistText 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 = PGFF.FieldParser a++convertPV :: PGFF.FromField a => (a -> b) -> Getter b+convertPV f = (fmap f .) . PGFF.fromField++getGetter :: PG.Oid -> Getter PersistValue+getGetter (PG.Oid oid) = case oid of+ 16 -> convertPV PersistBool+ 17 -> convertPV (PersistByteString . unBinary)+ 18 -> convertPV PersistText+ 19 -> convertPV PersistText+ 20 -> convertPV PersistInt64+ 21 -> convertPV PersistInt64+ 23 -> convertPV PersistInt64+ 25 -> convertPV PersistText+ 142 -> convertPV PersistText+ 700 -> convertPV PersistDouble+ 701 -> convertPV PersistDouble+ 702 -> convertPV PersistUTCTime+ 703 -> convertPV PersistUTCTime+ 1042 -> convertPV PersistText+ 1043 -> convertPV PersistText+ 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 -> \_ _ -> pure PersistNull+ _ -> \f dat -> fmap PersistByteString $ case dat of+ Nothing -> PGFF.returnError PGFF.UnexpectedNull f ""+ Just str -> pure $ copy str++unBinary :: PG.Binary a -> a+unBinary (PG.Binary x) = x++proxy :: proxy Postgresql+proxy = error "proxy Postgresql"++withSchema :: QualifiedName -> String+withSchema (sch, name) = maybe "" (\x -> escape x ++ ".") sch ++ escape name++-- | Put explicit type for expression. It is useful for values which are defaulted to a wrong type.+-- For example, a literal Int from a 64bit machine can be defaulted to a 32bit int by Postgresql.+-- 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 proxy a of+ DbTypePrimitive t' _ _ _ -> showSqlType t'+ _ -> error "explicitType: type is not primitive"++-- | Casts expression to a type. @castType value \"INT\"@ results in @value::INT@.+castType :: (Expression Postgresql r a, PersistField a) => a -> String -> Expr Postgresql r a+castType a t = mkExpr $ Snippet $ \conf _ -> ["(" <> renderExpr conf (toExpr a) <> ")::" <> fromString t]++-- | Distinct only on certain fields or expressions. For example, @select $ CondEmpty `distinctOn` (lower EmailField, IpField)@.+distinctOn :: (db ~ Postgresql, HasSelectOptions a db r, HasDistinct a ~ HFalse, Projection' p db r p') => a -> p -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a) HTrue+distinctOn opts p = opts' {dbSpecificOptions = ("DISTINCT_ON", clause) : dbSpecificOptions opts'}+ where+ opts' = getSelectOptions opts+ clause = Snippet $ \conf _ -> [commasJoin $ concatMap (renderExprExtended conf 0) $ projectionExprs p []]++preColumns :: HasSelectOptions opts Postgresql r => opts -> RenderS Postgresql r+preColumns opts = clause+ where+ clause = apply "DISTINCT_ON" (\t -> "DISTINCT ON (" <> t <> ")")+ apply k f = case lookup k opts' of+ Nothing -> mempty+ Just (Snippet snippet) -> f $ head $ snippet renderConfig 0+ opts' = dbSpecificOptions $ getSelectOptions opts
Database/Groundhog/Postgresql/Array.hs view
@@ -1,196 +1,210 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, OverloadedStrings, UndecidableInstances, 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.Expression -import Database.Groundhog.Generic -import Database.Groundhog.Generic.Sql hiding (append) -import Database.Groundhog.Postgresql hiding (append) - -import Control.Applicative -import Control.Monad (mzero) -import qualified Data.Aeson as A -import Data.Attoparsec.ByteString.Char8 -import qualified Data.Attoparsec.ByteString as A -import qualified Data.Attoparsec.Zepto as Z -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as B (toStrict) -import qualified Data.ByteString.Unsafe as B -import qualified Data.ByteString.Builder as B -import Data.Monoid hiding ((<>)) -import Data.Word -import qualified Data.Vector as V -import Data.Traversable (traverse) -import Prelude hiding (all, any) - --- | Represents PostgreSQL arrays -newtype Array a = Array [a] deriving (Eq, Show) - -instance A.ToJSON a => A.ToJSON (Array a) where - toJSON (Array xs) = A.toJSON xs - -instance A.FromJSON a => A.FromJSON (Array a) where - parseJSON (A.Array xs) = fmap (Array . V.toList) (traverse A.parseJSON xs) - parseJSON _ = mzero - -instance (ArrayElem a, PrimitivePersistField a) => PersistField (Array a) where - persistName a = "Array" ++ delim : persistName ((undefined :: Array a -> a) a) - toPersistValues = primToPersistValue - fromPersistValues = primFromPersistValue - 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 - parseElem :: Parser a - -instance {-# OVERLAPPABLE #-} ArrayElem a => ArrayElem (Array a) where - parseElem = parseArr - -instance {-# OVERLAPPABLE #-} PrimitivePersistField a => ArrayElem a where - parseElem = fmap (fromPrimitivePersistValue . PersistByteString) parseString - -instance (ArrayElem a, PrimitivePersistField a) => PrimitivePersistField (Array a) where - toPrimitivePersistValue (Array xs) = PersistCustom arr (vals []) where - arr = "ARRAY[" <> query <> "]::" <> fromString typ - RenderS query vals = commasJoin $ map (renderPersistValue . toPrimitivePersistValue) xs - typ = showSqlType $ arrayType (undefined :: p Postgresql) $ Array xs - fromPrimitivePersistValue a = parseHelper parser a where - dimensions = char '[' *> takeWhile1 (/= '=') *> char '=' - parser = optional dimensions *> parseArr - -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 = B.toStrict <$> B.toLazyByteString <$> 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` B.byteString h `mappend` m) - {-# INLINE cont #-} - cont (B.word8 escape) - done <- Z.atEnd - if done - then return (acc `mappend` B.byteString h) - else rest - -doubleQuote, backslash :: Word8 -doubleQuote = 34 -backslash = 92 - -parseArr :: ArrayElem a => Parser (Array a) -parseArr = Array <$> (char '{' *> parseElem `sepBy` char ',' <* char '}') - -(!) :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b Int, PersistField elem) => a -> b -> Expr Postgresql r elem -(!) arr i = mkExpr $ Snippet $ \conf _ -> [renderExpr conf (toExpr arr) <> "[" <> renderExpr conf (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) = mkExpr $ Snippet $ \conf _ -> [renderExpr conf (toExpr arr) <> "[" <> renderExpr conf (toExpr i1) <> ":" <> renderExpr conf (toExpr i2) <> "]"] - -prepend :: (ExpressionOf Postgresql r a elem, ExpressionOf Postgresql r b (Array elem)) => a -> b -> Expr Postgresql r (Array elem) -prepend a b = mkExpr $ function "array_prepend" [toExpr a, toExpr b] - -append :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b elem) => a -> b -> Expr Postgresql r (Array elem) -append a b = mkExpr $ function "array_append" [toExpr a, toExpr b] - -arrayCat :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b (Array elem)) => a -> b -> Expr Postgresql r (Array elem) -arrayCat a b = mkExpr $ function "array_cat" [toExpr a, toExpr b] - -arrayDims :: (ExpressionOf Postgresql r a (Array elem)) => a -> Expr Postgresql r String -arrayDims arr = mkExpr $ function "array_dims" [toExpr arr] - -arrayNDims :: (ExpressionOf Postgresql r a (Array elem)) => a -> Expr Postgresql r Int -arrayNDims arr = mkExpr $ function "array_ndims" [toExpr arr] - -arrayLower :: (ExpressionOf Postgresql r a (Array elem)) => a -> Int -> Expr Postgresql r Int -arrayLower arr dim = mkExpr $ function "array_lower" [toExpr arr, toExpr dim] - -arrayUpper :: (ExpressionOf Postgresql r a (Array elem)) => a -> Int -> Expr Postgresql r Int -arrayUpper arr dim = mkExpr $ function "array_upper" [toExpr arr, toExpr dim] - -arrayLength :: (ExpressionOf Postgresql r a (Array elem)) => a -> Int -> Expr Postgresql r Int -arrayLength arr dim = mkExpr $ 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 = mkExpr $ 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 = mkExpr $ 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 $ \conf _ -> [renderExprPriority conf 37 (toExpr a) <> "=ANY" <> fromChar '(' <> renderExpr conf (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 $ \conf _ -> [renderExprPriority conf 37 (toExpr a) <> "=ALL" <> fromChar '(' <> renderExpr conf (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 +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | 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 Control.Applicative+import Control.Monad (mzero)+import qualified Data.Aeson as A+import qualified Data.Attoparsec.ByteString as A+import Data.Attoparsec.ByteString.Char8+import qualified Data.Attoparsec.Zepto as Z+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Lazy as B (toStrict)+import qualified Data.ByteString.Unsafe as B+import Data.Monoid hiding ((<>))+import qualified Data.Vector as V+import Data.Word+import Database.Groundhog.Core+import Database.Groundhog.Expression+import Database.Groundhog.Generic+import Database.Groundhog.Generic.Sql hiding (append)+import Database.Groundhog.Postgresql hiding (append)+import Prelude hiding (all, any)++-- | Represents PostgreSQL arrays+newtype Array a = Array [a] deriving (Eq, Show)++instance A.ToJSON a => A.ToJSON (Array a) where+ toJSON (Array xs) = A.toJSON xs++instance A.FromJSON a => A.FromJSON (Array a) where+ parseJSON (A.Array xs) = fmap (Array . V.toList) (traverse A.parseJSON xs)+ parseJSON _ = mzero++instance (ArrayElem a, PrimitivePersistField a) => PersistField (Array a) where+ persistName a = "Array" ++ delim : persistName ((undefined :: Array a -> a) a)+ toPersistValues = primToPersistValue+ fromPersistValues = primFromPersistValue+ 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+ parseElem :: Parser a++instance {-# OVERLAPPABLE #-} ArrayElem a => ArrayElem (Array a) where+ parseElem = parseArr++instance {-# OVERLAPPABLE #-} PrimitivePersistField a => ArrayElem a where+ parseElem = fmap (fromPrimitivePersistValue . PersistByteString) parseString++instance (ArrayElem a, PrimitivePersistField a) => PrimitivePersistField (Array a) where+ toPrimitivePersistValue (Array xs) = PersistCustom arr (vals [])+ where+ arr = "ARRAY[" <> query <> "]::" <> fromString typ+ RenderS query vals = commasJoin $ map (renderPersistValue . toPrimitivePersistValue) xs+ typ = showSqlType $ arrayType (undefined :: p Postgresql) $ Array xs+ fromPrimitivePersistValue a = parseHelper parser a+ where+ dimensions = char '[' *> takeWhile1 (/= '=') *> char '='+ parser = optional dimensions *> parseArr++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 -> pure r+ Left err -> fail err+ else pure s+{-# INLINE jstring_ #-}++-- Borrowed from aeson+unescape :: Z.Parser ByteString+unescape = B.toStrict <$> B.toLazyByteString <$> 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` B.byteString h `mappend` m)+ {-# INLINE cont #-}+ cont (B.word8 escape)+ done <- Z.atEnd+ if done+ then pure (acc `mappend` B.byteString h)+ else rest++doubleQuote, backslash :: Word8+doubleQuote = 34+backslash = 92++parseArr :: ArrayElem a => Parser (Array a)+parseArr = Array <$> (char '{' *> parseElem `sepBy` char ',' <* char '}')++(!) :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b Int, PersistField elem) => a -> b -> Expr Postgresql r elem+(!) arr i = mkExpr $ Snippet $ \conf _ -> [renderExpr conf (toExpr arr) <> "[" <> renderExpr conf (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) = mkExpr $ Snippet $ \conf _ -> [renderExpr conf (toExpr arr) <> "[" <> renderExpr conf (toExpr i1) <> ":" <> renderExpr conf (toExpr i2) <> "]"]++prepend :: (ExpressionOf Postgresql r a elem, ExpressionOf Postgresql r b (Array elem)) => a -> b -> Expr Postgresql r (Array elem)+prepend a b = mkExpr $ function "array_prepend" [toExpr a, toExpr b]++append :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b elem) => a -> b -> Expr Postgresql r (Array elem)+append a b = mkExpr $ function "array_append" [toExpr a, toExpr b]++arrayCat :: (ExpressionOf Postgresql r a (Array elem), ExpressionOf Postgresql r b (Array elem)) => a -> b -> Expr Postgresql r (Array elem)+arrayCat a b = mkExpr $ function "array_cat" [toExpr a, toExpr b]++arrayDims :: (ExpressionOf Postgresql r a (Array elem)) => a -> Expr Postgresql r String+arrayDims arr = mkExpr $ function "array_dims" [toExpr arr]++arrayNDims :: (ExpressionOf Postgresql r a (Array elem)) => a -> Expr Postgresql r Int+arrayNDims arr = mkExpr $ function "array_ndims" [toExpr arr]++arrayLower :: (ExpressionOf Postgresql r a (Array elem)) => a -> Int -> Expr Postgresql r Int+arrayLower arr dim = mkExpr $ function "array_lower" [toExpr arr, toExpr dim]++arrayUpper :: (ExpressionOf Postgresql r a (Array elem)) => a -> Int -> Expr Postgresql r Int+arrayUpper arr dim = mkExpr $ function "array_upper" [toExpr arr, toExpr dim]++arrayLength :: (ExpressionOf Postgresql r a (Array elem)) => a -> Int -> Expr Postgresql r Int+arrayLength arr dim = mkExpr $ 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 = mkExpr $ 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 = mkExpr $ 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 $ \conf _ -> [renderExprPriority conf 37 (toExpr a) <> "=ANY" <> fromChar '(' <> renderExpr conf (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 $ \conf _ -> [renderExprPriority conf 37 (toExpr a) <> "=ALL" <> fromChar '(' <> renderExpr conf (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
Database/Groundhog/Postgresql/Geometry.hs view
@@ -1,419 +1,504 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses #-} -module Database.Groundhog.Postgresql.Geometry - ( - Point(..) - , Line(..) - , Lseg(..) - , Box(..) - , Path(..) - , Polygon(..) - , Circle(..) - , (+.) - , (-.) - , (*.) - , (/.) - , (#) - , (##) - , (<->) - , (&&) - , (<<) - , (>>) - , (&<) - , (&>) - , (<<|) - , (|>>) - , (&<|) - , (|&>) - , (<^) - , (>^) - , (?#) - , (?-) - , (?|) - , (?-|) - , (?||) - , (@>) - , (<@) - , (~=) - ) where - -import Prelude hiding ((&&), (>>)) - -import Database.Groundhog.Core -import Database.Groundhog.Expression -import Database.Groundhog.Generic -import Database.Groundhog.Generic.Sql -import Database.Groundhog.Instances () - -import Control.Applicative -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. -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) = toPrimitivePersistValue $ show (x, y) - fromPrimitivePersistValue = parseHelper point - -instance PersistField Point where - persistName _ = "Point" - toPersistValues = primToPersistValue - fromPersistValues = primFromPersistValue - dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "point"]) False Nothing Nothing - -instance PrimitivePersistField Line where - toPrimitivePersistValue (Line (Point x1 y1) (Point x2 y2)) = toPrimitivePersistValue $ show ((x1, y1), (x2, y2)) - fromPrimitivePersistValue = error "fromPrimitivePersistValue Line is not supported yet" - -instance PersistField Line where - persistName _ = "Line" - toPersistValues = primToPersistValue - fromPersistValues = primFromPersistValue - dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "line"]) False Nothing Nothing - -instance PrimitivePersistField Lseg where - toPrimitivePersistValue (Lseg (Point x1 y1) (Point x2 y2)) = toPrimitivePersistValue $ show ((x1, y1), (x2, y2)) - fromPrimitivePersistValue = parseHelper $ pair Lseg '[' ']' point - -instance PersistField Lseg where - persistName _ = "Lseg" - toPersistValues = primToPersistValue - fromPersistValues = primFromPersistValue - dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "lseg"]) False Nothing Nothing - -instance PrimitivePersistField Box where - toPrimitivePersistValue (Box (Point x1 y1) (Point x2 y2)) = toPrimitivePersistValue $ show ((x1, y1), (x2, y2)) - fromPrimitivePersistValue = parseHelper $ Box <$> (point <* char ',') <*> point - -instance PersistField Box where - persistName _ = "Box" - toPersistValues = primToPersistValue - fromPersistValues = primFromPersistValue - dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "box"]) False Nothing Nothing - -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 = toPrimitivePersistValue $ 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 _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "path"]) False Nothing Nothing - -instance PrimitivePersistField Polygon where - toPrimitivePersistValue (Polygon ps) = toPrimitivePersistValue $ showPath '(' ')' ps "" - fromPrimitivePersistValue = parseHelper $ Polygon <$> (char '(' *> points <* char ')') - -instance PersistField Polygon where - persistName _ = "Polygon" - toPersistValues = primToPersistValue - fromPersistValues = primFromPersistValue - dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "polygon"]) False Nothing Nothing - -instance PrimitivePersistField Circle where - toPrimitivePersistValue (Circle (Point x1 y1) r) = toPrimitivePersistValue $ show ((x1, y1), r) - fromPrimitivePersistValue = parseHelper $ Circle <$> (char '<' *> point) <* char ',' <*> double <* char '>' - -instance PersistField Circle where - persistName _ = "Circle" - toPersistValues = primToPersistValue - fromPersistValues = primFromPersistValue - dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "circle"]) False Nothing Nothing - -class BoxLineLseg a -instance BoxLineLseg Box -instance BoxLineLseg Line -instance BoxLineLseg Lseg - -class BoxCirclePolygon a -instance BoxCirclePolygon Box -instance BoxCirclePolygon Circle -instance BoxCirclePolygon Polygon - -class BoxCirclePathPoint a -instance BoxCirclePathPoint Box -instance BoxCirclePathPoint Circle -instance BoxCirclePathPoint Path -instance BoxCirclePathPoint Point - -class BoxCirclePointPolygon a -instance BoxCirclePointPolygon Box -instance BoxCirclePointPolygon Circle -instance BoxCirclePointPolygon Point -instance BoxCirclePointPolygon Polygon - -class BoxPoint a -instance BoxPoint Box -instance BoxPoint Point - -class LineLseg a -instance LineLseg Line -instance LineLseg Lseg - -class Plus a b -instance Plus Box Point -instance Plus Circle Point -instance Plus Path Point -instance Plus Path Path -instance Plus Point Point - -class Distance a b -instance Distance Box Box -instance Distance Circle Circle -instance Distance Circle Polygon -instance Distance Line Line -instance Distance Line Box -instance Distance Lseg Line -instance Distance Lseg Lseg -instance Distance Lseg Box -instance Distance Path Path -instance Distance Point Path -instance Distance Point Point -instance Distance Point Circle -instance Distance Point Line -instance Distance Point Box -instance Distance Point Lseg -instance Distance Polygon Polygon - -class Contains a b -instance Contains Box Box -instance Contains Box Point -instance Contains Circle Circle -instance Contains Circle Point -instance Contains Path Point -instance Contains Polygon Polygon -instance Contains Polygon Point - -class Contained a b -instance Contained Box Box -instance Contained Circle Circle -instance Contained Lseg Box -instance Contained Lseg Line -instance Contained Point Lseg -instance Contained Point Box -instance Contained Point Line -instance Contained Point Path -instance Contained Point Polygon -instance Contained Point Circle -instance Contained Polygon Polygon - -class Closest a b -instance Closest Line Box -instance Closest Line Lseg -instance Closest Lseg Box -instance Closest Lseg Line -instance Closest Lseg Lseg -instance Closest Point Line -instance Closest Point Box -instance Closest Point Lseg - -class Intersects a b -instance Intersects Box Box -instance Intersects Line Line -instance Intersects Line Box -instance Intersects Lseg Box -instance Intersects Lseg Line -instance Intersects Lseg Lseg -instance Intersects Path Path - -psqlOperatorExpr :: (SqlDb db, Expression db r a, Expression db r b, PersistField c) => String -> a -> b -> Expr db r c -psqlOperatorExpr op x y = mkExpr $ operator 50 op x y - -psqlOperatorCond :: (SqlDb db, Expression db r a, Expression db r b) => String -> a -> b -> Cond db r -psqlOperatorCond op x y = CondRaw $ operator 50 op x y - - -infixl 6 +. -infixl 6 -. -infixl 7 *. -infixl 7 /. --- | Translation --- --- @box '((0,0),(1,1))' + point '(2.0,0)' = box '(3,1),(2,0)'@ -(+.) :: (SqlDb db, Plus a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Expr db r a -x +. y = mkExpr $ operator 60 "+" x y - --- | Translation --- --- @box '((0,0),(1,1))' - point '(2.0,0)' = box '(-1,1),(-2,0)'@ -(-.) :: (SqlDb db, BoxCirclePathPoint a, ExpressionOf db r x a, ExpressionOf db r y Point) => x -> y -> Expr db r a -x -. y = mkExpr $ operator 60 "-" x y - --- | Scaling/rotation --- --- @box '((0,0),(1,1))' * point '(2.0,0)' = box '(2,2),(0,0)'@ -(*.) :: (SqlDb db, BoxCirclePathPoint a, ExpressionOf db r x a, ExpressionOf db r y Point) => x -> y -> Expr db r a -x *. y = mkExpr $ operator 70 "*" x y - --- | Scaling/rotation --- --- @box '((0,0),(2,2))' / point '(2.0,0)' = box '(1,1),(0,0)'@ -(/.) :: (SqlDb db, BoxCirclePathPoint a, ExpressionOf db r x a, ExpressionOf db r y Point) => x -> y -> Expr db r a -x /. y = mkExpr $ operator 70 "/" x y - --- | Point or box of intersection --- --- @lseg '((1,-1),(-1,1))' # '((1,1),(-1,-1))' = point '(0,0)'@ --- --- @box '((1,-1),(-1,1))' # '((1,1),(-1,-1))' = box '(1,1),(-1,-1)'@ -(#) :: (SqlDb db, BoxLineLseg a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Expr db r a -(#) = psqlOperatorExpr "#" - --- | Closest point to first operand on second operand --- --- @point '(0,0)' ## lseg '((2,0),(0,2))' = point '(1,1)'@ -(##) :: (SqlDb db, Closest a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Expr db r Point -(##) = psqlOperatorExpr "##" - --- | Distance between --- --- @circle '((0,0),1)' <-> circle '((5,0),1)' = 3@ -(<->) :: (SqlDb db, Distance a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Expr db r Double -(<->) = psqlOperatorExpr "<->" - --- | Overlaps? --- --- @box '((0,0),(1,1))' && box '((0,0),(2,2))' = true@ -(&&) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(&&) = psqlOperatorCond "&&" - --- | Is strictly left of? --- --- @circle '((0,0),1)' << circle '((5,0),1)' = true@ -(<<) :: (SqlDb db, BoxCirclePointPolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(<<) = psqlOperatorCond "<<" - --- | Is strictly right of? --- --- @circle '((5,0),1)' >> circle '((0,0),1)' = true@ -(>>) :: (SqlDb db, BoxCirclePointPolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(>>) = psqlOperatorCond ">>" - --- | Does not extend to the right of? box '((0,0),(1,1))' &< box '((0,0),(2,2))' = t -(&<) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(&<) = psqlOperatorCond "&<" - --- | Does not extend to the left of? --- --- @box '((0,0),(3,3))' &> box '((0,0),(2,2))' = true@ -(&>) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(&>) = psqlOperatorCond "&>" - --- | Is strictly below? --- --- @box '((0,0),(3,3))' <<| box '((3,4),(5,5))' = true@ -(<<|) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(<<|) = psqlOperatorCond "<<|" - --- | Is strictly above? --- --- @box '((3,4),(5,5))' |>> box '((0,0),(3,3))'@ -(|>>):: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(|>>) = psqlOperatorCond "|>>" - --- | Does not extend above? --- --- @box '((0,0),(1,1))' &<| box '((0,0),(2,2))' = true@ -(&<|):: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(&<|) = psqlOperatorCond "&<|" - --- | Does not extend below? --- --- @box '((0,0),(3,3))' |&> box '((0,0),(2,2))' = true@ -(|&>) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(|&>) = psqlOperatorCond "|&>" - --- | Is below (allows touching)? --- --- @circle '((0,0),1)' <^ circle '((0,5),1)' = true@ -(<^) :: (SqlDb db, BoxPoint a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(<^) = psqlOperatorCond "<^" - --- | Is above (allows touching)? --- --- @circle '((0,5),1)' >^ circle '((0,0),1)' = true@ -(>^) :: (SqlDb db, BoxPoint a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(>^) = psqlOperatorCond ">^" - --- | Intersects? --- --- @lseg '((-1,0),(1,0))' ?# box '((-2,-2),(2,2))' = true@ -(?#) :: (SqlDb db, Intersects a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Cond db r -(?#) = psqlOperatorCond "?#" - --- | Are horizontally aligned? --- --- @point '(1,0)' ?- point '(0,0)' = true@ -(?-) :: (SqlDb db, ExpressionOf db r x Point, ExpressionOf db r y Point) => x -> y -> Cond db r -(?-) = psqlOperatorCond "?-" - --- | Are vertically aligned? --- --- @point '(0,1)' ?| point '(0,0)' = true@ -(?|) :: (SqlDb db, ExpressionOf db r x Point, ExpressionOf db r y Point) => x -> y -> Cond db r -(?|) = psqlOperatorCond "?|" - --- | Is perpendicular? --- --- @lseg '((0,0),(0,1))' ?-| lseg '((0,0),(1,0))' = true@ -(?-|) :: (SqlDb db, LineLseg a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(?-|) = psqlOperatorCond "?-|" - --- | Are parallel? --- --- @lseg '((-1,0),(1,0))' ?|| lseg '((-1,2),(1,2))' = true@ -(?||) :: (SqlDb db, LineLseg a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(?||) = psqlOperatorCond "?||" - --- | Contains? --- --- @circle '((0,0),2)' \@> point '(1,1)' = true@ -(@>) :: (SqlDb db, Contains a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Cond db r -(@>) = psqlOperatorCond "@>" - --- | Contained in or on? --- --- @point '(1,1)' <\@ circle '((0,0),2)' = true@ -(<@) :: (SqlDb db, Contained a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Cond db r -(<@) = psqlOperatorCond "<@" - --- | Same as? --- --- @polygon '((0,0),(1,1))' ~= polygon '((1,1),(0,0))' = true@ -(~=) :: (SqlDb db, BoxCirclePointPolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r -(~=) = psqlOperatorCond "~=" +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Groundhog.Postgresql.Geometry+ ( Point (..),+ Line (..),+ Lseg (..),+ Box (..),+ Path (..),+ Polygon (..),+ Circle (..),+ (+.),+ (-.),+ (*.),+ (/.),+ (#),+ (##),+ (<->),+ (&&),+ (<<),+ (>>),+ (&<),+ (&>),+ (<<|),+ (|>>),+ (&<|),+ (|&>),+ (<^),+ (>^),+ (?#),+ (?-),+ (?|),+ (?-|),+ (?||),+ (@>),+ (<@),+ (~=),+ )+where++import Control.Applicative+import Data.Attoparsec.ByteString.Char8+import Database.Groundhog.Core+import Database.Groundhog.Expression+import Database.Groundhog.Generic+import Database.Groundhog.Generic.Sql+import Database.Groundhog.Instances ()+import Prelude hiding ((&&), (>>))++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)++newtype 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) = toPrimitivePersistValue $ show (x, y)+ fromPrimitivePersistValue = parseHelper point++instance PersistField Point where+ persistName _ = "Point"+ toPersistValues = primToPersistValue+ fromPersistValues = primFromPersistValue+ dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef [Left "point"]) False Nothing Nothing++instance PrimitivePersistField Line where+ toPrimitivePersistValue (Line (Point x1 y1) (Point x2 y2)) = toPrimitivePersistValue $ show ((x1, y1), (x2, y2))+ fromPrimitivePersistValue = error "fromPrimitivePersistValue Line is not supported yet"++instance PersistField Line where+ persistName _ = "Line"+ toPersistValues = primToPersistValue+ fromPersistValues = primFromPersistValue+ dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef [Left "line"]) False Nothing Nothing++instance PrimitivePersistField Lseg where+ toPrimitivePersistValue (Lseg (Point x1 y1) (Point x2 y2)) = toPrimitivePersistValue $ show ((x1, y1), (x2, y2))+ fromPrimitivePersistValue = parseHelper $ pair Lseg '[' ']' point++instance PersistField Lseg where+ persistName _ = "Lseg"+ toPersistValues = primToPersistValue+ fromPersistValues = primFromPersistValue+ dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef [Left "lseg"]) False Nothing Nothing++instance PrimitivePersistField Box where+ toPrimitivePersistValue (Box (Point x1 y1) (Point x2 y2)) = toPrimitivePersistValue $ show ((x1, y1), (x2, y2))+ fromPrimitivePersistValue = parseHelper $ Box <$> (point <* char ',') <*> point++instance PersistField Box where+ persistName _ = "Box"+ toPersistValues = primToPersistValue+ fromPersistValues = primFromPersistValue+ dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef [Left "box"]) False Nothing Nothing++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 = toPrimitivePersistValue $ 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 _ _ = DbTypePrimitive (DbOther $ OtherTypeDef [Left "path"]) False Nothing Nothing++instance PrimitivePersistField Polygon where+ toPrimitivePersistValue (Polygon ps) = toPrimitivePersistValue $ showPath '(' ')' ps ""+ fromPrimitivePersistValue = parseHelper $ Polygon <$> (char '(' *> points <* char ')')++instance PersistField Polygon where+ persistName _ = "Polygon"+ toPersistValues = primToPersistValue+ fromPersistValues = primFromPersistValue+ dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef [Left "polygon"]) False Nothing Nothing++instance PrimitivePersistField Circle where+ toPrimitivePersistValue (Circle (Point x1 y1) r) = toPrimitivePersistValue $ show ((x1, y1), r)+ fromPrimitivePersistValue = parseHelper $ Circle <$> (char '<' *> point) <* char ',' <*> double <* char '>'++instance PersistField Circle where+ persistName _ = "Circle"+ toPersistValues = primToPersistValue+ fromPersistValues = primFromPersistValue+ dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef [Left "circle"]) False Nothing Nothing++class BoxLineLseg a++instance BoxLineLseg Box++instance BoxLineLseg Line++instance BoxLineLseg Lseg++class BoxCirclePolygon a++instance BoxCirclePolygon Box++instance BoxCirclePolygon Circle++instance BoxCirclePolygon Polygon++class BoxCirclePathPoint a++instance BoxCirclePathPoint Box++instance BoxCirclePathPoint Circle++instance BoxCirclePathPoint Path++instance BoxCirclePathPoint Point++class BoxCirclePointPolygon a++instance BoxCirclePointPolygon Box++instance BoxCirclePointPolygon Circle++instance BoxCirclePointPolygon Point++instance BoxCirclePointPolygon Polygon++class BoxPoint a++instance BoxPoint Box++instance BoxPoint Point++class LineLseg a++instance LineLseg Line++instance LineLseg Lseg++class Plus a b++instance Plus Box Point++instance Plus Circle Point++instance Plus Path Point++instance Plus Path Path++instance Plus Point Point++class Distance a b++instance Distance Box Box++instance Distance Circle Circle++instance Distance Circle Polygon++instance Distance Line Line++instance Distance Line Box++instance Distance Lseg Line++instance Distance Lseg Lseg++instance Distance Lseg Box++instance Distance Path Path++instance Distance Point Path++instance Distance Point Point++instance Distance Point Circle++instance Distance Point Line++instance Distance Point Box++instance Distance Point Lseg++instance Distance Polygon Polygon++class Contains a b++instance Contains Box Box++instance Contains Box Point++instance Contains Circle Circle++instance Contains Circle Point++instance Contains Path Point++instance Contains Polygon Polygon++instance Contains Polygon Point++class Contained a b++instance Contained Box Box++instance Contained Circle Circle++instance Contained Lseg Box++instance Contained Lseg Line++instance Contained Point Lseg++instance Contained Point Box++instance Contained Point Line++instance Contained Point Path++instance Contained Point Polygon++instance Contained Point Circle++instance Contained Polygon Polygon++class Closest a b++instance Closest Line Box++instance Closest Line Lseg++instance Closest Lseg Box++instance Closest Lseg Line++instance Closest Lseg Lseg++instance Closest Point Line++instance Closest Point Box++instance Closest Point Lseg++class Intersects a b++instance Intersects Box Box++instance Intersects Line Line++instance Intersects Line Box++instance Intersects Lseg Box++instance Intersects Lseg Line++instance Intersects Lseg Lseg++instance Intersects Path Path++psqlOperatorExpr :: (SqlDb db, Expression db r a, Expression db r b, PersistField c) => String -> a -> b -> Expr db r c+psqlOperatorExpr op x y = mkExpr $ operator 50 op x y++psqlOperatorCond :: (SqlDb db, Expression db r a, Expression db r b) => String -> a -> b -> Cond db r+psqlOperatorCond op x y = CondRaw $ operator 50 op x y++infixl 6 +.++infixl 6 -.++infixl 7 *.++infixl 7 /.++-- | Translation+--+-- @box '((0,0),(1,1))' + point '(2.0,0)' = box '(3,1),(2,0)'@+(+.) :: (SqlDb db, Plus a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Expr db r a+x +. y = mkExpr $ operator 60 "+" x y++-- | Translation+--+-- @box '((0,0),(1,1))' - point '(2.0,0)' = box '(-1,1),(-2,0)'@+(-.) :: (SqlDb db, BoxCirclePathPoint a, ExpressionOf db r x a, ExpressionOf db r y Point) => x -> y -> Expr db r a+x -. y = mkExpr $ operator 60 "-" x y++-- | Scaling/rotation+--+-- @box '((0,0),(1,1))' * point '(2.0,0)' = box '(2,2),(0,0)'@+(*.) :: (SqlDb db, BoxCirclePathPoint a, ExpressionOf db r x a, ExpressionOf db r y Point) => x -> y -> Expr db r a+x *. y = mkExpr $ operator 70 "*" x y++-- | Scaling/rotation+--+-- @box '((0,0),(2,2))' / point '(2.0,0)' = box '(1,1),(0,0)'@+(/.) :: (SqlDb db, BoxCirclePathPoint a, ExpressionOf db r x a, ExpressionOf db r y Point) => x -> y -> Expr db r a+x /. y = mkExpr $ operator 70 "/" x y++-- | Point or box of intersection+--+-- @lseg '((1,-1),(-1,1))' # '((1,1),(-1,-1))' = point '(0,0)'@+--+-- @box '((1,-1),(-1,1))' # '((1,1),(-1,-1))' = box '(1,1),(-1,-1)'@+(#) :: (SqlDb db, BoxLineLseg a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Expr db r a+(#) = psqlOperatorExpr "#"++-- | Closest point to first operand on second operand+--+-- @point '(0,0)' ## lseg '((2,0),(0,2))' = point '(1,1)'@+(##) :: (SqlDb db, Closest a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Expr db r Point+(##) = psqlOperatorExpr "##"++-- | Distance between+--+-- @circle '((0,0),1)' <-> circle '((5,0),1)' = 3@+(<->) :: (SqlDb db, Distance a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Expr db r Double+(<->) = psqlOperatorExpr "<->"++-- | Overlaps?+--+-- @box '((0,0),(1,1))' && box '((0,0),(2,2))' = true@+(&&) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(&&) = psqlOperatorCond "&&"++-- | Is strictly left of?+--+-- @circle '((0,0),1)' << circle '((5,0),1)' = true@+(<<) :: (SqlDb db, BoxCirclePointPolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(<<) = psqlOperatorCond "<<"++-- | Is strictly right of?+--+-- @circle '((5,0),1)' >> circle '((0,0),1)' = true@+(>>) :: (SqlDb db, BoxCirclePointPolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(>>) = psqlOperatorCond ">>"++-- | Does not extend to the right of? box '((0,0),(1,1))' &< box '((0,0),(2,2))' = t+(&<) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(&<) = psqlOperatorCond "&<"++-- | Does not extend to the left of?+--+-- @box '((0,0),(3,3))' &> box '((0,0),(2,2))' = true@+(&>) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(&>) = psqlOperatorCond "&>"++-- | Is strictly below?+--+-- @box '((0,0),(3,3))' <<| box '((3,4),(5,5))' = true@+(<<|) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(<<|) = psqlOperatorCond "<<|"++-- | Is strictly above?+--+-- @box '((3,4),(5,5))' |>> box '((0,0),(3,3))'@+(|>>) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(|>>) = psqlOperatorCond "|>>"++-- | Does not extend above?+--+-- @box '((0,0),(1,1))' &<| box '((0,0),(2,2))' = true@+(&<|) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(&<|) = psqlOperatorCond "&<|"++-- | Does not extend below?+--+-- @box '((0,0),(3,3))' |&> box '((0,0),(2,2))' = true@+(|&>) :: (SqlDb db, BoxCirclePolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(|&>) = psqlOperatorCond "|&>"++-- | Is below (allows touching)?+--+-- @circle '((0,0),1)' <^ circle '((0,5),1)' = true@+(<^) :: (SqlDb db, BoxPoint a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(<^) = psqlOperatorCond "<^"++-- | Is above (allows touching)?+--+-- @circle '((0,5),1)' >^ circle '((0,0),1)' = true@+(>^) :: (SqlDb db, BoxPoint a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(>^) = psqlOperatorCond ">^"++-- | Intersects?+--+-- @lseg '((-1,0),(1,0))' ?# box '((-2,-2),(2,2))' = true@+(?#) :: (SqlDb db, Intersects a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Cond db r+(?#) = psqlOperatorCond "?#"++-- | Are horizontally aligned?+--+-- @point '(1,0)' ?- point '(0,0)' = true@+(?-) :: (SqlDb db, ExpressionOf db r x Point, ExpressionOf db r y Point) => x -> y -> Cond db r+(?-) = psqlOperatorCond "?-"++-- | Are vertically aligned?+--+-- @point '(0,1)' ?| point '(0,0)' = true@+(?|) :: (SqlDb db, ExpressionOf db r x Point, ExpressionOf db r y Point) => x -> y -> Cond db r+(?|) = psqlOperatorCond "?|"++-- | Is perpendicular?+--+-- @lseg '((0,0),(0,1))' ?-| lseg '((0,0),(1,0))' = true@+(?-|) :: (SqlDb db, LineLseg a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(?-|) = psqlOperatorCond "?-|"++-- | Are parallel?+--+-- @lseg '((-1,0),(1,0))' ?|| lseg '((-1,2),(1,2))' = true@+(?||) :: (SqlDb db, LineLseg a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(?||) = psqlOperatorCond "?||"++-- | Contains?+--+-- @circle '((0,0),2)' \@> point '(1,1)' = true@+(@>) :: (SqlDb db, Contains a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Cond db r+(@>) = psqlOperatorCond "@>"++-- | Contained in or on?+--+-- @point '(1,1)' <\@ circle '((0,0),2)' = true@+(<@) :: (SqlDb db, Contained a b, ExpressionOf db r x a, ExpressionOf db r y b) => x -> y -> Cond db r+(<@) = psqlOperatorCond "<@"++-- | Same as?+--+-- @polygon '((0,0),(1,1))' ~= polygon '((1,1),(0,0))' = true@+(~=) :: (SqlDb db, BoxCirclePointPolygon a, ExpressionOf db r x a, ExpressionOf db r y a) => x -> y -> Cond db r+(~=) = psqlOperatorCond "~="
Database/Groundhog/Postgresql/HStore.hs view
@@ -1,49 +1,49 @@-{-# LANGUAGE GADTs, OverloadedStrings, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+ -- | See detailed documentation for PostgreSQL HStore at http://www.postgresql.org/docs/9.3/static/hstore.html module Database.Groundhog.Postgresql.HStore ( -- * HStore manipulation- HStore(..)- , (->.)- , lookupArr- , hstoreConcat- , deleteKey- , deleteKeys- , difference- , hstore_to_array- , hstore_to_matrix- , akeys- , avals- , slice- , hstore_to_json- , hstore_to_json_loose- -- * HStore conditions- , exist- , defined- , (?&)- , (?|)- , (@>)- , (<@)- ) where+ HStore (..),+ (->.),+ lookupArr,+ hstoreConcat,+ deleteKey,+ deleteKeys,+ difference,+ hstore_to_array,+ hstore_to_matrix,+ akeys,+ avals,+ slice,+ hstore_to_json,+ hstore_to_json_loose, + -- * HStore conditions+ exist,+ defined,+ (?&),+ (?|),+ (@>),+ (<@),+ )+where++import Data.Aeson (Value)+import qualified Data.ByteString.Lazy as B (toStrict)+import qualified Data.Map as Map+import Data.String+import Data.Text (Text)+import qualified Data.Text.Encoding as T import Database.Groundhog.Core import Database.Groundhog.Expression import Database.Groundhog.Generic import Database.Groundhog.Generic.Sql import Database.Groundhog.Postgresql import Database.Groundhog.Postgresql.Array (Array)- import Database.PostgreSQL.Simple.HStore -import Data.Aeson (Value)-import qualified Data.ByteString.Builder as B-import qualified Data.ByteString.Lazy as B (toStrict)-import Control.Applicative-import qualified Data.Map as Map-import Data.String--import Data.Text (Text)-import qualified Data.Text.Encoding as T- newtype HStore = HStore (Map.Map Text Text) deriving (Eq, Ord, Show) @@ -51,13 +51,13 @@ persistName _ = "HStore" toPersistValues = primToPersistValue fromPersistValues = primFromPersistValue- dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "hstore"]) False Nothing Nothing+ dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef [Left "hstore"]) False Nothing Nothing instance PrimitivePersistField HStore where toPrimitivePersistValue (HStore a) = PersistCustom "E?::hstore" [toPrimitivePersistValue $ T.decodeUtf8 $ B.toStrict $ toLazyByteString (toHStore (HStoreMap a))] fromPrimitivePersistValue x = case parseHStoreList $ fromPrimitivePersistValue x of- Left err -> error $ "HStore: " ++ err- Right (HStoreList val) -> HStore $ Map.fromList val+ Left err -> error $ "HStore: " ++ err+ Right (HStoreList val) -> HStore $ Map.fromList val ---------------------------------------------------------------------- @@ -70,134 +70,185 @@ -- | Get value for key (NULL if not present) -- -- @'a=>x, b=>y'::hstore -> 'a' == x@-(->.) :: (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r key key', IsString key')- => hstore -> key -> Expr db r (Maybe Text)+(->.) ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r key key', IsString key') =>+ hstore ->+ key ->+ Expr db r (Maybe Text) (->.) = psqlOperatorExpr "->" -- | Get values for keys array (NULL if not present) -- -- @'a=>x, b=>y, c=>z'::hstore == ARRAY['c','a'] {"z","x"}@-lookupArr :: (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r keys (Array Text))- => hstore -> keys -> Expr db r (Array Text)+lookupArr ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r keys (Array Text)) =>+ hstore ->+ keys ->+ Expr db r (Array Text) lookupArr = psqlOperatorExpr "->" -- | Concatenate hstores -- -- @'a=>b, c=>d'::hstore || 'c=>x, d=>q'::hstore == "a"=>"b", "c"=>"x", "d"=>"q"@-hstoreConcat :: (db ~ Postgresql, ExpressionOf db r hstore1 HStore, ExpressionOf db r hstore2 HStore)- => hstore1 -> hstore2 -> Expr db r HStore+hstoreConcat ::+ (db ~ Postgresql, ExpressionOf db r hstore1 HStore, ExpressionOf db r hstore2 HStore) =>+ hstore1 ->+ hstore2 ->+ Expr db r HStore hstoreConcat = psqlOperatorExpr "||" -- | Does hstore contain key? Same as postgresql operator ?. -- -- @'a=>1'::hstore ? 'a' == True@-exist :: (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r key key', IsString key')- => hstore -> key -> Cond db r+exist ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r key key', IsString key') =>+ hstore ->+ key ->+ Cond db r exist h k = CondRaw $ function "exist" [toExpr h, toExpr k] -- | Does hstore contain non-NULL value for key? -- -- @defined('a=>NULL','a') == f@-defined :: (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r key key', IsString key')- => hstore -> key -> Cond db r+defined ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r key key', IsString key') =>+ hstore ->+ key ->+ Cond db r defined h k = CondRaw $ function "defined" [toExpr h, toExpr k] -- | Does hstore contain all specified keys? -- -- @'a=>1,b=>2'::hstore ?& ARRAY['a','b'] == True@-(?&) :: (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r keys (Array Text))- => hstore -> keys -> Cond db r+(?&) ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r keys (Array Text)) =>+ hstore ->+ keys ->+ Cond db r (?&) = psqlOperatorCond "?&" -- | Does hstore contain any of the specified keys? -- -- @'a=>1,b=>2'::hstore ?| ARRAY['b','c'] == True@-(?|) :: (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r keys (Array Text))- => hstore -> keys -> Cond db r+(?|) ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r keys (Array Text)) =>+ hstore ->+ keys ->+ Cond db r (?|) = psqlOperatorCond "?|" -- | Does left operand contain right? -- -- @'a=>b, b=>1, c=>NULL'::hstore @> 'b=>1' == True@-(@>) :: (db ~ Postgresql, ExpressionOf db r hstore1 HStore, ExpressionOf db r hstore2 HStore)- => hstore1 -> hstore2 -> Cond db r+(@>) ::+ (db ~ Postgresql, ExpressionOf db r hstore1 HStore, ExpressionOf db r hstore2 HStore) =>+ hstore1 ->+ hstore2 ->+ Cond db r (@>) = psqlOperatorCond "@>" -- | Is left operand contained in right? -- -- @'a=>c'::hstore <@ 'a=>b, b=>1, c=>NULL' == False@-(<@) :: (db ~ Postgresql, ExpressionOf db r hstore1 HStore, ExpressionOf db r hstore2 HStore)- => hstore1 -> hstore2 -> Cond db r+(<@) ::+ (db ~ Postgresql, ExpressionOf db r hstore1 HStore, ExpressionOf db r hstore2 HStore) =>+ hstore1 ->+ hstore2 ->+ Cond db r (<@) = psqlOperatorCond "<@" -- | Delete key from left operand -- -- @'a=>1, b=>2, c=>3'::hstore - 'b'::text == "a"=>"1", "c"=>"3"@-deleteKey :: (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r key key', IsString key')- => hstore -> key -> Expr db r HStore+deleteKey ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r key key', IsString key') =>+ hstore ->+ key ->+ Expr db r HStore deleteKey h k = mkExpr $ function "delete" [toExpr h, toExpr k] -- | Delete keys from left operand -- -- @'a=>1, b=>2, c=>3'::hstore - ARRAY['a','b'] == "c"=>"3"@-deleteKeys :: (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r keys (Array Text))- => hstore -> keys -> Expr db r HStore+deleteKeys ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r keys (Array Text)) =>+ hstore ->+ keys ->+ Expr db r HStore deleteKeys h k = mkExpr $ function "delete" [toExpr h, toExpr k] -- | Delete matching pairs from left operand -- -- @'a=>1, b=>2, c=>3'::hstore - 'a=>4, b=>2'::hstore == "a"=>"1", "c"=>"3"@-difference :: (db ~ Postgresql, ExpressionOf db r hstore1 HStore, ExpressionOf db r hstore2 HStore)- => hstore1 -> hstore2 -> Expr db r HStore+difference ::+ (db ~ Postgresql, ExpressionOf db r hstore1 HStore, ExpressionOf db r hstore2 HStore) =>+ hstore1 ->+ hstore2 ->+ Expr db r HStore difference h1 h2 = mkExpr $ function "delete" [toExpr h1, toExpr h2] -- | Convert hstore to array of alternating keys and values. Same as prefix operator %%. -- -- @hstore_to_array('a=>1,b=>2') == {a,1,b,2}@-hstore_to_array :: (db ~ Postgresql, ExpressionOf db r hstore HStore)- => hstore -> Expr db r (Array Text)+hstore_to_array ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore) =>+ hstore ->+ Expr db r (Array Text) hstore_to_array h = mkExpr $ function "hstore_to_array" [toExpr h] -- | Convert hstore to two-dimensional key/value array. Same as prefix operator %#. -- -- @hstore_to_matrix('a=>1,b=>2') == {{a,1},{b,2}}@-hstore_to_matrix :: (db ~ Postgresql, ExpressionOf db r hstore HStore)- => hstore -> Expr db r (Array (Array Text))+hstore_to_matrix ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore) =>+ hstore ->+ Expr db r (Array (Array Text)) hstore_to_matrix h = mkExpr $ function "hstore_to_matrix" [toExpr h] -- | Get hstore's keys as an array -- -- @akeys('a=>1,b=>2') == {a,b}@-akeys :: (db ~ Postgresql, ExpressionOf db r hstore HStore)- => hstore -> Expr db r (Array Text)+akeys ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore) =>+ hstore ->+ Expr db r (Array Text) akeys h = mkExpr $ function "akeys" [toExpr h] -- | Get hstore's values as an array -- -- @avals('a=>1,b=>2') == {1,2}@-avals :: (db ~ Postgresql, ExpressionOf db r hstore HStore)- => hstore -> Expr db r (Array Text)+avals ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore) =>+ hstore ->+ Expr db r (Array Text) avals h = mkExpr $ function "vals" [toExpr h] -- | Get hstore as a json value -- -- @hstore_to_json('"a key"=>1, b=>t, c=>null, d=>12345, e=>012345, f=>1.234, g=>2.345e+4') -- == {"a key": "1", "b": "t", "c": null, "d": "12345", "e": "012345", "f": "1.234", "g": "2.345e+4"}@-hstore_to_json :: (db ~ Postgresql, ExpressionOf db r hstore HStore)- => hstore -> Expr db r Value+hstore_to_json ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore) =>+ hstore ->+ Expr db r Value hstore_to_json h = mkExpr $ function "hstore_to_json" [toExpr h] -- | Get hstore as a json value, but attempting to distinguish numerical and Boolean values so they are unquoted in the JSON -- -- @hstore_to_json_loose('"a key"=>1, b=>t, c=>null, d=>12345, e=>012345, f=>1.234, g=>2.345e+4') -- == {"a key": 1, "b": true, "c": null, "d": 12345, "e": "012345", "f": 1.234, "g": 2.345e+4}@-hstore_to_json_loose :: (db ~ Postgresql, ExpressionOf db r hstore HStore)- => hstore -> Expr db r Value+hstore_to_json_loose ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore) =>+ hstore ->+ Expr db r Value hstore_to_json_loose h = mkExpr $ function "hstore_to_json_loose" [toExpr h] -- | Extract a subset of an hstore -- -- @slice('a=>1,b=>2,c=>3'::hstore, ARRAY['b','c','x']) =="b"=>"2", "c"=>"3"@-slice :: (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r keys (Array Text))- => hstore -> keys -> Expr db r HStore+slice ::+ (db ~ Postgresql, ExpressionOf db r hstore HStore, ExpressionOf db r keys (Array Text)) =>+ hstore ->+ keys ->+ Expr db r HStore slice h k = mkExpr $ function "slice" [toExpr h, toExpr k]
groundhog-postgresql.cabal view
@@ -1,5 +1,5 @@ name: groundhog-postgresql-version: 0.11+version: 0.12 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com>@@ -8,7 +8,7 @@ description: This package uses postgresql-simple and postgresql-libpq. category: Database stability: Stable-cabal-version: >= 1.6+cabal-version: >= 1.10 build-type: Simple extra-source-files:@@ -21,7 +21,7 @@ , postgresql-libpq >= 0.6.1 , bytestring >= 0.9 , transformers >= 0.2.1 && < 0.6- , groundhog >= 0.11 && < 0.12+ , groundhog >= 0.12 && < 0.13 , monad-control >= 0.3 && < 1.1 , containers >= 0.2 , text >= 0.8@@ -38,3 +38,4 @@ Database.Groundhog.Postgresql.Geometry Database.Groundhog.Postgresql.HStore ghc-options: -Wall -fno-warn-unused-do-bind+ default-language: Haskell2010