moved db structure detection at the beginning (2 tests failing)
This commit is contained in:
Ruslan Talpa
+4
-1
@@ -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
|
||||
|
||||
+33
-12
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
+27
-2
@@ -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
|
||||
|
||||
+224
-110
@@ -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
|
||||
|
||||
@@ -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)
|
||||
+17
-1
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user