diff --git a/Database/Groundhog/Postgresql.hs b/Database/Groundhog/Postgresql.hs --- a/Database/Groundhog/Postgresql.hs +++ b/Database/Groundhog/Postgresql.hs @@ -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 diff --git a/Database/Groundhog/Postgresql/Array.hs b/Database/Groundhog/Postgresql/Array.hs --- a/Database/Groundhog/Postgresql/Array.hs +++ b/Database/Groundhog/Postgresql/Array.hs @@ -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 diff --git a/Database/Groundhog/Postgresql/Geometry.hs b/Database/Groundhog/Postgresql/Geometry.hs --- a/Database/Groundhog/Postgresql/Geometry.hs +++ b/Database/Groundhog/Postgresql/Geometry.hs @@ -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 "~=" diff --git a/Database/Groundhog/Postgresql/HStore.hs b/Database/Groundhog/Postgresql/HStore.hs --- a/Database/Groundhog/Postgresql/HStore.hs +++ b/Database/Groundhog/Postgresql/HStore.hs @@ -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] diff --git a/groundhog-postgresql.cabal b/groundhog-postgresql.cabal --- a/groundhog-postgresql.cabal +++ b/groundhog-postgresql.cabal @@ -1,5 +1,5 @@ name: groundhog-postgresql -version: 0.11 +version: 0.12 license: BSD3 license-file: LICENSE author: Boris Lykah @@ -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