postgrest 0.3.0.1 → 0.3.0.2
raw patch · 20 files changed
+715/−438 lines, 20 filesdep +safedep +unixdep −QuickCheckdep −aeson-prettydep −bcryptdep ~warpPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: safe, unix
Dependencies removed: QuickCheck, aeson-pretty, bcrypt, bifunctors, blaze-builder, convertible, http-media, mtl, network, network-uri, regex-base, resource-pool, split, stringsearch
Dependency ranges changed: warp
API changes (from Hackage documentation)
- PostgREST.QueryBuilder: sourceSubqueryName :: SqlFragment
+ PostgREST.ApiRequest: Full :: PreferRepresentation
+ PostgREST.ApiRequest: HeadersOnly :: PreferRepresentation
+ PostgREST.ApiRequest: None :: PreferRepresentation
+ PostgREST.ApiRequest: data PreferRepresentation
+ PostgREST.ApiRequest: instance GHC.Classes.Eq PostgREST.ApiRequest.PreferRepresentation
+ PostgREST.Config: [configMaxRows] :: AppConfig -> Maybe Int
+ PostgREST.QueryBuilder: requestToCountQuery :: Schema -> DbRequest -> SqlQuery
+ PostgREST.QueryBuilder: sourceCTEName :: SqlFragment
+ PostgREST.RangeQuery: restrictRange :: Maybe Int -> NonnegRange -> NonnegRange
- PostgREST.ApiRequest: ApiRequest :: Action -> Maybe NonnegRange -> Target -> Either ByteString ContentType -> Maybe Payload -> Bool -> Bool -> Bool -> [(String, String)] -> String -> Maybe String -> ApiRequest
+ PostgREST.ApiRequest: ApiRequest :: Action -> NonnegRange -> Target -> Either ByteString ContentType -> Maybe Payload -> PreferRepresentation -> Bool -> Bool -> [(String, String)] -> String -> Maybe String -> ApiRequest
- PostgREST.ApiRequest: [iPreferRepresentation] :: ApiRequest -> Bool
+ PostgREST.ApiRequest: [iPreferRepresentation] :: ApiRequest -> PreferRepresentation
- PostgREST.ApiRequest: [iRange] :: ApiRequest -> Maybe NonnegRange
+ PostgREST.ApiRequest: [iRange] :: ApiRequest -> NonnegRange
- PostgREST.Config: AppConfig :: String -> Int -> String -> String -> Secret -> Int -> AppConfig
+ PostgREST.Config: AppConfig :: String -> Int -> String -> String -> Secret -> Int -> Maybe Int -> AppConfig
- PostgREST.Middleware: runWithClaims :: AppConfig -> (Request -> Tx Postgres s Response) -> Request -> Tx Postgres s Response
+ PostgREST.Middleware: runWithClaims :: AppConfig -> NominalDiffTime -> (Request -> Tx Postgres s Response) -> Request -> Tx Postgres s Response
- PostgREST.QueryBuilder: createReadStatement :: SqlQuery -> Maybe NonnegRange -> Bool -> Bool -> Bool -> Stmt Postgres
+ PostgREST.QueryBuilder: createReadStatement :: SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool -> Stmt Postgres
- PostgREST.QueryBuilder: createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> [Text] -> Bool -> Payload -> Stmt Postgres
+ PostgREST.QueryBuilder: createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool -> PreferRepresentation -> [Text] -> Bool -> Payload -> Stmt Postgres
- PostgREST.RangeQuery: rangeParse :: ByteString -> Maybe NonnegRange
+ PostgREST.RangeQuery: rangeParse :: ByteString -> NonnegRange
- PostgREST.RangeQuery: rangeRequested :: RequestHeaders -> Maybe NonnegRange
+ PostgREST.RangeQuery: rangeRequested :: RequestHeaders -> NonnegRange
- PostgREST.Types: Delete :: Text -> [Filter] -> MutateQuery
+ PostgREST.Types: Delete :: TableName -> [Filter] -> MutateQuery
- PostgREST.Types: Insert :: Text -> Payload -> MutateQuery
+ PostgREST.Types: Insert :: TableName -> Payload -> MutateQuery
- PostgREST.Types: Select :: [SelectItem] -> [Text] -> [Filter] -> Maybe [OrderTerm] -> ReadQuery
+ PostgREST.Types: Select :: [SelectItem] -> [TableName] -> [Filter] -> Maybe [OrderTerm] -> ReadQuery
- PostgREST.Types: Update :: Text -> Payload -> [Filter] -> MutateQuery
+ PostgREST.Types: Update :: TableName -> Payload -> [Filter] -> MutateQuery
- PostgREST.Types: [from] :: ReadQuery -> [Text]
+ PostgREST.Types: [from] :: ReadQuery -> [TableName]
- PostgREST.Types: [in_] :: MutateQuery -> Text
+ PostgREST.Types: [in_] :: MutateQuery -> TableName
Files
- postgrest.cabal +67/−74
- src/PostgREST/ApiRequest.hs +11/−7
- src/PostgREST/App.hs +32/−26
- src/PostgREST/Config.hs +4/−1
- src/PostgREST/DbStructure.hs +242/−31
- src/PostgREST/Main.hs +22/−4
- src/PostgREST/Middleware.hs +3/−6
- src/PostgREST/QueryBuilder.hs +141/−116
- src/PostgREST/RangeQuery.hs +16/−9
- src/PostgREST/Types.hs +4/−4
- test/Feature/AuthSpec.hs +6/−4
- test/Feature/CorsSpec.hs +6/−2
- test/Feature/DeleteSpec.hs +10/−4
- test/Feature/InsertSpec.hs +21/−9
- test/Feature/QuerySpec.hs +48/−32
- test/Feature/RangeSpec.hs +7/−3
- test/Feature/StructureSpec.hs +11/−8
- test/Main.hs +31/−2
- test/Spec.hs +0/−1
- test/SpecHelper.hs +33/−95
postgrest.cabal view
@@ -2,7 +2,7 @@ description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits.-version: 0.3.0.1+version: 0.3.0.2 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE@@ -30,37 +30,40 @@ main-is: PostgREST/Main.hs default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes default-language: Haskell2010- build-depends: base >= 4.8 && < 5- , postgrest+ build-depends: aeson >= 0.8+ , base >= 4.8 && < 5+ , bytestring+ , case-insensitive+ , cassava+ , containers+ , errors , hasql >= 0.7.3 && < 0.8 , hasql-backend >= 0.4.1 && < 0.5 , hasql-postgres >= 0.10.4 && < 0.11- , warp >= 3.0.2, wai >= 3.0.1- , wai-extra, wai-cors- , wai-middleware-static >= 0.6.0- , HTTP, convertible, http-types- , case-insensitive- , scientific, time- , aeson >= 0.8, network >= 2.6- , aeson-pretty >= 0.7 && < 0.8- , bytestring, text, split, string-conversions- , stringsearch- , containers, unordered-containers- , optparse-applicative >= 0.11 && < 0.13- , regex-base, regex-tdfa- , Ranged-sets- , transformers, MissingH- , bcrypt >= 0.0.6, base64-string- , network-uri >= 2.6- , resource-pool- , blaze-builder- , vector- , mtl- , cassava , jwt+ , optparse-applicative >= 0.11 && < 0.13 , parsec- , errors- , bifunctors+ , postgrest+ , regex-tdfa+ , safe >= 0.3 && < 0.4+ , scientific+ , string-conversions+ , text+ , time+ , transformers+ , unordered-containers+ , vector+ , wai >= 3.0.1+ , wai-cors+ , wai-extra+ , wai-middleware-static >= 0.6.0+ , warp >= 3.0.2+ , HTTP, http-types+ , MissingH+ , Ranged-sets+ if !os(windows)+ build-depends: unix >= 2.7 && < 3+ hs-source-dirs: src other-modules: Paths_postgrest , PostgREST.App@@ -83,48 +86,35 @@ default-language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes- build-depends: HTTP- , MissingH- , Ranged-sets- , aeson+ build-depends: aeson , base >=4.6 && <5- , base64-string- , bcrypt- , bifunctors- , blaze-builder , bytestring , case-insensitive , cassava , containers- , convertible , errors , hasql , hasql-backend , hasql-postgres , http-types , jwt- , mtl- , network- , network-uri , optparse-applicative , parsec- , regex-base , regex-tdfa- , resource-pool+ , safe , scientific- , split , string-conversions- , stringsearch , text , time- , transformers , unordered-containers , vector , wai , wai-cors , wai-extra , wai-middleware-static- , warp+ , HTTP+ , MissingH+ , Ranged-sets Other-Modules: Paths_postgrest Exposed-Modules: PostgREST.App@@ -169,39 +159,42 @@ , PostgREST.RangeQuery , PostgREST.ApiRequest , PostgREST.Types- , Spec , SpecHelper , TestTypes- Build-Depends: base, hspec == 2.2.*, QuickCheck- , hspec-wai, hspec-wai-json- , hasql, hasql-backend- , hasql-postgres- , warp, wai- , packdeps, hlint- , HTTP, convertible+ Build-Depends: aeson+ , base+ , base64-string+ , bytestring , case-insensitive- , wai-extra, wai-cors, containers- , wai-middleware-static- , http-types, scientific, time- , bytestring, aeson, network- , text, optparse-applicative- , stringsearch- , unordered-containers- , regex-base- , string-conversions- , http-media, regex-tdfa- , Ranged-sets- , transformers, MissingH, split- , bcrypt, base64-string- , network-uri- , resource-pool- , blaze-builder- , vector- , mtl , cassava- , process+ , containers+ , errors+ , hasql+ , hasql-backend+ , hasql-postgres , heredoc+ , hlint+ , hspec == 2.2.*+ , hspec-wai+ , hspec-wai-json+ , http-types , jwt+ , optparse-applicative+ , packdeps , parsec- , errors- , bifunctors+ , process+ , regex-tdfa+ , safe+ , scientific+ , string-conversions+ , text+ , time+ , unordered-containers+ , vector+ , wai+ , wai-cors+ , wai-extra+ , wai-middleware-static+ , HTTP+ , MissingH+ , Ranged-sets
src/PostgREST/ApiRequest.hs view
@@ -20,7 +20,7 @@ import PostgREST.Types (QualifiedIdentifier (..), Schema, Payload(..), UniformObjects(..))-import Data.Ranged.Ranges (singletonRange) +import Data.Ranged.Ranges (singletonRange) type RequestBody = BL.ByteString @@ -33,6 +33,8 @@ data Target = TargetIdent QualifiedIdentifier | TargetRoot | TargetUnknown [T.Text]+-- | How to return the inserted data+data PreferRepresentation = Full | HeadersOnly | None deriving Eq -- | Enumeration of currently supported content types for -- route responses and upload payloads data ContentType = ApplicationJSON | TextCSV deriving Eq@@ -51,7 +53,7 @@ -- | Set to Nothing for unknown HTTP verbs iAction :: Action -- | Set to Nothing for malformed range- , iRange :: Maybe NonnegRange+ , iRange :: NonnegRange -- | Set to Nothing for strangely nested urls , iTarget :: Target -- | The content type the client most desires (or JSON if undecided)@@ -59,7 +61,7 @@ -- | Data sent by client and used for mutation actions , iPayload :: Maybe Payload -- | If client wants created items echoed back- , iPreferRepresentation :: Bool+ , iPreferRepresentation :: PreferRepresentation -- | If client wants first row as raw object , iPreferSingular :: Bool -- | Whether the client wants a result count (slower)@@ -115,11 +117,11 @@ ApiRequest { iAction = action- , iRange = if singular then Just (singletonRange 0) else rangeRequested hdrs+ , iRange = if singular then singletonRange 0 else rangeRequested hdrs , iTarget = target , iAccepts = pickContentType $ lookupHeader "accept" , iPayload = relevantPayload- , iPreferRepresentation = hasPrefer "return=representation"+ , iPreferRepresentation = representation , iPreferSingular = singular , iPreferCount = not $ hasPrefer "count=none" , iFilters = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ]@@ -138,8 +140,10 @@ lookupHeader = flip lookup hdrs hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs singular = hasPrefer "plurality=singular"--+ representation+ | hasPrefer "return=representation" = Full+ | hasPrefer "return=minimal" = None+ | otherwise = HeadersOnly -- PRIVATE ---------------------------------------------------------------
src/PostgREST/App.hs view
@@ -43,6 +43,7 @@ import PostgREST.RangeQuery import PostgREST.ApiRequest (ApiRequest(..), ContentType(..) , Action(..), Target(..)+ , PreferRepresentation (..) , userApiRequest) import PostgREST.Types import PostgREST.Auth (tokenJWT)@@ -51,8 +52,9 @@ import PostgREST.QueryBuilder ( asJson , callProc , addJoinConditions- , sourceSubqueryName+ , sourceCTEName , requestToQuery+ , requestToCountQuery , addRelations , createReadStatement , createWriteStatement@@ -70,14 +72,14 @@ case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of (ActionRead, TargetIdent qi, Nothing) ->- case selectQuery of+ case readSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e- Right q -> do- let range = iRange apiRequest+ Right (q, cq) -> do+ let range = restrictRange (configMaxRows conf) $ iRange apiRequest singular = iPreferSingular apiRequest- stm = createReadStatement q range singular+ stm = createReadStatement q cq range singular (iPreferCount apiRequest) (contentType == TextCSV)- if range == Just emptyRange+ if range == emptyRange then return $ errResponse status416 "HTTP Range error" else do row <- H.maybeEx stm@@ -87,7 +89,7 @@ then responseLBS status404 [] "" else responseLBS status200 [contentTypeH] (fromMaybe "{}" body) else do- let frm = fromMaybe 0 $ rangeOffset <$> range+ let frm = rangeOffset range to = frm+queryTotal-1 contentRange = contentRangeH frm to tableTotal status = rangeStatus frm to tableTotal@@ -104,14 +106,14 @@ ) ] (fromMaybe "[]" body) - (ActionCreate, TargetIdent (QualifiedIdentifier _ table),+ (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON (UniformObjects rows))) ->- case queries of+ case mutateSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do let isSingle = (==1) $ V.length rows let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?- let stm = createWriteStatement sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload+ let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload row <- H.maybeEx stm let (_, _, location, body) = extractQueryResult row return $ responseLBS status201@@ -119,28 +121,28 @@ contentTypeH, (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location)) ]- $ if iPreferRepresentation apiRequest then fromMaybe "[]" body else ""+ $ if iPreferRepresentation apiRequest == Full then fromMaybe "[]" body else "" - (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON _)) ->- case queries of+ (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON _)) ->+ case mutateSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do- let stm = createWriteStatement sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload+ let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload row <- H.maybeEx stm let (_, queryTotal, _, body) = extractQueryResult row r = contentRangeH 0 (queryTotal-1) (Just queryTotal) s = case () of _ | queryTotal == 0 -> status404- | iPreferRepresentation apiRequest -> status200+ | iPreferRepresentation apiRequest == Full -> status200 | otherwise -> status204 return $ responseLBS s [contentTypeH, r]- $ if iPreferRepresentation apiRequest then fromMaybe "[]" body else ""+ $ if iPreferRepresentation apiRequest == Full then fromMaybe "[]" body else "" - (ActionDelete, TargetIdent _, Nothing) ->- case queries of+ (ActionDelete, TargetIdent qi, Nothing) ->+ case mutateSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do let fakeload = PayloadJSON $ UniformObjects V.empty- let stm = createWriteStatement sq mq False False [] (contentType == TextCSV) fakeload+ let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload row <- H.maybeEx stm let (_, queryTotal, _, _) = extractQueryResult row return $ if queryTotal == 0@@ -196,9 +198,13 @@ allOrigins = ("Access-Control-Allow-Origin", "*") :: Header schema = cs $ configSchema conf apiRequest = userApiRequest schema req reqBody- selectQuery = requestToQuery schema <$> (DbRead <$> buildReadRequest (dbRelations dbStructure) apiRequest)- mutateQuery = requestToQuery schema <$> (DbMutate <$> buildMutateRequest apiRequest)- queries = (,) <$> selectQuery <*> mutateQuery+ readDbRequest = DbRead <$> buildReadRequest (dbRelations dbStructure) apiRequest+ mutateDbRequest = DbMutate <$> buildMutateRequest apiRequest+ selectQuery = requestToQuery schema <$> readDbRequest+ countQuery = requestToCountQuery schema <$> readDbRequest+ mutateQuery = requestToQuery schema <$> mutateDbRequest+ readSqlParts = (,) <$> selectQuery <*> countQuery+ mutateSqlParts = (,) <$> selectQuery <*> mutateQuery rangeStatus :: Int -> Int -> Maybe Int -> Status rangeStatus _ _ Nothing = status200@@ -258,7 +264,7 @@ rootName = if action == ActionRead then rootTableName- else sourceSubqueryName+ else sourceCTEName filters = if action == ActionRead then iFilters apiRequest else filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update@@ -313,9 +319,9 @@ -- as just another table that has relations with other tables toSourceRelation :: TableName -> Relation -> Maybe Relation toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)- | mt == tableName t = Just $ r {relTable=t {tableName=sourceSubqueryName}}- | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceSubqueryName}}- | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceSubqueryName}) <$> rt}+ | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}+ | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}+ | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt} | otherwise = Nothing data TableOptions = TableOptions {
src/PostgREST/Config.hs view
@@ -30,6 +30,7 @@ import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) import Options.Applicative import Paths_postgrest (version)+import Safe (readMay) import Web.JWT (Secret, secret) import Prelude @@ -41,6 +42,7 @@ , configSchema :: String , configJwtSecret :: Secret , configPool :: Int+ , configMaxRows :: Maybe Int } argParser :: Parser AppConfig@@ -49,10 +51,11 @@ <*> option auto (long "port" <> short 'p' <> help "port number on which to run HTTP server" <> metavar "PORT" <> value 3000 <> showDefault) <*> strOption (long "anonymous" <> short 'a' <> help "postgres role to use for non-authenticated requests" <> metavar "ROLE")- <*> strOption (long "schema" <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "1" <> showDefault)+ <*> strOption (long "schema" <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "public" <> showDefault) <*> (secret . cs <$> strOption (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault)) <*> option auto (long "pool" <> short 'o' <> help "max connections in database pool" <> metavar "COUNT" <> value 10 <> showDefault)+ <*> (readMay <$> strOption (long "max-rows" <> short 'm' <> help "max rows in response" <> metavar "COUNT" <> value "infinity" <> showDefault)) defaultCorsPolicy :: CorsResourcePolicy defaultCorsPolicy = CorsResourcePolicy Nothing
src/PostgREST/DbStructure.hs view
@@ -202,6 +202,98 @@ info.column_default AS default_value, array_to_string(enum_info.vals, ',') AS enum FROM (+ /*+ -- CTE based on information_schema.columns to remove the owner filter+ */+ WITH columns AS (+ SELECT current_database()::information_schema.sql_identifier AS table_catalog,+ nc.nspname::information_schema.sql_identifier AS table_schema,+ c.relname::information_schema.sql_identifier AS table_name,+ a.attname::information_schema.sql_identifier AS column_name,+ a.attnum::information_schema.cardinal_number AS ordinal_position,+ pg_get_expr(ad.adbin, ad.adrelid)::information_schema.character_data AS column_default,+ CASE+ WHEN a.attnotnull OR t.typtype = 'd'::"char" AND t.typnotnull THEN 'NO'::text+ ELSE 'YES'::text+ END::information_schema.yes_or_no AS is_nullable,+ CASE+ WHEN t.typtype = 'd'::"char" THEN+ CASE+ WHEN bt.typelem <> 0::oid AND bt.typlen = (-1) THEN 'ARRAY'::text+ WHEN nbt.nspname = 'pg_catalog'::name THEN format_type(t.typbasetype, NULL::integer)+ ELSE 'USER-DEFINED'::text+ END+ ELSE+ CASE+ WHEN t.typelem <> 0::oid AND t.typlen = (-1) THEN 'ARRAY'::text+ WHEN nt.nspname = 'pg_catalog'::name THEN format_type(a.atttypid, NULL::integer)+ ELSE 'USER-DEFINED'::text+ END+ END::information_schema.character_data AS data_type,+ information_schema._pg_char_max_length(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS character_maximum_length,+ information_schema._pg_char_octet_length(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS character_octet_length,+ information_schema._pg_numeric_precision(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_precision,+ information_schema._pg_numeric_precision_radix(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_precision_radix,+ information_schema._pg_numeric_scale(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_scale,+ information_schema._pg_datetime_precision(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS datetime_precision,+ information_schema._pg_interval_type(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.character_data AS interval_type,+ NULL::integer::information_schema.cardinal_number AS interval_precision,+ NULL::character varying::information_schema.sql_identifier AS character_set_catalog,+ NULL::character varying::information_schema.sql_identifier AS character_set_schema,+ NULL::character varying::information_schema.sql_identifier AS character_set_name,+ CASE+ WHEN nco.nspname IS NOT NULL THEN current_database()+ ELSE NULL::name+ END::information_schema.sql_identifier AS collation_catalog,+ nco.nspname::information_schema.sql_identifier AS collation_schema,+ co.collname::information_schema.sql_identifier AS collation_name,+ CASE+ WHEN t.typtype = 'd'::"char" THEN current_database()+ ELSE NULL::name+ END::information_schema.sql_identifier AS domain_catalog,+ CASE+ WHEN t.typtype = 'd'::"char" THEN nt.nspname+ ELSE NULL::name+ END::information_schema.sql_identifier AS domain_schema,+ CASE+ WHEN t.typtype = 'd'::"char" THEN t.typname+ ELSE NULL::name+ END::information_schema.sql_identifier AS domain_name,+ current_database()::information_schema.sql_identifier AS udt_catalog,+ COALESCE(nbt.nspname, nt.nspname)::information_schema.sql_identifier AS udt_schema,+ COALESCE(bt.typname, t.typname)::information_schema.sql_identifier AS udt_name,+ NULL::character varying::information_schema.sql_identifier AS scope_catalog,+ NULL::character varying::information_schema.sql_identifier AS scope_schema,+ NULL::character varying::information_schema.sql_identifier AS scope_name,+ NULL::integer::information_schema.cardinal_number AS maximum_cardinality,+ a.attnum::information_schema.sql_identifier AS dtd_identifier,+ 'NO'::character varying::information_schema.yes_or_no AS is_self_referencing,+ 'NO'::character varying::information_schema.yes_or_no AS is_identity,+ NULL::character varying::information_schema.character_data AS identity_generation,+ NULL::character varying::information_schema.character_data AS identity_start,+ NULL::character varying::information_schema.character_data AS identity_increment,+ NULL::character varying::information_schema.character_data AS identity_maximum,+ NULL::character varying::information_schema.character_data AS identity_minimum,+ NULL::character varying::information_schema.yes_or_no AS identity_cycle,+ 'NEVER'::character varying::information_schema.character_data AS is_generated,+ NULL::character varying::information_schema.character_data AS generation_expression,+ CASE+ WHEN c.relkind = 'r'::"char" OR (c.relkind = ANY (ARRAY['v'::"char", 'f'::"char"])) AND pg_column_is_updatable(c.oid::regclass, a.attnum, false) THEN 'YES'::text+ ELSE 'NO'::text+ END::information_schema.yes_or_no AS is_updatable+ FROM pg_attribute a+ LEFT JOIN pg_attrdef ad ON a.attrelid = ad.adrelid AND a.attnum = ad.adnum+ JOIN (pg_class c+ JOIN pg_namespace nc ON c.relnamespace = nc.oid) ON a.attrelid = c.oid+ JOIN (pg_type t+ JOIN pg_namespace nt ON t.typnamespace = nt.oid) ON a.atttypid = t.oid+ LEFT JOIN (pg_type bt+ JOIN pg_namespace nbt ON bt.typnamespace = nbt.oid) ON t.typtype = 'd'::"char" AND t.typbasetype = bt.oid+ LEFT JOIN (pg_collation co+ JOIN pg_namespace nco ON co.collnamespace = nco.oid) ON a.attcollation = co.oid AND (nco.nspname <> 'pg_catalog'::name OR co.collname <> 'default'::name)+ WHERE NOT pg_is_other_temp_schema(nc.oid) AND a.attnum > 0 AND NOT a.attisdropped AND (c.relkind = ANY (ARRAY['r'::"char", 'v'::"char", 'f'::"char"]))+ /*--AND (pg_has_role(c.relowner, 'USAGE'::text) OR has_column_privilege(c.oid, a.attnum, 'SELECT, INSERT, UPDATE, REFERENCES'::text))*/+ ) SELECT table_schema, table_name,@@ -214,7 +306,8 @@ numeric_precision, column_default, udt_name- FROM information_schema.columns+ /*-- FROM information_schema.columns*/+ FROM columns WHERE table_schema NOT IN ('pg_catalog', 'information_schema') ) AS info LEFT OUTER JOIN (@@ -276,33 +369,118 @@ relationFromRow :: [Table] -> [Column] -> (Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) =- if isJust table && isJust tableF && length cols == length rcs && length colsF == length frcs- then Just $ Relation (fromJust table) cols (fromJust tableF) colsF Child Nothing Nothing Nothing- else Nothing+ Relation <$> table <*> cols <*> tableF <*> colsF <*> pure Child <*> pure Nothing <*> pure Nothing <*> pure Nothing where findTable s t = find (\tbl -> tableSchema tbl == s && tableName tbl == t) allTabs- findCols s t cs = filter (\col -> tableSchema (colTable col) == s && tableName (colTable col) == t && colName col `elem` cs) allCols+ findCol s t c = find (\col -> tableSchema (colTable col) == s && tableName (colTable col) == t && colName col == c) allCols table = findTable rs rt tableF = findTable frs frt- cols = findCols rs rt rcs- colsF = findCols frs frt frcs+ cols = mapM (findCol rs rt) rcs+ colsF = mapM (findCol frs frt) frcs allPrimaryKeys :: [Table] -> H.Tx P.Postgres s [PrimaryKey] allPrimaryKeys tabs = 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')+ /*+ -- CTE to replace information_schema.table_constraints to remove owner limit+ */+ WITH tc AS (+ SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,+ nc.nspname::information_schema.sql_identifier AS constraint_schema,+ c.conname::information_schema.sql_identifier AS constraint_name,+ current_database()::information_schema.sql_identifier AS table_catalog,+ nr.nspname::information_schema.sql_identifier AS table_schema,+ r.relname::information_schema.sql_identifier AS table_name,+ CASE c.contype+ WHEN 'c'::"char" THEN 'CHECK'::text+ WHEN 'f'::"char" THEN 'FOREIGN KEY'::text+ WHEN 'p'::"char" THEN 'PRIMARY KEY'::text+ WHEN 'u'::"char" THEN 'UNIQUE'::text+ ELSE NULL::text+ END::information_schema.character_data AS constraint_type,+ CASE+ WHEN c.condeferrable THEN 'YES'::text+ ELSE 'NO'::text+ END::information_schema.yes_or_no AS is_deferrable,+ CASE+ WHEN c.condeferred THEN 'YES'::text+ ELSE 'NO'::text+ END::information_schema.yes_or_no AS initially_deferred+ FROM pg_namespace nc,+ pg_namespace nr,+ pg_constraint c,+ pg_class r+ WHERE nc.oid = c.connamespace AND nr.oid = r.relnamespace AND c.conrelid = r.oid AND (c.contype <> ALL (ARRAY['t'::"char", 'x'::"char"])) AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)+ /*--AND (pg_has_role(r.relowner, 'USAGE'::text) OR has_table_privilege(r.oid, 'INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR has_any_column_privilege(r.oid, 'INSERT, UPDATE, REFERENCES'::text))*/+ UNION ALL+ SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,+ nr.nspname::information_schema.sql_identifier AS constraint_schema,+ (((((nr.oid::text || '_'::text) || r.oid::text) || '_'::text) || a.attnum::text) || '_not_null'::text)::information_schema.sql_identifier AS constraint_name,+ current_database()::information_schema.sql_identifier AS table_catalog,+ nr.nspname::information_schema.sql_identifier AS table_schema,+ r.relname::information_schema.sql_identifier AS table_name,+ 'CHECK'::character varying::information_schema.character_data AS constraint_type,+ 'NO'::character varying::information_schema.yes_or_no AS is_deferrable,+ 'NO'::character varying::information_schema.yes_or_no AS initially_deferred+ FROM pg_namespace nr,+ pg_class r,+ pg_attribute a+ WHERE nr.oid = r.relnamespace AND r.oid = a.attrelid AND a.attnotnull AND a.attnum > 0 AND NOT a.attisdropped AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)+ /*--AND (pg_has_role(r.relowner, 'USAGE'::text) OR has_table_privilege(r.oid, 'INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR has_any_column_privilege(r.oid, 'INSERT, UPDATE, REFERENCES'::text))*/+ ),+ /*+ -- CTE to replace information_schema.key_column_usage to remove owner limit+ */+ kc AS (+ SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,+ ss.nc_nspname::information_schema.sql_identifier AS constraint_schema,+ ss.conname::information_schema.sql_identifier AS constraint_name,+ current_database()::information_schema.sql_identifier AS table_catalog,+ ss.nr_nspname::information_schema.sql_identifier AS table_schema,+ ss.relname::information_schema.sql_identifier AS table_name,+ a.attname::information_schema.sql_identifier AS column_name,+ (ss.x).n::information_schema.cardinal_number AS ordinal_position,+ CASE+ WHEN ss.contype = 'f'::"char" THEN information_schema._pg_index_position(ss.conindid, ss.confkey[(ss.x).n])+ ELSE NULL::integer+ END::information_schema.cardinal_number AS position_in_unique_constraint+ FROM pg_attribute a,+ ( SELECT r.oid AS roid,+ r.relname,+ r.relowner,+ nc.nspname AS nc_nspname,+ nr.nspname AS nr_nspname,+ c.oid AS coid,+ c.conname,+ c.contype,+ c.conindid,+ c.confkey,+ c.confrelid,+ information_schema._pg_expandarray(c.conkey) AS x+ FROM pg_namespace nr,+ pg_class r,+ pg_namespace nc,+ pg_constraint c+ WHERE nr.oid = r.relnamespace AND r.oid = c.conrelid AND nc.oid = c.connamespace AND (c.contype = ANY (ARRAY['p'::"char", 'u'::"char", 'f'::"char"])) AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)) ss+ WHERE ss.roid = a.attrelid AND a.attnum = (ss.x).x AND NOT a.attisdropped+ /*--AND (pg_has_role(ss.relowner, 'USAGE'::text) OR has_column_privilege(ss.roid, a.attnum, 'SELECT, INSERT, UPDATE, REFERENCES'::text))*/+ )+ SELECT+ kc.table_schema,+ kc.table_name,+ kc.column_name+ FROM+ /*+ --information_schema.table_constraints tc,+ --information_schema.key_column_usage kc+ */+ tc, 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 $ mapMaybe (pkFromRow tabs) pks @@ -314,32 +492,65 @@ allSynonyms allCols = do syns <- H.listEx $ [H.stmt| WITH synonyms AS (+ /*+ -- CTE to replace the view from information_schema because the information in it depended on the logged in role+ -- notice the commented line+ */+ WITH view_column_usage AS (+ SELECT DISTINCT+ CAST(current_database() AS character varying) AS view_catalog,+ CAST(nv.nspname AS character varying) AS view_schema,+ CAST(v.relname AS character varying) AS view_name,+ CAST(current_database() AS character varying) AS table_catalog,+ CAST(nt.nspname AS character varying) AS table_schema,+ CAST(t.relname AS character varying) AS table_name,+ CAST(a.attname AS character varying) AS column_name+ FROM pg_namespace nv, pg_class v, pg_depend dv,+ pg_depend dt, pg_class t, pg_namespace nt,+ pg_attribute a+ WHERE nv.oid = v.relnamespace+ AND v.relkind = 'v'+ AND v.oid = dv.refobjid+ AND dv.refclassid = 'pg_catalog.pg_class'::regclass+ AND dv.classid = 'pg_catalog.pg_rewrite'::regclass+ AND dv.deptype = 'i'+ AND dv.objid = dt.objid+ AND dv.refobjid <> dt.refobjid+ AND dt.classid = 'pg_catalog.pg_rewrite'::regclass+ AND dt.refclassid = 'pg_catalog.pg_class'::regclass+ AND dt.refobjid = t.oid+ AND t.relnamespace = nt.oid+ AND t.relkind IN ('r', 'v', 'f')+ AND t.oid = a.attrelid+ AND dt.refobjsubid = a.attnum+ /*--AND pg_has_role(t.relowner, 'USAGE')*/+ ) SELECT vcu.table_schema AS src_table_schema, vcu.table_name AS src_table_name, vcu.column_name AS src_column_name,- view.table_schema AS syn_table_schema,- view.table_name AS syn_table_name,- view.view_definition AS view_definition+ view.schemaname AS syn_table_schema,+ view.viewname AS syn_table_name,+ view.definition AS view_definition FROM- information_schema.views AS view,- information_schema.view_column_usage AS vcu+ pg_catalog.pg_views AS view,+ view_column_usage AS vcu WHERE- view.table_schema = vcu.view_schema AND- view.table_name = vcu.view_name AND- view.table_schema NOT IN ('pg_catalog', 'information_schema') AND- (SELECT COUNT(*) FROM information_schema.view_table_usage WHERE view_schema = view.table_schema AND view_name = view.table_name) = 1+ view.schemaname = vcu.view_schema AND+ view.viewname = vcu.view_name AND+ view.schemaname NOT IN ('pg_catalog', 'information_schema')+ /*--AND (SELECT COUNT(*) FROM information_schema.view_table_usage WHERE view_schema = view.schemaname AND view_name = view.viewname) = 1*/ ) SELECT src_table_schema, src_table_name, src_column_name, syn_table_schema, syn_table_name,- (regexp_matches(view_definition, CONCAT('\.(', src_column_name, ')(?=,|$)'), 'gn'))[1]+ (regexp_matches(view_definition, CONCAT('\.(', src_column_name, ')(?=,|$)'), 'gn'))[1] AS syn_column_name FROM synonyms UNION ( SELECT src_table_schema, src_table_name, src_column_name, syn_table_schema, syn_table_name,- (regexp_matches(view_definition, CONCAT('\.', src_column_name, '\sAS\s("?)(.+?)\1(,|$)'), 'gn'))[2] /* " <- for syntax highlighting */+ (regexp_matches(view_definition, CONCAT('\.', src_column_name, '\sAS\s("?)(.+?)\1(,|$)'), 'gn'))[2] AS syn_column_name /* " <- for syntax highlighting */ FROM synonyms ) |]
src/PostgREST/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Main where @@ -6,17 +8,18 @@ minimumPgVersion, prettyVersion, readOptions)-import PostgREST.Error (pgErrResponse, PgError)-import PostgREST.Middleware import PostgREST.DbStructure+import PostgREST.Error (PgError, pgErrResponse)+import PostgREST.Middleware -import Control.Monad (unless)+import Control.Monad (unless, void) import Control.Monad.IO.Class (liftIO) import Data.Aeson (encode) import Data.Functor.Identity import Data.Monoid ((<>)) import Data.String.Conversions (cs) import Data.Text (Text)+import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Hasql as H import qualified Hasql.Postgres as P import Network.Wai@@ -27,6 +30,12 @@ stdin, stdout) import Web.JWT (secret) +#ifndef mingw32_HOST_OS+import System.Posix.Signals+import Control.Concurrent (myThreadId)+import Control.Exception.Base (throwTo, AsyncException(..))+#endif+ isServerVersionSupported :: H.Session P.Postgres IO Bool isServerVersionSupported = do Identity (row :: Text) <- H.tx Nothing $ H.singleEx [H.stmt|SHOW server_version_num|]@@ -68,12 +77,21 @@ <> show minimumPgVersion) ) supportedOrError +#ifndef mingw32_HOST_OS+ tid <- myThreadId+ void $ installHandler keyboardSignal (Catch $ do+ H.releasePool pool+ throwTo tid UserInterrupt+ ) Nothing+#endif+ let txSettings = Just (H.ReadCommitted, Just True) dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema conf) dbStructure <- either hasqlError return dbOrError runSettings appSettings $ middle $ \ req respond -> do+ time <- getPOSIXTime body <- strictRequestBody req resOrError <- liftIO $ H.session pool $ H.tx txSettings $- runWithClaims conf (app dbStructure conf body) req+ runWithClaims conf time (app dbStructure conf body) req either (respond . pgErrResponse) respond resOrError
src/PostgREST/Middleware.hs view
@@ -6,7 +6,7 @@ import Data.Maybe (fromMaybe) import Data.Text import Data.String.Conversions (cs)-import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Time.Clock (NominalDiffTime) import qualified Hasql as H import qualified Hasql.Postgres as P @@ -23,20 +23,17 @@ import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Error (errResponse) -import System.IO.Unsafe (unsafePerformIO)- import Prelude hiding(concat) import qualified Data.Vector as V import qualified Hasql.Backend as B import qualified Data.Map.Lazy as M -runWithClaims :: forall s. AppConfig ->+runWithClaims :: forall s. AppConfig -> NominalDiffTime -> (Request -> H.Tx P.Postgres s Response) -> Request -> H.Tx P.Postgres s Response-runWithClaims conf app req = do+runWithClaims conf time app req = do _ <- H.unitEx $ stmt setAnon- let time = unsafePerformIO getPOSIXTime case split (== ' ') (cs auth) of ("Bearer" : tokenStr : _) -> case jwtClaims jwtSecret tokenStr time of
src/PostgREST/QueryBuilder.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Module : PostgREST.QueryBuilder@@ -22,7 +23,8 @@ , pgFmtIdent , pgFmtLit , requestToQuery- , sourceSubqueryName+ , requestToCountQuery+ , sourceCTEName , unquoted ) where @@ -34,14 +36,14 @@ import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset) import Control.Error (note, fromMaybe, mapMaybe)-import Control.Monad (join) import qualified Data.HashMap.Strict as HM-import Data.List (find)+import Data.List (find, (\\)) import Data.Monoid ((<>)) import Data.Text (Text, intercalate, unwords, replace, isInfixOf, toLower, split) import qualified Data.Text as T (map, takeWhile) import Data.String.Conversions (cs) import Control.Applicative (empty, (<|>))+import Control.Monad (join) import Data.Tree (Tree(..)) import qualified Data.Vector as V import PostgREST.Types@@ -53,6 +55,7 @@ , isInteger ) import Prelude hiding (unwords)+import PostgREST.ApiRequest (PreferRepresentation (..)) type PStmt = H.Stmt P.Postgres instance Monoid PStmt where@@ -61,54 +64,88 @@ mempty = B.Stmt "" empty True type StatementT = PStmt -> PStmt -createReadStatement :: SqlQuery -> Maybe NonnegRange -> Bool -> Bool -> Bool -> B.Stmt P.Postgres-createReadStatement selectQuery range isSingle countTable asCsv =+createReadStatement :: SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool -> B.Stmt P.Postgres+createReadStatement selectQuery countQuery range isSingle countTotal asCsv = B.Stmt (- wrapQuery selectQuery [- if countTable then countAllF else countNoneF,- countF,- "null", -- location header can not be calucalted- if asCsv- then asCsvF- else if isSingle then asJsonSingleF else asJsonF- ] selectStarF range+ "WITH " <> sourceCTEName <> " AS (" <> selectQuery <> ") " <>+ "SELECT " <> intercalate ", " [+ countResultF <> " AS total_result_set",+ "pg_catalog.count(t) AS page_total",+ "null AS header",+ bodyF <> " AS body"+ ] <>+ " FROM ( SELECT * FROM " <> sourceCTEName <> " " <> limitF range <> ") t" ) V.empty True+ where+ countResultF = if countTotal then "("<>countQuery<>")" else "null"+ bodyF+ | asCsv = asCsvF+ | isSingle = asJsonSingleF+ | otherwise = asJsonF -createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool ->+createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool -> PreferRepresentation -> [Text] -> Bool -> Payload -> B.Stmt P.Postgres-createWriteStatement _ _ _ _ _ _ (PayloadParseError _) = undefined-createWriteStatement selectQuery mutateQuery isSingle echoRequested- pKeys asCsv (PayloadJSON (UniformObjects rows)) =+createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined+createWriteStatement _ _ mutateQuery _ None+ _ _ (PayloadJSON (UniformObjects rows)) = B.Stmt (- wrapQuery mutateQuery [- countNoneF, -- when updateing it does not make sense- countF,+ "WITH " <> sourceCTEName <> " AS (" <> mutateQuery <> ") " <>+ "SELECT null, 0, null, null"+ ) (V.singleton . B.encodeValue . JSON.Array . V.map JSON.Object $ rows) True+createWriteStatement qi _ mutateQuery isSingle HeadersOnly+ pKeys _ (PayloadJSON (UniformObjects rows)) =+ B.Stmt (+ "WITH " <> sourceCTEName <> " AS (" <> mutateQuery <> " RETURNING " <> fromQi qi <> ".*" <> ") " <>+ "SELECT " <> intercalate ", " [+ "null AS total_result_set",+ "pg_catalog.count(t) AS page_total", if isSingle then locationF pKeys else "null",- if echoRequested- then- if asCsv- then asCsvF- else if isSingle then asJsonSingleF else asJsonF- else "null"-- ] selectQuery Nothing+ "null"+ ] <>+ " FROM (SELECT 1 FROM " <> sourceCTEName <> ") t" ) (V.singleton . B.encodeValue . JSON.Array . V.map JSON.Object $ rows) True+createWriteStatement qi selectQuery mutateQuery isSingle Full+ pKeys asCsv (PayloadJSON (UniformObjects rows)) =+ B.Stmt (+ "WITH " <> sourceCTEName <> " AS (" <> mutateQuery <> " RETURNING " <> fromQi qi <> ".*" <> ") " <>+ "SELECT " <> intercalate ", " [+ "null AS total_result_set", -- when updateing it does not make sense+ "pg_catalog.count(t) AS page_total",+ if isSingle then locationF pKeys else "null" <> " AS header",+ bodyF <> " AS body"+ ] <>+ " FROM ( "<>selectQuery<>") t"+ ) (V.singleton . B.encodeValue . JSON.Array . V.map JSON.Object $ rows) True+ where+ bodyF+ | asCsv = asCsvF+ | isSingle = asJsonSingleF+ | otherwise = asJsonF addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest-addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) =+addRelations schema allRelations parentNode node@(Node readNode@(query, (name, _)) forest) = case parentNode of- Nothing -> Node (query, (table, Nothing)) <$> updatedForest- (Just (Node (_, (parentTable, _)) _)) -> Node <$> (addRel n <$> rel) <*> updatedForest+ (Just (Node (Select{from=[parentTable]}, (_, _)) _)) -> Node <$> (addRel readNode <$> rel) <*> updatedForest where- rel = note ("no relation between " <> table <> " and " <> parentTable)- $ findRelation schema table parentTable- <|> findRelation schema parentTable table+ rel = note ("no relation between " <> parentTable <> " and " <> name)+ $ findRelationByTable schema name parentTable+ <|> findRelationByTable schema parentTable name+ <|> findRelationByColumn schema parentTable name addRel :: (ReadQuery, (NodeName, Maybe Relation)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation))- addRel (q, (t, _)) r = (q, (t, Just r))+ addRel (q, (n, _)) r = (q {from=fromRelation}, (n, Just r))+ where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from q)++ _ -> Node (query, (name, Nothing)) <$> updatedForest where updatedForest = mapM (addRelations schema allRelations (Just node)) forest- findRelation s t1 t2 =- find (\r -> s == (tableSchema . relTable) r && t1 == (tableName . relTable) r && t2 == (tableName . relFTable) r) allRelations+ -- Searches through all the relations and returns a match given the parameter conditions.+ -- Will only find a relation where both schemas are in the PostgREST schema.+ -- `findRelationByColumn` also does a ducktype check to see if the column name has any variation of `id` or `fk`. If so then the relation is returned as a match.+ findRelationByTable s t1 t2 =+ find (\r -> s == tableSchema (relTable r) && s == tableSchema (relFTable r) && t1 == tableName (relTable r) && t2 == tableName (relFTable r)) allRelations+ findRelationByColumn s t c =+ find (\r -> s == tableSchema (relTable r) && s == tableSchema (relFTable r) && t == tableName (relFTable r) && length (relFColumns r) == 1 && c `colMatches` (colName . head . relFColumns) r) allRelations+ where n `colMatches` rc = (cs ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (cs n :: BS.ByteString) addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest addJoinConditions schema (Node (query, (n, r)) forest) =@@ -166,12 +203,7 @@ ] pgFmtIdent :: SqlFragment -> SqlFragment-pgFmtIdent x =- let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in- if (cs escaped :: BS.ByteString) =~ danger- then "\"" <> escaped <> "\""- else escaped- where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString+pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ cs x) <> "\"" pgFmtLit :: SqlFragment -> SqlFragment pgFmtLit x =@@ -182,44 +214,79 @@ then "E" <> slashed else slashed +requestToCountQuery :: Schema -> DbRequest -> SqlQuery+requestToCountQuery _ (DbMutate _) = undefined+requestToCountQuery schema (DbRead (Node (Select _ _ conditions _, (mainTbl, _)) _)) =+ unwords [+ "SELECT pg_catalog.count(1)",+ "FROM ", fromQi $ QualifiedIdentifier schema mainTbl,+ ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions+ ]+ where+ fn (Filter{value=VText _}) = True+ fn (Filter{value=VForeignKey _ _}) = False+ localConditions = filter fn conditions+ requestToQuery :: Schema -> DbRequest -> SqlQuery requestToQuery _ (DbMutate (Insert _ (PayloadParseError _))) = undefined requestToQuery _ (DbMutate (Update _ (PayloadParseError _) _)) = undefined-requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest)) =+requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (nodeName, maybeRelation)) forest)) = query where -- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name -- of our WITH query part- tblSchema tbl = if tbl == sourceSubqueryName then "" else schema+ mainTbl = fromMaybe nodeName (tableName . relTable <$> maybeRelation)+ tblSchema tbl = if tbl == sourceCTEName then "" else schema qi = QualifiedIdentifier (tblSchema mainTbl) mainTbl toQi t = QualifiedIdentifier (tblSchema t) t query = unwords [- ("WITH " <> intercalate ", " (map fst withs)) `emptyOnNull` withs, "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),- "FROM ", intercalate ", " (map (fromQi . toQi) tbls ++ map snd withs),- ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,+ "FROM ", intercalate ", " (map (fromQi . toQi) tbls),+ unwords (map joinStr joins),+ ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) localConditions )) `emptyOnNull` localConditions, orderF (fromMaybe [] ord) ]- (withs, selects) = foldr getQueryParts ([],[]) forest- getQueryParts :: Tree ReadNode -> ([(SqlFragment, Text)], [SqlFragment]) -> ([(SqlFragment,Text)], [SqlFragment])- getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s)+ orderF ts =+ if null ts+ then ""+ else "ORDER BY " <> clause+ where+ clause = intercalate "," (map queryTerm ts)+ queryTerm :: OrderTerm -> Text+ queryTerm t = " "+ <> cs (pgFmtColumn qi $ otTerm t) <> " "+ <> (cs.show) (otDirection t) <> " "+ <> maybe "" (cs.show) (otNullOrder t) <> " "+ (joins, selects) = foldr getQueryParts ([],[]) forest+ parentTables = map snd joins+ parentConditions = join $ map (( `filter` conditions ) . filterParentConditions) parentTables+ localConditions = conditions \\ parentConditions+ joinStr :: (SqlFragment, TableName) -> SqlFragment+ joinStr (sql, t) = "LEFT OUTER JOIN " <> sql <> " ON " <>+ intercalate " AND " ( map (pgFmtCondition qi ) joinConditions ) where- sel = "("+ joinConditions = filter (filterParentConditions t) conditions+ filterParentConditions parentTable (Filter _ _ (VForeignKey (QualifiedIdentifier "" t) _)) = parentTable == t+ filterParentConditions _ _ = False+ getQueryParts :: Tree ReadNode -> ([(SqlFragment, TableName)], [SqlFragment]) -> ([(SqlFragment,TableName)], [SqlFragment])+ getQueryParts (Node n@(_, (name, Just (Relation {relType=Child,relTable=Table{tableName=table}}))) forst) (j,s) = (j,sel:s)+ where+ sel = "COALESCE((" <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " <> "FROM (" <> subquery <> ") " <> table- <> ") AS " <> table+ <> "), '[]') AS " <> pgFmtIdent name where subquery = requestToQuery schema (DbRead (Node n forst))- getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s)+ getQueryParts (Node n@(_, (name, Just (Relation {relType=Parent,relTable=Table{tableName=table}}))) forst) (j,s) = (joi:j,sel:s) where- sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular- wit = (table <> " AS ( " <> subquery <> " )", table)+ sel = "row_to_json(" <> table <> ".*) AS "<>pgFmtIdent name --TODO must be singular+ joi = ("( " <> subquery <> " ) AS " <> table, table) where subquery = requestToQuery schema (DbRead (Node n forst))- getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s)+ getQueryParts (Node n@(_, (name, Just (Relation {relType=Many,relTable=Table{tableName=table}}))) forst) (j,s) = (j,sel:s) where- sel = "("+ sel = "COALESCE ((" <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " <> "FROM (" <> subquery <> ") " <> table- <> ") AS " <> table+ <> "), '[]') AS " <> pgFmtIdent name where subquery = requestToQuery schema (DbRead (Node n forst)) --the following is just to remove the warning --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only@@ -233,8 +300,7 @@ "INSERT INTO ", fromQi qi, " (" <> colsString <> ")" <> " SELECT " <> colsString <>- " FROM json_populate_recordset(null::" , fromQi qi, ", ?)",- " RETURNING " <> fromQi qi <> ".*"+ " FROM json_populate_recordset(null::" , fromQi qi, ", ?)" ] requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) = case rows V.!? 0 of@@ -244,8 +310,7 @@ unwords [ "UPDATE ", fromQi qi, " SET " <> intercalate "," assignments <> " ",- ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,- "RETURNING " <> fromQi qi <> ".*"+ ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions ] Nothing -> undefined where@@ -257,12 +322,11 @@ qi = QualifiedIdentifier schema mainTbl query = unwords [ "DELETE FROM ", fromQi qi,- ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,- "RETURNING " <> fromQi qi <> ".*"+ ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions ] -sourceSubqueryName :: SqlFragment-sourceSubqueryName = "pg_source"+sourceCTEName :: SqlFragment+sourceCTEName = "pg_source" unquoted :: JSON.Value -> Text unquoted (JSON.String t) = t@@ -280,7 +344,7 @@ " FROM (" <> " SELECT json_object_keys(r)::TEXT as k" <> " FROM ( " <>- " SELECT row_to_json(hh) as r from " <> sourceSubqueryName <> " as hh limit 1" <>+ " SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <> " ) s" <> " ) a" <> ")"@@ -292,19 +356,10 @@ asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element asJsonSingleF = "string_agg(row_to_json(t)::text, ',')::character varying " -countAllF :: SqlFragment-countAllF = "(SELECT pg_catalog.count(1) FROM (SELECT * FROM " <> sourceSubqueryName <> ") a )"--countF :: SqlFragment-countF = "pg_catalog.count(t)"--countNoneF :: SqlFragment-countNoneF = "null"- locationF :: [Text] -> SqlFragment locationF pKeys = "(" <>- " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceSubqueryName <> " as ss limit 1)" <>+ " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceCTEName <> " as ss limit 1)" <> " SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <> " FROM s, json_each_text(s.r) AS json_data" <> (@@ -314,6 +369,12 @@ ) <> ")" +limitF :: NonnegRange -> SqlFragment+limitF r = "LIMIT " <> limit <> " OFFSET " <> offset+ where+ limit = maybe "ALL" (cs . show) $ rangeLimit r+ offset = cs . show $ rangeOffset r+ fromQi :: QualifiedIdentifier -> SqlFragment fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n where@@ -337,19 +398,6 @@ emptyOnNull :: Text -> [a] -> Text emptyOnNull val x = if null x then "" else val -orderF :: [OrderTerm] -> SqlFragment-orderF ts =- if null ts- then ""- else "ORDER BY " <> clause- where- clause = intercalate "," (map queryTerm ts)- queryTerm :: OrderTerm -> Text- queryTerm t = " "- <> cs (pgFmtIdent $ otTerm t) <> " "- <> (cs.show) (otDirection t) <> " "- <> maybe "" (cs.show) (otNullOrder t) <> " "- insertableValue :: JSON.Value -> SqlFragment insertableValue JSON.Null = "null" insertableValue v = (<> "::unknown") . pgFmtLit $ unquoted v@@ -389,7 +437,7 @@ valToStr v = case v of VText s -> pgFmtValue opCode s VForeignKey (QualifiedIdentifier s _) (ForeignKey Column{colTable=Table{tableName=ft}, colName=fc}) -> pgFmtColumn qi fc- where qi = QualifiedIdentifier (if ft == sourceSubqueryName then "" else s) ft+ where qi = QualifiedIdentifier (if ft == sourceCTEName then "" else s) ft _ -> "" pgFmtValue :: Text -> Text -> SqlFragment@@ -421,26 +469,3 @@ trimNullChars :: Text -> Text trimNullChars = T.takeWhile (/= '\x0')--withSourceF :: SqlFragment -> SqlFragment-withSourceF s = "WITH " <> sourceSubqueryName <> " AS (" <> s <>")"--fromF :: SqlFragment -> SqlFragment -> SqlFragment-fromF sel limit = "FROM (" <> sel <> " " <> limit <> ") t"--limitF :: Maybe NonnegRange -> SqlFragment-limitF r = "LIMIT " <> limit <> " OFFSET " <> offset- where- limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r- offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r--selectStarF :: SqlFragment-selectStarF = "SELECT * FROM " <> sourceSubqueryName--wrapQuery :: SqlQuery -> [Text] -> Text -> Maybe NonnegRange -> SqlQuery-wrapQuery source selectColumns returnSelect range =- withSourceF source <>- " SELECT " <>- intercalate ", " selectColumns <>- " " <>- fromF returnSelect ( limitF range )
src/PostgREST/RangeQuery.hs view
@@ -3,6 +3,7 @@ , rangeRequested , rangeLimit , rangeOffset+, restrictRange , NonnegRange ) where @@ -25,20 +26,26 @@ type NonnegRange = Range Int -rangeParse :: BS.ByteString -> Maybe NonnegRange+rangeParse :: BS.ByteString -> NonnegRange rangeParse range = do let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString - parsedRange <- listToMaybe (range =~ rangeRegex :: [[BS.ByteString]])-- let [_, from, to] = readMaybe . cs <$> parsedRange- let lower = fromMaybe emptyRange (rangeGeq <$> from)- let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to)+ case listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) of+ Just parsedRange ->+ let [_, from, to] = readMaybe . cs <$> parsedRange+ lower = fromMaybe emptyRange (rangeGeq <$> from)+ upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to) in+ rangeIntersection lower upper+ Nothing -> rangeGeq 0 - return $ rangeIntersection lower upper+rangeRequested :: RequestHeaders -> NonnegRange+rangeRequested = rangeParse . fromMaybe "" . lookup hRange -rangeRequested :: RequestHeaders -> Maybe NonnegRange-rangeRequested = (rangeParse =<<) . lookup hRange+restrictRange :: Maybe Int -> NonnegRange -> NonnegRange+restrictRange Nothing r = r+restrictRange (Just limit) r =+ rangeIntersection r $+ Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1) rangeLimit :: NonnegRange -> Maybe Int rangeLimit range =
src/PostgREST/Types.hs view
@@ -106,10 +106,10 @@ type NodeName = Text type SelectItem = (Field, Maybe Cast) type Path = [Text]-data ReadQuery = Select { select::[SelectItem], from::[Text], flt_::[Filter], order::Maybe [OrderTerm] } deriving (Show, Eq)-data MutateQuery = Insert { in_::Text, qPayload::Payload }- | Delete { in_::Text, where_::[Filter] }- | Update { in_::Text, qPayload::Payload, where_::[Filter] } deriving (Show, Eq)+data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm] } deriving (Show, Eq)+data MutateQuery = Insert { in_::TableName, qPayload::Payload }+ | Delete { in_::TableName, where_::[Filter] }+ | Update { in_::TableName, qPayload::Payload, where_::[Filter] } deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) type ReadNode = (ReadQuery, (NodeName, Maybe Relation)) type ReadRequest = Tree ReadNode
test/Feature/AuthSpec.hs view
@@ -6,13 +6,15 @@ import Test.Hspec.Wai.JSON import Network.HTTP.Types +import Hasql as H+import Hasql.Postgres as P+ import SpecHelper+import PostgREST.Types (DbStructure(..)) -- }}} -spec :: Spec-spec = beforeAll- (clearTable "postgrest.auth") . afterAll_ (clearTable "postgrest.auth")- $ around withApp+spec :: DbStructure -> H.Pool P.Postgres -> Spec+spec struct pool = around (withApp cfgDefault struct pool) $ describe "authorization" $ do it "hides tables that anonymous does not own" $
test/Feature/CorsSpec.hs view
@@ -6,13 +6,17 @@ import Network.Wai.Test (SResponse(simpleHeaders, simpleBody)) import qualified Data.ByteString.Lazy as BL +import Hasql as H+import Hasql.Postgres as P+ import SpecHelper+import PostgREST.Types (DbStructure(..)) import Network.HTTP.Types -- }}} -spec :: Spec-spec = around withApp $ describe "CORS" $ do+spec :: DbStructure -> H.Pool P.Postgres -> Spec+spec struct pool = around (withApp cfgDefault struct pool) $ describe "CORS" $ do let preflightHeaders = [ ("Accept", "*/*"), ("Origin", "http://example.com"),
test/Feature/DeleteSpec.hs view
@@ -2,13 +2,19 @@ import Test.Hspec import Test.Hspec.Wai+import Text.Heredoc++import Hasql as H+import Hasql.Postgres as P+ import SpecHelper+import PostgREST.Types (DbStructure(..)) import Network.HTTP.Types -spec :: Spec-spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items")- . around withApp $+spec :: DbStructure -> H.Pool P.Postgres -> Spec+spec struct pool = beforeAll resetDb+ . around (withApp cfgDefault struct pool) $ describe "Deleting" $ do context "existing record" $ do it "succeeds with 204 and deletion count" $@@ -23,7 +29,7 @@ _ <- request methodDelete "/items?id=lt.15" [] "" get "/items" `shouldRespondWith` ResponseMatcher {- matchBody = Just "[{\"id\":15}]"+ matchBody = Just [str|[{"id":15}]|] , matchStatus = 200 , matchHeaders = ["Content-Range" <:> "0-0/1"] }
test/Feature/InsertSpec.hs view
@@ -5,7 +5,11 @@ import Test.Hspec.Wai.JSON import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus)) +import Hasql as H+import Hasql.Postgres as P+ import SpecHelper+import PostgREST.Types (DbStructure(..)) import qualified Data.Aeson as JSON import Data.Maybe (fromJust)@@ -16,8 +20,8 @@ import TestTypes(IncPK(..), CompoundPK(..)) -spec :: Spec-spec = afterAll_ resetDb $ around withApp $ do+spec :: DbStructure -> H.Pool P.Postgres -> Spec+spec struct pool = beforeAll_ resetDb $ around (withApp cfgDefault struct pool) $ do describe "Posting new record" $ do after_ (clearTable "menagerie") . context "disparate csv types" $ do it "accepts disparate json types" $ do@@ -45,10 +49,10 @@ it "includes related data after insert" $ request methodPost "/projects?select=id,name,clients{id,name}" [("Prefer", "return=representation")]- [str|{"id":5,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher {- matchBody = Just [str|{"id":5,"name":"New Project","clients":{"id":2,"name":"Apple"}}|]+ [str|{"id":6,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher {+ matchBody = Just [str|{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}|] , matchStatus = 201- , matchHeaders = ["Content-Type" <:> "application/json", "Location" <:> "/projects?id=eq.5"]+ , matchHeaders = ["Content-Type" <:> "application/json", "Location" <:> "/projects?id=eq.6"] } @@ -89,6 +93,15 @@ simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.bar&b=eq.baz" simpleStatus p `shouldBe` created201 + it "can insert in tables with no select privileges" $ do+ p <- request methodPost "/insertonly"+ [("Prefer", "return=minimal")]+ [json| { "v":"some value" } |]+ liftIO $ do+ simpleBody p `shouldBe` ""+ simpleStatus p `shouldBe` created201++ it "can post nulls" $ do p <- request methodPost "/no_pk" [("Prefer", "return=representation")]@@ -301,17 +314,16 @@ context "on an empty table" $ it "indicates no records found to update" $- request methodPatch "/simple_pk" []+ request methodPatch "/empty_table" [] [json| { "extra":20 } |] `shouldRespondWith` 404 - context "in a nonempty table" . before_ (clearTable "items" >> createItems 15) .- after_ (clearTable "items") $ do+ context "in a nonempty table" $ do it "can update a single item" $ do g <- get "/items?id=eq.42" liftIO $ simpleHeaders g `shouldSatisfy` matchHeader "Content-Range" "\\*/0"- request methodPatch "/items?id=eq.1" []+ request methodPatch "/items?id=eq.2" [] [json| { "id":42 } |] `shouldRespondWith` ResponseMatcher { matchBody = Nothing,
test/Feature/QuerySpec.hs view
@@ -6,23 +6,15 @@ import Network.HTTP.Types import Network.Wai.Test (SResponse(simpleHeaders)) +import Hasql as H+import Hasql.Postgres as P+ import SpecHelper+import PostgREST.Types (DbStructure(..)) import Text.Heredoc --spec :: Spec-spec =- beforeAll (clearTable "items" >> createItems 15)- . beforeAll clearProjectsTable- . beforeAll (clearTable "complex_items" >> createComplexItems)- . beforeAll (clearTable "nullable_integer" >> createNullInteger)- . beforeAll (- clearTable "no_pk" >>- createNulls 2 >>- createLikableStrings >>- createJsonData)- . afterAll_ (clearTable "items" >> clearTable "complex_items" >> clearTable "no_pk" >> clearTable "simple_pk")- . around withApp $ do+spec :: DbStructure -> H.Pool P.Postgres -> Spec+spec struct pool = around (withApp cfgDefault struct pool) $ do describe "Querying a table with a column called count" $ it "should not confuse count column with pg_catalog.count aggregate" $@@ -98,25 +90,25 @@ get "/no_pk?a=is.null" `shouldRespondWith` [json| [{"a": null, "b": null}] |] - get "/nullable_integer?a=is.null" `shouldRespondWith` "[{\"a\":null}]"+ get "/nullable_integer?a=is.null" `shouldRespondWith` [str|[{"a":null}]|] it "matches with like" $ do get "/simple_pk?k=like.*yx" `shouldRespondWith`- "[{\"k\":\"xyyx\",\"extra\":\"u\"}]"+ [str|[{"k":"xyyx","extra":"u"}]|] get "/simple_pk?k=like.xy*" `shouldRespondWith`- "[{\"k\":\"xyyx\",\"extra\":\"u\"}]"+ [str|[{"k":"xyyx","extra":"u"}]|] get "/simple_pk?k=like.*YY*" `shouldRespondWith`- "[{\"k\":\"xYYx\",\"extra\":\"v\"}]"+ [str|[{"k":"xYYx","extra":"v"}]|] it "matches with like using not operator" $ get "/simple_pk?k=not.like.*yx" `shouldRespondWith`- "[{\"k\":\"xYYx\",\"extra\":\"v\"}]"+ [str|[{"k":"xYYx","extra":"v"}]|] it "matches with ilike" $ do get "/simple_pk?k=ilike.xy*&order=extra.asc" `shouldRespondWith`- "[{\"k\":\"xyyx\",\"extra\":\"u\"},{\"k\":\"xYYx\",\"extra\":\"v\"}]"+ [str|[{"k":"xyyx","extra":"u"},{"k":"xYYx","extra":"v"}]|] get "/simple_pk?k=ilike.*YY*&order=extra.asc" `shouldRespondWith`- "[{\"k\":\"xyyx\",\"extra\":\"u\"},{\"k\":\"xYYx\",\"extra\":\"v\"}]"+ [str|[{"k":"xyyx","extra":"u"},{"k":"xYYx","extra":"v"}]|] it "matches with ilike using not operator" $ get "/simple_pk?k=not.ilike.xy*&order=extra.asc" `shouldRespondWith` "[]"@@ -130,12 +122,16 @@ [json| [{"text_search_vector":"'baz':1 'qux':2"}] |] it "matches with computed column" $- get "/items?always_true=eq.true" `shouldRespondWith`+ get "/items?always_true=eq.true&order=id.asc" `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 "order by computed column" $+ get "/items?order=anti_id.desc" `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\"}]}]}]"+ [str|[{"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"}]}]}]|] it "matches with @> operator" $ get "/complex_items?select=id&arr_data=@>.{2}" `shouldRespondWith`@@ -196,28 +192,49 @@ 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\"}]}]"+ [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] it "requesting parents and filtering parent columns" $ get "/projects?id=eq.1&select=id, name, clients{id}" `shouldRespondWith`- "[{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1}}]"+ [str|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|] + it "rows with missing parents are included" $+ get "/projects?id=in.1,5&select=id,clients{id}" `shouldRespondWith`+ [str|[{"id":1,"clients":{"id":1}},{"id":5,"clients":null}]|]++ it "rows with no children return [] instead of null" $+ get "/projects?id=in.5&select=id,tasks{id}" `shouldRespondWith`+ [str|[{"id":5,"tasks":[]}]|]+ 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}]}]}]"+ [str|[{"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}]"+ [str|[{"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":[]}]|] 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\"}]}]"+ [str|[{"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`- "[{\"user_id\":2,\"task_id\":6,\"comments\":[{\"content\":\"Needs to be delivered ASAP\"}]}]"+ [str|[{"user_id":2,"task_id":6,"comments":[{"content":"Needs to be delivered ASAP"}]}]|] + it "detect relations in views from exposed schema that are based on tables in private schema and have columns renames" $+ get "/articles?id=eq.1&select=id,articleStars{users{*}}" `shouldRespondWith`+ [str|[{"id":1,"articleStars":[{"users":{"id":1,"name":"Angela Martin"}},{"users":{"id":2,"name":"Michael Scott"}},{"users":{"id":3,"name":"Dwight Schrute"}}]}]|]++ it "can select by column name" $+ get "/projects?id=in.1,3&select=id,name,client_id,client_id{id,name}" `shouldRespondWith`+ [str|[{"id":1,"name":"Windows 7","client_id":1,"client_id":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client_id":{"id":2,"name":"Apple"}}]|]++ it "can select by column name sans id" $+ get "/projects?id=in.1,3&select=id,name,client_id,client{id,name}" `shouldRespondWith`+ [str|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|]++ describe "Plurality singular" $ do it "will select an existing object" $ request methodGet "/items?id=eq.5" [("Prefer","plurality=singular")] ""@@ -244,7 +261,7 @@ it "can shape plurality singular object routes" $ request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [("Prefer","plurality=singular")] "" `shouldRespondWith`- "{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}"+ [str|{"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@@ -351,8 +368,7 @@ [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |] describe "remote procedure call" $ do- context "a proc that returns a set" . before_ (clearTable "items" >> createItems 10) .- after_ (clearTable "items") $+ context "a proc that returns a set" $ it "returns proper json" $ post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith` [json| [ {"id": 3}, {"id":4} ] |]
test/Feature/RangeSpec.hs view
@@ -6,11 +6,15 @@ import Network.HTTP.Types import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus)) +import Hasql as H+import Hasql.Postgres as P+ import SpecHelper+import PostgREST.Types (DbStructure(..)) -spec :: Spec-spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items")- . around withApp $+spec :: DbStructure -> H.Pool P.Postgres -> Spec+spec struct pool = beforeAll resetDb+ . around (withApp cfgDefault struct pool) $ describe "GET /items" $ do context "without range headers" $ do
test/Feature/StructureSpec.hs view
@@ -4,12 +4,16 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON +import Hasql as H+import Hasql.Postgres as P+ import SpecHelper+import PostgREST.Types (DbStructure(..)) import Network.HTTP.Types -spec :: Spec-spec = around withApp $ do+spec :: DbStructure -> H.Pool P.Postgres -> Spec+spec struct pool = around (withApp cfgDefault struct pool) $ do describe "GET /" $ do it "lists views in schema" $ request methodGet "/" [] ""@@ -24,6 +28,7 @@ , {"schema":"test","name":"has_count_column","insertable":false} , {"schema":"test","name":"has_fk","insertable":true} , {"schema":"test","name":"insertable_view_with_join","insertable":true}+ , {"schema":"test","name":"insertonly","insertable":true} , {"schema":"test","name":"items","insertable":true} , {"schema":"test","name":"json","insertable":true} , {"schema":"test","name":"materialized_view","insertable":false}@@ -208,16 +213,14 @@ } |] - it "includes foreign key data" $ do- pendingWith "have to resolve issue #107"-+ it "includes foreign key data" $ request methodOptions "/has_fk" [] "" `shouldRespondWith` [json| { "pkey": ["id"], "columns":[ {- "default": "nextval('\"1\".has_fk_id_seq'::regclass)",+ "default": "nextval('test.has_fk_id_seq'::regclass)", "precision": 64, "updatable": true, "schema": "test",@@ -239,7 +242,7 @@ "nullable": true, "position": 2, "enum": [],- "references": {"table": "auto_incrementing_pk", "column": "id"}+ "references": {"schema":"test", "table": "auto_incrementing_pk", "column": "id"} }, { "default": null, "precision": null,@@ -251,7 +254,7 @@ "nullable": true, "position": 3, "enum": [],- "references": {"table": "simple_pk", "column": "k"}+ "references": {"schema":"test", "table": "simple_pk", "column": "k"} } ] }
test/Main.hs view
@@ -2,7 +2,36 @@ import Test.Hspec import SpecHelper-import Spec +--import PostgREST.Types (DbStructure(..))++import qualified Feature.AuthSpec+import qualified Feature.CorsSpec+import qualified Feature.DeleteSpec+import qualified Feature.InsertSpec+import qualified Feature.QueryLimitedSpec+import qualified Feature.QuerySpec+import qualified Feature.RangeSpec+import qualified Feature.StructureSpec+ main :: IO ()-main = resetDb >> hspec spec+main = do+ setupDb++ pool <- specDbPool+ dbStructure <- specDbStructure pool++ -- Not using hspec-discover because we want to precompute+ -- the db structure and pass it to specs for speed+ hspec $ specs dbStructure pool++ where+ specs dbStructure pool = do+ describe "Feature.AuthSpec" $ Feature.AuthSpec.spec dbStructure pool+ describe "Feature.CorsSpec" $ Feature.CorsSpec.spec dbStructure pool+ describe "Feature.DeleteSpec" $ Feature.DeleteSpec.spec dbStructure pool+ describe "Feature.InsertSpec" $ Feature.InsertSpec.spec dbStructure pool+ describe "Feature.QueryLimitedSpec" $ Feature.QueryLimitedSpec.spec dbStructure pool+ describe "Feature.QuerySpec" $ Feature.QuerySpec.spec dbStructure pool+ describe "Feature.RangeSpec" $ Feature.RangeSpec.spec dbStructure pool+ describe "Feature.StructureSpec" $ Feature.StructureSpec.spec dbStructure pool
− test/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
test/SpecHelper.hs view
@@ -12,8 +12,8 @@ import Data.Monoid import Data.Text hiding (map) import qualified Data.Vector as V+import Data.Time.Clock.POSIX (getPOSIXTime) import Control.Monad (void)-import Control.Applicative import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, hRange, hAuthorization, hAccept)@@ -25,67 +25,67 @@ import System.Process (readProcess) import Web.JWT (secret) -import qualified Data.Aeson.Types as J- import PostgREST.App (app) import PostgREST.Config (AppConfig(..)) import PostgREST.Middleware import PostgREST.Error(pgErrResponse) import PostgREST.DbStructure+import PostgREST.Types dbString :: String-dbString = "postgres://postgrest_test@localhost:5432/postgrest_test"+dbString = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test" -isLeft :: Either a b -> Bool-isLeft (Left _ ) = True-isLeft _ = False+cfg :: String -> Maybe Int -> AppConfig+cfg conStr = AppConfig conStr 3000 "postgrest_test_anonymous" "test" (secret "safe") 10 -cfg :: AppConfig-cfg = AppConfig dbString 3000 "postgrest_anonymous" "test" (secret "safe") 10+cfgDefault :: AppConfig+cfgDefault = cfg dbString Nothing +cfgLimitRows :: Int -> AppConfig+cfgLimitRows = cfg dbString . Just+ testPoolOpts :: PoolSettings testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30 pgSettings :: P.Settings pgSettings = P.StringSettings $ cs dbString -withApp :: ActionWith Application -> IO ()-withApp perform = do- pool :: H.Pool P.Postgres- <- H.acquirePool pgSettings testPoolOpts+specDbPool :: IO (H.Pool P.Postgres)+specDbPool = H.acquirePool pgSettings testPoolOpts - let txSettings = Just (H.ReadCommitted, Just True)- dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema cfg)- db <- either (fail . show) return dbOrError+specDbStructure :: H.Pool P.Postgres -> IO DbStructure+specDbStructure pool = do+ dbOrError <- H.session pool $ H.tx specTxSettings+ $ getDbStructure "test"+ either (fail . show) return dbOrError +withApp :: AppConfig -> DbStructure -> H.Pool P.Postgres+ -> ActionWith Application -> IO ()+withApp config dbStructure pool perform = do perform $ middle $ \req resp -> do+ time <- getPOSIXTime body <- strictRequestBody req- result <- liftIO $ H.session pool $ H.tx txSettings- $ runWithClaims cfg (app db cfg body) req+ result <- liftIO $ H.session pool $ H.tx specTxSettings+ $ runWithClaims config time (app dbStructure config body) req either (resp . pgErrResponse) resp result where middle = defaultMiddle --resetDb :: IO ()-resetDb = do- pool :: H.Pool P.Postgres- <- H.acquirePool pgSettings testPoolOpts- void . liftIO $ H.session pool $- H.tx Nothing $ do- H.unitEx [H.stmt| drop schema if exists test cascade |]- H.unitEx [H.stmt| drop schema if exists private cascade |]- H.unitEx [H.stmt| drop schema if exists postgrest cascade |]-+setupDb :: IO ()+setupDb = do+ void $ readProcess "psql" ["-d", "postgres", "-a", "-f", "test/fixtures/database.sql"] [] loadFixture "roles" loadFixture "schema"+ loadFixture "privileges"+ resetDb +resetDb :: IO ()+resetDb = loadFixture "data" loadFixture :: FilePath -> IO() loadFixture name = void $ readProcess "psql" ["-U", "postgrest_test", "-d", "postgrest_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] - rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)] @@ -114,69 +114,7 @@ clearTable table = do pool <- testPool void . liftIO $ H.session pool $ H.tx Nothing $- H.unitEx $ B.Stmt ("delete from test."<>table) V.empty True--clearProjectsTable :: IO ()-clearProjectsTable = do- pool <- testPool- void . liftIO $ H.session pool $ H.tx Nothing $- H.unitEx $ B.Stmt "delete from test.projects where id > 4" V.empty True---createItems :: Int -> IO ()-createItems n = do- pool <- testPool- void . liftIO $ H.session pool $ H.tx Nothing txn- where- txn = mapM_ H.unitEx stmts- stmts = map [H.stmt|insert into test.items (id) values (?)|] [1..n]--createComplexItems :: IO ()-createComplexItems = do- pool <- testPool- void . liftIO $ H.session pool $ H.tx Nothing txn- where- txn = mapM_ H.unitEx stmts- stmts = getZipList $ [H.stmt|insert into test.complex_items (id, name, settings, arr_data) values (?,?,?,?)|]- <$> ZipList ([1..3]::[Int])- <*> ZipList (["One", "Two", "Three"]::[Text])- <*> ZipList [jobj,jobj,jobj]- <*> ZipList ([[1], [1,2], [1,2,3]]::[[Int]])- jobj = J.object [("foo", J.object [("int", J.Number 1),("bar", J.String "baz")])]--createNulls :: Int -> IO ()-createNulls n = do- pool <- testPool- void . liftIO $ H.session pool $ H.tx Nothing txn- where- txn = mapM_ H.unitEx (stmt':stmts)- stmt' = [H.stmt|insert into test.no_pk (a,b) values (null,null)|]- stmts = map [H.stmt|insert into test.no_pk (a,b) values (?,0)|] [1..n]--createNullInteger :: IO ()-createNullInteger = do- pool <- testPool- void . liftIO $ H.session pool $ H.tx Nothing $- H.unitEx $ [H.stmt| insert into "test".nullable_integer (a) values (null) |]--createLikableStrings :: IO ()-createLikableStrings = do- pool <- testPool- void . liftIO $ H.session pool $ H.tx Nothing $ do- H.unitEx $ insertSimplePk "xyyx" "u"- H.unitEx $ insertSimplePk "xYYx" "v"- where- insertSimplePk :: Text -> Text -> H.Stmt P.Postgres- insertSimplePk = [H.stmt|insert into test.simple_pk (k, extra) values (?,?)|]+ H.unitEx $ B.Stmt ("truncate table test." <> table <> " cascade") V.empty True -createJsonData :: IO ()-createJsonData = do- pool <- testPool- void . liftIO $ H.session pool $ H.tx Nothing $- H.unitEx $- [H.stmt|- insert into test.json (data) values (?)- |]- (J.object [("id", J.Number 1)- ,("foo", J.object [("bar", J.String "baz")])- ])+specTxSettings :: Maybe (TxIsolationLevel, Maybe Bool)+specTxSettings = Just (H.ReadCommitted, Just True)