From a7b883c9228db42b8a099e50d99f26777820e559 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Tue, 22 Sep 2015 16:56:19 +0300 Subject: [PATCH 01/31] moved db structure detection at the beginning (2 tests failing) --- postgrest.cabal | 5 +- src/PostgREST/App.hs | 45 +++-- src/PostgREST/Config.hs | 6 +- src/PostgREST/Main.hs | 29 ++- src/PostgREST/PgStructure.hs | 334 +++++++++++++++++++++++------------ src/PostgREST/Types.hs | 41 +++++ test/SpecHelper.hs | 18 +- 7 files changed, 349 insertions(+), 129 deletions(-) create mode 100644 src/PostgREST/Types.hs diff --git a/postgrest.cabal b/postgrest.cabal index d623df7aa..8aeb74145 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -58,7 +58,8 @@ library if flag(ci) ghc-options: -Wall -W -Werror else - ghc-options: -Wall -W -O2 + -- ghc-options: -Wall -W -O2 + ghc-options: -Wall -W default-language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes @@ -88,6 +89,7 @@ library , cassava , jwt Exposed-Modules: PostgREST.App + , PostgREST.Types , PostgREST.Auth , PostgREST.Config , PostgREST.Error @@ -108,6 +110,7 @@ Test-Suite spec ghc-options: -Wall -W -O2 Main-Is: Main.hs Other-Modules: PostgREST.App + , PostgREST.Types , PostgREST.Auth , PostgREST.Config , PostgREST.Error diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index b4df142fd..a702752e3 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -1,11 +1,16 @@ {-# LANGUAGE FlexibleContexts #-} -module PostgREST.App (app, sqlError, isSqlError, contentTypeForAccept) where +module PostgREST.App (app, sqlError, isSqlError, contentTypeForAccept +-- added +, jsonH +, requestedSchema +, TableOptions(..) +) where import Control.Monad (join) import Control.Arrow ((***), second) import Control.Applicative -import Data.Text hiding (map, find) +import Data.Text hiding (map, find, filter) import Data.Maybe (fromMaybe, mapMaybe, isJust, isNothing) import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) @@ -36,6 +41,7 @@ import qualified Hasql as H import qualified Hasql.Backend as B import qualified Hasql.Postgres as P +import PostgREST.Types import PostgREST.Config (AppConfig(..)) import PostgREST.Auth import PostgREST.PgQuery @@ -44,19 +50,31 @@ import PostgREST.PgStructure import Prelude -app :: AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response -app conf reqBody req = +app :: [Table] -> [Relation] -> [Column] -> [PrimaryKey] -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response +app allTables allRelations allColumns allPrimaryKeys conf reqBody req = case (path, verb) of + -- ([], _) -> do + -- body <- encode <$> tables (cs schema) + -- return $ responseLBS status200 [jsonH] $ cs body + + -- ([table], "OPTIONS") -> do + -- let qt = qualify table + -- cols <- columns qt + -- pkey <- map cs <$> primaryKeyColumns qt + -- return $ responseLBS status200 [jsonH, allOrigins] + -- $ encode (TableOptions cols pkey) + ([], _) -> do - body <- encode <$> tables (cs schema) - return $ responseLBS status200 [jsonH] $ cs body + let body = encode $ filter (((cs schema)==).tableSchema) allTables + return $ responseLBS status200 [jsonH, ("Custom", "header")] $ cs body ([table], "OPTIONS") -> do - let qt = qualify table - cols <- columns qt - pkey <- map cs <$> primaryKeyColumns qt - return $ responseLBS status200 [jsonH, allOrigins] - $ encode (TableOptions cols pkey) + let qt = Table schema table + let cols = filter (filterCol schema table) allColumns + let pkey = map pkName $ filter (filterPk schema table) allPrimaryKeys + let body = encode (TableOptions cols pkey) + return $ responseLBS status200 [jsonH, allOrigins, ("Custom", "header2")] $ cs body + ([table], "GET") -> if range == Just emptyRange @@ -187,7 +205,8 @@ app conf reqBody req = then return $ responseLBS status405 [] "You must speficy all and only primary keys as params" else do - tableCols <- map (cs . colName) <$> columns qt + --tableCols <- map (cs . colName) <$> columns qt + let tableCols = map (cs . colName) $ filter (filterCol schema table) allColumns let cols = map cs $ M.keys obj if S.fromList tableCols == S.fromList cols then do @@ -238,6 +257,8 @@ app conf reqBody req = return $ responseLBS status404 [] "" where + filterCol schema table (Column{colSchema=s, colTable=t}) = s==schema && table==t + filterPk schema table (PrimaryKey{pkSchema=s, pkTable=t}) = s==schema && table==t path = pathInfo req verb = requestMethod req qq = queryString req diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 37c772e37..1de7da33b 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -28,10 +28,10 @@ data AppConfig = AppConfig { argParser :: Parser AppConfig argParser = AppConfig - <$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> help "name of database") + <$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> value "skin_test" <> help "name of database") <*> option auto (long "db-port" <> short 'P' <> metavar "PORT" <> value 5432 <> help "postgres server port" <> showDefault) - <*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> help "postgres authenticator role") - <*> strOption (long "db-pass" <> metavar "PASS" <> value "" <> help "password for authenticator role") + <*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> value "skin_test" <> help "postgres authenticator role") + <*> strOption (long "db-pass" <> metavar "PASS" <> value "skin_pass" <> help "password for authenticator role") <*> strOption (long "db-host" <> metavar "HOST" <> value "localhost" <> help "postgres server hostname" <> showDefault) <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "port number on which to run HTTP server" <> showDefault) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index a0d486c29..83842ae4b 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -2,6 +2,16 @@ module Main where import Paths_postgrest (version) +-- added +import PostgREST.PgStructure +import Data.Aeson +import Data.List (find) +import Data.Maybe (isJust) +import PostgREST.Types +import Network.HTTP.Types.Status +import Network.HTTP.Types.Header +import Network.Wai -- (strictRequestBody, pathInfo, requestMethod, requestHeaders) + import PostgREST.App import PostgREST.Middleware @@ -10,7 +20,6 @@ import PostgREST.Error(errResponse) import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Data.String.Conversions (cs) -import Network.Wai (strictRequestBody) import Network.Wai.Handler.Warp hiding (Connection) import Network.Wai.Middleware.RequestLogger (logStdout) import Data.List (intercalate) @@ -74,10 +83,26 @@ main = do fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0" ) resOrError + -- read the structure of the database + -- read the structure of the database + let txParam = (Just (H.ReadCommitted, Just True)) + + tblsRes <- H.session pool $ H.tx txParam alltables + let allTables = either (fail . show) id tblsRes + + relsRes <- H.session pool $ H.tx txParam allrelations + let allRelations = either (fail . show) id relsRes + + colsRes <- H.session pool $ H.tx txParam $ allcolumns allRelations + let allColumns = either (fail . show) id colsRes + + pkRes <- H.session pool $ H.tx txParam $ allprimaryKeys + let allPrimaryKeys = either (fail . show) id pkRes + runSettings appSettings $ middle $ \req respond -> do body <- strictRequestBody req resOrError <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) $ - authenticated conf (app conf body) req + authenticated conf (app allTables allRelations allColumns allPrimaryKeys conf body) req either (respond . errResponse) respond resOrError where diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index 9e5647b8a..dc0e52de9 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -4,7 +4,9 @@ module PostgREST.PgStructure where import PostgREST.PgQuery (QualifiedIdentifier(..)) -import Data.Text hiding (foldl, map, zipWith, concat) +import PostgREST.Types +import Data.Text (Text, unpack, split) +import Data.List (find) import Data.Aeson import Data.Functor.Identity import Data.String.Conversions (cs) @@ -18,93 +20,94 @@ import qualified Hasql.Postgres as P import Prelude -foreignKeys :: QualifiedIdentifier -> H.Tx P.Postgres s (Map.Map Text ForeignKey) -foreignKeys table = do - r <- H.listEx $ [H.stmt| - select kcu.column_name, ccu.table_name AS foreign_table_name, - ccu.column_name AS foreign_column_name - from information_schema.table_constraints AS tc - join information_schema.key_column_usage AS kcu - on tc.constraint_name = kcu.constraint_name - join information_schema.constraint_column_usage AS ccu - on ccu.constraint_name = tc.constraint_name - where constraint_type = 'FOREIGN KEY' - and tc.table_name=? and tc.table_schema = ? - order by kcu.column_name - |] (qiName table) (qiSchema table) - - return $ foldl addKey Map.empty r - where - addKey :: Map.Map Text ForeignKey -> (Text, Text, Text) -> Map.Map Text ForeignKey - addKey m (col, ftab, fcol) = Map.insert col (ForeignKey ftab fcol) m +----------- +-- foreignKeys :: QualifiedIdentifier -> H.Tx P.Postgres s (Map.Map Text ForeignKey) +-- foreignKeys table = do +-- r <- H.listEx $ [H.stmt| +-- select kcu.column_name, ccu.table_name AS foreign_table_name, +-- ccu.column_name AS foreign_column_name +-- from information_schema.table_constraints AS tc +-- join information_schema.key_column_usage AS kcu +-- on tc.constraint_name = kcu.constraint_name +-- join information_schema.constraint_column_usage AS ccu +-- on ccu.constraint_name = tc.constraint_name +-- where constraint_type = 'FOREIGN KEY' +-- and tc.table_name=? and tc.table_schema = ? +-- order by kcu.column_name +-- |] (qiName table) (qiSchema table) +-- +-- return $ foldl addKey Map.empty r +-- where +-- addKey :: Map.Map Text ForeignKey -> (Text, Text, Text) -> Map.Map Text ForeignKey +-- addKey m (col, ftab, fcol) = Map.insert col (ForeignKey ftab fcol) m +-- +-- +-- tables :: Text -> H.Tx P.Postgres s [Table] +-- tables schema = do +-- rows <- H.listEx $ +-- [H.stmt| +-- select +-- n.nspname as table_schema, +-- relname as table_name, +-- c.relkind = 'r' or (c.relkind IN ('v', 'f')) and (pg_relation_is_updatable(c.oid::regclass, false) & 8) = 8 +-- or (exists ( +-- select 1 +-- from pg_trigger +-- where pg_trigger.tgrelid = c.oid and (pg_trigger.tgtype::integer & 69) = 69) +-- ) as insertable +-- from +-- pg_class c +-- join pg_namespace n on n.oid = c.relnamespace +-- where +-- c.relkind in ('v', 'r', 'm') +-- and n.nspname = ? +-- and ( +-- pg_has_role(c.relowner, 'USAGE'::text) +-- or has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) +-- or has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) +-- ) +-- order by relname +-- |] schema +-- return $ map tableFromRow rows -tables :: Text -> H.Tx P.Postgres s [Table] -tables schema = do - rows <- H.listEx $ - [H.stmt| - select - n.nspname as table_schema, - relname as table_name, - c.relkind = 'r' or (c.relkind IN ('v', 'f')) and (pg_relation_is_updatable(c.oid::regclass, false) & 8) = 8 - or (exists ( - select 1 - from pg_trigger - where pg_trigger.tgrelid = c.oid and (pg_trigger.tgtype::integer & 69) = 69) - ) as insertable - from - pg_class c - join pg_namespace n on n.oid = c.relnamespace - where - c.relkind in ('v', 'r', 'm') - and n.nspname = ? - and ( - pg_has_role(c.relowner, 'USAGE'::text) - or has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) - or has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) - ) - order by relname - |] schema - return $ map tableFromRow rows - - -columns :: QualifiedIdentifier -> H.Tx P.Postgres s [Column] -columns table = do - cols <- H.listEx $ [H.stmt| - select info.table_schema as schema, info.table_name as table_name, - info.column_name as name, info.ordinal_position as position, - info.is_nullable::boolean as nullable, info.data_type as col_type, - info.is_updatable::boolean as updatable, - info.character_maximum_length as max_len, - info.numeric_precision as precision, - info.column_default as default_value, - array_to_string(enum_info.vals, ',') as enum - from ( - select table_schema, table_name, column_name, ordinal_position, - is_nullable, data_type, is_updatable, - character_maximum_length, numeric_precision, - column_default, udt_name - from information_schema.columns - where table_schema = ? and table_name = ? - ) as info - left outer join ( - select n.nspname as s, - t.typname as n, - array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals - from pg_type t - join pg_enum e on t.oid = e.enumtypid - join pg_catalog.pg_namespace n ON n.oid = t.typnamespace - group by s, n - ) as enum_info - on (info.udt_name = enum_info.n) - order by position |] - (qiSchema table) (qiName table) - - fks <- foreignKeys table - return $ map (addFK fks . columnFromRow) cols - - where - addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks } +-- columns :: QualifiedIdentifier -> H.Tx P.Postgres s [Column] +-- columns table = do +-- cols <- H.listEx $ [H.stmt| +-- select info.table_schema as schema, info.table_name as table_name, +-- info.column_name as name, info.ordinal_position as position, +-- info.is_nullable::boolean as nullable, info.data_type as col_type, +-- info.is_updatable::boolean as updatable, +-- info.character_maximum_length as max_len, +-- info.numeric_precision as precision, +-- info.column_default as default_value, +-- array_to_string(enum_info.vals, ',') as enum +-- from ( +-- select table_schema, table_name, column_name, ordinal_position, +-- is_nullable, data_type, is_updatable, +-- character_maximum_length, numeric_precision, +-- column_default, udt_name +-- from information_schema.columns +-- where table_schema = ? and table_name = ? +-- ) as info +-- left outer join ( +-- select n.nspname as s, +-- t.typname as n, +-- array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals +-- from pg_type t +-- join pg_enum e on t.oid = e.enumtypid +-- join pg_catalog.pg_namespace n ON n.oid = t.typnamespace +-- group by s, n +-- ) as enum_info +-- on (info.udt_name = enum_info.n) +-- order by position |] +-- (qiSchema table) (qiName table) +-- +-- fks <- foreignKeys table +-- return $ map (addFK fks . columnFromRow) cols +-- +-- where +-- addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks } primaryKeyColumns :: QualifiedIdentifier -> H.Tx P.Postgres s [Text] @@ -134,30 +137,6 @@ doesProcExist schema proc = do |] schema proc return $ isJust row -data Table = Table { - tableSchema :: Text -, tableName :: Text -, tableInsertable :: Bool -} deriving (Show) - -data ForeignKey = ForeignKey { - fkTable::Text, fkCol::Text -} deriving (Eq, Show) - -data Column = Column { - colSchema :: Text -, colTable :: Text -, colName :: Text -, colPosition :: Int -, colNullable :: Bool -, colType :: Text -, colUpdatable :: Bool -, colMaxLen :: Maybe Int -, colPrecision :: Maybe Int -, colDefault :: Maybe Text -, colEnum :: [Text] -, colFK :: Maybe ForeignKey -} deriving (Show) tableFromRow :: (Text, Text, Bool) -> Table tableFromRow (s, n, i) = Table s n i @@ -197,3 +176,138 @@ instance ToJSON Table where "schema" .= tableSchema v , "name" .= tableName v , "insertable" .= tableInsertable v ] +------------ + + +relationFromRow :: (Text, Text, Text, Text, Text) -> Relation +relationFromRow (s, t, c, ft, fc) = Relation s t c ft fc "child" + +pkFromRow :: (Text, Text, Text) -> PrimaryKey +pkFromRow (s, t, n) = PrimaryKey s t n + + +addFlippedRelation :: Relation -> [Relation] -> [Relation] +addFlippedRelation rel@(Relation s t c ft fc _) rels = Relation s ft fc t c "parent":rel:rels + +alltables :: H.Tx P.Postgres s [Table] +alltables = do + rows <- H.listEx $ [H.stmt| + SELECT n.nspname AS table_schema, + relname AS TABLE_NAME, + c.relkind = 'r' OR (c.relkind IN ('v','f')) + AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8 + OR (EXISTS ( SELECT 1 + FROM pg_trigger + WHERE pg_trigger.tgrelid = c.oid + AND (pg_trigger.tgtype::integer & 69) = 69) + ) AS insertable + FROM pg_class c + JOIN pg_namespace n ON n.oid = c.relnamespace + WHERE c.relkind IN ('v','r','m') + AND n.nspname NOT IN ('information_schema','pg_catalog') + AND ( pg_has_role(c.relowner, 'USAGE'::text) + OR has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) + OR has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) + ) + ORDER BY relname + |] + return $ map tableFromRow rows + +allrelations :: H.Tx P.Postgres s [Relation] +allrelations = do + rels <- H.listEx $ [H.stmt| + WITH table_fk AS ( + SELECT DISTINCT + tc.table_schema, tc.table_name, kcu.column_name, + ccu.table_name AS foreign_table_name, + ccu.column_name AS foreign_column_name + FROM information_schema.table_constraints AS tc + JOIN information_schema.key_column_usage AS kcu on tc.constraint_name = kcu.constraint_name + JOIN information_schema.constraint_column_usage AS ccu on ccu.constraint_name = tc.constraint_name + WHERE constraint_type = 'FOREIGN KEY' + AND tc.table_schema NOT IN ('pg_catalog', 'information_schema') + ORDER BY tc.table_schema, tc.table_name, kcu.column_name + ) + SELECT * FROM table_fk + UNION + ( + SELECT DISTINCT + vcu.table_schema, vcu.view_name AS table_name, vcu.column_name, + table_fk.foreign_table_name, + table_fk.foreign_column_name + FROM information_schema.view_column_usage as vcu + JOIN table_fk ON + table_fk.table_schema = vcu.view_schema AND + table_fk.table_name = vcu.table_name AND + table_fk.column_name = vcu.column_name + WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') + ORDER BY vcu.table_schema, vcu.view_name, vcu.column_name + ) + + |] + return $ foldr (addFlippedRelation.relationFromRow) [] rels + +allcolumns :: [Relation] -> H.Tx P.Postgres s [Column] +allcolumns relations = do + cols <- H.listEx $ [H.stmt| + SELECT + info.table_schema AS schema, + info.table_name AS table_name, + info.column_name AS name, + info.ordinal_position AS position, + info.is_nullable::boolean AS nullable, + info.data_type AS col_type, + info.is_updatable::boolean AS updatable, + info.character_maximum_length AS max_len, + info.numeric_precision AS precision, + info.column_default AS default_value, + array_to_string(enum_info.vals, ',') AS enum + FROM ( + SELECT + table_schema, + table_name, + column_name, + ordinal_position, + is_nullable, + data_type, + is_updatable, + character_maximum_length, + numeric_precision, + column_default, + udt_name + FROM information_schema.columns + WHERE table_schema NOT IN ('pg_catalog', 'information_schema') + ) AS info + LEFT OUTER JOIN ( + SELECT + n.nspname AS s, + t.typname AS n, + array_agg(e.enumlabel ORDER BY e.enumsortorder) AS vals + FROM pg_type t + JOIN pg_enum e ON t.oid = e.enumtypid + JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace + GROUP BY s,n + ) AS enum_info ON (info.udt_name = enum_info.n) + ORDER BY schema, position + |] + return $ map (addFK . columnFromRow) cols + + where + addFK col = col { colFK = relToFk <$> find (lookupFn col) relations } + lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumn=rc, relType=rty}) = + cs==rs && ct==rt && cn==rc && rty=="child" + relToFk (Relation{relFTable=t, relFColumn=c}) = ForeignKey t c + +allprimaryKeys :: H.Tx P.Postgres s [PrimaryKey] +allprimaryKeys = do + pks <- H.listEx $ [H.stmt| + SELECT kc.table_schema, kc.table_name, kc.column_name + FROM information_schema.table_constraints tc, + information_schema.key_column_usage kc + WHERE tc.constraint_type = 'PRIMARY KEY' + AND kc.table_name = tc.table_name + AND kc.table_schema = tc.table_schema + AND kc.constraint_name = tc.constraint_name + AND kc.table_schema NOT IN ('pg_catalog', 'information_schema') + |] + return $ map pkFromRow pks diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs new file mode 100644 index 000000000..e1ad82f6f --- /dev/null +++ b/src/PostgREST/Types.hs @@ -0,0 +1,41 @@ +module PostgREST.Types where +import Data.Text + +data Table = Table { + tableSchema :: Text +, tableName :: Text +, tableInsertable :: Bool +} deriving (Show) + +data ForeignKey = ForeignKey { + fkTable::Text, fkCol::Text +} deriving (Eq, Show) + + +data Column = Column { + colSchema :: Text +, colTable :: Text +, colName :: Text +, colPosition :: Int +, colNullable :: Bool +, colType :: Text +, colUpdatable :: Bool +, colMaxLen :: Maybe Int +, colPrecision :: Maybe Int +, colDefault :: Maybe Text +, colEnum :: [Text] +, colFK :: Maybe ForeignKey +} deriving (Show) + +data PrimaryKey = PrimaryKey { + pkSchema::Text, pkTable::Text, pkName::Text +} + +data Relation = Relation { + relSchema :: Text +, relTable :: Text +, relColumn :: Text +, relFTable :: Text +, relFColumn :: Text +, relType :: Text +} deriving (Show, Eq) diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index f198cf7dc..6fbfee02f 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -30,6 +30,7 @@ import PostgREST.App (app) import PostgREST.Config (AppConfig(..)) import PostgREST.Middleware import PostgREST.Error(errResponse) +import PostgREST.PgStructure isLeft :: Either a b -> Bool isLeft (Left _ ) = True @@ -53,10 +54,25 @@ withApp perform = do pool :: H.Pool P.Postgres <- H.acquirePool pgSettings testPoolOpts + let txParam = (Just (H.ReadCommitted, Just True)) + + tblsRes <- H.session pool $ H.tx txParam alltables + let allTables = either (fail . show) id tblsRes + + relsRes <- H.session pool $ H.tx txParam allrelations + let allRelations = either (fail . show) id relsRes + + colsRes <- H.session pool $ H.tx txParam $ allcolumns allRelations + let allColumns = either (fail . show) id colsRes + + pkRes <- H.session pool $ H.tx txParam $ allprimaryKeys + let allPrimaryKeys = either (fail . show) id pkRes + + perform $ middle $ \req resp -> do body <- strictRequestBody req result <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) - $ authenticated cfg (app cfg body) req + $ authenticated cfg (app allTables allRelations allColumns allPrimaryKeys cfg body) req either (resp . errResponse) resp result where middle = defaultMiddle False From 6f55e1d38949f19589112a3fccc5eb4590f0a6dc Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Tue, 22 Sep 2015 18:17:24 +0300 Subject: [PATCH 02/31] fix for one of the failing tests (acl for tables added) --- src/PostgREST/App.hs | 14 +++++++++++--- src/PostgREST/Main.hs | 15 +++++++++++++-- src/PostgREST/Middleware.hs | 9 +++++---- src/PostgREST/PgStructure.hs | 14 ++++++++++++++ src/PostgREST/Types.hs | 8 ++++++++ test/SpecHelper.hs | 14 +++++++++++++- 6 files changed, 64 insertions(+), 10 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index a702752e3..4785f17b5 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -50,8 +50,8 @@ import PostgREST.PgStructure import Prelude -app :: [Table] -> [Relation] -> [Column] -> [PrimaryKey] -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response -app allTables allRelations allColumns allPrimaryKeys conf reqBody req = +app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response +app dbstructure conf reqBody role req = case (path, verb) of -- ([], _) -> do -- body <- encode <$> tables (cs schema) @@ -65,7 +65,7 @@ app allTables allRelations allColumns allPrimaryKeys conf reqBody req = -- $ encode (TableOptions cols pkey) ([], _) -> do - let body = encode $ filter (((cs schema)==).tableSchema) allTables + let body = encode $ filter (filterTableAcl allTablesAcl role) $ filter (((cs schema)==).tableSchema) allTables return $ responseLBS status200 [jsonH, ("Custom", "header")] $ cs body ([table], "OPTIONS") -> do @@ -257,8 +257,16 @@ app allTables allRelations allColumns allPrimaryKeys conf reqBody req = return $ responseLBS status404 [] "" where + allTables = tables dbstructure + allRelations = relations dbstructure + allColumns = columns dbstructure + allPrimaryKeys = primaryKeys dbstructure + allTablesAcl = tablesAcl dbstructure filterCol schema table (Column{colSchema=s, colTable=t}) = s==schema && table==t filterPk schema table (PrimaryKey{pkSchema=s, pkTable=t}) = s==schema && table==t + + filterTableAcl :: [(Text, Text, Text)] -> Text -> Table -> Bool + filterTableAcl acl r (Table{tableSchema=s, tableName=n}) = isJust $ find (\(as,an,ar)->as==s && an==n && ar==r) acl path = pathInfo req verb = requestMethod req qq = queryString req diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 83842ae4b..86b6a5252 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -99,10 +99,21 @@ main = do pkRes <- H.session pool $ H.tx txParam $ allprimaryKeys let allPrimaryKeys = either (fail . show) id pkRes - runSettings appSettings $ middle $ \req respond -> do + tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl + let allTablesAcl = either (fail . show) id tableAclRes + + + let dbstructure = DbStructure { + tables=allTables, + columns=allColumns, + relations=allRelations, + primaryKeys=allPrimaryKeys, + tablesAcl=allTablesAcl} + + runSettings appSettings $ middle $ \ req respond -> do body <- strictRequestBody req resOrError <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) $ - authenticated conf (app allTables allRelations allColumns allPrimaryKeys conf body) req + authenticated conf (app dbstructure conf body) req either (respond . errResponse) respond resOrError where diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 8fa775f25..e29fabda2 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -26,11 +26,12 @@ import PostgREST.Config (AppConfig(..), corsPolicy) import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, setUserId) import PostgREST.App (contentTypeForAccept) import Codec.Binary.Base64.String (decode) +import PostgREST.Auth (DbRole) import Prelude authenticated :: forall s. AppConfig -> - (Request -> H.Tx P.Postgres s Response) -> + (DbRole -> Request -> H.Tx P.Postgres s Response) -> Request -> H.Tx P.Postgres s Response authenticated conf app req = do attempt <- httpRequesterRole (requestHeaders req) @@ -39,8 +40,8 @@ authenticated conf app req = do return $ responseLBS status400 [] "Malformed basic auth header" LoginFailed -> return $ responseLBS status401 [] "Invalid username or password" - LoginSuccess role uid -> if role /= currentRole then runInRole role uid else app req - NoCredentials -> if anon /= currentRole then runInRole anon "" else app req + LoginSuccess role uid -> if role /= currentRole then runInRole role uid else app currentRole req + NoCredentials -> if anon /= currentRole then runInRole anon "" else app currentRole req where jwtSecret = cs $ configJwtSecret conf @@ -62,7 +63,7 @@ authenticated conf app req = do runInRole r uid = do setUserId uid setRole r - app req + app r req redirectInsecure :: Application -> Application diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index dc0e52de9..d98c7d429 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -311,3 +311,17 @@ allprimaryKeys = do AND kc.table_schema NOT IN ('pg_catalog', 'information_schema') |] return $ map pkFromRow pks + +alltablesAcl :: H.Tx P.Postgres s [(Text, Text, Text)] +alltablesAcl = do + acl <- H.listEx $ [H.stmt| + SELECT + table_schema, + table_name, + grantee as role + FROM information_schema.role_table_grants + WHERE + table_schema NOT IN ('pg_catalog', 'information_schema') AND + privilege_type = 'SELECT' + |] + return acl diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index e1ad82f6f..0c218b394 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -1,6 +1,14 @@ module PostgREST.Types where import Data.Text +data DbStructure = DbStructure { + tables :: [Table] +, columns :: [Column] +, relations :: [Relation] +, primaryKeys :: [PrimaryKey] +, tablesAcl :: [(Text, Text, Text)] +} + data Table = Table { tableSchema :: Text , tableName :: Text diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 6fbfee02f..f1281c602 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -31,6 +31,7 @@ import PostgREST.Config (AppConfig(..)) import PostgREST.Middleware import PostgREST.Error(errResponse) import PostgREST.PgStructure +import PostgREST.Types isLeft :: Either a b -> Bool isLeft (Left _ ) = True @@ -68,11 +69,22 @@ withApp perform = do pkRes <- H.session pool $ H.tx txParam $ allprimaryKeys let allPrimaryKeys = either (fail . show) id pkRes + tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl + let allTablesAcl = either (fail . show) id tableAclRes + + + let dbstructure = DbStructure { + tables=allTables, + columns=allColumns, + relations=allRelations, + primaryKeys=allPrimaryKeys, + tablesAcl=allTablesAcl} + perform $ middle $ \req resp -> do body <- strictRequestBody req result <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) - $ authenticated cfg (app allTables allRelations allColumns allPrimaryKeys cfg body) req + $ authenticated cfg (app dbstructure cfg body) req either (resp . errResponse) resp result where middle = defaultMiddle False From c0e17c44ba3c4b496b5aa253c46957ce550cddf5 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Wed, 23 Sep 2015 09:38:40 +0300 Subject: [PATCH 03/31] all tests passing after moving table structure detection at load time --- src/PostgREST/App.hs | 8 ++-- src/PostgREST/Main.hs | 15 +++---- src/PostgREST/PgStructure.hs | 76 ++++++++++++++++++++---------------- src/PostgREST/Types.hs | 3 +- test/SpecHelper.hs | 15 +++---- 5 files changed, 64 insertions(+), 53 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 4785f17b5..748db75ba 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -65,7 +65,7 @@ app dbstructure conf reqBody role req = -- $ encode (TableOptions cols pkey) ([], _) -> do - let body = encode $ filter (filterTableAcl allTablesAcl role) $ filter (((cs schema)==).tableSchema) allTables + let body = encode $ filter (filterTableAcl role) $ filter (((cs schema)==).tableSchema) allTables return $ responseLBS status200 [jsonH, ("Custom", "header")] $ cs body ([table], "OPTIONS") -> do @@ -261,12 +261,12 @@ app dbstructure conf reqBody role req = allRelations = relations dbstructure allColumns = columns dbstructure allPrimaryKeys = primaryKeys dbstructure - allTablesAcl = tablesAcl dbstructure + --allTablesAcl = tablesAcl dbstructure filterCol schema table (Column{colSchema=s, colTable=t}) = s==schema && table==t filterPk schema table (PrimaryKey{pkSchema=s, pkTable=t}) = s==schema && table==t - filterTableAcl :: [(Text, Text, Text)] -> Text -> Table -> Bool - filterTableAcl acl r (Table{tableSchema=s, tableName=n}) = isJust $ find (\(as,an,ar)->as==s && an==n && ar==r) acl + filterTableAcl :: Text -> Table -> Bool + filterTableAcl r (Table{tableAcl=a}) = r `elem` a path = pathInfo req verb = requestMethod req qq = queryString req diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 86b6a5252..1921d3dc9 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -99,16 +99,17 @@ main = do pkRes <- H.session pool $ H.tx txParam $ allprimaryKeys let allPrimaryKeys = either (fail . show) id pkRes - tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl - let allTablesAcl = either (fail . show) id tableAclRes + -- tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl + -- let allTablesAcl = either (fail . show) id tableAclRes let dbstructure = DbStructure { - tables=allTables, - columns=allColumns, - relations=allRelations, - primaryKeys=allPrimaryKeys, - tablesAcl=allTablesAcl} + tables=allTables + , columns=allColumns + , relations=allRelations + , primaryKeys=allPrimaryKeys + --, tablesAcl=allTablesAcl + } runSettings appSettings $ middle $ \ req respond -> do body <- strictRequestBody req diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index d98c7d429..1422ccf3c 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -138,8 +138,11 @@ doesProcExist schema proc = do return $ isJust row -tableFromRow :: (Text, Text, Bool) -> Table -tableFromRow (s, n, i) = Table s n i +tableFromRow :: (Text, Text, Bool, Maybe Text) -> Table +tableFromRow (s, n, i, a) = Table s n i (parseAcl a) + where + parseAcl :: Maybe Text -> [Text] + parseAcl str = fromMaybe [] $ split (==',') <$> str columnFromRow :: (Text, Text, Text, Int, Bool, Text, @@ -192,25 +195,30 @@ addFlippedRelation rel@(Relation s t c ft fc _) rels = Relation s ft fc t c "par alltables :: H.Tx P.Postgres s [Table] alltables = do rows <- H.listEx $ [H.stmt| - SELECT n.nspname AS table_schema, - relname AS TABLE_NAME, - c.relkind = 'r' OR (c.relkind IN ('v','f')) - AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8 - OR (EXISTS ( SELECT 1 - FROM pg_trigger - WHERE pg_trigger.tgrelid = c.oid - AND (pg_trigger.tgtype::integer & 69) = 69) - ) AS insertable - FROM pg_class c - JOIN pg_namespace n ON n.oid = c.relnamespace - WHERE c.relkind IN ('v','r','m') - AND n.nspname NOT IN ('information_schema','pg_catalog') - AND ( pg_has_role(c.relowner, 'USAGE'::text) - OR has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) - OR has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) - ) - ORDER BY relname - |] + SELECT + n.nspname AS table_schema, + c.relname AS table_name, + c.relkind = 'r' OR (c.relkind IN ('v','f')) + AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8 + OR (EXISTS + ( SELECT 1 + FROM pg_trigger + WHERE pg_trigger.tgrelid = c.oid + AND (pg_trigger.tgtype::integer & 69) = 69) ) AS insertable, + array_to_string(array_agg(r.rolname), ',') AS acl + FROM pg_class c + CROSS JOIN pg_roles r + JOIN pg_namespace n ON n.oid = c.relnamespace + WHERE c.relkind IN ('v','r','m') + AND n.nspname NOT IN ('pg_catalog', 'information_schema') + AND ( + pg_has_role(r.rolname, c.relowner, 'USAGE'::text) OR + has_table_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR + has_any_column_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) ) + + GROUP BY table_schema, table_name, insertable + ORDER BY table_schema, table_name + |] return $ map tableFromRow rows allrelations :: H.Tx P.Postgres s [Relation] @@ -312,16 +320,16 @@ allprimaryKeys = do |] return $ map pkFromRow pks -alltablesAcl :: H.Tx P.Postgres s [(Text, Text, Text)] -alltablesAcl = do - acl <- H.listEx $ [H.stmt| - SELECT - table_schema, - table_name, - grantee as role - FROM information_schema.role_table_grants - WHERE - table_schema NOT IN ('pg_catalog', 'information_schema') AND - privilege_type = 'SELECT' - |] - return acl +-- alltablesAcl :: H.Tx P.Postgres s [(Text, Text, Text)] +-- alltablesAcl = do +-- acl <- H.listEx $ [H.stmt| +-- SELECT +-- table_schema, +-- table_name, +-- grantee as role +-- FROM information_schema.role_table_grants +-- WHERE +-- table_schema NOT IN ('pg_catalog', 'information_schema') AND +-- privilege_type = 'SELECT' +-- |] +-- return acl diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 0c218b394..d9cf4e55d 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -6,13 +6,14 @@ data DbStructure = DbStructure { , columns :: [Column] , relations :: [Relation] , primaryKeys :: [PrimaryKey] -, tablesAcl :: [(Text, Text, Text)] +--, tablesAcl :: [(Text, Text, Text)] } data Table = Table { tableSchema :: Text , tableName :: Text , tableInsertable :: Bool +, tableAcl :: [Text] } deriving (Show) data ForeignKey = ForeignKey { diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index f1281c602..cd17e41e6 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -69,16 +69,17 @@ withApp perform = do pkRes <- H.session pool $ H.tx txParam $ allprimaryKeys let allPrimaryKeys = either (fail . show) id pkRes - tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl - let allTablesAcl = either (fail . show) id tableAclRes + -- tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl + -- let allTablesAcl = either (fail . show) id tableAclRes let dbstructure = DbStructure { - tables=allTables, - columns=allColumns, - relations=allRelations, - primaryKeys=allPrimaryKeys, - tablesAcl=allTablesAcl} + tables=allTables + , columns=allColumns + , relations=allRelations + , primaryKeys=allPrimaryKeys + --, tablesAcl=allTablesAcl + } perform $ middle $ \req resp -> do From fb92b76a1a0f73b1a41ed883b86b438f06ac7b02 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Wed, 23 Sep 2015 14:31:24 +0300 Subject: [PATCH 04/31] integrated skin code gor generating Sql Query (only left to execute it) --- postgrest.cabal | 10 +++ src/PostgREST/App.hs | 20 ++++- src/PostgREST/Functions.hs | 168 +++++++++++++++++++++++++++++++++++++ src/PostgREST/Parsers.hs | 154 ++++++++++++++++++++++++++++++++++ src/PostgREST/PgQuery.hs | 61 ++++++++------ src/PostgREST/Types.hs | 26 +++++- 6 files changed, 410 insertions(+), 29 deletions(-) create mode 100644 src/PostgREST/Functions.hs create mode 100644 src/PostgREST/Parsers.hs diff --git a/postgrest.cabal b/postgrest.cabal index 8aeb74145..dc2ceba5b 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -52,6 +52,8 @@ executable postgrest , mtl , cassava , jwt + , parsec + , errors hs-source-dirs: src library @@ -88,8 +90,12 @@ library , mtl , cassava , jwt + , parsec + , errors Exposed-Modules: PostgREST.App , PostgREST.Types + , PostgREST.Parsers + , PostgREST.Functions , PostgREST.Auth , PostgREST.Config , PostgREST.Error @@ -111,6 +117,8 @@ Test-Suite spec Main-Is: Main.hs Other-Modules: PostgREST.App , PostgREST.Types + , PostgREST.Parsers + , PostgREST.Functions , PostgREST.Auth , PostgREST.Config , PostgREST.Error @@ -150,3 +158,5 @@ Test-Suite spec , process , heredoc , jwt + , parsec + , errors diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 748db75ba..2646b2fca 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -9,7 +9,7 @@ module PostgREST.App (app, sqlError, isSqlError, contentTypeForAccept import Control.Monad (join) import Control.Arrow ((***), second) import Control.Applicative - +import Data.Bifunctor (first) import Data.Text hiding (map, find, filter) import Data.Maybe (fromMaybe, mapMaybe, isJust, isNothing) import Text.Regex.TDFA ((=~)) @@ -47,6 +47,8 @@ import PostgREST.Auth import PostgREST.PgQuery import PostgREST.RangeQuery import PostgREST.PgStructure +import PostgREST.Parsers +import PostgREST.Functions import Prelude @@ -66,20 +68,31 @@ app dbstructure conf reqBody role req = ([], _) -> do let body = encode $ filter (filterTableAcl role) $ filter (((cs schema)==).tableSchema) allTables - return $ responseLBS status200 [jsonH, ("Custom", "header")] $ cs body + return $ responseLBS status200 [jsonH] $ cs body ([table], "OPTIONS") -> do let qt = Table schema table let cols = filter (filterCol schema table) allColumns let pkey = map pkName $ filter (filterPk schema table) allPrimaryKeys let body = encode (TableOptions cols pkey) - return $ responseLBS status200 [jsonH, allOrigins, ("Custom", "header2")] $ cs body + return $ responseLBS status200 [jsonH, allOrigins] $ cs body ([table], "GET") -> if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else do + let apiRequest = parseGetRequest req + dbRequest = first formatParserError apiRequest + >>= traverse (requestNodeToQuery schema allTables allColumns) + >>= addRelations allRelations Nothing + >>= addJoinConditions allColumns + where formatParserError = pack.show + query = dbRequestToQuery <$> dbRequest + body = show query + return $ responseLBS status200 [] $ cs body + + {-- let qt = qualify table from = fromMaybe 0 $ rangeOffset <$> range query = B.Stmt "select " V.empty True <> @@ -110,6 +123,7 @@ app dbstructure conf reqBody role req = if Prelude.null canonical then "" else "?" <> cs canonical ) ] (cs $ fromMaybe "[]" body) + --} (["postgrest", "users"], "POST") -> do let user = decode reqBody :: Maybe AuthUser diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs new file mode 100644 index 000000000..77c7e6661 --- /dev/null +++ b/src/PostgREST/Functions.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +module PostgREST.Functions +where + +import PostgREST.Types +import Control.Error +import Data.List (find) +import Data.Tree +import Data.Text hiding (find, foldr, map, null, last) +import Data.Monoid +import PostgREST.PgQuery (pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, QualifiedIdentifier(..)) + + +findColumn :: [Column] -> Text -> Text -> Text -> Either Text Column +findColumn allColumns s t c = note ("no such column: "<>t<>"."<>c) $ + find (\ col -> colSchema col == s && colTable col == t && colName col == c ) allColumns + +findTable :: [Table] -> Text -> Text -> Either Text Table +findTable allTables s t = note ("no such table: "<>t) $ + find (\tb-> s == tableSchema tb && t == tableName tb ) allTables + +findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation +findRelation allRelations s t1 t2 = + find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations + + +filterToCondition :: Text -> [Column] -> Text -> Filter -> Either Text Condition +filterToCondition schema allColumns table (Filter fld op val) = + Condition <$> c <*> pure op <*> pure (VText (pack val)) + where + c = (,) <$> column <*> pure (snd fld) + column = findColumn allColumns schema table $ pack $ fst fld + + +requestNodeToQuery ::Text -> [Table] -> [Column] -> RequestNode -> Either Text Query +requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs) = + Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel + where + tblName = pack tblNameS + mainTable = findTable allTables schema tblName + select = mapM toDbSelectItem flds --besides specific columns, we allow * here also + where + -- it's ok not to check that the table exists here, mainTable will do the checking + toDbSelectItem :: SelectItem -> Either Text DbSelectItem + toDbSelectItem (("*", Nothing), Nothing) = Right $ ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing) + toDbSelectItem ((c,jp), cast) = (,) <$> dbFld <*> pure cast + where + col = findColumn allColumns schema tblName $ pack c + dbFld = (,) <$> col <*> pure jp + + qwhere = mapM (filterToCondition schema allColumns tblName) fltrs + joinTables = pure [] + rel = pure Nothing + +addRelations :: [Relation] -> Maybe DbRequest -> DbRequest -> Either Text DbRequest +addRelations allRelations parentNode node@(Node query@(Select {qMainTable=table}) forest) = + case parentNode of + Nothing -> Node query{qRelation=Nothing} <$> updatedForest + (Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest + where + rel = note ("no relation between " <> (tableName table) <> " and " <> (tableName parentTable)) $ + findRelation allRelations (tableSchema table) (tableName table) (tableName parentTable) + addRel :: Query -> Relation -> Query + addRel q r = q{qRelation = Just r} + where + updatedForest = mapM (addRelations allRelations (Just node)) forest + + +addJoinConditions :: [Column] -> Tree Query -> Either Text DbRequest +addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = + case relation of + Nothing -> Node <$> updatedQuery <*> updatedForest -- this is the root node + Just rel@(Relation{relType="child"}) -> Node <$> (addCond <$> updatedQuery <*> getJoinCondition rel) <*> updatedForest + Just (Relation{relType="parent"}) -> Node <$> updatedQuery <*> updatedForest + -- Just (Many relationColumn1 relationColumn2) -> Node <$> pure updatedQuery{qJoinTables=linkTable:qJoinTables updatedQuery, qWhere=cond1:cond2:qWhere updatedQuery} <*> updatedForest + -- where + -- cond1 = getJoinCondition relationColumn1 + -- cond2 = getJoinCondition relationColumn2 + -- linkTable = Table "public" (colTable relationColumn1) True + _ -> Left "unknow relation" + where + -- add parentTable and parentJoinConditions to the query + updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ (qJoinTables query)}) <$> parentJoinConditions + where + parentJoinConditions = mapM (getJoinCondition.snd) parents + parentTables = map fst parents + parents = mapMaybe (getParents.rootLabel) forest + getParents qq@(Select{qRelation=(Just rel@(Relation{relType="parent"}))}) = Just (qMainTable qq, rel) + getParents _ = Nothing + updatedForest = mapM (addJoinConditions allColumns) forest + getJoinCondition rel@(Relation s t c _ _ _) = Condition <$> cc <*> pure "=" <*> pure (VForeignKey rel) + where + col = findColumn allColumns s t c + cc = (,) <$> col <*> pure Nothing + addCond q con = q{qWhere=con:qWhere q} + + +dbRequestToQuery :: DbRequest -> Text +dbRequestToQuery (Node (Select mainTable columns tables conditions relation) forest) = + case relation of + Nothing -> "SELECT " + <> "pg_catalog.count(t)," + <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " + <> "FROM (" + <> query + <> ") t;" + + _ -> query + where + query = Data.Text.unwords [ + ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, + "SELECT ", intercalate ", " (map selectItemToStr columns ++ selects), + "FROM ", intercalate ", " (map pgFmtTable (mainTable:tables)), + ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions + ] + emptyOnNull val x = if null x then "" else val + (withs, selects) = foldr getQueryParts ([],[]) forest + --getQueryParts is not total but dbRequestToQuery is called only after addJoinConditions which ensures the only + --posible relations are Child Parent Many + getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text]) + getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation {relType="child"}))}) forst) (w,s) = (w,sel:s) + where name = tableName table + sel = "(" + <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " + <> "FROM (" <> dbRequestToQuery (Node q forst) <> ") " <> name + <> ") AS " <> name + getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s) + where name = tableName table + sel = "row_to_json(" <> name <> ".*) AS "<>name --TODO must be singular + wit = name <> " AS ( " <> dbRequestToQuery (Node q forst) <> " )" + -- getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Many _ _))}) forst) (w,s) = (w,sel:s) + -- where name = tableName table + -- sel = "(" + -- <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " + -- <> "FROM (" <> dbRequestToQuery (Node q forst) <> ") " <> name + -- <> ") AS " <> name + -- the following is just to remove the warning, maybe relType should not be String? + getQueryParts (Node (Select{qRelation=Nothing}) _) _ = undefined + getQueryParts (Node (Select{qRelation=(Just (Relation {relType=_}))}) _) _ = undefined + +pgFmtCondition :: Condition -> Text +pgFmtCondition (Condition (col,jp) ops val) = pgFmtColumn col <> pgFmtJsonPath jp <> opToStr op <> valToStr val + where + op = pack ops + opToStr o = pgFmtOperator o + valToStr v = case v of + VText s -> pgFmtValue op s + VForeignKey (Relation{relFTable=table, relFColumn=column}) -> table <> "." <> column + +pgFmtColumn :: Column -> Text +pgFmtColumn Column {colSchema=s, colTable=t, colName=c} = pgFmtIdent s <> "." <> pgFmtIdent t <> "." <> pgFmtIdent c +pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*" + +pgFmtJsonPath :: Maybe JsonPath -> Text +pgFmtJsonPath (Just [x]) = "->>" <> (pgFmtLit $ pack x) +pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit (pack x) <> pgFmtJsonPath ( Just xs ) +pgFmtJsonPath _ = "" + +pgFmtTable :: Table -> Text +pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n + +selectItemToStr :: DbSelectItem -> Text +selectItemToStr ((c, jp), Nothing) = pgFmtColumn c <> pgFmtJsonPath jp <> asJsonPath jp +selectItemToStr ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn c <> pgFmtJsonPath jp <> " AS " <> pack cast <> " )" <> asJsonPath jp + +asJsonPath :: Maybe JsonPath -> Text +asJsonPath Nothing = "" +asJsonPath (Just xx) = " AS " <> (pack $ last xx) diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs new file mode 100644 index 000000000..071a6b7fa --- /dev/null +++ b/src/PostgREST/Parsers.hs @@ -0,0 +1,154 @@ +--{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-} +module PostgREST.Parsers +-- ( parseGetRequest +-- , pSelect +-- , pField +-- , pRequestSelect +-- ) + +where +import Text.ParserCombinators.Parsec hiding (many, (<|>)) +--import Text.Parsec.Text +--import Text.Parsec hiding (many, (<|>)) +--import Text.Parsec.Prim hiding (many, (<|>)) +import Control.Applicative +--import Control.Monad +--import qualified Data.Text as T +import Data.Tree +import Network.Wai (Request, pathInfo, queryString) +import PostgREST.Types +--import qualified Data.ByteString.Char8 as C +--import Control.Monad +--import Data.Foldable (foldrM) +import Data.List (delete, find) +import Data.Maybe +import Data.String.Conversions (cs) +--import qualified Data.ByteString.Char8 as C + +--buildRequest :: String -> String -> [(String, String)] -> Either P.ParseError Request +parseGetRequest :: Request -> Either ParseError ApiRequest +parseGetRequest httpRequest = + foldr addFilter <$> apiRequest <*> flts + where + apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select ("++selectStr++")") $ cs selectStr + flts = mapM pRequestFilter whereFilters + rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head + qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] + selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * + whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select"], isJust v ] + +pRequestSelect :: String -> Parser ApiRequest +pRequestSelect rootNodeName = do + fieldTree <- pFieldForest + return $ foldr treeEntry (Node (RequestNode rootNodeName [] []) []) fieldTree + where + treeEntry :: Tree SelectItem -> Tree RequestNode -> Tree RequestNode + treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) = + case fldForest of + [] -> Node (rNode {fields=fld:fields rNode}) rForest + _ -> Node rNode (foldr treeEntry (Node (RequestNode fn [] []) []) fldForest:rForest) + +pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) +pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) + where + treePath = parse pTreePath ("failed to parser tree path ("++k++")") k + opVal = parse pOpValueExp ("failed to parse filter ("++v++")") v + path = fst <$> treePath + fld = snd <$> treePath + op = fst <$> opVal + val = snd <$> opVal + +addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest +addFilter ([], flt) (Node rn@(RequestNode {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest +addFilter (path, flt) (Node rn forest) = + case targetNode of + Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path + Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest) + where + targetNodeName:remainingPath = path + (targetNode,restForest) = splitForest targetNodeName forest + splitForest name forst = + case maybeNode of + Nothing -> (Nothing,forest) + Just node -> (Just node, delete node forest) + where maybeNode = find ((name==).nodeName.rootLabel) forst + +ws :: Parser String +ws = many (oneOf " \t") + +--lexeme :: Parser String -> Parser String +--lexeme :: Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity a -> Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity a +--lexeme :: Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity Char -> Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity Char +lexeme p = ws *> p <* ws + +pTreePath :: Parser (Path,Field) +pTreePath = do + p <- (pFieldName `sepBy1` pDelimiter) + --f <- pField + jp <- optionMaybe ( string "->" >> pJsonPath) + return (init p, (last p, jp)) + + +pFieldForest :: Parser [Tree SelectItem] +pFieldForest = pFieldTree `sepBy1` lexeme (char ',') + +pFieldTree :: Parser (Tree SelectItem) +pFieldTree = + try ( do + fld <- pSelect + char '(' + subforest <- pFieldForest + char ')' + return (Node fld subforest) + ) + <|> do + fld <- pSelect + return (Node fld []) + +pStar :: Parser String +pStar = string "*" *> pure "*" + +pFieldName :: Parser String +pFieldName = many1 (letter <|> digit <|> oneOf "_") + "field name (* or [a..z0..9_])" + +pJsonPath :: Parser [String] +pJsonPath = pFieldName `sepBy1` (try (string "->>") <|> string "->") + +pField :: Parser Field +pField = lexeme $ do + f <- pFieldName + jp <- optionMaybe ( (try (string "->>") <|> string "->") >> pJsonPath) + return (f, jp) + +pSelect :: Parser SelectItem +pSelect = lexeme $ + try (do + n <- pField + v <- optionMaybe (string "::" >> many letter) + return (n, v) + ) + <|> do + s <- pStar + return ((s, Nothing), Nothing) + +pOperator :: Parser Operator +pOperator = try (string "eq") + <|> try (string "gt") + <|> try (string "lt") + "operator (eq, gt, ...)" + +pInt :: Parser Int +pInt = try (liftA read (many1 digit)) "integer" + +--pValue :: Parser Value +--pValue = (VInt <$> try (pInt <* eof)) +-- <|>(VString <$> many anyChar) +pValue :: Parser FValue +pValue = many anyChar + +pDelimiter :: Parser Char +pDelimiter = char '.' "delimiter (.)" + +pOpValueExp :: Parser (Operator, FValue) +pOpValueExp = liftA2 (,) pOperator (pDelimiter *> pValue) diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs index 9e6c8f25b..9e7955780 100644 --- a/src/PostgREST/PgQuery.hs +++ b/src/PostgREST/PgQuery.hs @@ -222,35 +222,46 @@ wherePred table (col, predicate) = opCode = hasNot (head rest) headPredicate notOp = hasNot headPredicate "" value = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest) - whiteList val = fromMaybe - (cs (pgFmtLit val) <> "::unknown ") - (L.find ((==) . T.toLower $ val) ["null","true","false"]) + sqlValue = pgFmtValue opCode value + op = pgFmtOperator opCode + + +whiteList :: T.Text -> T.Text +whiteList val = fromMaybe + (cs (pgFmtLit val) <> "::unknown ") + (L.find ((==) . T.toLower $ val) ["null","true","false"]) + +pgFmtValue :: T.Text -> T.Text -> T.Text +pgFmtValue opCode value = + case opCode of + "like" -> unknownLiteral $ T.map star value + "ilike" -> unknownLiteral $ T.map star value + "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " + "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " + "@@" -> "to_tsquery(" <> unknownLiteral value <> ") " + _ -> unknownLiteral value + where star c = if c == '*' then '%' else c unknownLiteral = (<> "::unknown ") . pgFmtLit - sqlValue = case opCode of - "like" -> unknownLiteral $ T.map star value - "ilike" -> unknownLiteral $ T.map star value - "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " - "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " - "@@" -> "to_tsquery(" <> unknownLiteral value <> ") " - _ -> unknownLiteral value +pgFmtOperator :: T.Text -> T.Text +pgFmtOperator opCode = + case opCode of + "eq" -> "=" + "gt" -> ">" + "lt" -> "<" + "gte" -> ">=" + "lte" -> "<=" + "neq" -> "<>" + "like"-> "like" + "ilike"-> "ilike" + "in" -> "in" + "notin" -> "not in" + "is" -> "is" + "isnot" -> "is not" + "@@" -> "@@" + _ -> "=" - op = case opCode of - "eq" -> "=" - "gt" -> ">" - "lt" -> "<" - "gte" -> ">=" - "lte" -> "<=" - "neq" -> "<>" - "like"-> "like" - "ilike"-> "ilike" - "in" -> "in" - "notin" -> "not in" - "is" -> "is" - "isnot" -> "is not" - "@@" -> "@@" - _ -> "=" orderParse :: Net.Query -> [OrderTerm] orderParse q = diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index d9cf4e55d..2568e3439 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -1,5 +1,6 @@ module PostgREST.Types where import Data.Text +import Data.Tree data DbStructure = DbStructure { tables :: [Table] @@ -34,7 +35,7 @@ data Column = Column { , colDefault :: Maybe Text , colEnum :: [Text] , colFK :: Maybe ForeignKey -} deriving (Show) +} | Star {colSchema :: Text, colTable :: Text } deriving (Show) data PrimaryKey = PrimaryKey { pkSchema::Text, pkTable::Text, pkName::Text @@ -48,3 +49,26 @@ data Relation = Relation { , relFColumn :: Text , relType :: Text } deriving (Show, Eq) + + +-------- +-- Request Types +type Operator = String +type FValue = String +type ApiRequest = Tree RequestNode +type FieldName = String +type JsonPath = [String] +type Field = (FieldName, Maybe JsonPath) +type Cast = String +type SelectItem = (Field, Maybe Cast) +type Path = [String] +data RequestNode = RequestNode {nodeName::String, fields::[SelectItem], filters::[Filter]} deriving (Show, Eq) +data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) + +-- Db Request Types +type DbField = (Column, Maybe JsonPath) +type DbSelectItem = (DbField, Maybe Cast) +data DbValue = VText Text | VForeignKey Relation deriving (Show) +data Condition = Condition {conColumn::DbField, conOperator::Operator, conValue::DbValue} deriving (Show) +data Query = Select {qMainTable::Table, qSelect::[DbSelectItem], qJoinTables::[Table], qWhere::[Condition], qRelation::Maybe Relation} deriving (Show) +type DbRequest = Tree Query From 448a81dff8c70a40d3e2813c8f4d89f7b8af685a Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Thu, 24 Sep 2015 11:45:34 +0300 Subject: [PATCH 05/31] first fully functioning build, some tests are failing (limit,order,csv not implemented yet) --- src/PostgREST/App.hs | 97 ++++++++++++++++++++++++-------------- src/PostgREST/Functions.hs | 34 ++++++++++--- src/PostgREST/Parsers.hs | 21 ++++++++- 3 files changed, 107 insertions(+), 45 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 2646b2fca..c6c5ef970 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -81,49 +81,74 @@ app dbstructure conf reqBody role req = ([table], "GET") -> if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" - else do - let apiRequest = parseGetRequest req + else + case query of + Left e -> return $ responseLBS status200 [("Content-Type", "text/plain")] $ cs e + Right qs -> do + let q = B.Stmt qs V.empty True + row <- H.maybeEx q + let (tableTotal, queryTotal, body) = fromMaybe (0::Int, 0::Int, Just "" :: Maybe Text) row + to = from+queryTotal-1 + contentRange = contentRangeH from to tableTotal + status = rangeStatus from to tableTotal + canonical = urlEncodeVars + . sortBy (comparing fst) + . map (join (***) cs) + . parseSimpleQuery + $ rawQueryString req + + + return $ responseLBS status + [contentTypeH, contentRange, + ("Content-Location", + "/" <> cs table <> + if Prelude.null canonical then "" else "?" <> cs canonical + ) + ] (cs $ fromMaybe "[]" body) + + where + from = fromMaybe 0 $ rangeOffset <$> range + apiRequest = parseGetRequest req dbRequest = first formatParserError apiRequest >>= traverse (requestNodeToQuery schema allTables allColumns) >>= addRelations allRelations Nothing >>= addJoinConditions allColumns where formatParserError = pack.show query = dbRequestToQuery <$> dbRequest - body = show query - return $ responseLBS status200 [] $ cs body - {-- - let qt = qualify table - from = fromMaybe 0 $ rangeOffset <$> range - query = B.Stmt "select " V.empty True <> - parentheticT ( - whereT qt qq $ countRows qt - ) <> commaq <> ( - bodyForAccept contentType qt - . limitT range - . orderT (orderParse qq) - . whereT qt qq - $ select qt qq - ) - row <- H.maybeEx query - let (tableTotal, queryTotal, body) = - fromMaybe (0, 0, Just "" :: Maybe Text) row - to = from+queryTotal-1 - contentRange = contentRangeH from to tableTotal - status = rangeStatus from to tableTotal - canonical = urlEncodeVars - . sortBy (comparing fst) - . map (join (***) cs) - . parseSimpleQuery - $ rawQueryString req - return $ responseLBS status - [contentTypeH, contentRange, - ("Content-Location", - "/" <> cs table <> - if Prelude.null canonical then "" else "?" <> cs canonical - ) - ] (cs $ fromMaybe "[]" body) - --} + + -- + -- let qt = qualify table + -- from = fromMaybe 0 $ rangeOffset <$> range + -- query = B.Stmt "select " V.empty True <> + -- parentheticT ( + -- whereT qt qq $ countRows qt + -- ) <> commaq <> ( + -- bodyForAccept contentType qt + -- . limitT range + -- . orderT (orderParse qq) + -- . whereT qt qq + -- $ select qt qq + -- ) + -- row <- H.maybeEx query + -- let (tableTotal, queryTotal, body) = + -- fromMaybe (0, 0, Just "" :: Maybe Text) row + -- to = from+queryTotal-1 + -- contentRange = contentRangeH from to tableTotal + -- status = rangeStatus from to tableTotal + -- canonical = urlEncodeVars + -- . sortBy (comparing fst) + -- . map (join (***) cs) + -- . parseSimpleQuery + -- $ rawQueryString req + -- return $ responseLBS status + -- [contentTypeH, contentRange, + -- ("Content-Location", + -- "/" <> cs table <> + -- if Prelude.null canonical then "" else "?" <> cs canonical + -- ) + -- ] (cs $ fromMaybe "[]" body) + (["postgrest", "users"], "POST") -> do let user = decode reqBody :: Maybe AuthUser diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index 77c7e6661..56dd52df4 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -6,9 +6,9 @@ import PostgREST.Types import Control.Error import Data.List (find) import Data.Tree -import Data.Text hiding (find, foldr, map, null, last) +import Data.Text hiding (find, foldr, map, null, last, head) import Data.Monoid -import PostgREST.PgQuery (pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, QualifiedIdentifier(..)) +import PostgREST.PgQuery (pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, whiteList, QualifiedIdentifier(..)) findColumn :: [Column] -> Text -> Text -> Text -> Either Text Column @@ -95,10 +95,22 @@ addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = addCond q con = q{qWhere=con:qWhere q} +dbRequestToCountQuery :: DbRequest -> Text +dbRequestToCountQuery (Node (Select mainTable columns tables conditions relation) forest) = + Data.Text.unwords [ + "SELECT pg_catalog.count(1)", + "FROM ", pgFmtTable mainTable, + ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions + ] + where emptyOnNull val x = if null x then "" else val + dbRequestToQuery :: DbRequest -> Text -dbRequestToQuery (Node (Select mainTable columns tables conditions relation) forest) = +dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation) forest) = case relation of Nothing -> "SELECT " + <> "(" + <> dbRequestToCountQuery r + <> ")," <> "pg_catalog.count(t)," <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " <> "FROM (" @@ -139,12 +151,20 @@ dbRequestToQuery (Node (Select mainTable columns tables conditions relation) for getQueryParts (Node (Select{qRelation=(Just (Relation {relType=_}))}) _) _ = undefined pgFmtCondition :: Condition -> Text -pgFmtCondition (Condition (col,jp) ops val) = pgFmtColumn col <> pgFmtJsonPath jp <> opToStr op <> valToStr val +pgFmtCondition (Condition (col,jp) ops val) = + notOp <> " " <> pgFmtColumn col <> pgFmtJsonPath jp <> " " <> pgFmtOperator opCode <> " " <> + if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue where - op = pack ops - opToStr o = pgFmtOperator o + headPredicate:rest = split (=='.') $ pack ops + hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse + opCode = hasNot (head rest) headPredicate + notOp = hasNot headPredicate "" + sqlValue = valToStr val + getInner v = case v of + VText s -> s + _ -> "" valToStr v = case v of - VText s -> pgFmtValue op s + VText s -> pgFmtValue opCode s VForeignKey (Relation{relFTable=table, relFColumn=column}) -> table <> "." <> column pgFmtColumn :: Column -> Text diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 071a6b7fa..d66e28562 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -35,7 +35,7 @@ parseGetRequest httpRequest = rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * - whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select"], isJust v ] + whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] pRequestSelect :: String -> Parser ApiRequest pRequestSelect rootNodeName = do @@ -136,6 +136,19 @@ pOperator :: Parser Operator pOperator = try (string "eq") <|> try (string "gt") <|> try (string "lt") + <|> try (string "eq") + <|> try (string "gt") + <|> try (string "lt") + <|> try (string "gte") + <|> try (string "lte") + <|> try (string "neq") + <|> try (string "like") + <|> try (string "ilike") + <|> try (string "in") + <|> try (string "notin") + <|> try (string "is" ) + <|> try (string "isnot") + <|> try (string "@@") "operator (eq, gt, ...)" pInt :: Parser Int @@ -151,4 +164,8 @@ pDelimiter :: Parser Char pDelimiter = char '.' "delimiter (.)" pOpValueExp :: Parser (Operator, FValue) -pOpValueExp = liftA2 (,) pOperator (pDelimiter *> pValue) +pOpValueExp = do + o <- ( try ( liftA2 (++) (string "not.") pOperator) <|> pOperator ) + pDelimiter + v <- pValue + return (o, v) From f2d6c59bab4714fd4de7e525d1818a8fdf225256 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Thu, 24 Sep 2015 16:29:20 +0300 Subject: [PATCH 06/31] fixes for failing tests (only 2 failing, yay! :)) --- src/PostgREST/App.hs | 20 +++++++++-- src/PostgREST/Functions.hs | 72 ++++++++++++++++++++++--------------- src/PostgREST/Parsers.hs | 28 +++++++++++---- src/PostgREST/PgQuery.hs | 7 +--- src/PostgREST/RangeQuery.hs | 1 + src/PostgREST/Types.hs | 24 +++++++++++-- 6 files changed, 105 insertions(+), 47 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index c6c5ef970..b881ec7f8 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -82,10 +82,22 @@ app dbstructure conf reqBody role req = if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else - case query of + case queries of Left e -> return $ responseLBS status200 [("Content-Type", "text/plain")] $ cs e - Right qs -> do - let q = B.Stmt qs V.empty True + Right (qs, cqs) -> do + let qt = qualify table + q = B.Stmt "select " V.empty True <> + parentheticT ( + cqs + ) <> commaq <> ( + bodyForAccept contentType qt + . limitT range + -- . orderT (orderParse qq) + -- . whereT qt qq + -- $ select qt qq + $ qs + ) + -- return $ responseLBS status200 [contentTypeH] (cs $ show $ B.stmtTemplate q) row <- H.maybeEx q let (tableTotal, queryTotal, body) = fromMaybe (0::Int, 0::Int, Just "" :: Maybe Text) row to = from+queryTotal-1 @@ -115,6 +127,8 @@ app dbstructure conf reqBody role req = >>= addJoinConditions allColumns where formatParserError = pack.show query = dbRequestToQuery <$> dbRequest + countQuery = dbRequestToCountQuery <$> dbRequest + queries = (,) <$> query <*> countQuery -- diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index 56dd52df4..ee5320242 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -8,7 +8,12 @@ import Data.List (find) import Data.Tree import Data.Text hiding (find, foldr, map, null, last, head) import Data.Monoid -import PostgREST.PgQuery (pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, whiteList, QualifiedIdentifier(..)) +import PostgREST.PgQuery (orderT, pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, whiteList, QualifiedIdentifier(..), StatementT, PStmt) +import qualified Hasql as H +import qualified Hasql.Postgres as P +import qualified Hasql.Backend as B +import qualified Data.Vector as V (empty) + findColumn :: [Column] -> Text -> Text -> Text -> Either Text Column @@ -33,8 +38,8 @@ filterToCondition schema allColumns table (Filter fld op val) = requestNodeToQuery ::Text -> [Table] -> [Column] -> RequestNode -> Either Text Query -requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs) = - Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel +requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs ord) = + Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel <*> pure ord where tblName = pack tblNameS mainTable = findTable allTables schema tblName @@ -95,31 +100,37 @@ addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = addCond q con = q{qWhere=con:qWhere q} -dbRequestToCountQuery :: DbRequest -> Text -dbRequestToCountQuery (Node (Select mainTable columns tables conditions relation) forest) = - Data.Text.unwords [ - "SELECT pg_catalog.count(1)", - "FROM ", pgFmtTable mainTable, - ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions - ] - where emptyOnNull val x = if null x then "" else val - -dbRequestToQuery :: DbRequest -> Text -dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation) forest) = - case relation of - Nothing -> "SELECT " - <> "(" - <> dbRequestToCountQuery r - <> ")," - <> "pg_catalog.count(t)," - <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " - <> "FROM (" - <> query - <> ") t;" - - _ -> query +dbRequestToCountQuery :: DbRequest -> PStmt +dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) forest) = + B.Stmt query V.empty True where - query = Data.Text.unwords [ + query = Data.Text.unwords [ + "SELECT pg_catalog.count(1)", + "FROM ", pgFmtTable mainTable, + ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions + ] + emptyOnNull val x = if null x then "" else val + +dbRequestToQuery :: DbRequest -> PStmt +dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation ord) forest) = + orderT (fromMaybe [] ord) $ query + -- case relation of + -- Nothing ->B.Stmt ("SELECT " + -- <> "(" + -- <> dbRequestToCountQuery r + -- <> ")," + -- <> "pg_catalog.count(t)," + -- <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " + -- <> "FROM (" + -- <> query + -- <> ") t;" + -- ) V.empty True + -- + -- _ -> B.Stmt query V.empty True + where + + query = B.Stmt q V.empty True + q = Data.Text.unwords [ ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, "SELECT ", intercalate ", " (map selectItemToStr columns ++ selects), "FROM ", intercalate ", " (map pgFmtTable (mainTable:tables)), @@ -134,12 +145,15 @@ dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation) f where name = tableName table sel = "(" <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " - <> "FROM (" <> dbRequestToQuery (Node q forst) <> ") " <> name + <> "FROM (" <> subquery <> ") " <> name <> ") AS " <> name + where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) + getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s) where name = tableName table sel = "row_to_json(" <> name <> ".*) AS "<>name --TODO must be singular - wit = name <> " AS ( " <> dbRequestToQuery (Node q forst) <> " )" + wit = name <> " AS ( " <> subquery <> " )" + where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) -- getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Many _ _))}) forst) (w,s) = (w,sel:s) -- where name = tableName table -- sel = "(" diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index d66e28562..03b476222 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -23,30 +23,35 @@ import PostgREST.Types import Data.List (delete, find) import Data.Maybe import Data.String.Conversions (cs) +import Control.Monad (join) + --import qualified Data.ByteString.Char8 as C --buildRequest :: String -> String -> [(String, String)] -> Either P.ParseError Request parseGetRequest :: Request -> Either ParseError ApiRequest parseGetRequest httpRequest = - foldr addFilter <$> apiRequest <*> flts + foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts where apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select ("++selectStr++")") $ cs selectStr + addOrder (Node r f) o = Node r{order=o} f flts = mapM pRequestFilter whereFilters rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] + orderStr = join $ lookup "order" qString + ord = traverse (parse pOrder ("failed to parse order ()")) orderStr selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] pRequestSelect :: String -> Parser ApiRequest pRequestSelect rootNodeName = do fieldTree <- pFieldForest - return $ foldr treeEntry (Node (RequestNode rootNodeName [] []) []) fieldTree + return $ foldr treeEntry (Node (RequestNode rootNodeName [] [] Nothing) []) fieldTree where treeEntry :: Tree SelectItem -> Tree RequestNode -> Tree RequestNode treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) = case fldForest of [] -> Node (rNode {fields=fld:fields rNode}) rForest - _ -> Node rNode (foldr treeEntry (Node (RequestNode fn [] []) []) fldForest:rForest) + _ -> Node rNode (foldr treeEntry (Node (RequestNode fn [] [] Nothing) []) fldForest:rForest) pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) @@ -133,14 +138,12 @@ pSelect = lexeme $ return ((s, Nothing), Nothing) pOperator :: Parser Operator -pOperator = try (string "eq") - <|> try (string "gt") +pOperator = try (string "lte") -- has to be before lt <|> try (string "lt") <|> try (string "eq") + <|> try (string "gte") -- has to be before gh <|> try (string "gt") <|> try (string "lt") - <|> try (string "gte") - <|> try (string "lte") <|> try (string "neq") <|> try (string "like") <|> try (string "ilike") @@ -169,3 +172,14 @@ pOpValueExp = do pDelimiter v <- pValue return (o, v) + +pOrder :: Parser ([OrderTerm]) +pOrder = lexeme pOrderTerm `sepBy` char ',' + +pOrderTerm :: Parser OrderTerm +pOrderTerm = do + c <- pFieldName + pDelimiter + d <- string "asc" <|> string "desc" + nls <- optionMaybe (pDelimiter *> ( try(string "nullslast" *> pure ("nulls last"::String)) <|> try(string "nullsfirst" *> pure ("nulls first"::String)))) + return $ OrderTerm (cs c) (cs d) (cs <$> nls) diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs index 9e7955780..dcbccf626 100644 --- a/src/PostgREST/PgQuery.hs +++ b/src/PostgREST/PgQuery.hs @@ -4,7 +4,7 @@ module PostgREST.PgQuery where import PostgREST.RangeQuery - +import PostgREST.Types (OrderTerm(..)) import qualified Hasql as H import qualified Hasql.Postgres as P import qualified Hasql.Backend as B @@ -39,11 +39,6 @@ data QualifiedIdentifier = QualifiedIdentifier { , qiName :: T.Text } deriving (Show) -data OrderTerm = OrderTerm { - otTerm :: T.Text -, otDirection :: BS.ByteString -, otNullOrder :: Maybe BS.ByteString -} limitT :: Maybe NonnegRange -> StatementT limitT r q = diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs index a138d9559..d28e2574c 100644 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -6,6 +6,7 @@ module PostgREST.RangeQuery ( , NonnegRange ) where +import PostgREST.Types (OrderTerm(..)) import Control.Applicative import Network.HTTP.Types.Header diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 2568e3439..2144a0689 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -1,6 +1,7 @@ module PostgREST.Types where import Data.Text import Data.Tree +import qualified Data.ByteString.Char8 as BS data DbStructure = DbStructure { tables :: [Table] @@ -41,6 +42,13 @@ data PrimaryKey = PrimaryKey { pkSchema::Text, pkTable::Text, pkName::Text } +data OrderTerm = OrderTerm { + otTerm :: Text +, otDirection :: BS.ByteString +, otNullOrder :: Maybe BS.ByteString +} deriving (Show, Eq) + + data Relation = Relation { relSchema :: Text , relTable :: Text @@ -62,7 +70,12 @@ type Field = (FieldName, Maybe JsonPath) type Cast = String type SelectItem = (Field, Maybe Cast) type Path = [String] -data RequestNode = RequestNode {nodeName::String, fields::[SelectItem], filters::[Filter]} deriving (Show, Eq) +data RequestNode = RequestNode { + nodeName::String +, fields::[SelectItem] +, filters::[Filter] +, order::Maybe [OrderTerm] +} deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) -- Db Request Types @@ -70,5 +83,12 @@ type DbField = (Column, Maybe JsonPath) type DbSelectItem = (DbField, Maybe Cast) data DbValue = VText Text | VForeignKey Relation deriving (Show) data Condition = Condition {conColumn::DbField, conOperator::Operator, conValue::DbValue} deriving (Show) -data Query = Select {qMainTable::Table, qSelect::[DbSelectItem], qJoinTables::[Table], qWhere::[Condition], qRelation::Maybe Relation} deriving (Show) +data Query = Select { + qMainTable::Table +, qSelect::[DbSelectItem] +, qJoinTables::[Table] +, qWhere::[Condition] +, qRelation::Maybe Relation +, qOrder::Maybe [OrderTerm] +} deriving (Show) type DbRequest = Tree Query From f546dc3ac813d586c0f97967666a4e665dfbcb34 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Thu, 24 Sep 2015 22:06:44 +0300 Subject: [PATCH 07/31] small note about a bug --- src/PostgREST/App.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index b881ec7f8..c07926d05 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -90,7 +90,7 @@ app dbstructure conf reqBody role req = parentheticT ( cqs ) <> commaq <> ( - bodyForAccept contentType qt + bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables . limitT range -- . orderT (orderParse qq) -- . whereT qt qq From 8783615ebcf06b6066230abfa8a2ad428e168d79 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Thu, 24 Sep 2015 23:30:47 +0300 Subject: [PATCH 08/31] detect primary keys for views (fix #217) --- src/PostgREST/PgStructure.hs | 35 ++++++++++---- test/Feature/StructureSpec.hs | 88 +++++++++++++++++++++++++++++++++++ 2 files changed, 113 insertions(+), 10 deletions(-) diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index 9e5647b8a..2a79b7610 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -110,16 +110,31 @@ columns table = do primaryKeyColumns :: QualifiedIdentifier -> H.Tx P.Postgres s [Text] primaryKeyColumns table = do r <- H.listEx $ [H.stmt| - select kc.column_name - from - information_schema.table_constraints tc, - information_schema.key_column_usage kc - where - tc.constraint_type = 'PRIMARY KEY' - and kc.table_name = tc.table_name and kc.table_schema = tc.table_schema - and kc.constraint_name = tc.constraint_name - and kc.table_schema = ? - and kc.table_name = ? |] (qiSchema table) (qiName table) + WITH table_pk AS + ( SELECT kc.table_schema, + kc.table_name, + kc.column_name + FROM information_schema.table_constraints tc, + information_schema.key_column_usage kc + WHERE tc.constraint_type = 'PRIMARY KEY' + AND kc.table_name = tc.table_name + AND kc.table_schema = tc.table_schema + AND kc.constraint_name = tc.constraint_name + AND kc.table_schema = ?) + SELECT column_name + FROM table_pk + WHERE table_pk.table_name = ? + UNION + ( + SELECT vcu.column_name + FROM information_schema.view_column_usage AS vcu + JOIN table_pk ON table_pk.table_schema = vcu.view_schema + AND table_pk.TABLE_NAME = vcu.TABLE_NAME + AND table_pk.column_name = vcu.column_name + WHERE vcu.view_schema = ? + AND vcu.view_name = ? + ) + |] (qiSchema table) (qiName table) (qiSchema table) (qiName table) return $ map runIdentity r doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index f63628e8a..d2f6bdb45 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -145,6 +145,94 @@ spec = around withApp $ do } |] + it "it includes primary key for views" $ + request methodOptions "/insertable_view_with_join" [] "" `shouldRespondWith` + [json| + { + "pkey":["id"], + "columns":[ + { + "references":null, + "default":null, + "precision":64, + "updatable":false, + "schema":"1", + "name":"id", + "type":"bigint", + "maxLen":null, + "enum":[], + "nullable":true, + "position":1 + }, + { + "references":null, + "default":null, + "precision":32, + "updatable":false, + "schema":"1", + "name":"auto_inc_fk", + "type":"integer", + "maxLen":null, + "enum":[], + "nullable":true, + "position":2 + }, + { + "references":null, + "default":null, + "precision":null, + "updatable":false, + "schema":"1", + "name":"simple_fk", + "type":"character varying", + "maxLen":255, + "enum":[], + "nullable":true, + "position":3 + }, + { + "references":null, + "default":null, + "precision":null, + "updatable":false, + "schema":"1", + "name":"nullable_string", + "type":"character varying", + "maxLen":null, + "enum":[], + "nullable":true, + "position":4 + }, + { + "references":null, + "default":null, + "precision":null, + "updatable":false, + "schema":"1", + "name":"non_nullable_string", + "type":"character varying", + "maxLen":null, + "enum":[], + "nullable":true, + "position":5 + }, + { + "references":null, + "default":null, + "precision":null, + "updatable":false, + "schema":"1", + "name":"inserted_at", + "type":"timestamp with time zone", + "maxLen":null, + "enum":[], + "nullable":true, + "position":6 + } + ] + } + |] + it "includes foreign key data" $ do pendingWith "have to resolve issue #107" From 54d1e4112a39804445c168291adca036ae708178 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 25 Sep 2015 10:30:19 +0300 Subject: [PATCH 09/31] detect primary keys for views & use cached info in PUT/PATCH requests --- src/PostgREST/App.hs | 10 ++++++---- src/PostgREST/PgStructure.hs | 16 +++++++++++++++- test/Feature/StructureSpec.hs | 16 ++++++++++++---- 3 files changed, 33 insertions(+), 9 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index c07926d05..dc160fe54 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -73,8 +73,8 @@ app dbstructure conf reqBody role req = ([table], "OPTIONS") -> do let qt = Table schema table let cols = filter (filterCol schema table) allColumns - let pkey = map pkName $ filter (filterPk schema table) allPrimaryKeys - let body = encode (TableOptions cols pkey) + let pkeys = map pkName $ filter (filterPk schema table) allPrimaryKeys + let body = encode (TableOptions cols pkeys) return $ responseLBS status200 [jsonH, allOrigins] $ cs body @@ -218,7 +218,8 @@ app dbstructure conf reqBody role req = Right toBeInserted -> do rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows - primaryKeys <- primaryKeyColumns qt + primaryKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys + --primaryKeys <- primaryKeyColumns qt let responses = flip map inserted $ \obj -> do let primaries = if Prelude.null primaryKeys @@ -252,7 +253,8 @@ app dbstructure conf reqBody role req = ([table], "PUT") -> handleJsonObj reqBody $ \obj -> do let qt = qualify table - primaryKeys <- primaryKeyColumns qt + primaryKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys + --primaryKeys <- primaryKeyColumns qt let specifiedKeys = map (cs . fst) qq if S.fromList primaryKeys /= S.fromList specifiedKeys then return $ responseLBS status405 [] diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index 48689cb5f..f56ed6fe5 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -324,7 +324,9 @@ allcolumns relations = do allprimaryKeys :: H.Tx P.Postgres s [PrimaryKey] allprimaryKeys = do pks <- H.listEx $ [H.stmt| - SELECT kc.table_schema, kc.table_name, kc.column_name + WITH table_pk AS + ( + SELECT kc.table_schema, kc.table_name, kc.column_name FROM information_schema.table_constraints tc, information_schema.key_column_usage kc WHERE tc.constraint_type = 'PRIMARY KEY' @@ -332,6 +334,18 @@ allprimaryKeys = do AND kc.table_schema = tc.table_schema AND kc.constraint_name = tc.constraint_name AND kc.table_schema NOT IN ('pg_catalog', 'information_schema') + ) + SELECT table_schema, table_name, column_name + FROM table_pk + UNION + ( + SELECT vcu.view_schema, vcu.view_name, vcu.column_name + FROM information_schema.view_column_usage AS vcu + JOIN table_pk ON table_pk.table_schema = vcu.view_schema + AND table_pk.table_name = vcu.table_name + AND table_pk.column_name = vcu.column_name + WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') + ) |] return $ map pkFromRow pks diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index d2f6bdb45..eb63e5724 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -145,11 +145,13 @@ spec = around withApp $ do } |] - it "it includes primary key for views" $ + it "it includes primary and foreign keys for views" $ request methodOptions "/insertable_view_with_join" [] "" `shouldRespondWith` [json| { - "pkey":["id"], + "pkey":[ + "id" + ], "columns":[ { "references":null, @@ -165,7 +167,10 @@ spec = around withApp $ do "position":1 }, { - "references":null, + "references":{ + "column":"id", + "table":"auto_incrementing_pk" + }, "default":null, "precision":32, "updatable":false, @@ -178,7 +183,10 @@ spec = around withApp $ do "position":2 }, { - "references":null, + "references":{ + "column":"k", + "table":"simple_pk" + }, "default":null, "precision":null, "updatable":false, From 770e04c04afc9d48af554451742fd77a3d5daa82 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 25 Sep 2015 10:36:19 +0300 Subject: [PATCH 10/31] remove unused functions in pgstructure --- src/PostgREST/PgStructure.hs | 119 ----------------------------------- 1 file changed, 119 deletions(-) diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index f56ed6fe5..33fe3c633 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -20,125 +20,6 @@ import qualified Hasql.Postgres as P import Prelude ------------ --- foreignKeys :: QualifiedIdentifier -> H.Tx P.Postgres s (Map.Map Text ForeignKey) --- foreignKeys table = do --- r <- H.listEx $ [H.stmt| --- select kcu.column_name, ccu.table_name AS foreign_table_name, --- ccu.column_name AS foreign_column_name --- from information_schema.table_constraints AS tc --- join information_schema.key_column_usage AS kcu --- on tc.constraint_name = kcu.constraint_name --- join information_schema.constraint_column_usage AS ccu --- on ccu.constraint_name = tc.constraint_name --- where constraint_type = 'FOREIGN KEY' --- and tc.table_name=? and tc.table_schema = ? --- order by kcu.column_name --- |] (qiName table) (qiSchema table) --- --- return $ foldl addKey Map.empty r --- where --- addKey :: Map.Map Text ForeignKey -> (Text, Text, Text) -> Map.Map Text ForeignKey --- addKey m (col, ftab, fcol) = Map.insert col (ForeignKey ftab fcol) m --- --- --- tables :: Text -> H.Tx P.Postgres s [Table] --- tables schema = do --- rows <- H.listEx $ --- [H.stmt| --- select --- n.nspname as table_schema, --- relname as table_name, --- c.relkind = 'r' or (c.relkind IN ('v', 'f')) and (pg_relation_is_updatable(c.oid::regclass, false) & 8) = 8 --- or (exists ( --- select 1 --- from pg_trigger --- where pg_trigger.tgrelid = c.oid and (pg_trigger.tgtype::integer & 69) = 69) --- ) as insertable --- from --- pg_class c --- join pg_namespace n on n.oid = c.relnamespace --- where --- c.relkind in ('v', 'r', 'm') --- and n.nspname = ? --- and ( --- pg_has_role(c.relowner, 'USAGE'::text) --- or has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) --- or has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) --- ) --- order by relname --- |] schema --- return $ map tableFromRow rows - - --- columns :: QualifiedIdentifier -> H.Tx P.Postgres s [Column] --- columns table = do --- cols <- H.listEx $ [H.stmt| --- select info.table_schema as schema, info.table_name as table_name, --- info.column_name as name, info.ordinal_position as position, --- info.is_nullable::boolean as nullable, info.data_type as col_type, --- info.is_updatable::boolean as updatable, --- info.character_maximum_length as max_len, --- info.numeric_precision as precision, --- info.column_default as default_value, --- array_to_string(enum_info.vals, ',') as enum --- from ( --- select table_schema, table_name, column_name, ordinal_position, --- is_nullable, data_type, is_updatable, --- character_maximum_length, numeric_precision, --- column_default, udt_name --- from information_schema.columns --- where table_schema = ? and table_name = ? --- ) as info --- left outer join ( --- select n.nspname as s, --- t.typname as n, --- array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals --- from pg_type t --- join pg_enum e on t.oid = e.enumtypid --- join pg_catalog.pg_namespace n ON n.oid = t.typnamespace --- group by s, n --- ) as enum_info --- on (info.udt_name = enum_info.n) --- order by position |] --- (qiSchema table) (qiName table) --- --- fks <- foreignKeys table --- return $ map (addFK fks . columnFromRow) cols --- --- where --- addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks } - - -primaryKeyColumns :: QualifiedIdentifier -> H.Tx P.Postgres s [Text] -primaryKeyColumns table = do - r <- H.listEx $ [H.stmt| - WITH table_pk AS - ( SELECT kc.table_schema, - kc.table_name, - kc.column_name - FROM information_schema.table_constraints tc, - information_schema.key_column_usage kc - WHERE tc.constraint_type = 'PRIMARY KEY' - AND kc.table_name = tc.table_name - AND kc.table_schema = tc.table_schema - AND kc.constraint_name = tc.constraint_name - AND kc.table_schema = ?) - SELECT column_name - FROM table_pk - WHERE table_pk.table_name = ? - UNION - ( - SELECT vcu.column_name - FROM information_schema.view_column_usage AS vcu - JOIN table_pk ON table_pk.table_schema = vcu.view_schema - AND table_pk.TABLE_NAME = vcu.TABLE_NAME - AND table_pk.column_name = vcu.column_name - WHERE vcu.view_schema = ? - AND vcu.view_name = ? - ) - |] (qiSchema table) (qiName table) (qiSchema table) (qiName table) - return $ map runIdentity r doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool doesProcExist schema proc = do From c42832f1c53451c9e234c3865a03b8729d3804dc Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 25 Sep 2015 11:51:37 +0300 Subject: [PATCH 11/31] code cleanup --- src/PostgREST/App.hs | 33 ++++++++------ src/PostgREST/Auth.hs | 39 ++++++++-------- src/PostgREST/Config.hs | 39 ++++++++-------- src/PostgREST/Error.hs | 22 +++++---- src/PostgREST/Functions.hs | 47 ++++++++++--------- src/PostgREST/Main.hs | 68 +++++++++++++++------------- src/PostgREST/Middleware.hs | 47 ++++++++++--------- src/PostgREST/Parsers.hs | 88 ++++++++++++------------------------ src/PostgREST/PgQuery.hs | 48 +++++++++++--------- src/PostgREST/PgStructure.hs | 63 ++++++++++---------------- src/PostgREST/RangeQuery.hs | 22 ++++----- src/PostgREST/Types.hs | 25 ++++++++++ 12 files changed, 272 insertions(+), 269 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index dc160fe54..932b5bc94 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -1,11 +1,15 @@ {-# LANGUAGE FlexibleContexts #-} -module PostgREST.App (app, sqlError, isSqlError, contentTypeForAccept --- added +module PostgREST.App ( + app +, sqlError +, isSqlError +, contentTypeForAccept , jsonH , requestedSchema , TableOptions(..) ) where + import Control.Monad (join) import Control.Arrow ((***), second) import Control.Applicative @@ -53,7 +57,7 @@ import PostgREST.Functions import Prelude app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response -app dbstructure conf reqBody role req = +app dbstructure conf reqBody dbrole req = case (path, verb) of -- ([], _) -> do -- body <- encode <$> tables (cs schema) @@ -67,11 +71,11 @@ app dbstructure conf reqBody role req = -- $ encode (TableOptions cols pkey) ([], _) -> do - let body = encode $ filter (filterTableAcl role) $ filter (((cs schema)==).tableSchema) allTables + let body = encode $ filter (filterTableAcl dbrole) $ filter (((cs schema)==).tableSchema) allTables return $ responseLBS status200 [jsonH] $ cs body ([table], "OPTIONS") -> do - let qt = Table schema table + --let qt = Table schema table let cols = filter (filterCol schema table) allColumns let pkeys = map pkName $ filter (filterPk schema table) allPrimaryKeys let body = encode (TableOptions cols pkeys) @@ -218,13 +222,13 @@ app dbstructure conf reqBody role req = Right toBeInserted -> do rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows - primaryKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys - --primaryKeys <- primaryKeyColumns qt + pKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys + --pKeys <- primaryKeyColumns qt let responses = flip map inserted $ \obj -> do let primaries = - if Prelude.null primaryKeys + if Prelude.null pKeys then obj - else M.filterWithKey (const . (`elem` primaryKeys)) obj + else M.filterWithKey (const . (`elem` pKeys)) obj let params = urlEncodeVars $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t))) $ sortBy (comparing fst) $ M.toList primaries @@ -253,10 +257,10 @@ app dbstructure conf reqBody role req = ([table], "PUT") -> handleJsonObj reqBody $ \obj -> do let qt = qualify table - primaryKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys - --primaryKeys <- primaryKeyColumns qt + pKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys + --pKeys <- primaryKeyColumns qt let specifiedKeys = map (cs . fst) qq - if S.fromList primaryKeys /= S.fromList specifiedKeys + if S.fromList pKeys /= S.fromList specifiedKeys then return $ responseLBS status405 [] "You must speficy all and only primary keys as params" else do @@ -317,8 +321,9 @@ app dbstructure conf reqBody role req = allColumns = columns dbstructure allPrimaryKeys = primaryKeys dbstructure --allTablesAcl = tablesAcl dbstructure - filterCol schema table (Column{colSchema=s, colTable=t}) = s==schema && table==t - filterPk schema table (PrimaryKey{pkSchema=s, pkTable=t}) = s==schema && table==t + filterCol sc table (Column{colSchema=s, colTable=t}) = s==sc && table==t + filterCol _ _ _ = False + filterPk sc table (PrimaryKey{pkSchema=s, pkTable=t}) = s==sc && table==t filterTableAcl :: Text -> Table -> Bool filterTableAcl r (Table{tableAcl=a}) = r `elem` a diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 0dfe553e0..9cd8cf779 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -1,27 +1,28 @@ -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} module PostgREST.Auth where -import Data.Aeson -import Control.Monad (mzero) -import Control.Applicative -import Crypto.BCrypt -import Data.Text -import Data.Monoid -import Data.Map -import qualified Data.Vector as V -import qualified Hasql as H -import qualified Hasql.Backend as B -import qualified Hasql.Postgres as P -import qualified Web.JWT as JWT -import Data.String.Conversions (cs) -import PostgREST.PgQuery (pgFmtLit) +import Control.Applicative +import Control.Monad (mzero) +import Crypto.BCrypt +import Data.Aeson +import Data.Map +import Data.Monoid +import Data.String.Conversions (cs) +import Data.Text +import qualified Data.Vector as V +import qualified Hasql as H +import qualified Hasql.Backend as B +import qualified Hasql.Postgres as P +import PostgREST.PgQuery (pgFmtLit) +import Prelude +import qualified Web.JWT as JWT -import Prelude - -import System.IO.Unsafe +import System.IO.Unsafe data AuthUser = AuthUser { - userId :: String + userId :: String , userPass :: String , userRole :: String } deriving (Show) diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 1de7da33b..30d6d2a5d 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -1,27 +1,28 @@ module PostgREST.Config where -import Network.Wai -import Control.Applicative -import Data.Text (strip) -import qualified Data.CaseInsensitive as CI -import qualified Data.ByteString.Char8 as BS -import Data.String.Conversions (cs) -import Options.Applicative hiding (columns) -import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) -import Prelude + +import Control.Applicative +import qualified Data.ByteString.Char8 as BS +import qualified Data.CaseInsensitive as CI +import Data.String.Conversions (cs) +import Data.Text (strip) +import Network.Wai +import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) +import Options.Applicative hiding (columns) +import Prelude data AppConfig = AppConfig { - configDbName :: String - , configDbPort :: Int - , configDbUser :: String - , configDbPass :: String - , configDbHost :: String + configDbName :: String + , configDbPort :: Int + , configDbUser :: String + , configDbPass :: String + , configDbHost :: String - , configPort :: Int - , configAnonRole :: String - , configSecure :: Bool - , configPool :: Int - , configV1Schema :: String + , configPort :: Int + , configAnonRole :: String + , configSecure :: Bool + , configPool :: Int + , configV1Schema :: String , configJwtSecret :: String } diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 176b5a327..9b162c53a 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -1,18 +1,20 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} module PostgREST.Error (PgError, errResponse) where -import qualified Hasql as H -import qualified Hasql.Postgres as P + +import Data.Aeson ((.=)) +import qualified Data.Aeson as JSON +import Data.String.Conversions (cs) +import Data.String.Utils (replace) +import qualified Data.Text as T +import qualified Hasql as H +import qualified Hasql.Postgres as P +import Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT -import qualified Data.Aeson as JSON -import qualified Data.Text as T -import Data.Aeson ((.=)) -import Data.String.Conversions (cs) -import Data.String.Utils(replace) -import Network.Wai(Response, responseLBS) -import Network.HTTP.Types.Header +import Network.Wai (Response, responseLBS) type PgError = H.SessionError P.Postgres diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index ee5320242..c4b972e4c 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -2,17 +2,20 @@ module PostgREST.Functions where -import PostgREST.Types + import Control.Error -import Data.List (find) -import Data.Tree -import Data.Text hiding (find, foldr, map, null, last, head) -import Data.Monoid -import PostgREST.PgQuery (orderT, pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, whiteList, QualifiedIdentifier(..), StatementT, PStmt) -import qualified Hasql as H -import qualified Hasql.Postgres as P -import qualified Hasql.Backend as B -import qualified Data.Vector as V (empty) +import Data.List (find) +import Data.Monoid +import Data.Text hiding (find, foldr, head, last, map, null) +import Data.Tree +import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi, + orderT, pgFmtIdent, pgFmtLit, pgFmtOperator, + pgFmtValue, whiteList) +import PostgREST.Types +--import qualified Hasql as H +--import qualified Hasql.Postgres as P +import qualified Data.Vector as V (empty) +import qualified Hasql.Backend as B @@ -47,7 +50,7 @@ requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs where -- it's ok not to check that the table exists here, mainTable will do the checking toDbSelectItem :: SelectItem -> Either Text DbSelectItem - toDbSelectItem (("*", Nothing), Nothing) = Right $ ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing) + toDbSelectItem (("*", Nothing), Nothing) = Right ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing) toDbSelectItem ((c,jp), cast) = (,) <$> dbFld <*> pure cast where col = findColumn allColumns schema tblName $ pack c @@ -63,7 +66,7 @@ addRelations allRelations parentNode node@(Node query@(Select {qMainTable=table} Nothing -> Node query{qRelation=Nothing} <$> updatedForest (Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest where - rel = note ("no relation between " <> (tableName table) <> " and " <> (tableName parentTable)) $ + rel = note ("no relation between " <> tableName table <> " and " <> tableName parentTable) $ findRelation allRelations (tableSchema table) (tableName table) (tableName parentTable) addRel :: Query -> Relation -> Query addRel q r = q{qRelation = Just r} @@ -85,7 +88,7 @@ addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = _ -> Left "unknow relation" where -- add parentTable and parentJoinConditions to the query - updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ (qJoinTables query)}) <$> parentJoinConditions + updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ qJoinTables query}) <$> parentJoinConditions where parentJoinConditions = mapM (getJoinCondition.snd) parents parentTables = map fst parents @@ -101,7 +104,7 @@ addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = dbRequestToCountQuery :: DbRequest -> PStmt -dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) forest) = +dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) _) = B.Stmt query V.empty True where query = Data.Text.unwords [ @@ -112,8 +115,8 @@ dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) forest) = emptyOnNull val x = if null x then "" else val dbRequestToQuery :: DbRequest -> PStmt -dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation ord) forest) = - orderT (fromMaybe [] ord) $ query +dbRequestToQuery (Node (Select mainTable colSelects tbls conditions _ ord) forest) = + orderT (fromMaybe [] ord) query -- case relation of -- Nothing ->B.Stmt ("SELECT " -- <> "(" @@ -129,11 +132,11 @@ dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation or -- _ -> B.Stmt query V.empty True where - query = B.Stmt q V.empty True - q = Data.Text.unwords [ + query = B.Stmt qStr V.empty True + qStr = Data.Text.unwords [ ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, - "SELECT ", intercalate ", " (map selectItemToStr columns ++ selects), - "FROM ", intercalate ", " (map pgFmtTable (mainTable:tables)), + "SELECT ", intercalate ", " (map selectItemToStr colSelects ++ selects), + "FROM ", intercalate ", " (map pgFmtTable (mainTable:tbls)), ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions ] emptyOnNull val x = if null x then "" else val @@ -186,7 +189,7 @@ pgFmtColumn Column {colSchema=s, colTable=t, colName=c} = pgFmtIdent s <> "." <> pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*" pgFmtJsonPath :: Maybe JsonPath -> Text -pgFmtJsonPath (Just [x]) = "->>" <> (pgFmtLit $ pack x) +pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit (pack x) pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit (pack x) <> pgFmtJsonPath ( Just xs ) pgFmtJsonPath _ = "" @@ -199,4 +202,4 @@ selectItemToStr ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn c <> pgFmtJsonPa asJsonPath :: Maybe JsonPath -> Text asJsonPath Nothing = "" -asJsonPath (Just xx) = " AS " <> (pack $ last xx) +asJsonPath (Just xx) = " AS " <> pack (last xx) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 1921d3dc9..7af30e22e 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -1,42 +1,48 @@ -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Paths_postgrest (version) + +import Paths_postgrest (version) -- added -import PostgREST.PgStructure -import Data.Aeson -import Data.List (find) -import Data.Maybe (isJust) -import PostgREST.Types -import Network.HTTP.Types.Status -import Network.HTTP.Types.Header -import Network.Wai -- (strictRequestBody, pathInfo, requestMethod, requestHeaders) +import PostgREST.PgStructure +--import Data.Aeson +--import Data.List (find) +--import Data.Maybe (isJust) +import PostgREST.Types +--import Network.HTTP.Types.Status +--import Network.HTTP.Types.Header +import Network.Wai -import PostgREST.App -import PostgREST.Middleware -import PostgREST.Error(errResponse) +import PostgREST.App +import PostgREST.Error (errResponse) +import PostgREST.Middleware -import Control.Monad (unless) -import Control.Monad.IO.Class (liftIO) -import Data.String.Conversions (cs) -import Network.Wai.Handler.Warp hiding (Connection) -import Network.Wai.Middleware.RequestLogger (logStdout) -import Data.List (intercalate) -import Data.Version (versionBranch) -import Data.Functor.Identity -import Data.Text(Text) -import qualified Hasql as H -import qualified Hasql.Postgres as P -import Options.Applicative hiding (columns) +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Data.Functor.Identity +import Data.List (intercalate) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Version (versionBranch) +import qualified Hasql as H +import qualified Hasql.Postgres as P +import Network.Wai.Handler.Warp hiding (Connection) +import Network.Wai.Middleware.RequestLogger (logStdout) +import Options.Applicative hiding (columns) -import System.IO (stderr, stdin, stdout, hSetBuffering, BufferMode(..)) +import System.IO (BufferMode (..), + hSetBuffering, stderr, + stdin, stdout) -import PostgREST.Config (AppConfig(..), argParser) +import PostgREST.Config (AppConfig (..), + argParser) +isServerVersionSupported :: H.Session P.Postgres IO Bool isServerVersionSupported = do Identity (row :: Text) <- H.tx Nothing $ H.singleEx $ [H.stmt|SHOW server_version_num|] - return $ read (cs row) >= 90200 + return $ read (cs row) >= (90200::Integer) main :: IO () main = do @@ -76,12 +82,12 @@ main = do H.poolSettings (fromIntegral $ configPool conf) 30 pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings - resOrError <- H.session pool isServerVersionSupported + supportedOrError <- H.session pool isServerVersionSupported either (fail . show) (\supported -> unless supported $ fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0" - ) resOrError + ) supportedOrError -- read the structure of the database -- read the structure of the database @@ -96,7 +102,7 @@ main = do colsRes <- H.session pool $ H.tx txParam $ allcolumns allRelations let allColumns = either (fail . show) id colsRes - pkRes <- H.session pool $ H.tx txParam $ allprimaryKeys + pkRes <- H.session pool $ H.tx txParam allprimaryKeys let allPrimaryKeys = either (fail . show) id pkRes -- tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index e29fabda2..47ae96389 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -3,32 +3,37 @@ module PostgREST.Middleware where -import Data.Maybe (fromMaybe, isNothing) -import Data.Monoid -import Data.Text +import Data.Maybe (fromMaybe, isNothing) +import Data.Monoid +import Data.Text -- import Data.Pool(withResource, Pool) -import qualified Hasql as H -import qualified Hasql.Postgres as P -import Data.String.Conversions(cs) +import Data.String.Conversions (cs) +import qualified Hasql as H +import qualified Hasql.Postgres as P -import Network.HTTP.Types.Header (hLocation, hAuthorization, hAccept) -import Network.HTTP.Types (RequestHeaders) -import Network.HTTP.Types.Status (status400, status401, status301, status415) -import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo, - rawQueryString, isSecure, Request(..), Response) -import Network.Wai.Middleware.Gzip (gzip, def) -import Network.Wai.Middleware.Cors (cors) -import Network.Wai.Middleware.Static (staticPolicy, only) -import Network.URI (URI(..), parseURI) +import Network.HTTP.Types (RequestHeaders) +import Network.HTTP.Types.Header (hAccept, hAuthorization, + hLocation) +import Network.HTTP.Types.Status (status301, status400, status401, + status415) +import Network.URI (URI (..), parseURI) +import Network.Wai (Application, Request (..), + Response, isSecure, rawPathInfo, + rawQueryString, requestHeaders, + responseLBS) +import Network.Wai.Middleware.Cors (cors) +import Network.Wai.Middleware.Gzip (def, gzip) +import Network.Wai.Middleware.Static (only, staticPolicy) -import PostgREST.Config (AppConfig(..), corsPolicy) -import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, setUserId) -import PostgREST.App (contentTypeForAccept) -import Codec.Binary.Base64.String (decode) -import PostgREST.Auth (DbRole) +import Codec.Binary.Base64.String (decode) +import PostgREST.App (contentTypeForAccept) +import PostgREST.Auth (DbRole, LoginAttempt (..), + setRole, setUserId, signInRole, + signInWithJWT) +import PostgREST.Config (AppConfig (..), corsPolicy) -import Prelude +import Prelude authenticated :: forall s. AppConfig -> (DbRole -> Request -> H.Tx P.Postgres s Response) -> diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 03b476222..889fb2920 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -1,33 +1,18 @@ --{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-} module PostgREST.Parsers --- ( parseGetRequest --- , pSelect --- , pField --- , pRequestSelect --- ) - +( parseGetRequest +) where -import Text.ParserCombinators.Parsec hiding (many, (<|>)) ---import Text.Parsec.Text ---import Text.Parsec hiding (many, (<|>)) ---import Text.Parsec.Prim hiding (many, (<|>)) + import Control.Applicative ---import Control.Monad ---import qualified Data.Text as T -import Data.Tree -import Network.Wai (Request, pathInfo, queryString) -import PostgREST.Types ---import qualified Data.ByteString.Char8 as C ---import Control.Monad ---import Data.Foldable (foldrM) +import Control.Monad (join) import Data.List (delete, find) import Data.Maybe import Data.String.Conversions (cs) -import Control.Monad (join) - ---import qualified Data.ByteString.Char8 as C - ---buildRequest :: String -> String -> [(String, String)] -> Either P.ParseError Request +import Data.Tree +import Network.Wai (Request, pathInfo, queryString) +import PostgREST.Types +import Text.ParserCombinators.Parsec hiding (many, (<|>)) parseGetRequest :: Request -> Either ParseError ApiRequest parseGetRequest httpRequest = foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts @@ -38,7 +23,7 @@ parseGetRequest httpRequest = rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] orderStr = join $ lookup "order" qString - ord = traverse (parse pOrder ("failed to parse order ()")) orderStr + ord = traverse (parse pOrder ("failed to parse order ("++fromMaybe "" orderStr++")")) orderStr selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] @@ -81,15 +66,12 @@ addFilter (path, flt) (Node rn forest) = ws :: Parser String ws = many (oneOf " \t") ---lexeme :: Parser String -> Parser String ---lexeme :: Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity a -> Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity a ---lexeme :: Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity Char -> Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity Char +lexeme :: Parser a -> Parser a lexeme p = ws *> p <* ws pTreePath :: Parser (Path,Field) pTreePath = do - p <- (pFieldName `sepBy1` pDelimiter) - --f <- pField + p <- pFieldName `sepBy1` pDelimiter jp <- optionMaybe ( string "->" >> pJsonPath) return (init p, (last p, jp)) @@ -98,17 +80,8 @@ pFieldForest :: Parser [Tree SelectItem] pFieldForest = pFieldTree `sepBy1` lexeme (char ',') pFieldTree :: Parser (Tree SelectItem) -pFieldTree = - try ( do - fld <- pSelect - char '(' - subforest <- pFieldForest - char ')' - return (Node fld subforest) - ) - <|> do - fld <- pSelect - return (Node fld []) +pFieldTree = try (Node <$> pSelect <*> ( char '(' *> pFieldForest <* char ')')) + <|> Node <$> pSelect <*> pure [] pStar :: Parser String pStar = string "*" *> pure "*" @@ -117,22 +90,18 @@ pFieldName :: Parser String pFieldName = many1 (letter <|> digit <|> oneOf "_") "field name (* or [a..z0..9_])" +pJsonPathDelimiter :: Parser String +pJsonPathDelimiter = try (string "->>") <|> string "->" + pJsonPath :: Parser [String] -pJsonPath = pFieldName `sepBy1` (try (string "->>") <|> string "->") +pJsonPath = pFieldName `sepBy1` pJsonPathDelimiter pField :: Parser Field -pField = lexeme $ do - f <- pFieldName - jp <- optionMaybe ( (try (string "->>") <|> string "->") >> pJsonPath) - return (f, jp) +pField = lexeme $ (,) <$> pFieldName <*> optionMaybe ( pJsonPathDelimiter *> pJsonPath) pSelect :: Parser SelectItem pSelect = lexeme $ - try (do - n <- pField - v <- optionMaybe (string "::" >> many letter) - return (n, v) - ) + try ((,) <$> pField <*> optionMaybe (string "::" *> many letter)) <|> do s <- pStar return ((s, Nothing), Nothing) @@ -154,8 +123,8 @@ pOperator = try (string "lte") -- has to be before lt <|> try (string "@@") "operator (eq, gt, ...)" -pInt :: Parser Int -pInt = try (liftA read (many1 digit)) "integer" +-- pInt :: Parser Int +-- pInt = try (liftA read (many1 digit)) "integer" --pValue :: Parser Value --pValue = (VInt <$> try (pInt <* eof)) @@ -166,20 +135,19 @@ pValue = many anyChar pDelimiter :: Parser Char pDelimiter = char '.' "delimiter (.)" -pOpValueExp :: Parser (Operator, FValue) -pOpValueExp = do - o <- ( try ( liftA2 (++) (string "not.") pOperator) <|> pOperator ) - pDelimiter - v <- pValue - return (o, v) +pOperatiorWithNegation :: Parser Operator +pOperatiorWithNegation = try ( (++) <$> string "not." <*> pOperator) <|> pOperator -pOrder :: Parser ([OrderTerm]) +pOpValueExp :: Parser (Operator, FValue) +pOpValueExp = (,) <$> pOperatiorWithNegation <*> (pDelimiter *> pValue) + +pOrder :: Parser [OrderTerm] pOrder = lexeme pOrderTerm `sepBy` char ',' pOrderTerm :: Parser OrderTerm pOrderTerm = do c <- pFieldName - pDelimiter + _ <- pDelimiter d <- string "asc" <|> string "desc" nls <- optionMaybe (pDelimiter *> ( try(string "nullslast" *> pure ("nulls last"::String)) <|> try(string "nullsfirst" *> pure ("nulls first"::String)))) return $ OrderTerm (cs c) (cs d) (cs <$> nls) diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs index dcbccf626..b2182e20e 100644 --- a/src/PostgREST/PgQuery.hs +++ b/src/PostgREST/PgQuery.hs @@ -1,31 +1,35 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiWayIf #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module PostgREST.PgQuery where -import PostgREST.RangeQuery -import PostgREST.Types (OrderTerm(..)) -import qualified Hasql as H -import qualified Hasql.Postgres as P -import qualified Hasql.Backend as B -import qualified Data.Text as T -import qualified Data.HashMap.Strict as H -import Text.Regex.TDFA ( (=~) ) -import qualified Network.HTTP.Types.URI as Net -import qualified Data.ByteString.Char8 as BS -import Data.Monoid -import Data.Vector (empty) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Functor -import Control.Monad (join) -import Data.String.Conversions (cs) -import qualified Data.Aeson as JSON -import qualified Data.List as L -import qualified Data.Vector as V -import Data.Scientific (isInteger, formatScientific, FPFormat(..)) +import qualified Hasql as H +import qualified Hasql.Backend as B +import qualified Hasql.Postgres as P +import PostgREST.RangeQuery +import PostgREST.Types (OrderTerm (..)) -import Prelude +import Control.Monad (join) +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as BS +import Data.Functor +import qualified Data.HashMap.Strict as H +import qualified Data.List as L +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Monoid +import Data.Scientific (FPFormat (..), formatScientific, + isInteger) +import Data.String.Conversions (cs) +import qualified Data.Text as T +import Data.Vector (empty) +import qualified Data.Vector as V +import qualified Network.HTTP.Types.URI as Net +import Text.Regex.TDFA ((=~)) + +import Prelude type PStmt = H.Stmt P.Postgres instance Monoid PStmt where diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index 33fe3c633..9cd82e449 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -1,24 +1,27 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances, - MultiParamTypeClasses, ScopedTypeVariables, - FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} module PostgREST.PgStructure where -import PostgREST.PgQuery (QualifiedIdentifier(..)) -import PostgREST.Types -import Data.Text (Text, unpack, split) -import Data.List (find) -import Data.Aeson -import Data.Functor.Identity -import Data.String.Conversions (cs) -import Data.Maybe (fromMaybe, isJust) -import Control.Applicative +import Data.List (find) +import Data.Text (Text, split) +import PostgREST.PgQuery () +import PostgREST.Types +--import Data.Aeson +import Data.Functor.Identity +--import Data.String.Conversions (cs) +import Control.Applicative +import Data.Maybe (fromMaybe, isJust) -import qualified Data.Map as Map +--import qualified Data.Map as Map -import qualified Hasql as H -import qualified Hasql.Postgres as P +import qualified Hasql as H +import qualified Hasql.Postgres as P -import Prelude +import Prelude doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool @@ -53,28 +56,6 @@ columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) = parseEnum str = fromMaybe [] $ split (==',') <$> str -instance ToJSON Column where - toJSON c = object [ - "schema" .= colSchema c - , "name" .= colName c - , "position" .= colPosition c - , "nullable" .= colNullable c - , "type" .= colType c - , "updatable" .= colUpdatable c - , "maxLen" .= colMaxLen c - , "precision" .= colPrecision c - , "references".= colFK c - , "default" .= colDefault c - , "enum" .= colEnum c ] - -instance ToJSON ForeignKey where - toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk] - -instance ToJSON Table where - toJSON v = object [ - "schema" .= tableSchema v - , "name" .= tableName v - , "insertable" .= tableInsertable v ] ------------ @@ -152,7 +133,7 @@ allrelations = do return $ foldr (addFlippedRelation.relationFromRow) [] rels allcolumns :: [Relation] -> H.Tx P.Postgres s [Column] -allcolumns relations = do +allcolumns rels = do cols <- H.listEx $ [H.stmt| SELECT info.table_schema AS schema, @@ -197,9 +178,11 @@ allcolumns relations = do return $ map (addFK . columnFromRow) cols where - addFK col = col { colFK = relToFk <$> find (lookupFn col) relations } + addFK col = col { colFK = relToFk <$> find (lookupFn col) rels } + lookupFn :: Column -> Relation -> Bool lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumn=rc, relType=rty}) = cs==rs && ct==rt && cn==rc && rty=="child" + lookupFn _ _ = False relToFk (Relation{relFTable=t, relFColumn=c}) = ForeignKey t c allprimaryKeys :: H.Tx P.Postgres s [PrimaryKey] diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs index d28e2574c..ff9997378 100644 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -6,22 +6,22 @@ module PostgREST.RangeQuery ( , NonnegRange ) where -import PostgREST.Types (OrderTerm(..)) -import Control.Applicative -import Network.HTTP.Types.Header -import qualified Data.ByteString.Char8 as BS +import Control.Applicative +import Network.HTTP.Types.Header +import PostgREST.Types () -import Data.Ranged.Boundaries -import Data.Ranged.Ranges +import qualified Data.ByteString.Char8 as BS +import Data.Ranged.Boundaries +import Data.Ranged.Ranges -import Data.String.Conversions (cs) -import Text.Regex.TDFA ((=~)) -import Text.Read (readMaybe) +import Data.String.Conversions (cs) +import Text.Read (readMaybe) +import Text.Regex.TDFA ((=~)) -import Data.Maybe (fromMaybe, listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe) -import Prelude +import Prelude type NonnegRange = Range Int diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 2144a0689..3321b0e68 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -2,6 +2,7 @@ module PostgREST.Types where import Data.Text import Data.Tree import qualified Data.ByteString.Char8 as BS +import Data.Aeson data DbStructure = DbStructure { tables :: [Table] @@ -11,6 +12,7 @@ data DbStructure = DbStructure { --, tablesAcl :: [(Text, Text, Text)] } + data Table = Table { tableSchema :: Text , tableName :: Text @@ -92,3 +94,26 @@ data Query = Select { , qOrder::Maybe [OrderTerm] } deriving (Show) type DbRequest = Tree Query + +instance ToJSON Column where + toJSON c = object [ + "schema" .= colSchema c + , "name" .= colName c + , "position" .= colPosition c + , "nullable" .= colNullable c + , "type" .= colType c + , "updatable" .= colUpdatable c + , "maxLen" .= colMaxLen c + , "precision" .= colPrecision c + , "references".= colFK c + , "default" .= colDefault c + , "enum" .= colEnum c ] + +instance ToJSON ForeignKey where + toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk] + +instance ToJSON Table where + toJSON v = object [ + "schema" .= tableSchema v + , "name" .= tableName v + , "insertable" .= tableInsertable v ] From ff2c0b63e2d599c524dfb808f4c19c7535c6dc61 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 25 Sep 2015 12:04:44 +0300 Subject: [PATCH 12/31] changed identation to 2 spaces to match the rest of the project --- src/PostgREST/Functions.hs | 258 +++++++++++++++++++------------------ src/PostgREST/Parsers.hs | 122 +++++++++--------- 2 files changed, 191 insertions(+), 189 deletions(-) diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index c4b972e4c..42c06a831 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -21,168 +21,170 @@ import qualified Hasql.Backend as B findColumn :: [Column] -> Text -> Text -> Text -> Either Text Column findColumn allColumns s t c = note ("no such column: "<>t<>"."<>c) $ - find (\ col -> colSchema col == s && colTable col == t && colName col == c ) allColumns + find (\ col -> colSchema col == s && colTable col == t && colName col == c ) allColumns findTable :: [Table] -> Text -> Text -> Either Text Table findTable allTables s t = note ("no such table: "<>t) $ - find (\tb-> s == tableSchema tb && t == tableName tb ) allTables + find (\tb-> s == tableSchema tb && t == tableName tb ) allTables findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation findRelation allRelations s t1 t2 = - find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations + find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations filterToCondition :: Text -> [Column] -> Text -> Filter -> Either Text Condition filterToCondition schema allColumns table (Filter fld op val) = - Condition <$> c <*> pure op <*> pure (VText (pack val)) - where - c = (,) <$> column <*> pure (snd fld) - column = findColumn allColumns schema table $ pack $ fst fld + Condition <$> c <*> pure op <*> pure (VText (pack val)) + where + c = (,) <$> column <*> pure (snd fld) + column = findColumn allColumns schema table $ pack $ fst fld requestNodeToQuery ::Text -> [Table] -> [Column] -> RequestNode -> Either Text Query requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs ord) = - Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel <*> pure ord - where - tblName = pack tblNameS - mainTable = findTable allTables schema tblName - select = mapM toDbSelectItem flds --besides specific columns, we allow * here also - where - -- it's ok not to check that the table exists here, mainTable will do the checking - toDbSelectItem :: SelectItem -> Either Text DbSelectItem - toDbSelectItem (("*", Nothing), Nothing) = Right ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing) - toDbSelectItem ((c,jp), cast) = (,) <$> dbFld <*> pure cast - where - col = findColumn allColumns schema tblName $ pack c - dbFld = (,) <$> col <*> pure jp + Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel <*> pure ord + where + tblName = pack tblNameS + mainTable = findTable allTables schema tblName + select = mapM toDbSelectItem flds --besides specific columns, we allow * here also + where + -- it's ok not to check that the table exists here, mainTable will do the checking + toDbSelectItem :: SelectItem -> Either Text DbSelectItem + toDbSelectItem (("*", Nothing), Nothing) = Right ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing) + toDbSelectItem ((c,jp), cast) = (,) <$> dbFld <*> pure cast + where + col = findColumn allColumns schema tblName $ pack c + dbFld = (,) <$> col <*> pure jp - qwhere = mapM (filterToCondition schema allColumns tblName) fltrs - joinTables = pure [] - rel = pure Nothing + qwhere = mapM (filterToCondition schema allColumns tblName) fltrs + joinTables = pure [] + rel = pure Nothing addRelations :: [Relation] -> Maybe DbRequest -> DbRequest -> Either Text DbRequest addRelations allRelations parentNode node@(Node query@(Select {qMainTable=table}) forest) = - case parentNode of - Nothing -> Node query{qRelation=Nothing} <$> updatedForest - (Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest - where - rel = note ("no relation between " <> tableName table <> " and " <> tableName parentTable) $ - findRelation allRelations (tableSchema table) (tableName table) (tableName parentTable) - addRel :: Query -> Relation -> Query - addRel q r = q{qRelation = Just r} - where - updatedForest = mapM (addRelations allRelations (Just node)) forest + case parentNode of + Nothing -> Node query{qRelation=Nothing} <$> updatedForest + (Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest + where + rel = note ("no relation between " <> tableName table <> " and " <> tableName parentTable) $ + findRelation allRelations (tableSchema table) (tableName table) (tableName parentTable) + addRel :: Query -> Relation -> Query + addRel q r = q{qRelation = Just r} + where + updatedForest = mapM (addRelations allRelations (Just node)) forest addJoinConditions :: [Column] -> Tree Query -> Either Text DbRequest addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = - case relation of - Nothing -> Node <$> updatedQuery <*> updatedForest -- this is the root node - Just rel@(Relation{relType="child"}) -> Node <$> (addCond <$> updatedQuery <*> getJoinCondition rel) <*> updatedForest - Just (Relation{relType="parent"}) -> Node <$> updatedQuery <*> updatedForest - -- Just (Many relationColumn1 relationColumn2) -> Node <$> pure updatedQuery{qJoinTables=linkTable:qJoinTables updatedQuery, qWhere=cond1:cond2:qWhere updatedQuery} <*> updatedForest - -- where - -- cond1 = getJoinCondition relationColumn1 - -- cond2 = getJoinCondition relationColumn2 - -- linkTable = Table "public" (colTable relationColumn1) True - _ -> Left "unknow relation" - where - -- add parentTable and parentJoinConditions to the query - updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ qJoinTables query}) <$> parentJoinConditions - where - parentJoinConditions = mapM (getJoinCondition.snd) parents - parentTables = map fst parents - parents = mapMaybe (getParents.rootLabel) forest - getParents qq@(Select{qRelation=(Just rel@(Relation{relType="parent"}))}) = Just (qMainTable qq, rel) - getParents _ = Nothing - updatedForest = mapM (addJoinConditions allColumns) forest - getJoinCondition rel@(Relation s t c _ _ _) = Condition <$> cc <*> pure "=" <*> pure (VForeignKey rel) - where - col = findColumn allColumns s t c - cc = (,) <$> col <*> pure Nothing - addCond q con = q{qWhere=con:qWhere q} + case relation of + Nothing -> Node <$> updatedQuery <*> updatedForest -- this is the root node + Just rel@(Relation{relType="child"}) -> Node <$> (addCond <$> updatedQuery <*> getJoinCondition rel) <*> updatedForest + Just (Relation{relType="parent"}) -> Node <$> updatedQuery <*> updatedForest + -- Just (Many relationColumn1 relationColumn2) -> Node <$> pure updatedQuery{qJoinTables=linkTable:qJoinTables updatedQuery, qWhere=cond1:cond2:qWhere updatedQuery} <*> updatedForest + -- where + -- cond1 = getJoinCondition relationColumn1 + -- cond2 = getJoinCondition relationColumn2 + -- linkTable = Table "public" (colTable relationColumn1) True + _ -> Left "unknow relation" + where + -- add parentTable and parentJoinConditions to the query + updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ qJoinTables query}) <$> parentJoinConditions + where + parentJoinConditions = mapM (getJoinCondition.snd) parents + parentTables = map fst parents + parents = mapMaybe (getParents.rootLabel) forest + getParents qq@(Select{qRelation=(Just rel@(Relation{relType="parent"}))}) = Just (qMainTable qq, rel) + getParents _ = Nothing + updatedForest = mapM (addJoinConditions allColumns) forest + getJoinCondition rel@(Relation s t c _ _ _) = Condition <$> cc <*> pure "=" <*> pure (VForeignKey rel) + where + col = findColumn allColumns s t c + cc = (,) <$> col <*> pure Nothing + addCond q con = q{qWhere=con:qWhere q} dbRequestToCountQuery :: DbRequest -> PStmt dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) _) = - B.Stmt query V.empty True - where - query = Data.Text.unwords [ - "SELECT pg_catalog.count(1)", - "FROM ", pgFmtTable mainTable, - ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions - ] - emptyOnNull val x = if null x then "" else val + B.Stmt query V.empty True + where + query = Data.Text.unwords [ + "SELECT pg_catalog.count(1)", + "FROM ", pgFmtTable mainTable, + ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions + ] + emptyOnNull val x = if null x then "" else val dbRequestToQuery :: DbRequest -> PStmt dbRequestToQuery (Node (Select mainTable colSelects tbls conditions _ ord) forest) = - orderT (fromMaybe [] ord) query - -- case relation of - -- Nothing ->B.Stmt ("SELECT " - -- <> "(" - -- <> dbRequestToCountQuery r - -- <> ")," - -- <> "pg_catalog.count(t)," - -- <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " - -- <> "FROM (" - -- <> query - -- <> ") t;" - -- ) V.empty True - -- - -- _ -> B.Stmt query V.empty True - where + orderT (fromMaybe [] ord) query + -- case relation of + -- Nothing ->B.Stmt ("SELECT " + -- <> "(" + -- <> dbRequestToCountQuery r + -- <> ")," + -- <> "pg_catalog.count(t)," + -- <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " + -- <> "FROM (" + -- <> query + -- <> ") t;" + -- ) V.empty True + -- + -- _ -> B.Stmt query V.empty True + where - query = B.Stmt qStr V.empty True - qStr = Data.Text.unwords [ - ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, - "SELECT ", intercalate ", " (map selectItemToStr colSelects ++ selects), - "FROM ", intercalate ", " (map pgFmtTable (mainTable:tbls)), - ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions - ] - emptyOnNull val x = if null x then "" else val - (withs, selects) = foldr getQueryParts ([],[]) forest - --getQueryParts is not total but dbRequestToQuery is called only after addJoinConditions which ensures the only - --posible relations are Child Parent Many - getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text]) - getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation {relType="child"}))}) forst) (w,s) = (w,sel:s) - where name = tableName table - sel = "(" - <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " - <> "FROM (" <> subquery <> ") " <> name - <> ") AS " <> name - where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) + query = B.Stmt qStr V.empty True + qStr = Data.Text.unwords [ + ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, + "SELECT ", intercalate ", " (map selectItemToStr colSelects ++ selects), + "FROM ", intercalate ", " (map pgFmtTable (mainTable:tbls)), + ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions + ] + emptyOnNull val x = if null x then "" else val + (withs, selects) = foldr getQueryParts ([],[]) forest + --getQueryParts is not total but dbRequestToQuery is called only after addJoinConditions which ensures the only + --posible relations are Child Parent Many + getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text]) + getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation {relType="child"}))}) forst) (w,s) = (w,sel:s) + where + name = tableName table + sel = "(" + <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " + <> "FROM (" <> subquery <> ") " <> name + <> ") AS " <> name + where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) - getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s) - where name = tableName table - sel = "row_to_json(" <> name <> ".*) AS "<>name --TODO must be singular - wit = name <> " AS ( " <> subquery <> " )" - where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) - -- getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Many _ _))}) forst) (w,s) = (w,sel:s) - -- where name = tableName table - -- sel = "(" - -- <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " - -- <> "FROM (" <> dbRequestToQuery (Node q forst) <> ") " <> name - -- <> ") AS " <> name - -- the following is just to remove the warning, maybe relType should not be String? - getQueryParts (Node (Select{qRelation=Nothing}) _) _ = undefined - getQueryParts (Node (Select{qRelation=(Just (Relation {relType=_}))}) _) _ = undefined + getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s) + where + name = tableName table + sel = "row_to_json(" <> name <> ".*) AS "<>name --TODO must be singular + wit = name <> " AS ( " <> subquery <> " )" + where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) + -- getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Many _ _))}) forst) (w,s) = (w,sel:s) + -- where name = tableName table + -- sel = "(" + -- <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " + -- <> "FROM (" <> dbRequestToQuery (Node q forst) <> ") " <> name + -- <> ") AS " <> name + -- the following is just to remove the warning, maybe relType should not be String? + getQueryParts (Node (Select{qRelation=Nothing}) _) _ = undefined + getQueryParts (Node (Select{qRelation=(Just (Relation {relType=_}))}) _) _ = undefined pgFmtCondition :: Condition -> Text pgFmtCondition (Condition (col,jp) ops val) = - notOp <> " " <> pgFmtColumn col <> pgFmtJsonPath jp <> " " <> pgFmtOperator opCode <> " " <> - if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue - where - headPredicate:rest = split (=='.') $ pack ops - hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse - opCode = hasNot (head rest) headPredicate - notOp = hasNot headPredicate "" - sqlValue = valToStr val - getInner v = case v of - VText s -> s - _ -> "" - valToStr v = case v of - VText s -> pgFmtValue opCode s - VForeignKey (Relation{relFTable=table, relFColumn=column}) -> table <> "." <> column + notOp <> " " <> pgFmtColumn col <> pgFmtJsonPath jp <> " " <> pgFmtOperator opCode <> " " <> + if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue + where + headPredicate:rest = split (=='.') $ pack ops + hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse + opCode = hasNot (head rest) headPredicate + notOp = hasNot headPredicate "" + sqlValue = valToStr val + getInner v = case v of + VText s -> s + _ -> "" + valToStr v = case v of + VText s -> pgFmtValue opCode s + VForeignKey (Relation{relFTable=table, relFColumn=column}) -> table <> "." <> column pgFmtColumn :: Column -> Text pgFmtColumn Column {colSchema=s, colTable=t, colName=c} = pgFmtIdent s <> "." <> pgFmtIdent t <> "." <> pgFmtIdent c diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 889fb2920..b80b0cba4 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -15,53 +15,53 @@ import PostgREST.Types import Text.ParserCombinators.Parsec hiding (many, (<|>)) parseGetRequest :: Request -> Either ParseError ApiRequest parseGetRequest httpRequest = - foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts - where - apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select ("++selectStr++")") $ cs selectStr - addOrder (Node r f) o = Node r{order=o} f - flts = mapM pRequestFilter whereFilters - rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head - qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] - orderStr = join $ lookup "order" qString - ord = traverse (parse pOrder ("failed to parse order ("++fromMaybe "" orderStr++")")) orderStr - selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * - whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] + foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts + where + apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select ("++selectStr++")") $ cs selectStr + addOrder (Node r f) o = Node r{order=o} f + flts = mapM pRequestFilter whereFilters + rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head + qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] + orderStr = join $ lookup "order" qString + ord = traverse (parse pOrder ("failed to parse order ("++fromMaybe "" orderStr++")")) orderStr + selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * + whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] pRequestSelect :: String -> Parser ApiRequest pRequestSelect rootNodeName = do - fieldTree <- pFieldForest - return $ foldr treeEntry (Node (RequestNode rootNodeName [] [] Nothing) []) fieldTree - where - treeEntry :: Tree SelectItem -> Tree RequestNode -> Tree RequestNode - treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) = - case fldForest of - [] -> Node (rNode {fields=fld:fields rNode}) rForest - _ -> Node rNode (foldr treeEntry (Node (RequestNode fn [] [] Nothing) []) fldForest:rForest) + fieldTree <- pFieldForest + return $ foldr treeEntry (Node (RequestNode rootNodeName [] [] Nothing) []) fieldTree + where + treeEntry :: Tree SelectItem -> Tree RequestNode -> Tree RequestNode + treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) = + case fldForest of + [] -> Node (rNode {fields=fld:fields rNode}) rForest + _ -> Node rNode (foldr treeEntry (Node (RequestNode fn [] [] Nothing) []) fldForest:rForest) pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) - where - treePath = parse pTreePath ("failed to parser tree path ("++k++")") k - opVal = parse pOpValueExp ("failed to parse filter ("++v++")") v - path = fst <$> treePath - fld = snd <$> treePath - op = fst <$> opVal - val = snd <$> opVal + where + treePath = parse pTreePath ("failed to parser tree path ("++k++")") k + opVal = parse pOpValueExp ("failed to parse filter ("++v++")") v + path = fst <$> treePath + fld = snd <$> treePath + op = fst <$> opVal + val = snd <$> opVal addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest addFilter ([], flt) (Node rn@(RequestNode {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest addFilter (path, flt) (Node rn forest) = - case targetNode of - Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path - Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest) - where - targetNodeName:remainingPath = path - (targetNode,restForest) = splitForest targetNodeName forest - splitForest name forst = - case maybeNode of - Nothing -> (Nothing,forest) - Just node -> (Just node, delete node forest) - where maybeNode = find ((name==).nodeName.rootLabel) forst + case targetNode of + Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path + Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest) + where + targetNodeName:remainingPath = path + (targetNode,restForest) = splitForest targetNodeName forest + splitForest name forst = + case maybeNode of + Nothing -> (Nothing,forest) + Just node -> (Just node, delete node forest) + where maybeNode = find ((name==).nodeName.rootLabel) forst ws :: Parser String ws = many (oneOf " \t") @@ -71,9 +71,9 @@ lexeme p = ws *> p <* ws pTreePath :: Parser (Path,Field) pTreePath = do - p <- pFieldName `sepBy1` pDelimiter - jp <- optionMaybe ( string "->" >> pJsonPath) - return (init p, (last p, jp)) + p <- pFieldName `sepBy1` pDelimiter + jp <- optionMaybe ( string "->" >> pJsonPath) + return (init p, (last p, jp)) pFieldForest :: Parser [Tree SelectItem] @@ -81,14 +81,14 @@ pFieldForest = pFieldTree `sepBy1` lexeme (char ',') pFieldTree :: Parser (Tree SelectItem) pFieldTree = try (Node <$> pSelect <*> ( char '(' *> pFieldForest <* char ')')) - <|> Node <$> pSelect <*> pure [] + <|> Node <$> pSelect <*> pure [] pStar :: Parser String pStar = string "*" *> pure "*" pFieldName :: Parser String pFieldName = many1 (letter <|> digit <|> oneOf "_") - "field name (* or [a..z0..9_])" + "field name (* or [a..z0..9_])" pJsonPathDelimiter :: Parser String pJsonPathDelimiter = try (string "->>") <|> string "->" @@ -101,34 +101,34 @@ pField = lexeme $ (,) <$> pFieldName <*> optionMaybe ( pJsonPathDelimiter *> pJ pSelect :: Parser SelectItem pSelect = lexeme $ - try ((,) <$> pField <*> optionMaybe (string "::" *> many letter)) - <|> do - s <- pStar - return ((s, Nothing), Nothing) + try ((,) <$> pField <*> optionMaybe (string "::" *> many letter)) + <|> do + s <- pStar + return ((s, Nothing), Nothing) pOperator :: Parser Operator pOperator = try (string "lte") -- has to be before lt - <|> try (string "lt") - <|> try (string "eq") - <|> try (string "gte") -- has to be before gh - <|> try (string "gt") - <|> try (string "lt") - <|> try (string "neq") - <|> try (string "like") - <|> try (string "ilike") - <|> try (string "in") - <|> try (string "notin") - <|> try (string "is" ) - <|> try (string "isnot") - <|> try (string "@@") - "operator (eq, gt, ...)" + <|> try (string "lt") + <|> try (string "eq") + <|> try (string "gte") -- has to be before gh + <|> try (string "gt") + <|> try (string "lt") + <|> try (string "neq") + <|> try (string "like") + <|> try (string "ilike") + <|> try (string "in") + <|> try (string "notin") + <|> try (string "is" ) + <|> try (string "isnot") + <|> try (string "@@") + "operator (eq, gt, ...)" -- pInt :: Parser Int -- pInt = try (liftA read (many1 digit)) "integer" --pValue :: Parser Value --pValue = (VInt <$> try (pInt <* eof)) --- <|>(VString <$> many anyChar) +-- <|>(VString <$> many anyChar) pValue :: Parser FValue pValue = many anyChar From 2fb5c5187a92626f54ff28c8968c3a827bb2e428 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 25 Sep 2015 15:28:48 +0300 Subject: [PATCH 13/31] deleted some commented code --- src/PostgREST/App.hs | 46 ------------------------------------ src/PostgREST/Functions.hs | 13 ---------- src/PostgREST/PgStructure.hs | 14 ----------- 3 files changed, 73 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 932b5bc94..e9793a65e 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -59,16 +59,6 @@ import Prelude app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response app dbstructure conf reqBody dbrole req = case (path, verb) of - -- ([], _) -> do - -- body <- encode <$> tables (cs schema) - -- return $ responseLBS status200 [jsonH] $ cs body - - -- ([table], "OPTIONS") -> do - -- let qt = qualify table - -- cols <- columns qt - -- pkey <- map cs <$> primaryKeyColumns qt - -- return $ responseLBS status200 [jsonH, allOrigins] - -- $ encode (TableOptions cols pkey) ([], _) -> do let body = encode $ filter (filterTableAcl dbrole) $ filter (((cs schema)==).tableSchema) allTables @@ -96,9 +86,6 @@ app dbstructure conf reqBody dbrole req = ) <> commaq <> ( bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables . limitT range - -- . orderT (orderParse qq) - -- . whereT qt qq - -- $ select qt qq $ qs ) -- return $ responseLBS status200 [contentTypeH] (cs $ show $ B.stmtTemplate q) @@ -135,39 +122,6 @@ app dbstructure conf reqBody dbrole req = queries = (,) <$> query <*> countQuery - -- - -- let qt = qualify table - -- from = fromMaybe 0 $ rangeOffset <$> range - -- query = B.Stmt "select " V.empty True <> - -- parentheticT ( - -- whereT qt qq $ countRows qt - -- ) <> commaq <> ( - -- bodyForAccept contentType qt - -- . limitT range - -- . orderT (orderParse qq) - -- . whereT qt qq - -- $ select qt qq - -- ) - -- row <- H.maybeEx query - -- let (tableTotal, queryTotal, body) = - -- fromMaybe (0, 0, Just "" :: Maybe Text) row - -- to = from+queryTotal-1 - -- contentRange = contentRangeH from to tableTotal - -- status = rangeStatus from to tableTotal - -- canonical = urlEncodeVars - -- . sortBy (comparing fst) - -- . map (join (***) cs) - -- . parseSimpleQuery - -- $ rawQueryString req - -- return $ responseLBS status - -- [contentTypeH, contentRange, - -- ("Content-Location", - -- "/" <> cs table <> - -- if Prelude.null canonical then "" else "?" <> cs canonical - -- ) - -- ] (cs $ fromMaybe "[]" body) - - (["postgrest", "users"], "POST") -> do let user = decode reqBody :: Maybe AuthUser diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index 42c06a831..d109de671 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -117,19 +117,6 @@ dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) _) = dbRequestToQuery :: DbRequest -> PStmt dbRequestToQuery (Node (Select mainTable colSelects tbls conditions _ ord) forest) = orderT (fromMaybe [] ord) query - -- case relation of - -- Nothing ->B.Stmt ("SELECT " - -- <> "(" - -- <> dbRequestToCountQuery r - -- <> ")," - -- <> "pg_catalog.count(t)," - -- <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " - -- <> "FROM (" - -- <> query - -- <> ") t;" - -- ) V.empty True - -- - -- _ -> B.Stmt query V.empty True where query = B.Stmt qStr V.empty True diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index 9cd82e449..54e257ece 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -212,17 +212,3 @@ allprimaryKeys = do ) |] return $ map pkFromRow pks - --- alltablesAcl :: H.Tx P.Postgres s [(Text, Text, Text)] --- alltablesAcl = do --- acl <- H.listEx $ [H.stmt| --- SELECT --- table_schema, --- table_name, --- grantee as role --- FROM information_schema.role_table_grants --- WHERE --- table_schema NOT IN ('pg_catalog', 'information_schema') AND --- privilege_type = 'SELECT' --- |] --- return acl From 3d1736e0d3fc1ac775c0a37940efc82f50ff564c Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 25 Sep 2015 16:33:25 +0300 Subject: [PATCH 14/31] fix for generating count query --- src/PostgREST/Functions.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index d109de671..15e4dabcf 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -6,7 +6,8 @@ where import Control.Error import Data.List (find) import Data.Monoid -import Data.Text hiding (find, foldr, head, last, map, null) +import Data.Text hiding (filter, find, foldr, head, last, map, + null) import Data.Tree import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi, orderT, pgFmtIdent, pgFmtLit, pgFmtOperator, @@ -110,9 +111,13 @@ dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) _) = query = Data.Text.unwords [ "SELECT pg_catalog.count(1)", "FROM ", pgFmtTable mainTable, - ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions + ("WHERE " <> intercalate " AND " ( map pgFmtCondition localConditions )) `emptyOnNull` localConditions ] emptyOnNull val x = if null x then "" else val + localConditions = filter fn conditions + where + fn (Condition{conValue=VText _}) = True + fn (Condition{conValue=VForeignKey _}) = False dbRequestToQuery :: DbRequest -> PStmt dbRequestToQuery (Node (Select mainTable colSelects tbls conditions _ ord) forest) = From db1372413171777e28a1afb011ee21f0e21baa01 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Mon, 28 Sep 2015 10:11:59 +0300 Subject: [PATCH 15/31] moved string packing to parsers --- src/PostgREST/Functions.hs | 20 +++++++++--------- src/PostgREST/Parsers.hs | 42 ++++++++++++++++++++++---------------- src/PostgREST/Types.hs | 14 ++++++------- 3 files changed, 41 insertions(+), 35 deletions(-) diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index 15e4dabcf..afa915950 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -8,6 +8,7 @@ import Data.List (find) import Data.Monoid import Data.Text hiding (filter, find, foldr, head, last, map, null) + import Data.Tree import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi, orderT, pgFmtIdent, pgFmtLit, pgFmtOperator, @@ -35,17 +36,16 @@ findRelation allRelations s t1 t2 = filterToCondition :: Text -> [Column] -> Text -> Filter -> Either Text Condition filterToCondition schema allColumns table (Filter fld op val) = - Condition <$> c <*> pure op <*> pure (VText (pack val)) + Condition <$> c <*> pure op <*> pure (VText val) where c = (,) <$> column <*> pure (snd fld) - column = findColumn allColumns schema table $ pack $ fst fld + column = findColumn allColumns schema table $ fst fld requestNodeToQuery ::Text -> [Table] -> [Column] -> RequestNode -> Either Text Query -requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs ord) = +requestNodeToQuery schema allTables allColumns (RequestNode tblName flds fltrs ord) = Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel <*> pure ord where - tblName = pack tblNameS mainTable = findTable allTables schema tblName select = mapM toDbSelectItem flds --besides specific columns, we allow * here also where @@ -54,7 +54,7 @@ requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs toDbSelectItem (("*", Nothing), Nothing) = Right ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing) toDbSelectItem ((c,jp), cast) = (,) <$> dbFld <*> pure cast where - col = findColumn allColumns schema tblName $ pack c + col = findColumn allColumns schema tblName c dbFld = (,) <$> col <*> pure jp qwhere = mapM (filterToCondition schema allColumns tblName) fltrs @@ -166,7 +166,7 @@ pgFmtCondition (Condition (col,jp) ops val) = notOp <> " " <> pgFmtColumn col <> pgFmtJsonPath jp <> " " <> pgFmtOperator opCode <> " " <> if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue where - headPredicate:rest = split (=='.') $ pack ops + headPredicate:rest = split (=='.') ops hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse opCode = hasNot (head rest) headPredicate notOp = hasNot headPredicate "" @@ -183,8 +183,8 @@ pgFmtColumn Column {colSchema=s, colTable=t, colName=c} = pgFmtIdent s <> "." <> pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*" pgFmtJsonPath :: Maybe JsonPath -> Text -pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit (pack x) -pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit (pack x) <> pgFmtJsonPath ( Just xs ) +pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x +pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs ) pgFmtJsonPath _ = "" pgFmtTable :: Table -> Text @@ -192,8 +192,8 @@ pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n selectItemToStr :: DbSelectItem -> Text selectItemToStr ((c, jp), Nothing) = pgFmtColumn c <> pgFmtJsonPath jp <> asJsonPath jp -selectItemToStr ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn c <> pgFmtJsonPath jp <> " AS " <> pack cast <> " )" <> asJsonPath jp +selectItemToStr ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp asJsonPath :: Maybe JsonPath -> Text asJsonPath Nothing = "" -asJsonPath (Just xx) = " AS " <> pack (last xx) +asJsonPath (Just xx) = " AS " <> last xx diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index e26321e1a..6ad2e59e5 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -8,7 +8,9 @@ import Control.Applicative import Control.Monad (join) import Data.List (delete, find) import Data.Maybe +import Data.Monoid import Data.String.Conversions (cs) +import Data.Text (Text) import Data.Tree import Network.Wai (Request, pathInfo, queryString) import PostgREST.Types @@ -27,7 +29,7 @@ parseGetRequest httpRequest = selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] -pRequestSelect :: String -> Parser ApiRequest +pRequestSelect :: Text -> Parser ApiRequest pRequestSelect rootNodeName = do fieldTree <- pFieldForest return $ foldr treeEntry (Node (RequestNode rootNodeName [] [] Nothing) []) fieldTree @@ -41,8 +43,8 @@ pRequestSelect rootNodeName = do pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) where - treePath = parse pTreePath ("failed to parser tree path ("++k++")") k - opVal = parse pOpValueExp ("failed to parse filter ("++v++")") v + treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k + opVal = parse pOpValueExp ("failed to parse filter (" ++ v ++ ")") v path = fst <$> treePath fld = snd <$> treePath op = fst <$> opVal @@ -63,8 +65,8 @@ addFilter (path, flt) (Node rn forest) = Just node -> (Just node, delete node forest) where maybeNode = find ((name==).nodeName.rootLabel) forst -ws :: Parser String -ws = many (oneOf " \t") +ws :: Parser Text +ws = cs <$> many (oneOf " \t") lexeme :: Parser a -> Parser a lexeme p = ws *> p <* ws @@ -73,7 +75,10 @@ pTreePath :: Parser (Path,Field) pTreePath = do p <- pFieldName `sepBy1` pDelimiter jp <- optionMaybe ( string "->" >> pJsonPath) - return (init p, (last p, jp)) + let pp = map cs p + jpp = map cs <$> jp + return (init pp, (last pp, jpp)) + where pFieldForest :: Parser [Tree SelectItem] @@ -83,17 +88,17 @@ pFieldTree :: Parser (Tree SelectItem) pFieldTree = try (Node <$> pSelect <*> ( char '(' *> pFieldForest <* char ')')) <|> Node <$> pSelect <*> pure [] -pStar :: Parser String -pStar = string "*" *> pure "*" +pStar :: Parser Text +pStar = cs <$> (string "*" *> pure ("*"::String)) -pFieldName :: Parser String -pFieldName = many1 (letter <|> digit <|> oneOf "_") - "field name (* or [a..z0..9_])" +pFieldName :: Parser Text +pFieldName = cs <$> (many1 (letter <|> digit <|> oneOf "_") + "field name (* or [a..z0..9_])") -pJsonPathDelimiter :: Parser String -pJsonPathDelimiter = try (string "->>") <|> string "->" +pJsonPathDelimiter :: Parser Text +pJsonPathDelimiter = cs <$> (try (string "->>") <|> string "->") -pJsonPath :: Parser [String] +pJsonPath :: Parser [Text] pJsonPath = pFieldName `sepBy1` pJsonPathDelimiter pField :: Parser Field @@ -101,13 +106,13 @@ pField = lexeme $ (,) <$> pFieldName <*> optionMaybe ( pJsonPathDelimiter *> pJ pSelect :: Parser SelectItem pSelect = lexeme $ - try ((,) <$> pField <*> optionMaybe (string "::" *> many letter)) + try ((,) <$> pField <*>((cs <$>) <$> optionMaybe (string "::" *> many letter)) ) <|> do s <- pStar return ((s, Nothing), Nothing) pOperator :: Parser Operator -pOperator = try (string "lte") -- has to be before lt +pOperator = cs <$> ( try (string "lte") -- has to be before lt <|> try (string "lt") <|> try (string "eq") <|> try (string "gte") -- has to be before gh @@ -122,6 +127,7 @@ pOperator = try (string "lte") -- has to be before lt <|> try (string "isnot") <|> try (string "@@") "operator (eq, gt, ...)" + ) -- pInt :: Parser Int -- pInt = try (liftA read (many1 digit)) "integer" @@ -130,13 +136,13 @@ pOperator = try (string "lte") -- has to be before lt --pValue = (VInt <$> try (pInt <* eof)) -- <|>(VString <$> many anyChar) pValue :: Parser FValue -pValue = many anyChar +pValue = cs <$> many anyChar pDelimiter :: Parser Char pDelimiter = char '.' "delimiter (.)" pOperatiorWithNegation :: Parser Operator -pOperatiorWithNegation = try ( (++) <$> string "not." <*> pOperator) <|> pOperator +pOperatiorWithNegation = try ( (<>) <$> ( cs <$> string "not." ) <*> pOperator) <|> pOperator pOpValueExp :: Parser (Operator, FValue) pOpValueExp = (,) <$> pOperatiorWithNegation <*> (pDelimiter *> pValue) diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 3321b0e68..901766a58 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -63,17 +63,17 @@ data Relation = Relation { -------- -- Request Types -type Operator = String -type FValue = String +type Operator = Text +type FValue = Text type ApiRequest = Tree RequestNode -type FieldName = String -type JsonPath = [String] +type FieldName = Text +type JsonPath = [Text] type Field = (FieldName, Maybe JsonPath) -type Cast = String +type Cast = Text type SelectItem = (Field, Maybe Cast) -type Path = [String] +type Path = [Text] data RequestNode = RequestNode { - nodeName::String + nodeName::Text , fields::[SelectItem] , filters::[Filter] , order::Maybe [OrderTerm] From 9342cc8c8a56ba53b34e916b9a332815d35fe848 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Mon, 28 Sep 2015 12:06:49 +0300 Subject: [PATCH 16/31] removide duplication from data types (all tests passing) --- src/PostgREST/App.hs | 15 ++-- src/PostgREST/Functions.hs | 144 +++++++++++++++---------------------- src/PostgREST/Parsers.hs | 23 ++++-- src/PostgREST/Types.hs | 26 ++----- 4 files changed, 88 insertions(+), 120 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index d3e414350..afee8f239 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -76,6 +76,7 @@ app dbstructure conf reqBody dbrole req = if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else + -- return $ responseLBS status416 [] $ cs $ show queries case queries of Left e -> return $ responseLBS status200 [("Content-Type", "text/plain")] $ cs e Right (qs, cqs) -> do @@ -114,14 +115,12 @@ app dbstructure conf reqBody dbrole req = where from = fromMaybe 0 $ rangeOffset <$> range - apiRequest = parseGetRequest req - dbRequest = first formatParserError apiRequest - >>= traverse (requestNodeToQuery schema allTables allColumns) - >>= addRelations allRelations Nothing - >>= addJoinConditions allColumns - where formatParserError = pack.show - query = dbRequestToQuery <$> dbRequest - countQuery = dbRequestToCountQuery <$> dbRequest + apiRequest = first formatParserError (parseGetRequest req) + >>= addRelations schema allRelations Nothing + >>= addJoinConditions schema allColumns + where formatParserError = pack.show + query = requestToQuery schema <$> apiRequest + countQuery = requestToCountQuery schema <$> apiRequest queries = (,) <$> query <*> countQuery diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index afa915950..e73a103e2 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -34,53 +34,26 @@ findRelation allRelations s t1 t2 = find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations -filterToCondition :: Text -> [Column] -> Text -> Filter -> Either Text Condition -filterToCondition schema allColumns table (Filter fld op val) = - Condition <$> c <*> pure op <*> pure (VText val) - where - c = (,) <$> column <*> pure (snd fld) - column = findColumn allColumns schema table $ fst fld - - -requestNodeToQuery ::Text -> [Table] -> [Column] -> RequestNode -> Either Text Query -requestNodeToQuery schema allTables allColumns (RequestNode tblName flds fltrs ord) = - Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel <*> pure ord - where - mainTable = findTable allTables schema tblName - select = mapM toDbSelectItem flds --besides specific columns, we allow * here also - where - -- it's ok not to check that the table exists here, mainTable will do the checking - toDbSelectItem :: SelectItem -> Either Text DbSelectItem - toDbSelectItem (("*", Nothing), Nothing) = Right ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing) - toDbSelectItem ((c,jp), cast) = (,) <$> dbFld <*> pure cast - where - col = findColumn allColumns schema tblName c - dbFld = (,) <$> col <*> pure jp - - qwhere = mapM (filterToCondition schema allColumns tblName) fltrs - joinTables = pure [] - rel = pure Nothing - -addRelations :: [Relation] -> Maybe DbRequest -> DbRequest -> Either Text DbRequest -addRelations allRelations parentNode node@(Node query@(Select {qMainTable=table}) forest) = +addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest +addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) = case parentNode of - Nothing -> Node query{qRelation=Nothing} <$> updatedForest - (Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest + Nothing -> Node query{relation=Nothing} <$> updatedForest + (Just (Node (Select{mainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest where - rel = note ("no relation between " <> tableName table <> " and " <> tableName parentTable) $ - findRelation allRelations (tableSchema table) (tableName table) (tableName parentTable) + rel = note ("no relation between " <> table <> " and " <> parentTable) $ + findRelation allRelations schema table parentTable addRel :: Query -> Relation -> Query - addRel q r = q{qRelation = Just r} + addRel q r = q{relation = Just r} where - updatedForest = mapM (addRelations allRelations (Just node)) forest + updatedForest = mapM (addRelations schema allRelations (Just node)) forest -addJoinConditions :: [Column] -> Tree Query -> Either Text DbRequest -addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = - case relation of - Nothing -> Node <$> updatedQuery <*> updatedForest -- this is the root node - Just rel@(Relation{relType="child"}) -> Node <$> (addCond <$> updatedQuery <*> getJoinCondition rel) <*> updatedForest - Just (Relation{relType="parent"}) -> Node <$> updatedQuery <*> updatedForest +addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest +addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) = + case r of + Nothing -> Node updatedQuery <$> updatedForest -- this is the root node + Just rel@(Relation{relType="child"}) -> Node (addCond updatedQuery (getJoinCondition rel)) <$> updatedForest + Just (Relation{relType="parent"}) -> Node updatedQuery <$> updatedForest -- Just (Many relationColumn1 relationColumn2) -> Node <$> pure updatedQuery{qJoinTables=linkTable:qJoinTables updatedQuery, qWhere=cond1:cond2:qWhere updatedQuery} <*> updatedForest -- where -- cond1 = getJoinCondition relationColumn1 @@ -89,81 +62,77 @@ addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = _ -> Left "unknow relation" where -- add parentTable and parentJoinConditions to the query - updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ qJoinTables query}) <$> parentJoinConditions + updatedQuery = foldr (flip addCond) (query{joinTables = parentTables ++ joinTables query}) parentJoinConditions where - parentJoinConditions = mapM (getJoinCondition.snd) parents + parentJoinConditions = map (getJoinCondition.snd) parents parentTables = map fst parents parents = mapMaybe (getParents.rootLabel) forest - getParents qq@(Select{qRelation=(Just rel@(Relation{relType="parent"}))}) = Just (qMainTable qq, rel) + getParents qq@(Select{relation=(Just rel@(Relation{relType="parent"}))}) = Just (mainTable qq, rel) getParents _ = Nothing - updatedForest = mapM (addJoinConditions allColumns) forest - getJoinCondition rel@(Relation s t c _ _ _) = Condition <$> cc <*> pure "=" <*> pure (VForeignKey rel) - where - col = findColumn allColumns s t c - cc = (,) <$> col <*> pure Nothing - addCond q con = q{qWhere=con:qWhere q} + updatedForest = mapM (addJoinConditions schema allColumns) forest + getJoinCondition rel@(Relation _ _ c _ _ _) = Filter (c, Nothing) "=" (VForeignKey rel) + addCond q con = q{filters=con:filters q} -dbRequestToCountQuery :: DbRequest -> PStmt -dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) _) = +requestToCountQuery :: Text -> ApiRequest -> PStmt +requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) = B.Stmt query V.empty True where query = Data.Text.unwords [ "SELECT pg_catalog.count(1)", - "FROM ", pgFmtTable mainTable, - ("WHERE " <> intercalate " AND " ( map pgFmtCondition localConditions )) `emptyOnNull` localConditions + "FROM ", fromQi $ QualifiedIdentifier schema mainTbl, + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions ] emptyOnNull val x = if null x then "" else val localConditions = filter fn conditions where - fn (Condition{conValue=VText _}) = True - fn (Condition{conValue=VForeignKey _}) = False + fn (Filter{value=VText _}) = True + fn (Filter{value=VForeignKey _}) = False -dbRequestToQuery :: DbRequest -> PStmt -dbRequestToQuery (Node (Select mainTable colSelects tbls conditions _ ord) forest) = + +-- main field join filters order rela +requestToQuery :: Text -> ApiRequest -> PStmt +requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) forest) = orderT (fromMaybe [] ord) query where - query = B.Stmt qStr V.empty True qStr = Data.Text.unwords [ ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, - "SELECT ", intercalate ", " (map selectItemToStr colSelects ++ selects), - "FROM ", intercalate ", " (map pgFmtTable (mainTable:tbls)), - ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions + "SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects), + "FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) (mainTbl:tbls)), + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions ] emptyOnNull val x = if null x then "" else val (withs, selects) = foldr getQueryParts ([],[]) forest - --getQueryParts is not total but dbRequestToQuery is called only after addJoinConditions which ensures the only + --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --posible relations are Child Parent Many getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text]) - getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation {relType="child"}))}) forst) (w,s) = (w,sel:s) + getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType="child"}))}) forst) (w,s) = (w,sel:s) where - name = tableName table sel = "(" - <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " - <> "FROM (" <> subquery <> ") " <> name - <> ") AS " <> name - where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) + <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " + <> "FROM (" <> subquery <> ") " <> table + <> ") AS " <> table + where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) - getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s) + getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s) where - name = tableName table - sel = "row_to_json(" <> name <> ".*) AS "<>name --TODO must be singular - wit = name <> " AS ( " <> subquery <> " )" - where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) + sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular + wit = table <> " AS ( " <> subquery <> " )" + where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) -- getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Many _ _))}) forst) (w,s) = (w,sel:s) -- where name = tableName table -- sel = "(" -- <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " - -- <> "FROM (" <> dbRequestToQuery (Node q forst) <> ") " <> name + -- <> "FROM (" <> requestToQuery (Node q forst) <> ") " <> name -- <> ") AS " <> name -- the following is just to remove the warning, maybe relType should not be String? - getQueryParts (Node (Select{qRelation=Nothing}) _) _ = undefined - getQueryParts (Node (Select{qRelation=(Just (Relation {relType=_}))}) _) _ = undefined + getQueryParts (Node (Select{relation=Nothing}) _) _ = undefined + getQueryParts (Node (Select{relation=(Just (Relation {relType=_}))}) _) _ = undefined -pgFmtCondition :: Condition -> Text -pgFmtCondition (Condition (col,jp) ops val) = - notOp <> " " <> pgFmtColumn col <> pgFmtJsonPath jp <> " " <> pgFmtOperator opCode <> " " <> +pgFmtCondition :: QualifiedIdentifier -> Filter -> Text +pgFmtCondition table (Filter (col,jp) ops val) = + notOp <> " " <> pgFmtColumn table col <> pgFmtJsonPath jp <> " " <> pgFmtOperator opCode <> " " <> if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue where headPredicate:rest = split (=='.') ops @@ -176,11 +145,12 @@ pgFmtCondition (Condition (col,jp) ops val) = _ -> "" valToStr v = case v of VText s -> pgFmtValue opCode s - VForeignKey (Relation{relFTable=table, relFColumn=column}) -> table <> "." <> column + VForeignKey (Relation{relSchema=s, relFTable=ft, relFColumn=fc}) -> pgFmtColumn (QualifiedIdentifier s ft) fc -pgFmtColumn :: Column -> Text -pgFmtColumn Column {colSchema=s, colTable=t, colName=c} = pgFmtIdent s <> "." <> pgFmtIdent t <> "." <> pgFmtIdent c -pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*" +pgFmtColumn :: QualifiedIdentifier -> Text -> Text +pgFmtColumn table "*" = fromQi table <> ".*" +pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c +--pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*" pgFmtJsonPath :: Maybe JsonPath -> Text pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x @@ -190,9 +160,9 @@ pgFmtJsonPath _ = "" pgFmtTable :: Table -> Text pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n -selectItemToStr :: DbSelectItem -> Text -selectItemToStr ((c, jp), Nothing) = pgFmtColumn c <> pgFmtJsonPath jp <> asJsonPath jp -selectItemToStr ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp +pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> Text +pgFmtSelectItem table ((c, jp), Nothing) = pgFmtColumn table c <> pgFmtJsonPath jp <> asJsonPath jp +pgFmtSelectItem table ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn table c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp asJsonPath :: Maybe JsonPath -> Text asJsonPath Nothing = "" diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 6ad2e59e5..de88c4a79 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -29,16 +29,27 @@ parseGetRequest httpRequest = selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] +{-- +data Query = Select { + mainTable::Text +, fields::[SelectItem] +, joinTables::[Text] +, filters::[Filter] +, order::Maybe [OrderTerm] +, relation::Maybe Relation +} deriving (Show) + +--} pRequestSelect :: Text -> Parser ApiRequest pRequestSelect rootNodeName = do fieldTree <- pFieldForest - return $ foldr treeEntry (Node (RequestNode rootNodeName [] [] Nothing) []) fieldTree + return $ foldr treeEntry (Node (Select rootNodeName [] [] [] Nothing Nothing) []) fieldTree where - treeEntry :: Tree SelectItem -> Tree RequestNode -> Tree RequestNode + treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) = case fldForest of [] -> Node (rNode {fields=fld:fields rNode}) rForest - _ -> Node rNode (foldr treeEntry (Node (RequestNode fn [] [] Nothing) []) fldForest:rForest) + _ -> Node rNode (foldr treeEntry (Node (Select fn [] [] [] Nothing Nothing) []) fldForest:rForest) pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) @@ -51,7 +62,7 @@ pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) val = snd <$> opVal addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest -addFilter ([], flt) (Node rn@(RequestNode {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest +addFilter ([], flt) (Node rn@(Select {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest addFilter (path, flt) (Node rn forest) = case targetNode of Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path @@ -63,7 +74,7 @@ addFilter (path, flt) (Node rn forest) = case maybeNode of Nothing -> (Nothing,forest) Just node -> (Just node, delete node forest) - where maybeNode = find ((name==).nodeName.rootLabel) forst + where maybeNode = find ((name==).mainTable.rootLabel) forst ws :: Parser Text ws = cs <$> many (oneOf " \t") @@ -136,7 +147,7 @@ pOperator = cs <$> ( try (string "lte") -- has to be before lt --pValue = (VInt <$> try (pInt <* eof)) -- <|>(VString <$> many anyChar) pValue :: Parser FValue -pValue = cs <$> many anyChar +pValue = VText <$> (cs <$> many anyChar) pDelimiter :: Parser Char pDelimiter = char '.' "delimiter (.)" diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 901766a58..76304002d 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -22,7 +22,7 @@ data Table = Table { data ForeignKey = ForeignKey { fkTable::Text, fkCol::Text -} deriving (Eq, Show) +} deriving (Show) data Column = Column { @@ -64,36 +64,24 @@ data Relation = Relation { -------- -- Request Types type Operator = Text -type FValue = Text -type ApiRequest = Tree RequestNode +data FValue = VText Text | VForeignKey Relation deriving (Show, Eq) type FieldName = Text type JsonPath = [Text] type Field = (FieldName, Maybe JsonPath) type Cast = Text type SelectItem = (Field, Maybe Cast) type Path = [Text] -data RequestNode = RequestNode { - nodeName::Text +data Query = Select { + mainTable::Text , fields::[SelectItem] +, joinTables::[Text] , filters::[Filter] , order::Maybe [OrderTerm] +, relation::Maybe Relation } deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) +type ApiRequest = Tree Query --- Db Request Types -type DbField = (Column, Maybe JsonPath) -type DbSelectItem = (DbField, Maybe Cast) -data DbValue = VText Text | VForeignKey Relation deriving (Show) -data Condition = Condition {conColumn::DbField, conOperator::Operator, conValue::DbValue} deriving (Show) -data Query = Select { - qMainTable::Table -, qSelect::[DbSelectItem] -, qJoinTables::[Table] -, qWhere::[Condition] -, qRelation::Maybe Relation -, qOrder::Maybe [OrderTerm] -} deriving (Show) -type DbRequest = Tree Query instance ToJSON Column where toJSON c = object [ From edff915f9ee19b79811d64400d39c9c529e738bb Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Mon, 28 Sep 2015 13:41:45 +0300 Subject: [PATCH 17/31] delete unused functions --- src/PostgREST/PgQuery.hs | 55 +--------------------------------------- 1 file changed, 1 insertion(+), 54 deletions(-) diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs index 0d8b08c82..4fb81dac0 100644 --- a/src/PostgREST/PgQuery.hs +++ b/src/PostgREST/PgQuery.hs @@ -18,7 +18,7 @@ import qualified Data.ByteString.Char8 as BS import Data.Functor import qualified Data.HashMap.Strict as H import qualified Data.List as L -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe) import Data.Monoid import Data.Scientific (FPFormat (..), formatScientific, isInteger) @@ -130,36 +130,6 @@ withCount s = s { B.stmtTemplate = "pg_catalog.count(t), " <> B.stmtTemplate s } asJsonRow :: StatementT asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" } -selectStar :: QualifiedIdentifier -> PStmt -selectStar t = B.Stmt ("select * from " <> fromQi t) empty True - -select :: QualifiedIdentifier -> Net.Query -> PStmt -select table params = - if L.null cols - then selectStar table - else B.Stmt "select " empty True <> conjunction <> B.Stmt (" from " <> fromQi table ) empty True - where - selectTermTable = selectTerm table - conjunction = mconcat $ L.intersperse commaq (map selectTermTable cols) - columnsParam = fromMaybe "" $ join (lookup "select" params) - cols = filter ((>0) . T.length) $ map T.strip $ T.split (==',') $ cs columnsParam - -selectTerm :: QualifiedIdentifier -> T.Text -> PStmt -selectTerm table col = - case T.splitOn "::" col of - [colName,castTo] -> - B.Stmt ( - "CAST (" <> pgFmtJsonbPath table (cs colName) <> " AS " - <> castToSafe <> " )" <> asT (jsonbPath colName) - ) empty True - where castToSafe = T.filter ( `elem` ['a'..'z'] ) castTo - _ -> B.Stmt (pgFmtJsonbPath table (cs col) <> asT (jsonbPath col)) empty True - where - jsonbPath :: T.Text -> Maybe JsonbPath - jsonbPath c = parseJsonbPath $ cs c - asT (Just (DoubleArrow _ (KeyIdentifier key))) = " AS " <> pgFmtIdent key - asT _ = "" - returningStarT :: StatementT returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" } @@ -264,29 +234,6 @@ pgFmtOperator opCode = "@@" -> "@@" _ -> "=" - -orderParse :: Net.Query -> [OrderTerm] -orderParse q = - mapMaybe orderParseTerm . T.split (==',') $ cs order - where - order = fromMaybe "" $ join (lookup "order" q) - -orderParseTerm :: T.Text -> Maybe OrderTerm -orderParseTerm s = - case T.split (=='.') s of - (c:d:nls) -> - if d `elem` ["asc", "desc"] - then Just $ OrderTerm c - ( if d == "asc" then "asc" else "desc" ) - ( case nls of - [n] -> if | n == "nullsfirst" -> Just "nulls first" - | n == "nullslast" -> Just "nulls last" - | otherwise -> Nothing - _ -> Nothing - ) - else Nothing - _ -> Nothing - commaq :: PStmt commaq = B.Stmt ", " empty True From bcf3bf558665bf15784b9d8246bfd52948fcdfe7 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Mon, 28 Sep 2015 15:53:03 +0300 Subject: [PATCH 18/31] handle many to many relations --- src/PostgREST/Functions.hs | 54 +++++++++++++++++++++++------------- src/PostgREST/PgStructure.hs | 22 +++++++++++---- src/PostgREST/Types.hs | 3 ++ 3 files changed, 54 insertions(+), 25 deletions(-) diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index e73a103e2..eaca079a9 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -16,11 +16,10 @@ import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi, import PostgREST.Types --import qualified Hasql as H --import qualified Hasql.Postgres as P +import Control.Applicative ((<|>)) import qualified Data.Vector as V (empty) import qualified Hasql.Backend as B - - findColumn :: [Column] -> Text -> Text -> Text -> Either Text Column findColumn allColumns s t c = note ("no such column: "<>t<>"."<>c) $ find (\ col -> colSchema col == s && colTable col == t && colName col == c ) allColumns @@ -40,8 +39,9 @@ addRelations schema allRelations parentNode node@(Node query@(Select {mainTable= Nothing -> Node query{relation=Nothing} <$> updatedForest (Just (Node (Select{mainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest where - rel = note ("no relation between " <> table <> " and " <> parentTable) $ - findRelation allRelations schema table parentTable + rel = note ("no relation between " <> table <> " and " <> parentTable) + $ findRelation allRelations schema table parentTable + <|> findRelation allRelations schema parentTable table addRel :: Query -> Relation -> Query addRel q r = q{relation = Just r} where @@ -52,26 +52,34 @@ addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) = case r of Nothing -> Node updatedQuery <$> updatedForest -- this is the root node - Just rel@(Relation{relType="child"}) -> Node (addCond updatedQuery (getJoinCondition rel)) <$> updatedForest + Just rel@(Relation{relType="child"}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest Just (Relation{relType="parent"}) -> Node updatedQuery <$> updatedForest - -- Just (Many relationColumn1 relationColumn2) -> Node <$> pure updatedQuery{qJoinTables=linkTable:qJoinTables updatedQuery, qWhere=cond1:cond2:qWhere updatedQuery} <*> updatedForest - -- where - -- cond1 = getJoinCondition relationColumn1 - -- cond2 = getJoinCondition relationColumn2 - -- linkTable = Table "public" (colTable relationColumn1) True + Just rel@(Relation{relType="many", relLTable=(Just linkTable)}) -> + Node <$> pure qq <*> updatedForest + where + q = addCond updatedQuery (getJoinConditions rel) + qq = q{joinTables=linkTable:joinTables q} _ -> Left "unknow relation" where -- add parentTable and parentJoinConditions to the query updatedQuery = foldr (flip addCond) (query{joinTables = parentTables ++ joinTables query}) parentJoinConditions where - parentJoinConditions = map (getJoinCondition.snd) parents + parentJoinConditions = map (getJoinConditions.snd) parents parentTables = map fst parents parents = mapMaybe (getParents.rootLabel) forest getParents qq@(Select{relation=(Just rel@(Relation{relType="parent"}))}) = Just (mainTable qq, rel) getParents _ = Nothing updatedForest = mapM (addJoinConditions schema allColumns) forest - getJoinCondition rel@(Relation _ _ c _ _ _) = Filter (c, Nothing) "=" (VForeignKey rel) - addCond q con = q{filters=con:filters q} + getJoinConditions :: Relation -> [Filter] + getJoinConditions rel@(Relation _ _ c _ _ "child" _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)] + getJoinConditions rel@(Relation _ _ c _ _ "parent" _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)] + getJoinConditions (Relation s t c ft fc "many" (Just lt) (Just lc1) (Just lc2)) = + [ + Filter (c, Nothing) "=" (VForeignKey (Relation s t c lt lc1 "child" Nothing Nothing Nothing)), + Filter (fc, Nothing) "=" (VForeignKey (Relation s ft fc lt lc2 "child" Nothing Nothing Nothing)) + ] + getJoinConditions _ = [] + addCond q con = q{filters=con ++ filters q} requestToCountQuery :: Text -> ApiRequest -> PStmt @@ -120,25 +128,31 @@ requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) fo sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular wit = table <> " AS ( " <> subquery <> " )" where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) - -- getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Many _ _))}) forst) (w,s) = (w,sel:s) - -- where name = tableName table - -- sel = "(" - -- <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " - -- <> "FROM (" <> requestToQuery (Node q forst) <> ") " <> name - -- <> ") AS " <> name + + getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType="many"}))}) forst) (w,s) = (w,sel:s) + where + sel = "(" + <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " + <> "FROM (" <> subquery <> ") " <> table + <> ") AS " <> table + where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) + -- the following is just to remove the warning, maybe relType should not be String? getQueryParts (Node (Select{relation=Nothing}) _) _ = undefined getQueryParts (Node (Select{relation=(Just (Relation {relType=_}))}) _) _ = undefined pgFmtCondition :: QualifiedIdentifier -> Filter -> Text pgFmtCondition table (Filter (col,jp) ops val) = - notOp <> " " <> pgFmtColumn table col <> pgFmtJsonPath jp <> " " <> pgFmtOperator opCode <> " " <> + notOp <> " " <> sqlCol <> " " <> pgFmtOperator opCode <> " " <> if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue where headPredicate:rest = split (=='.') ops hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse opCode = hasNot (head rest) headPredicate notOp = hasNot headPredicate "" + sqlCol = case val of + VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp + VForeignKey (Relation s t c _ _ _ _ _ _) -> pgFmtColumn (QualifiedIdentifier s t) c sqlValue = valToStr val getInner v = case v of VText s -> s diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index 54e257ece..6ea26f260 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -14,7 +14,8 @@ import PostgREST.Types import Data.Functor.Identity --import Data.String.Conversions (cs) import Control.Applicative -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Monoid --import qualified Data.Map as Map @@ -22,6 +23,7 @@ import qualified Hasql as H import qualified Hasql.Postgres as P import Prelude +import GHC.Exts (groupWith) doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool @@ -60,14 +62,14 @@ columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) = relationFromRow :: (Text, Text, Text, Text, Text) -> Relation -relationFromRow (s, t, c, ft, fc) = Relation s t c ft fc "child" +relationFromRow (s, t, c, ft, fc) = Relation s t c ft fc "child" Nothing Nothing Nothing pkFromRow :: (Text, Text, Text) -> PrimaryKey pkFromRow (s, t, n) = PrimaryKey s t n -addFlippedRelation :: Relation -> [Relation] -> [Relation] -addFlippedRelation rel@(Relation s t c ft fc _) rels = Relation s ft fc t c "parent":rel:rels +addParentRelation :: Relation -> [Relation] -> [Relation] +addParentRelation rel@(Relation s t c ft fc _ _ _ _) rels = Relation s ft fc t c "parent" Nothing Nothing Nothing:rel:rels alltables :: H.Tx P.Postgres s [Table] alltables = do @@ -130,7 +132,17 @@ allrelations = do ) |] - return $ foldr (addFlippedRelation.relationFromRow) [] rels + let simpleRelations = foldr (addParentRelation.relationFromRow) [] rels + let links = filter ((==2).length) $ groupWith groupFn $ filter ( (=="child"). relType) simpleRelations + return $ simpleRelations ++ mapMaybe link2Relation links + where + groupFn :: Relation -> Text + groupFn (Relation{relSchema=s, relTable=t}) = s<>"_"<>t + link2Relation [ + Relation{relSchema=sc, relTable=lt, relColumn=lc1, relFTable=t, relFColumn=c}, + Relation{ relColumn=lc2, relFTable=ft, relFColumn=fc} + ] = Just $ Relation sc t c ft fc "many" (Just lt) (Just lc1) (Just lc2) + link2Relation _ = Nothing allcolumns :: [Relation] -> H.Tx P.Postgres s [Column] allcolumns rels = do diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 76304002d..8c333d7b2 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -58,6 +58,9 @@ data Relation = Relation { , relFTable :: Text , relFColumn :: Text , relType :: Text +, relLTable :: Maybe Text +, relLCol1 :: Maybe Text +, relLCol2 :: Maybe Text } deriving (Show, Eq) From dbf3d5809b50a7d17a4a38348a4f97a3d2b2de8a Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Mon, 28 Sep 2015 16:23:57 +0300 Subject: [PATCH 19/31] add bifunctors to cabal config --- postgrest.cabal | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/postgrest.cabal b/postgrest.cabal index 65b126e26..d2ec20d6a 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -54,6 +54,7 @@ executable postgrest , jwt , parsec , errors + , bifunctors hs-source-dirs: src library @@ -92,6 +93,8 @@ library , jwt , parsec , errors + , bifunctors + Exposed-Modules: PostgREST.App , PostgREST.Types , PostgREST.Parsers @@ -160,3 +163,4 @@ Test-Suite spec , jwt , parsec , errors + , bifunctors From 68c7f45be121f50d0467092285c97f09dcd3f329 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Mon, 28 Sep 2015 16:40:22 +0300 Subject: [PATCH 20/31] trying to make it work with ghc 7.8 --- src/PostgREST/Parsers.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index de88c4a79..78e0d9afa 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -4,7 +4,8 @@ module PostgREST.Parsers -- ) where -import Control.Applicative +import Control.Applicative hiding ((<$>)) +import Data.Functor ((<$>)) import Control.Monad (join) import Data.List (delete, find) import Data.Maybe From a4a2c8b8867ee3ce4e62182ad7a8a6979133b3f3 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Mon, 28 Sep 2015 16:46:33 +0300 Subject: [PATCH 21/31] trying to make it work with ghc 7.8 (2) --- src/PostgREST/Functions.hs | 4 ++-- src/PostgREST/Parsers.hs | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index eaca079a9..2338d7ad9 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -8,7 +8,7 @@ import Data.List (find) import Data.Monoid import Data.Text hiding (filter, find, foldr, head, last, map, null) - +import Control.Applicative import Data.Tree import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi, orderT, pgFmtIdent, pgFmtLit, pgFmtOperator, @@ -16,7 +16,7 @@ import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi, import PostgREST.Types --import qualified Hasql as H --import qualified Hasql.Postgres as P -import Control.Applicative ((<|>)) +--import Control.Applicative ((<|>)) import qualified Data.Vector as V (empty) import qualified Hasql.Backend as B diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 78e0d9afa..794b94e7a 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -6,6 +6,8 @@ where import Control.Applicative hiding ((<$>)) import Data.Functor ((<$>)) +import Data.Traversable (traverse) + import Control.Monad (join) import Data.List (delete, find) import Data.Maybe From 1da26cac98455568a4cc6b505caee4d110682a1b Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Mon, 28 Sep 2015 16:54:34 +0300 Subject: [PATCH 22/31] trying to make it work with ghc 7.8 (3) --- src/PostgREST/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 7af30e22e..f4d5c4787 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -91,7 +91,7 @@ main = do -- read the structure of the database -- read the structure of the database - let txParam = (Just (H.ReadCommitted, Just True)) + let txParam = Just (H.ReadCommitted, Just True) tblsRes <- H.session pool $ H.tx txParam alltables let allTables = either (fail . show) id tblsRes From 94b1d2815c5ed9f195c62776cf12d6b74fa6dce6 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Tue, 29 Sep 2015 11:40:33 +0300 Subject: [PATCH 23/31] small changes suggested by @diogob --- postgrest.cabal | 4 ++-- src/PostgREST/App.hs | 4 ++-- src/PostgREST/Auth.hs | 3 --- src/PostgREST/Main.hs | 2 -- src/PostgREST/Parsers.hs | 5 ++--- src/PostgREST/PgStructure.hs | 4 ---- src/PostgREST/{Functions.hs => QueryBuilder.hs} | 3 +-- 7 files changed, 7 insertions(+), 18 deletions(-) rename src/PostgREST/{Functions.hs => QueryBuilder.hs} (99%) diff --git a/postgrest.cabal b/postgrest.cabal index d2ec20d6a..e04d4a65e 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -98,7 +98,7 @@ library Exposed-Modules: PostgREST.App , PostgREST.Types , PostgREST.Parsers - , PostgREST.Functions + , PostgREST.QueryBuilder , PostgREST.Auth , PostgREST.Config , PostgREST.Error @@ -121,7 +121,7 @@ Test-Suite spec Other-Modules: PostgREST.App , PostgREST.Types , PostgREST.Parsers - , PostgREST.Functions + , PostgREST.QueryBuilder , PostgREST.Auth , PostgREST.Config , PostgREST.Error diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index afee8f239..487581e17 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -52,7 +52,7 @@ import PostgREST.PgQuery import PostgREST.RangeQuery import PostgREST.PgStructure import PostgREST.Parsers -import PostgREST.Functions +import PostgREST.QueryBuilder import Prelude @@ -78,7 +78,7 @@ app dbstructure conf reqBody dbrole req = else -- return $ responseLBS status416 [] $ cs $ show queries case queries of - Left e -> return $ responseLBS status200 [("Content-Type", "text/plain")] $ cs e + Left e -> return $ responseLBS status400 [("Content-Type", "text/plain")] $ cs e Right (qs, cqs) -> do let qt = qualify table count = if hasPrefer "count=none" diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 9cd8cf779..2e60448c5 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} module PostgREST.Auth where import Control.Applicative diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index f4d5c4787..b4ba1bc1b 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} module Main where diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 794b94e7a..1e74cdd46 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -1,7 +1,6 @@ ---{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-} module PostgREST.Parsers --- ( parseGetRequest --- ) +( parseGetRequest +) where import Control.Applicative hiding ((<$>)) diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index 6ea26f260..cbe784472 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -1,8 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} module PostgREST.PgStructure where @@ -10,9 +8,7 @@ import Data.List (find) import Data.Text (Text, split) import PostgREST.PgQuery () import PostgREST.Types ---import Data.Aeson import Data.Functor.Identity ---import Data.String.Conversions (cs) import Control.Applicative import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Monoid diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/QueryBuilder.hs similarity index 99% rename from src/PostgREST/Functions.hs rename to src/PostgREST/QueryBuilder.hs index 2338d7ad9..0f7d5fd50 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} -module PostgREST.Functions +module PostgREST.QueryBuilder where From 7f2c39ef94238ae2387ce8a56e025b9caac3c34d Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Tue, 29 Sep 2015 19:16:25 +0300 Subject: [PATCH 24/31] small cleanup suggested by @begriffs --- postgrest.cabal | 3 +- src/PostgREST/App.hs | 88 ++++++++++++++++++++++---------------------- 2 files changed, 46 insertions(+), 45 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index e04d4a65e..bfe278c4a 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -61,8 +61,7 @@ library if flag(ci) ghc-options: -Wall -W -Werror else - -- ghc-options: -Wall -W -O2 - ghc-options: -Wall -W + ghc-options: -Wall -W -O2 default-language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 487581e17..b93e4bc7b 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} module PostgREST.App ( app , sqlError @@ -10,51 +11,52 @@ module PostgREST.App ( ) where -import Control.Monad (join) -import Control.Arrow ((***), second) -import Control.Applicative -import Data.Bifunctor (first) -import Data.Text (Text, pack) -import Data.Maybe (fromMaybe, mapMaybe, isJust, isNothing) -import Text.Regex.TDFA ((=~)) -import Data.Ord (comparing) -import Data.Ranged.Ranges (emptyRange) -import qualified Data.HashMap.Strict as M -import Data.String.Conversions (cs) -import Data.CaseInsensitive (original) -import Data.List (sortBy, find) -import Data.Functor.Identity -import qualified Data.Set as S -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Char8 as BS -import qualified Blaze.ByteString.Builder as BB -import qualified Data.Csv as CSV +import qualified Blaze.ByteString.Builder as BB +import Control.Applicative +import Control.Arrow (second, (***)) +import Control.Monad (join) +import Data.Bifunctor (first) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL +import Data.CaseInsensitive (original) +import qualified Data.Csv as CSV +import Data.Functor.Identity +import qualified Data.HashMap.Strict as M +import Data.List (find, sortBy) +import Data.Maybe (fromMaybe, isJust, isNothing, + mapMaybe) +import Data.Ord (comparing) +import Data.Ranged.Ranges (emptyRange) +import qualified Data.Set as S +import Data.String.Conversions (cs) +import Data.Text (Text, pack) +import Text.Regex.TDFA ((=~)) -import Network.HTTP.Types.Status -import Network.HTTP.Types.Header -import Network.HTTP.Types.URI (parseSimpleQuery) -import Network.HTTP.Base (urlEncodeVars) -import Network.Wai -import Network.Wai.Parse (parseHttpAccept) -import Network.Wai.Internal (Response(..)) +import Network.HTTP.Base (urlEncodeVars) +import Network.HTTP.Types.Header +import Network.HTTP.Types.Status +import Network.HTTP.Types.URI (parseSimpleQuery) +import Network.Wai +import Network.Wai.Internal (Response (..)) +import Network.Wai.Parse (parseHttpAccept) -import Data.Aeson -import Data.Monoid -import qualified Data.Vector as V -import qualified Hasql as H -import qualified Hasql.Backend as B -import qualified Hasql.Postgres as P +import Data.Aeson +import Data.Monoid +import qualified Data.Vector as V +import qualified Hasql as H +import qualified Hasql.Backend as B +import qualified Hasql.Postgres as P -import PostgREST.Types -import PostgREST.Config (AppConfig(..)) -import PostgREST.Auth -import PostgREST.PgQuery -import PostgREST.RangeQuery -import PostgREST.PgStructure -import PostgREST.Parsers -import PostgREST.QueryBuilder +import PostgREST.Auth +import PostgREST.Config (AppConfig (..)) +import PostgREST.Parsers +import PostgREST.PgQuery +import PostgREST.PgStructure +import PostgREST.QueryBuilder +import PostgREST.RangeQuery +import PostgREST.Types -import Prelude +import Prelude app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response app dbstructure conf reqBody dbrole req = @@ -402,7 +404,7 @@ multipart s rs = data TableOptions = TableOptions { tblOptcolumns :: [Column] -, tblOptpkey :: [Text] +, tblOptpkey :: [Text] } instance ToJSON TableOptions where From 812135d1e5c9f1b1037e283f90e2c58b3a2d7cfa Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Thu, 1 Oct 2015 10:30:41 +0300 Subject: [PATCH 25/31] cleanup suggested by @begriffs --- src/PostgREST/App.hs | 48 +++++++--------- src/PostgREST/Config.hs | 6 +- src/PostgREST/Main.hs | 50 ++++++----------- src/PostgREST/Middleware.hs | 2 - src/PostgREST/Parsers.hs | 18 +----- src/PostgREST/PgStructure.hs | 102 ++++++++++++++++++---------------- src/PostgREST/QueryBuilder.hs | 48 +++++----------- src/PostgREST/Types.hs | 7 +-- test/SpecHelper.hs | 43 ++++++-------- 9 files changed, 127 insertions(+), 197 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index b93e4bc7b..b1f6b3f25 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -29,7 +29,7 @@ import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) import qualified Data.Set as S import Data.String.Conversions (cs) -import Data.Text (Text, pack) +import Data.Text (Text) import Text.Regex.TDFA ((=~)) import Network.HTTP.Base (urlEncodeVars) @@ -63,22 +63,19 @@ app dbstructure conf reqBody dbrole req = case (path, verb) of ([], _) -> do - let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTables + let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTabs return $ responseLBS status200 [jsonH] $ cs body ([table], "OPTIONS") -> do - --let qt = Table schema table - let cols = filter (filterCol schema table) allColumns - let pkeys = map pkName $ filter (filterPk schema table) allPrimaryKeys - let body = encode (TableOptions cols pkeys) + let cols = filter (filterCol schema table) allCols + pkeys = map pkName $ filter (filterPk schema table) allPrKeys + body = encode (TableOptions cols pkeys) return $ responseLBS status200 [jsonH, allOrigins] $ cs body - ([table], "GET") -> if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else - -- return $ responseLBS status416 [] $ cs $ show queries case queries of Left e -> return $ responseLBS status400 [("Content-Type", "text/plain")] $ cs e Right (qs, cqs) -> do @@ -94,7 +91,6 @@ app dbstructure conf reqBody dbrole req = . limitT range $ qs ) - -- return $ responseLBS status200 [contentTypeH] (cs $ show $ B.stmtTemplate q) row <- H.maybeEx q let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe Text) row to = from+queryTotal-1 @@ -105,8 +101,6 @@ app dbstructure conf reqBody dbrole req = . map (join (***) cs) . parseSimpleQuery $ rawQueryString req - - return $ responseLBS status [contentTypeH, contentRange, ("Content-Location", @@ -118,9 +112,9 @@ app dbstructure conf reqBody dbrole req = where from = fromMaybe 0 $ rangeOffset <$> range apiRequest = first formatParserError (parseGetRequest req) - >>= addRelations schema allRelations Nothing - >>= addJoinConditions schema allColumns - where formatParserError = pack.show + >>= addRelations schema allRels Nothing + >>= addJoinConditions schema allCols + where formatParserError = cs.show query = requestToQuery schema <$> apiRequest countQuery = requestToCountQuery schema <$> apiRequest queries = (,) <$> query <*> countQuery @@ -180,9 +174,8 @@ app dbstructure conf reqBody dbrole req = Right toBeInserted -> do rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows - pKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys - --pKeys <- primaryKeyColumns qt - let responses = flip map inserted $ \obj -> do + pKeys = map pkName $ filter (filterPk schema table) allPrKeys + responses = flip map inserted $ \obj -> do let primaries = if Prelude.null pKeys then obj @@ -215,16 +208,14 @@ app dbstructure conf reqBody dbrole req = ([table], "PUT") -> handleJsonObj reqBody $ \obj -> do let qt = qualify table - pKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys - --pKeys <- primaryKeyColumns qt - let specifiedKeys = map (cs . fst) qq + pKeys = map pkName $ filter (filterPk schema table) allPrKeys + specifiedKeys = map (cs . fst) qq if S.fromList pKeys /= S.fromList specifiedKeys then return $ responseLBS status405 [] "You must speficy all and only primary keys as params" else do - --tableCols <- map (cs . colName) <$> columns qt - let tableCols = map (cs . colName) $ filter (filterCol schema table) allColumns - let cols = map cs $ M.keys obj + let tableCols = map (cs . colName) $ filter (filterCol schema table) allCols + cols = map cs $ M.keys obj if S.fromList tableCols == S.fromList cols then do let vals = M.elems obj @@ -274,14 +265,13 @@ app dbstructure conf reqBody dbrole req = return $ responseLBS status404 [] "" where - allTables = tables dbstructure - allRelations = relations dbstructure - allColumns = columns dbstructure - allPrimaryKeys = primaryKeys dbstructure - --allTablesAcl = tablesAcl dbstructure + allTabs = tables dbstructure + allRels = relations dbstructure + allCols = columns dbstructure + allPrKeys = primaryKeys dbstructure filterCol sc table (Column{colSchema=s, colTable=t}) = s==sc && table==t filterCol _ _ _ = False - filterPk sc table (PrimaryKey{pkSchema=s, pkTable=t}) = s==sc && table==t + filterPk sc table pk = sc == pkSchema pk && table == pkTable pk filterTableAcl :: Text -> Table -> Bool filterTableAcl r (Table{tableAcl=a}) = r `elem` a diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 30d6d2a5d..4e2448149 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -29,10 +29,10 @@ data AppConfig = AppConfig { argParser :: Parser AppConfig argParser = AppConfig - <$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> value "skin_test" <> help "name of database") + <$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> help "name of database") <*> option auto (long "db-port" <> short 'P' <> metavar "PORT" <> value 5432 <> help "postgres server port" <> showDefault) - <*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> value "skin_test" <> help "postgres authenticator role") - <*> strOption (long "db-pass" <> metavar "PASS" <> value "skin_pass" <> help "password for authenticator role") + <*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> help "postgres authenticator role") + <*> strOption (long "db-pass" <> metavar "PASS" <> help "password for authenticator role") <*> strOption (long "db-host" <> metavar "HOST" <> value "localhost" <> help "postgres server hostname" <> showDefault) <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "port number on which to run HTTP server" <> showDefault) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index b4ba1bc1b..07460423b 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -2,17 +2,10 @@ module Main where import Paths_postgrest (version) --- added import PostgREST.PgStructure ---import Data.Aeson ---import Data.List (find) ---import Data.Maybe (isJust) import PostgREST.Types ---import Network.HTTP.Types.Status ---import Network.HTTP.Types.Header import Network.Wai - import PostgREST.App import PostgREST.Error (errResponse) import PostgREST.Middleware @@ -87,37 +80,28 @@ main = do fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0" ) supportedOrError - -- read the structure of the database - -- read the structure of the database - let txParam = Just (H.ReadCommitted, Just True) + let txSettings = Just (H.ReadCommitted, Just True) + metadata <- H.session pool $ H.tx txSettings $ do + tabs <- allTables + rels <- allRelations + cols <- allColumns rels + keys <- allPrimaryKeys + return (tabs, rels, cols, keys) - tblsRes <- H.session pool $ H.tx txParam alltables - let allTables = either (fail . show) id tblsRes + dbstructure <- case metadata of + Left e -> fail $ show e + Right (tabs, rels, cols, keys) -> + return $ DbStructure { + tables=tabs + , columns=cols + , relations=rels + , primaryKeys=keys + } - relsRes <- H.session pool $ H.tx txParam allrelations - let allRelations = either (fail . show) id relsRes - - colsRes <- H.session pool $ H.tx txParam $ allcolumns allRelations - let allColumns = either (fail . show) id colsRes - - pkRes <- H.session pool $ H.tx txParam allprimaryKeys - let allPrimaryKeys = either (fail . show) id pkRes - - -- tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl - -- let allTablesAcl = either (fail . show) id tableAclRes - - - let dbstructure = DbStructure { - tables=allTables - , columns=allColumns - , relations=allRelations - , primaryKeys=allPrimaryKeys - --, tablesAcl=allTablesAcl - } runSettings appSettings $ middle $ \ req respond -> do body <- strictRequestBody req - resOrError <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) $ + resOrError <- liftIO $ H.session pool $ H.tx txSettings $ authenticated conf (app dbstructure conf body) req either (respond . errResponse) respond resOrError diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 47ae96389..b2dfee16a 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -6,8 +6,6 @@ module PostgREST.Middleware where import Data.Maybe (fromMaybe, isNothing) import Data.Monoid import Data.Text --- import Data.Pool(withResource, Pool) - import Data.String.Conversions (cs) import qualified Hasql as H import qualified Hasql.Postgres as P diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 1e74cdd46..4cebf0d8f 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -4,6 +4,7 @@ module PostgREST.Parsers where import Control.Applicative hiding ((<$>)) +--lines needed for ghc 7.8 import Data.Functor ((<$>)) import Data.Traversable (traverse) @@ -31,17 +32,6 @@ parseGetRequest httpRequest = selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] -{-- -data Query = Select { - mainTable::Text -, fields::[SelectItem] -, joinTables::[Text] -, filters::[Filter] -, order::Maybe [OrderTerm] -, relation::Maybe Relation -} deriving (Show) - ---} pRequestSelect :: Text -> Parser ApiRequest pRequestSelect rootNodeName = do fieldTree <- pFieldForest @@ -142,12 +132,6 @@ pOperator = cs <$> ( try (string "lte") -- has to be before lt "operator (eq, gt, ...)" ) --- pInt :: Parser Int --- pInt = try (liftA read (many1 digit)) "integer" - ---pValue :: Parser Value ---pValue = (VInt <$> try (pInt <* eof)) --- <|>(VString <$> many anyChar) pValue :: Parser FValue pValue = VText <$> (cs <$> many anyChar) diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index cbe784472..3d4f7f0c1 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -1,25 +1,23 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} module PostgREST.PgStructure where -import Data.List (find) -import Data.Text (Text, split) -import PostgREST.PgQuery () -import PostgREST.Types -import Data.Functor.Identity import Control.Applicative +import Data.Functor.Identity +import Data.List (find) import Data.Maybe (fromMaybe, isJust, mapMaybe) -import Data.Monoid - ---import qualified Data.Map as Map - +import Data.Monoid +import Data.Text (Text, split) import qualified Hasql as H import qualified Hasql.Postgres as P +import PostgREST.PgQuery () +import PostgREST.Types +import GHC.Exts (groupWith) import Prelude -import GHC.Exts (groupWith) doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool @@ -54,21 +52,18 @@ columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) = parseEnum str = fromMaybe [] $ split (==',') <$> str ------------- - - relationFromRow :: (Text, Text, Text, Text, Text) -> Relation -relationFromRow (s, t, c, ft, fc) = Relation s t c ft fc "child" Nothing Nothing Nothing +relationFromRow (s, t, c, ft, fc) = Relation s t c ft fc Child Nothing Nothing Nothing pkFromRow :: (Text, Text, Text) -> PrimaryKey pkFromRow (s, t, n) = PrimaryKey s t n addParentRelation :: Relation -> [Relation] -> [Relation] -addParentRelation rel@(Relation s t c ft fc _ _ _ _) rels = Relation s ft fc t c "parent" Nothing Nothing Nothing:rel:rels +addParentRelation rel@(Relation s t c ft fc _ _ _ _) rels = Relation s ft fc t c Parent Nothing Nothing Nothing:rel:rels -alltables :: H.Tx P.Postgres s [Table] -alltables = do +allTables :: H.Tx P.Postgres s [Table] +allTables = do rows <- H.listEx $ [H.stmt| SELECT n.nspname AS table_schema, @@ -96,8 +91,8 @@ alltables = do |] return $ map tableFromRow rows -allrelations :: H.Tx P.Postgres s [Relation] -allrelations = do +allRelations :: H.Tx P.Postgres s [Relation] +allRelations = do rels <- H.listEx $ [H.stmt| WITH table_fk AS ( SELECT DISTINCT @@ -129,7 +124,7 @@ allrelations = do |] let simpleRelations = foldr (addParentRelation.relationFromRow) [] rels - let links = filter ((==2).length) $ groupWith groupFn $ filter ( (=="child"). relType) simpleRelations + let links = filter ((==2).length) $ groupWith groupFn $ filter ( (==Child). relType) simpleRelations return $ simpleRelations ++ mapMaybe link2Relation links where groupFn :: Relation -> Text @@ -137,11 +132,11 @@ allrelations = do link2Relation [ Relation{relSchema=sc, relTable=lt, relColumn=lc1, relFTable=t, relFColumn=c}, Relation{ relColumn=lc2, relFTable=ft, relFColumn=fc} - ] = Just $ Relation sc t c ft fc "many" (Just lt) (Just lc1) (Just lc2) + ] = Just $ Relation sc t c ft fc Many (Just lt) (Just lc1) (Just lc2) link2Relation _ = Nothing -allcolumns :: [Relation] -> H.Tx P.Postgres s [Column] -allcolumns rels = do +allColumns :: [Relation] -> H.Tx P.Postgres s [Column] +allColumns rels = do cols <- H.listEx $ [H.stmt| SELECT info.table_schema AS schema, @@ -189,34 +184,43 @@ allcolumns rels = do addFK col = col { colFK = relToFk <$> find (lookupFn col) rels } lookupFn :: Column -> Relation -> Bool lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumn=rc, relType=rty}) = - cs==rs && ct==rt && cn==rc && rty=="child" + cs==rs && ct==rt && cn==rc && rty==Child lookupFn _ _ = False relToFk (Relation{relFTable=t, relFColumn=c}) = ForeignKey t c -allprimaryKeys :: H.Tx P.Postgres s [PrimaryKey] -allprimaryKeys = do +allPrimaryKeys :: H.Tx P.Postgres s [PrimaryKey] +allPrimaryKeys = do pks <- H.listEx $ [H.stmt| - WITH table_pk AS - ( - SELECT kc.table_schema, kc.table_name, kc.column_name - FROM information_schema.table_constraints tc, - information_schema.key_column_usage kc - WHERE tc.constraint_type = 'PRIMARY KEY' - AND kc.table_name = tc.table_name - AND kc.table_schema = tc.table_schema - AND kc.constraint_name = tc.constraint_name - AND kc.table_schema NOT IN ('pg_catalog', 'information_schema') - ) - SELECT table_schema, table_name, column_name - FROM table_pk - UNION - ( - SELECT vcu.view_schema, vcu.view_name, vcu.column_name - FROM information_schema.view_column_usage AS vcu - JOIN table_pk ON table_pk.table_schema = vcu.view_schema - AND table_pk.table_name = vcu.table_name - AND table_pk.column_name = vcu.column_name - WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') - ) - |] + WITH table_pk AS ( + SELECT + kc.table_schema, + kc.table_name, + kc.column_name + FROM + information_schema.table_constraints tc, + information_schema.key_column_usage kc + WHERE + tc.constraint_type = 'PRIMARY KEY' AND + kc.table_name = tc.table_name AND + kc.table_schema = tc.table_schema AND + kc.constraint_name = tc.constraint_name AND + kc.table_schema NOT IN ('pg_catalog', 'information_schema') + ) + SELECT table_schema, + table_name, + column_name + FROM table_pk + UNION ( + SELECT + vcu.view_schema, + vcu.view_name, + vcu.column_name + FROM information_schema.view_column_usage AS vcu + JOIN + table_pk ON table_pk.table_schema = vcu.view_schema AND + table_pk.table_name = vcu.table_name AND + table_pk.column_name = vcu.column_name + WHERE vcu.view_schema NOT IN ('pg_catalog','information_schema') + ) + |] return $ map pkFromRow pks diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 0f7d5fd50..95243800a 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -13,25 +13,13 @@ import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi, orderT, pgFmtIdent, pgFmtLit, pgFmtOperator, pgFmtValue, whiteList) import PostgREST.Types ---import qualified Hasql as H ---import qualified Hasql.Postgres as P ---import Control.Applicative ((<|>)) import qualified Data.Vector as V (empty) import qualified Hasql.Backend as B -findColumn :: [Column] -> Text -> Text -> Text -> Either Text Column -findColumn allColumns s t c = note ("no such column: "<>t<>"."<>c) $ - find (\ col -> colSchema col == s && colTable col == t && colName col == c ) allColumns - -findTable :: [Table] -> Text -> Text -> Either Text Table -findTable allTables s t = note ("no such table: "<>t) $ - find (\tb-> s == tableSchema tb && t == tableName tb ) allTables - findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation findRelation allRelations s t1 t2 = find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations - addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) = case parentNode of @@ -46,14 +34,13 @@ addRelations schema allRelations parentNode node@(Node query@(Select {mainTable= where updatedForest = mapM (addRelations schema allRelations (Just node)) forest - addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) = case r of Nothing -> Node updatedQuery <$> updatedForest -- this is the root node - Just rel@(Relation{relType="child"}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest - Just (Relation{relType="parent"}) -> Node updatedQuery <$> updatedForest - Just rel@(Relation{relType="many", relLTable=(Just linkTable)}) -> + Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest + Just (Relation{relType=Parent}) -> Node updatedQuery <$> updatedForest + Just rel@(Relation{relType=Many, relLTable=(Just linkTable)}) -> Node <$> pure qq <*> updatedForest where q = addCond updatedQuery (getJoinConditions rel) @@ -66,21 +53,20 @@ addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) = parentJoinConditions = map (getJoinConditions.snd) parents parentTables = map fst parents parents = mapMaybe (getParents.rootLabel) forest - getParents qq@(Select{relation=(Just rel@(Relation{relType="parent"}))}) = Just (mainTable qq, rel) + getParents qq@(Select{relation=(Just rel@(Relation{relType=Parent}))}) = Just (mainTable qq, rel) getParents _ = Nothing updatedForest = mapM (addJoinConditions schema allColumns) forest getJoinConditions :: Relation -> [Filter] - getJoinConditions rel@(Relation _ _ c _ _ "child" _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)] - getJoinConditions rel@(Relation _ _ c _ _ "parent" _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)] - getJoinConditions (Relation s t c ft fc "many" (Just lt) (Just lc1) (Just lc2)) = + getJoinConditions rel@(Relation _ _ c _ _ Child _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)] + getJoinConditions rel@(Relation _ _ c _ _ Parent _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)] + getJoinConditions (Relation s t c ft fc Many (Just lt) (Just lc1) (Just lc2)) = [ - Filter (c, Nothing) "=" (VForeignKey (Relation s t c lt lc1 "child" Nothing Nothing Nothing)), - Filter (fc, Nothing) "=" (VForeignKey (Relation s ft fc lt lc2 "child" Nothing Nothing Nothing)) + Filter (c, Nothing) "=" (VForeignKey (Relation s t c lt lc1 Child Nothing Nothing Nothing)), + Filter (fc, Nothing) "=" (VForeignKey (Relation s ft fc lt lc2 Child Nothing Nothing Nothing)) ] getJoinConditions _ = [] addCond q con = q{filters=con ++ filters q} - requestToCountQuery :: Text -> ApiRequest -> PStmt requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) = B.Stmt query V.empty True @@ -96,8 +82,6 @@ requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) = fn (Filter{value=VText _}) = True fn (Filter{value=VForeignKey _}) = False - --- main field join filters order rela requestToQuery :: Text -> ApiRequest -> PStmt requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) forest) = orderT (fromMaybe [] ord) query @@ -111,10 +95,8 @@ requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) fo ] emptyOnNull val x = if null x then "" else val (withs, selects) = foldr getQueryParts ([],[]) forest - --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only - --posible relations are Child Parent Many getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text]) - getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType="child"}))}) forst) (w,s) = (w,sel:s) + getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Child}))}) forst) (w,s) = (w,sel:s) where sel = "(" <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " @@ -122,13 +104,13 @@ requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) fo <> ") AS " <> table where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) - getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s) + getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation{relType=Parent}))}) forst) (w,s) = (wit:w,sel:s) where sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular wit = table <> " AS ( " <> subquery <> " )" where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) - getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType="many"}))}) forst) (w,s) = (w,sel:s) + getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Many}))}) forst) (w,s) = (w,sel:s) where sel = "(" <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " @@ -136,9 +118,10 @@ requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) fo <> ") AS " <> table where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) - -- the following is just to remove the warning, maybe relType should not be String? + -- the following is just to remove the warning + --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only + --posible relations are Child Parent Many getQueryParts (Node (Select{relation=Nothing}) _) _ = undefined - getQueryParts (Node (Select{relation=(Just (Relation {relType=_}))}) _) _ = undefined pgFmtCondition :: QualifiedIdentifier -> Filter -> Text pgFmtCondition table (Filter (col,jp) ops val) = @@ -163,7 +146,6 @@ pgFmtCondition table (Filter (col,jp) ops val) = pgFmtColumn :: QualifiedIdentifier -> Text -> Text pgFmtColumn table "*" = fromQi table <> ".*" pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c ---pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*" pgFmtJsonPath :: Maybe JsonPath -> Text pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 8c333d7b2..164f2d7a4 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -9,7 +9,6 @@ data DbStructure = DbStructure { , columns :: [Column] , relations :: [Relation] , primaryKeys :: [PrimaryKey] ---, tablesAcl :: [(Text, Text, Text)] } @@ -50,22 +49,20 @@ data OrderTerm = OrderTerm { , otNullOrder :: Maybe BS.ByteString } deriving (Show, Eq) - +data RelationType = Child | Parent | Many deriving (Show, Eq) data Relation = Relation { relSchema :: Text , relTable :: Text , relColumn :: Text , relFTable :: Text , relFColumn :: Text -, relType :: Text +, relType :: RelationType , relLTable :: Maybe Text , relLCol1 :: Maybe Text , relLCol2 :: Maybe Text } deriving (Show, Eq) --------- --- Request Types type Operator = Text data FValue = VText Text | VForeignKey Relation deriving (Show, Eq) type FieldName = Text diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index cd17e41e6..f47f23b6d 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -55,36 +55,27 @@ withApp perform = do pool :: H.Pool P.Postgres <- H.acquirePool pgSettings testPoolOpts - let txParam = (Just (H.ReadCommitted, Just True)) - - tblsRes <- H.session pool $ H.tx txParam alltables - let allTables = either (fail . show) id tblsRes - - relsRes <- H.session pool $ H.tx txParam allrelations - let allRelations = either (fail . show) id relsRes - - colsRes <- H.session pool $ H.tx txParam $ allcolumns allRelations - let allColumns = either (fail . show) id colsRes - - pkRes <- H.session pool $ H.tx txParam $ allprimaryKeys - let allPrimaryKeys = either (fail . show) id pkRes - - -- tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl - -- let allTablesAcl = either (fail . show) id tableAclRes - - - let dbstructure = DbStructure { - tables=allTables - , columns=allColumns - , relations=allRelations - , primaryKeys=allPrimaryKeys - --, tablesAcl=allTablesAcl - } + let txSettings = Just (H.ReadCommitted, Just True) + metadata <- H.session pool $ H.tx txSettings $ do + tabs <- allTables + rels <- allRelations + cols <- allColumns rels + keys <- allPrimaryKeys + return (tabs, rels, cols, keys) + dbstructure <- case metadata of + Left e -> fail $ show e + Right (tabs, rels, cols, keys) -> + return $ DbStructure { + tables=tabs + , columns=cols + , relations=rels + , primaryKeys=keys + } perform $ middle $ \req resp -> do body <- strictRequestBody req - result <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) + result <- liftIO $ H.session pool $ H.tx txSettings $ authenticated cfg (app dbstructure cfg body) req either (resp . errResponse) resp result From 8ff4b4be6694e555ce1b4648035c9c4e6c993184 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Thu, 1 Oct 2015 10:36:33 +0300 Subject: [PATCH 26/31] lint fix --- src/PostgREST/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 07460423b..bf756e14d 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -91,7 +91,7 @@ main = do dbstructure <- case metadata of Left e -> fail $ show e Right (tabs, rels, cols, keys) -> - return $ DbStructure { + return DbStructure { tables=tabs , columns=cols , relations=rels From c7666c0a672b376721e9ff0729a6a0fbd807b4e0 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Thu, 1 Oct 2015 14:20:40 +0300 Subject: [PATCH 27/31] tests for table relations & bugfix for not detecting child relations of view --- src/PostgREST/PgStructure.hs | 71 +++++++++++++++++----------- test/Feature/QuerySpec.hs | 20 ++++++++ test/Feature/StructureSpec.hs | 7 +++ test/fixtures/schema.sql | 87 +++++++++++++++++++++++++++++++++++ 4 files changed, 157 insertions(+), 28 deletions(-) diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index 3d4f7f0c1..8ed08873b 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -94,34 +94,49 @@ allTables = do allRelations :: H.Tx P.Postgres s [Relation] allRelations = do rels <- H.listEx $ [H.stmt| - WITH table_fk AS ( - SELECT DISTINCT - tc.table_schema, tc.table_name, kcu.column_name, - ccu.table_name AS foreign_table_name, - ccu.column_name AS foreign_column_name - FROM information_schema.table_constraints AS tc - JOIN information_schema.key_column_usage AS kcu on tc.constraint_name = kcu.constraint_name - JOIN information_schema.constraint_column_usage AS ccu on ccu.constraint_name = tc.constraint_name - WHERE constraint_type = 'FOREIGN KEY' - AND tc.table_schema NOT IN ('pg_catalog', 'information_schema') - ORDER BY tc.table_schema, tc.table_name, kcu.column_name - ) - SELECT * FROM table_fk - UNION - ( - SELECT DISTINCT - vcu.table_schema, vcu.view_name AS table_name, vcu.column_name, - table_fk.foreign_table_name, - table_fk.foreign_column_name - FROM information_schema.view_column_usage as vcu - JOIN table_fk ON - table_fk.table_schema = vcu.view_schema AND - table_fk.table_name = vcu.table_name AND - table_fk.column_name = vcu.column_name - WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') - ORDER BY vcu.table_schema, vcu.view_name, vcu.column_name - ) - + WITH table_fk AS ( + SELECT + tc.table_schema, tc.table_name, kcu.column_name, + ccu.table_name AS foreign_table_name, + ccu.column_name AS foreign_column_name + FROM information_schema.table_constraints AS tc + JOIN information_schema.key_column_usage AS kcu on tc.constraint_name = kcu.constraint_name + JOIN information_schema.constraint_column_usage AS ccu on ccu.constraint_name = tc.constraint_name + WHERE constraint_type = 'FOREIGN KEY' + AND tc.table_schema NOT IN ('pg_catalog', 'information_schema') + ORDER BY tc.table_schema, tc.table_name, kcu.column_name + ) + SELECT * FROM table_fk + UNION + ( + SELECT + vcu.table_schema, vcu.view_name AS table_name, vcu.column_name, + table_fk.foreign_table_name, + table_fk.foreign_column_name + FROM information_schema.view_column_usage as vcu + JOIN table_fk ON + table_fk.table_schema = vcu.view_schema AND + table_fk.table_name = vcu.table_name AND + table_fk.column_name = vcu.column_name + WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') + ORDER BY vcu.table_schema, vcu.view_name, vcu.column_name + ) + UNION + ( + SELECT + vcu.view_schema as table_schema, + table_fk.table_name, + table_fk.column_name, + vcu.view_name as foreign_table_name, + vcu.column_name as foreign_column_name + FROM information_schema.view_column_usage as vcu + JOIN table_fk ON + table_fk.table_schema = vcu.view_schema AND + table_fk.foreign_table_name = vcu.table_name AND + table_fk.foreign_column_name = vcu.column_name + WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') + ORDER BY vcu.table_schema, vcu.view_name, vcu.column_name + ) |] let simpleRelations = foldr (addParentRelation.relationFromRow) [] rels let links = filter ((==2).length) $ groupWith groupFn $ filter ( (==Child). relType) simpleRelations diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 4593c7fa8..71de94751 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -130,6 +130,10 @@ spec = get "/items?always_true=eq.true" `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] + it "matches filtering nested items" $ + get "/clients?select=id,projects(id,tasks(id,name))&projects.tasks.name=like.Design*" `shouldRespondWith` + "[{\"id\":1,\"projects\":[{\"id\":1,\"tasks\":[{\"id\":1,\"name\":\"Design w7\"}]},{\"id\":2,\"tasks\":[{\"id\":3,\"name\":\"Design w10\"}]}]},{\"id\":2,\"projects\":[{\"id\":3,\"tasks\":[{\"id\":5,\"name\":\"Design IOS\"}]},{\"id\":4,\"tasks\":[{\"id\":7,\"name\":\"Design OSX\"}]}]}]" + describe "Shaping response with select parameter" $ do it "selectStar works in absense of parameter" $ @@ -178,6 +182,22 @@ spec = get "/complex_items?id=eq.1&select=settings->foo->>int::integer" `shouldRespondWith` [json| [{"int":1}] |] -- the value in the db is an int, but here we expect a string for now + it "requesting parents and children" $ + get "/projects?id=eq.1&select=id, name, clients(*), tasks(id, name)" `shouldRespondWith` + "[{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}]" + + it "requesting children 2 levels" $ + get "/clients?id=eq.1&select=id,projects(id,tasks(id))" `shouldRespondWith` + "[{\"id\":1,\"projects\":[{\"id\":1,\"tasks\":[{\"id\":1},{\"id\":2}]},{\"id\":2,\"tasks\":[{\"id\":3},{\"id\":4}]}]}]" + + it "requesting many<->many relation" $ + get "/tasks?select=id,users(id)" `shouldRespondWith` + "[{\"id\":1,\"users\":[{\"id\":1},{\"id\":3}]},{\"id\":2,\"users\":[{\"id\":1}]},{\"id\":3,\"users\":[{\"id\":1}]},{\"id\":4,\"users\":[{\"id\":1}]},{\"id\":5,\"users\":[{\"id\":2},{\"id\":3}]},{\"id\":6,\"users\":[{\"id\":2}]},{\"id\":7,\"users\":[{\"id\":2}]},{\"id\":8,\"users\":null}]" + + it "requesting parents and children on views" $ + get "/projects_view?id=eq.1&select=id, name, clients(*), tasks(id, name)" `shouldRespondWith` + "[{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}]" + describe "ordering response" $ do it "by a column asc" $ diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index eb63e5724..03b7b010c 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -15,6 +15,7 @@ spec = around withApp $ do request methodGet "/" [] "" `shouldRespondWith` [json| [ {"schema":"1","name":"auto_incrementing_pk","insertable":true} + , {"schema":"1","name":"clients","insertable":true} , {"schema":"1","name":"complex_items","insertable":true} , {"schema":"1","name":"compound_pk","insertable":true} , {"schema":"1","name":"has_count_column","insertable":false} @@ -26,8 +27,14 @@ spec = around withApp $ do , {"schema":"1","name":"menagerie","insertable":true} , {"schema":"1","name":"no_pk","insertable":true} , {"schema":"1","name":"nullable_integer","insertable":true} + , {"schema":"1","name":"projects","insertable":true} + , {"schema":"1","name":"projects_view","insertable":true} , {"schema":"1","name":"simple_pk","insertable":true} + , {"schema":"1","name":"tasks","insertable":true} , {"schema":"1","name":"tsearch","insertable":true} + , {"schema":"1","name":"users","insertable":true} + , {"schema":"1","name":"users_projects","insertable":true} + , {"schema":"1","name":"users_tasks","insertable":true} ] |] {matchStatus = 200} diff --git a/test/fixtures/schema.sql b/test/fixtures/schema.sql index 0f5cb5068..f70f6265d 100755 --- a/test/fixtures/schema.sql +++ b/test/fixtures/schema.sql @@ -210,6 +210,62 @@ CREATE TABLE complex_items ( ALTER TABLE "1".complex_items OWNER TO postgrest_test; +--- Structure for testing table relations +CREATE TABLE clients( + id INT PRIMARY KEY NOT NULL, + name TEXT NOT NULL +); +ALTER TABLE "1".clients OWNER TO postgrest_test; + +CREATE TABLE projects( + id INT PRIMARY KEY NOT NULL, + name TEXT NOT NULL, + client_id INT REFERENCES clients(id) +); +ALTER TABLE "1".projects OWNER TO postgrest_test; + +CREATE TABLE tasks( + id INT PRIMARY KEY NOT NULL, + name TEXT NOT NULL, + project_id INT REFERENCES projects(id) +); +ALTER TABLE "1".tasks OWNER TO postgrest_test; + +CREATE TABLE users( + id INT PRIMARY KEY NOT NULL, + name TEXT NOT NULL +); +ALTER TABLE "1".users OWNER TO postgrest_test; + +CREATE TABLE users_tasks( + user_id INT REFERENCES users(id), + task_id INT REFERENCES tasks(id), + CONSTRAINT task_user PRIMARY KEY (task_id,user_id) +); +ALTER TABLE "1".users_tasks OWNER TO postgrest_test; + +CREATE TABLE users_projects( + user_id INT REFERENCES users(id), + project_id INT REFERENCES projects(id), + CONSTRAINT project_user PRIMARY KEY (project_id, user_id) +); +ALTER TABLE "1".users_projects OWNER TO postgrest_test; + +CREATE VIEW "1".projects_view AS + SELECT + projects.id, + projects.name, + projects.client_id + FROM projects; +ALTER TABLE "1".projects_view OWNER TO postgrest_test; +------- SAMPLE DATA ----- +INSERT INTO clients VALUES (1, 'Microsoft'),(2, 'Apple'); +INSERT INTO projects VALUES (1,'Windows 7', 1),(2,'Windows 10', 1),(3,'IOS', 2),(4,'OSX', 2); +INSERT INTO tasks VALUES (1,'Design w7',1),(2,'Code w7',1),(3,'Design w10',2),(4,'Code w10',2),(5,'Design IOS',3),(6,'Code IOS',3),(7,'Design OSX',4),(8,'Code OSX',4); +INSERT INTO users VALUES (1, 'Angela Martin'),(2, 'Michael Scott'),(3, 'Dwight Schrute'); +INSERT INTO users_projects VALUES(1,1),(1,2),(2,3),(2,4),(3,1),(3,3); +INSERT INTO users_tasks VALUES(1,1),(1,2),(1,3),(1,4),(2,5),(2,6),(2,7),(3,1),(3,5); +---------------- CREATE SEQUENCE items_id_seq START WITH 1 @@ -555,6 +611,37 @@ REVOKE ALL ON TABLE complex_items FROM postgrest_test; GRANT ALL ON TABLE complex_items TO postgrest_test; GRANT ALL ON TABLE complex_items TO postgrest_anonymous; +--------- +REVOKE ALL ON TABLE clients FROM PUBLIC; +REVOKE ALL ON TABLE clients FROM postgrest_test; +GRANT ALL ON TABLE clients TO postgrest_test; +GRANT ALL ON TABLE clients TO postgrest_anonymous; +REVOKE ALL ON TABLE projects FROM PUBLIC; +REVOKE ALL ON TABLE projects FROM postgrest_test; +GRANT ALL ON TABLE projects TO postgrest_test; +GRANT ALL ON TABLE projects TO postgrest_anonymous; +REVOKE ALL ON TABLE tasks FROM PUBLIC; +REVOKE ALL ON TABLE tasks FROM postgrest_test; +GRANT ALL ON TABLE tasks TO postgrest_test; +GRANT ALL ON TABLE tasks TO postgrest_anonymous; +REVOKE ALL ON TABLE users FROM PUBLIC; +REVOKE ALL ON TABLE users FROM postgrest_test; +GRANT ALL ON TABLE users TO postgrest_test; +GRANT ALL ON TABLE users TO postgrest_anonymous; +REVOKE ALL ON TABLE users_tasks FROM PUBLIC; +REVOKE ALL ON TABLE users_tasks FROM postgrest_test; +GRANT ALL ON TABLE users_tasks TO postgrest_test; +GRANT ALL ON TABLE users_tasks TO postgrest_anonymous; +REVOKE ALL ON TABLE users_projects FROM PUBLIC; +REVOKE ALL ON TABLE users_projects FROM postgrest_test; +GRANT ALL ON TABLE users_projects TO postgrest_test; +GRANT ALL ON TABLE users_projects TO postgrest_anonymous; +REVOKE ALL ON TABLE projects_view FROM PUBLIC; +REVOKE ALL ON TABLE projects_view FROM postgrest_test; +GRANT ALL ON TABLE projects_view TO postgrest_test; +GRANT ALL ON TABLE projects_view TO postgrest_anonymous; +--------- + REVOKE ALL ON FUNCTION getitemrange(bigint, bigint) FROM PUBLIC; REVOKE ALL ON FUNCTION getitemrange(bigint, bigint) FROM postgrest_test; From e6baafdb8f36ca2b3796444ece3be5bd55fbba92 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Thu, 1 Oct 2015 15:28:02 +0300 Subject: [PATCH 28/31] remove space --- src/PostgREST/App.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index b1f6b3f25..03845a92b 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -83,7 +83,6 @@ app dbstructure conf reqBody dbrole req = count = if hasPrefer "count=none" then countNone else cqs - q = B.Stmt "select " V.empty True <> parentheticT count <> commaq <> ( From e23a49395b54456b1d20b4d3515bdd9dd1ee5aa3 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 2 Oct 2015 11:36:56 +0300 Subject: [PATCH 29/31] error formatting for parsers and relation --- src/PostgREST/App.hs | 24 +++++++++++++++++++----- src/PostgREST/Parsers.hs | 4 ++-- 2 files changed, 21 insertions(+), 7 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 03845a92b..8dc758f48 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -10,7 +10,6 @@ module PostgREST.App ( , TableOptions(..) ) where - import qualified Blaze.ByteString.Builder as BB import Control.Applicative import Control.Arrow (second, (***)) @@ -29,9 +28,11 @@ import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) import qualified Data.Set as S import Data.String.Conversions (cs) -import Data.Text (Text) +import Data.Text (Text, replace, strip) import Text.Regex.TDFA ((=~)) +import Text.Parsec.Error + import Network.HTTP.Base (urlEncodeVars) import Network.HTTP.Types.Header import Network.HTTP.Types.Status @@ -77,7 +78,7 @@ app dbstructure conf reqBody dbrole req = then return $ responseLBS status416 [] "HTTP Range error" else case queries of - Left e -> return $ responseLBS status400 [("Content-Type", "text/plain")] $ cs e + Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e Right (qs, cqs) -> do let qt = qualify table count = if hasPrefer "count=none" @@ -111,9 +112,22 @@ app dbstructure conf reqBody dbrole req = where from = fromMaybe 0 $ rangeOffset <$> range apiRequest = first formatParserError (parseGetRequest req) - >>= addRelations schema allRels Nothing + >>= first formatRelationError . addRelations schema allRels Nothing >>= addJoinConditions schema allCols - where formatParserError = cs.show + where + formatRelationError :: Text -> Text + formatRelationError e = cs $ encode $ object [ + "mesage" .= ("could not find foreign keys between these entities"::String), + "details" .= e] + formatParserError :: ParseError -> Text + formatParserError e = cs $ encode $ object [ + "message" .= message, + "details" .= details] + where + message = show (errorPos e) + details = strip $ replace "\n" " " $ cs + $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) + query = requestToQuery schema <$> apiRequest countQuery = requestToCountQuery schema <$> apiRequest queries = (,) <$> query <*> countQuery diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 4cebf0d8f..235962811 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -22,13 +22,13 @@ parseGetRequest :: Request -> Either ParseError ApiRequest parseGetRequest httpRequest = foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts where - apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select ("++selectStr++")") $ cs selectStr + apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr addOrder (Node r f) o = Node r{order=o} f flts = mapM pRequestFilter whereFilters rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] orderStr = join $ lookup "order" qString - ord = traverse (parse pOrder ("failed to parse order ("++fromMaybe "" orderStr++")")) orderStr + ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderStr++">>")) orderStr selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] From 4dd508a6289646fbe3ce731c29828f976d4100b7 Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sat, 3 Oct 2015 15:02:02 -0400 Subject: [PATCH 30/31] Adds a failing spec for child relation (comments) using a composite foreign key (references to users_tasks) --- test/Feature/QuerySpec.hs | 4 ++++ test/Feature/StructureSpec.hs | 1 + test/fixtures/schema.sql | 15 +++++++++++++++ 3 files changed, 20 insertions(+) diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 71de94751..d36ac8970 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -198,6 +198,10 @@ spec = get "/projects_view?id=eq.1&select=id, name, clients(*), tasks(id, name)" `shouldRespondWith` "[{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}]" + it "requesting children with composite key" $ + get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments(content)" `shouldRespondWith` + [json| [{"user_id":2,"task_id":6,"comments":[{"content": "Needs to be delivered ASAP"}]}] |] + describe "ordering response" $ do it "by a column asc" $ diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index 03b7b010c..d68db8440 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -16,6 +16,7 @@ spec = around withApp $ do `shouldRespondWith` [json| [ {"schema":"1","name":"auto_incrementing_pk","insertable":true} , {"schema":"1","name":"clients","insertable":true} + , {"schema":"1","name":"comments","insertable":true} , {"schema":"1","name":"complex_items","insertable":true} , {"schema":"1","name":"compound_pk","insertable":true} , {"schema":"1","name":"has_count_column","insertable":false} diff --git a/test/fixtures/schema.sql b/test/fixtures/schema.sql index f70f6265d..d66ce05a4 100755 --- a/test/fixtures/schema.sql +++ b/test/fixtures/schema.sql @@ -244,6 +244,16 @@ CREATE TABLE users_tasks( ); ALTER TABLE "1".users_tasks OWNER TO postgrest_test; +CREATE TABLE comments( +id INT PRIMARY KEY NOT NULL, +commenter_id INT NOT NULL REFERENCES users(id), +user_id INT NOT NULL, +task_id INT NOT NULL, +content TEXT NOT NULL, +FOREIGN KEY (task_id,user_id) REFERENCES users_tasks (task_id,user_id) +); +ALTER TABLE "1".comments OWNER TO postgrest_test; + CREATE TABLE users_projects( user_id INT REFERENCES users(id), project_id INT REFERENCES projects(id), @@ -265,6 +275,7 @@ INSERT INTO tasks VALUES (1,'Design w7',1),(2,'Code w7',1),(3,'Design w10',2),(4 INSERT INTO users VALUES (1, 'Angela Martin'),(2, 'Michael Scott'),(3, 'Dwight Schrute'); INSERT INTO users_projects VALUES(1,1),(1,2),(2,3),(2,4),(3,1),(3,3); INSERT INTO users_tasks VALUES(1,1),(1,2),(1,3),(1,4),(2,5),(2,6),(2,7),(3,1),(3,5); +INSERT INTO comments VALUES (1, 1, 2, 6, 'Needs to be delivered ASAP'); ---------------- CREATE SEQUENCE items_id_seq @@ -632,6 +643,10 @@ REVOKE ALL ON TABLE users_tasks FROM PUBLIC; REVOKE ALL ON TABLE users_tasks FROM postgrest_test; GRANT ALL ON TABLE users_tasks TO postgrest_test; GRANT ALL ON TABLE users_tasks TO postgrest_anonymous; +REVOKE ALL ON TABLE comments FROM PUBLIC; +REVOKE ALL ON TABLE comments FROM postgrest_test; +GRANT ALL ON TABLE comments TO postgrest_test; +GRANT ALL ON TABLE comments TO postgrest_anonymous; REVOKE ALL ON TABLE users_projects FROM PUBLIC; REVOKE ALL ON TABLE users_projects FROM postgrest_test; GRANT ALL ON TABLE users_projects TO postgrest_test; From b675276f318a286aba28f357af7b86e02cf3b163 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Sun, 4 Oct 2015 07:26:05 +0300 Subject: [PATCH 31/31] merge new test from @diogob --- test/Feature/QuerySpec.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index d36ac8970..df100c8c8 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -1,6 +1,6 @@ module Feature.QuerySpec where -import Test.Hspec +import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Network.HTTP.Types @@ -198,7 +198,8 @@ spec = get "/projects_view?id=eq.1&select=id, name, clients(*), tasks(id, name)" `shouldRespondWith` "[{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}]" - it "requesting children with composite key" $ + it "requesting children with composite key" $ do + pendingWith "have to resolve issue #302" get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments(content)" `shouldRespondWith` [json| [{"user_id":2,"task_id":6,"comments":[{"content": "Needs to be delivered ASAP"}]}] |]