diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 1a46f72c8..b4df142fd 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -65,15 +65,15 @@ app conf reqBody req = let qt = qualify table from = fromMaybe 0 $ rangeOffset <$> range query = B.Stmt "select " V.empty True <> - parentheticT ( - whereT qt qq $ countRows qt - ) <> commaq <> ( - bodyForAccept contentType qt - . limitT range - . orderT (orderParse qq) - . whereT qt qq - $ select qt qq - ) + parentheticT ( + whereT qt qq $ countRows qt + ) <> commaq <> ( + bodyForAccept contentType qt + . limitT range + . orderT (orderParse qq) + . whereT qt qq + $ select qt qq + ) row <- H.maybeEx query let (tableTotal, queryTotal, body) = fromMaybe (0, 0, Just "" :: Maybe Text) row @@ -81,14 +81,14 @@ app conf reqBody req = contentRange = contentRangeH from to tableTotal status = rangeStatus from to tableTotal canonical = urlEncodeVars - . sortBy (comparing fst) - . map (join (***) cs) - . parseSimpleQuery - $ rawQueryString req + . sortBy (comparing fst) + . map (join (***) cs) + . parseSimpleQuery + $ rawQueryString req return $ responseLBS status [contentTypeH, contentRange, ("Content-Location", - "/" <> cs table <> + "/" <> cs table <> if Prelude.null canonical then "" else "?" <> cs canonical ) ] (cs $ fromMaybe "[]" body) @@ -119,8 +119,7 @@ app conf reqBody req = encode . object $ [("message", String "Failed to parse user.")] Just u -> do setRole authenticator - login <- signInRole (cs $ userId u) - (cs $ userPass u) + login <- signInRole (cs $ userId u) (cs $ userPass u) case login of LoginSuccess role uid -> return $ responseLBS status201 [ jsonH ] $ @@ -133,15 +132,15 @@ app conf reqBody req = echoRequested = lookupHeader "Prefer" == Just "return=representation" parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value)) parsed = if lookupHeader "Content-Type" == Just csvMT - then do - rows <- CSV.decode CSV.NoHeader reqBody - if V.null rows then Left "CSV requires header" - else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows)) - else eitherDecode reqBody >>= \val -> - case val of - Object obj -> Right . second V.singleton . V.unzip . V.fromList $ - M.toList obj - _ -> Left "Expecting single JSON object or CSV rows" + then do + rows <- CSV.decode CSV.NoHeader reqBody + if V.null rows then Left "CSV requires header" + else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows)) + else eitherDecode reqBody >>= \val -> + case val of + Object obj -> Right . second V.singleton . V.unzip . V.fromList $ + M.toList obj + _ -> Left "Expecting single JSON object or CSV rows" case parsed of Left err -> return $ responseLBS status400 [] $ encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)] @@ -186,7 +185,7 @@ app conf reqBody req = let specifiedKeys = map (cs . fst) qq if S.fromList primaryKeys /= S.fromList specifiedKeys then return $ responseLBS status405 [] - "You must speficy all and only primary keys as params" + "You must speficy all and only primary keys as params" else do tableCols <- map (cs . colName) <$> columns qt let cols = map cs $ M.keys obj @@ -194,21 +193,21 @@ app conf reqBody req = then do let vals = M.elems obj H.unitEx $ iffNotT - (whereT qt qq $ update qt cols vals) - (insertSelect qt cols vals) + (whereT qt qq $ update qt cols vals) + (insertSelect qt cols vals) return $ responseLBS status204 [ jsonH ] "" else return $ if Prelude.null tableCols then responseLBS status404 [] "" else responseLBS status400 [] - "You must specify all columns in PUT request" + "You must specify all columns in PUT request" ([table], "PATCH") -> handleJsonObj reqBody $ \obj -> do let qt = qualify table up = returningStarT - . whereT qt qq - $ update qt (map cs $ M.keys obj) (M.elems obj) + . whereT qt qq + $ update qt (map cs $ M.keys obj) (M.elems obj) patch = withT up "t" $ B.Stmt "select count(t), array_to_json(array_agg(row_to_json(t)))::character varying" V.empty True @@ -232,8 +231,8 @@ app conf reqBody req = row <- H.maybeEx del let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row return $ if deletedCount == 0 - then responseLBS status404 [] "" - else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] "" + then responseLBS status404 [] "" + else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] "" (_, _) -> return $ responseLBS status404 [] "" @@ -271,19 +270,20 @@ contentRangeH from to total = ("Content-Range", if total == 0 || from > total then "*/" <> cs (show total) - else cs (show from) <> "-" - <> cs (show to) <> "/" - <> cs (show total) + else cs (show from) + <> "-" <> cs (show to) + <> "/" <> cs (show total) ) requestedSchema :: Text -> Maybe BS.ByteString -> Text requestedSchema v1schema accept = case verStr of - Just [[_, ver]] -> if ver == "1" then v1schema else cs ver - _ -> v1schema + Just [[_, ver]] -> if ver == "1" then v1schema else cs ver + _ -> v1schema - where verRegex = "version[ ]*=[ ]*([0-9]+)" :: BS.ByteString - verStr = (=~ verRegex) <$> accept :: Maybe [[BS.ByteString]] + where + verRegex = "version[ ]*=[ ]*([0-9]+)" :: BS.ByteString + verStr = (=~ verRegex) <$> accept :: Maybe [[BS.ByteString]] jsonMT :: BS.ByteString diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 9d8f5f99c..0dfe553e0 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -56,10 +56,10 @@ setRole :: Text -> H.Tx P.Postgres s () setRole role = H.unitEx $ B.Stmt ("set local role " <> cs (pgFmtLit role)) V.empty True setUserId :: Text -> H.Tx P.Postgres s () -setUserId uid = if uid /= "" then - H.unitEx $ B.Stmt ("set local user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True -else - resetUserId +setUserId uid = + if uid /= "" + then H.unitEx $ B.Stmt ("set local user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True + else resetUserId resetUserId :: H.Tx P.Postgres s () resetUserId = H.unitEx [H.stmt|reset user_vars.user_id|] diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 477e44525..37c772e37 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -22,7 +22,7 @@ data AppConfig = AppConfig { , configSecure :: Bool , configPool :: Int , configV1Schema :: String - + , configJwtSecret :: String } @@ -52,9 +52,9 @@ corsPolicy req = case lookup "origin" headers of corsOrigins = Just ([origin], True) , corsRequestHeaders = "Authentication":accHeaders , corsExposedHeaders = Just [ - "Content-Encoding", "Content-Location", "Content-Range", "Content-Type" - , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit" - ] + "Content-Encoding", "Content-Location", "Content-Range", "Content-Type" + , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit" + ] } Nothing -> Nothing where diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 1a14c2f4d..a0d486c29 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -36,12 +36,12 @@ main = do hSetBuffering stderr NoBuffering let opts = info (helper <*> argParser) $ - fullDesc - <> progDesc ( - "PostgREST " - <> prettyVersion - <> " / create a REST API to an existing Postgres database" - ) + fullDesc + <> progDesc ( + "PostgREST " + <> prettyVersion + <> " / create a REST API to an existing Postgres database" + ) parserPrefs = prefs showHelpOnError conf <- customExecParser parserPrefs opts let port = configPort conf @@ -64,12 +64,15 @@ main = do middle = logStdout . defaultMiddle (configSecure conf) poolSettings <- maybe (fail "Improper session settings") return $ - H.poolSettings (fromIntegral $ configPool conf) 30 - pool :: H.Pool P.Postgres - <- H.acquirePool pgSettings poolSettings + H.poolSettings (fromIntegral $ configPool conf) 30 + pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings resOrError <- H.session pool isServerVersionSupported - either (fail . show) (\supported -> unless supported $ fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0") resOrError + either (fail . show) + (\supported -> + unless supported $ + fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0" + ) resOrError runSettings appSettings $ middle $ \req respond -> do body <- strictRequestBody req diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index f560e8313..8fa775f25 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -78,12 +78,12 @@ redirectInsecure app req respond = do if not (isSecure req || isHerokuSecure) then case uriM of - Just uri -> - respond $ responseLBS status301 [ - (hLocation, cs . show $ uri { uriScheme = "https:" }) - ] "" - Nothing -> - respond $ responseLBS status400 [] "SSL is required" + Just uri -> + respond $ responseLBS status301 [ + (hLocation, cs . show $ uri { uriScheme = "https:" }) + ] "" + Nothing -> + respond $ responseLBS status400 [] "SSL is required" else app req respond unsupportedAccept :: Application -> Application @@ -96,6 +96,6 @@ unsupportedAccept app req respond = do defaultMiddle :: Bool -> Application -> Application defaultMiddle secure = (if secure then redirectInsecure else id) - . gzip def . cors corsPolicy - . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) - . unsupportedAccept + . gzip def . cors corsPolicy + . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) + . unsupportedAccept diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs index 19a0cca34..9e6c8f25b 100644 --- a/src/PostgREST/PgQuery.hs +++ b/src/PostgREST/PgQuery.hs @@ -54,13 +54,13 @@ limitT r q = whereT :: QualifiedIdentifier -> Net.Query -> StatementT whereT table params q = - if L.null cols - then q - else q <> B.Stmt " where " empty True <> conjunction - where - cols = [ col | col <- params, fst col `notElem` ["order","select"] ] - wherePredTable = wherePred table - conjunction = mconcat $ L.intersperse andq (map wherePredTable cols) + if L.null cols + then q + else q <> B.Stmt " where " empty True <> conjunction + where + cols = [ col | col <- params, fst col `notElem` ["order","select"] ] + wherePredTable = wherePred table + conjunction = mconcat $ L.intersperse andq (map wherePredTable cols) withT :: PStmt -> T.Text -> StatementT withT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) = @@ -74,13 +74,13 @@ orderT ts q = then q else q <> B.Stmt " order by " empty True <> clause where - clause = mconcat $ L.intersperse commaq (map queryTerm ts) - queryTerm :: OrderTerm -> PStmt - queryTerm t = B.Stmt - (" " <> cs (pgFmtIdent $ otTerm t) <> " " - <> cs (otDirection t) <> " " - <> maybe "" cs (otNullOrder t) <> " ") - empty True + clause = mconcat $ L.intersperse commaq (map queryTerm ts) + queryTerm :: OrderTerm -> PStmt + queryTerm t = B.Stmt + (" " <> cs (pgFmtIdent $ otTerm t) <> " " + <> cs (otDirection t) <> " " + <> maybe "" cs (otNullOrder t) <> " ") + empty True parentheticT :: StatementT parentheticT s = @@ -105,7 +105,8 @@ asCsvWithCount :: QualifiedIdentifier -> StatementT asCsvWithCount table = withCount . asCsv table asCsv :: QualifiedIdentifier -> StatementT -asCsv table s = s { B.stmtTemplate = +asCsv table s = s { + B.stmtTemplate = "(select string_agg(quote_ident(column_name::text), ',') from " <> "(select column_name from information_schema.columns where quote_ident(table_schema) || '.' || table_name = '" <> fromQi table <> "' order by ordinal_position) h) || '\r' || " @@ -116,7 +117,8 @@ asJsonWithCount :: StatementT asJsonWithCount = withCount . asJson asJson :: StatementT -asJson s = s { B.stmtTemplate = +asJson s = s { + B.stmtTemplate = "array_to_json(array_agg(row_to_json(t)))::character varying from (" <> B.stmtTemplate s <> ") t" } @@ -131,26 +133,30 @@ selectStar t = B.Stmt ("select * from " <> fromQi t) empty True select :: QualifiedIdentifier -> Net.Query -> PStmt select table params = - if L.null cols - then selectStar table - else B.Stmt "select " empty True <> conjunction <> B.Stmt (" from " <> fromQi table ) empty True - where - selectTermTable = selectTerm table - conjunction = mconcat $ L.intersperse commaq (map selectTermTable cols) - columnsParam = fromMaybe "" $ join (lookup "select" params) - cols = filter ((>0) . T.length) $ map T.strip $ T.split (==',') $ cs columnsParam + if L.null cols + then selectStar table + else B.Stmt "select " empty True <> conjunction <> B.Stmt (" from " <> fromQi table ) empty True + where + selectTermTable = selectTerm table + conjunction = mconcat $ L.intersperse commaq (map selectTermTable cols) + columnsParam = fromMaybe "" $ join (lookup "select" params) + cols = filter ((>0) . T.length) $ map T.strip $ T.split (==',') $ cs columnsParam selectTerm :: QualifiedIdentifier -> T.Text -> PStmt selectTerm table col = - case T.splitOn "::" col of - [colName,castTo] -> B.Stmt ("CAST (" <> pgFmtJsonbPath table (cs colName) <> " AS " <> castToSafe <> " )" <> asT (jsonbPath colName)) empty True - where castToSafe = T.filter ( `elem` ['a'..'z'] ) castTo - _-> B.Stmt (pgFmtJsonbPath table (cs col) <> asT (jsonbPath col)) empty True - where - jsonbPath :: T.Text -> Maybe JsonbPath - jsonbPath c = parseJsonbPath $ cs c - asT (Just (DoubleArrow _ (KeyIdentifier key))) = " AS " <> pgFmtIdent key - asT _ = "" + case T.splitOn "::" col of + [colName,castTo] -> + B.Stmt ( + "CAST (" <> pgFmtJsonbPath table (cs colName) <> " AS " + <> castToSafe <> " )" <> asT (jsonbPath colName) + ) empty True + where castToSafe = T.filter ( `elem` ['a'..'z'] ) castTo + _ -> B.Stmt (pgFmtJsonbPath table (cs col) <> asT (jsonbPath col)) empty True + where + jsonbPath :: T.Text -> Maybe JsonbPath + jsonbPath c = parseJsonbPath $ cs c + asT (Just (DoubleArrow _ (KeyIdentifier key))) = " AS " <> pgFmtIdent key + asT _ = "" returningStarT :: StatementT returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" } @@ -212,39 +218,39 @@ wherePred table (col, predicate) = where headPredicate:rest = T.split (=='.') $ cs $ fromMaybe "." predicate - hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse - opCode = hasNot (head rest) headPredicate - notOp = hasNot headPredicate "" - value = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest) - whiteList val = fromMaybe (cs (pgFmtLit val) <> "::unknown ") - (L.find ((==) . T.toLower $ val) - ["null","true","false"]) + hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse + opCode = hasNot (head rest) headPredicate + notOp = hasNot headPredicate "" + value = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest) + whiteList val = fromMaybe + (cs (pgFmtLit val) <> "::unknown ") + (L.find ((==) . T.toLower $ val) ["null","true","false"]) star c = if c == '*' then '%' else c unknownLiteral = (<> "::unknown ") . pgFmtLit sqlValue = case opCode of - "like" -> unknownLiteral $ T.map star value - "ilike" -> unknownLiteral $ T.map star value - "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " - "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " - "@@" -> "to_tsquery(" <> unknownLiteral value <> ") " - _ -> unknownLiteral value + "like" -> unknownLiteral $ T.map star value + "ilike" -> unknownLiteral $ T.map star value + "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " + "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " + "@@" -> "to_tsquery(" <> unknownLiteral value <> ") " + _ -> unknownLiteral value op = case opCode of - "eq" -> "=" - "gt" -> ">" - "lt" -> "<" - "gte" -> ">=" - "lte" -> "<=" - "neq" -> "<>" - "like"-> "like" - "ilike"-> "ilike" - "in" -> "in" - "notin" -> "not in" - "is" -> "is" - "isnot" -> "is not" - "@@" -> "@@" - _ -> "=" + "eq" -> "=" + "gt" -> ">" + "lt" -> "<" + "gte" -> ">=" + "lte" -> "<=" + "neq" -> "<>" + "like"-> "like" + "ilike"-> "ilike" + "in" -> "in" + "notin" -> "not in" + "is" -> "is" + "isnot" -> "is not" + "@@" -> "@@" + _ -> "=" orderParse :: Net.Query -> [OrderTerm] orderParse q = @@ -255,18 +261,18 @@ orderParse q = orderParseTerm :: T.Text -> Maybe OrderTerm orderParseTerm s = case T.split (=='.') s of - (c:d:nls) -> - if d `elem` ["asc", "desc"] - then Just $ OrderTerm c - ( if d == "asc" then "asc" else "desc" ) - ( case nls of - [n] -> if | n == "nullsfirst" -> Just "nulls first" - | n == "nullslast" -> Just "nulls last" - | otherwise -> Nothing - _ -> Nothing - ) - else Nothing - _ -> Nothing + (c:d:nls) -> + if d `elem` ["asc", "desc"] + then Just $ OrderTerm c + ( if d == "asc" then "asc" else "desc" ) + ( case nls of + [n] -> if | n == "nullsfirst" -> Just "nulls first" + | n == "nullslast" -> Just "nulls last" + | otherwise -> Nothing + _ -> Nothing + ) + else Nothing + _ -> Nothing commaq :: PStmt commaq = B.Stmt ", " empty True diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index 4e3a724e7..9e5647b8a 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -43,8 +43,8 @@ tables :: Text -> H.Tx P.Postgres s [Table] tables schema = do rows <- H.listEx $ [H.stmt| - select - n.nspname as table_schema, + 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 ( @@ -52,16 +52,17 @@ tables schema = do 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) - ) + 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 @@ -71,31 +72,31 @@ 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) + 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) diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs index ac1b9c6d6..a138d9559 100644 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -41,15 +41,15 @@ rangeRequested = (rangeParse =<<) . lookup hRange rangeLimit :: NonnegRange -> Maybe Int rangeLimit range = - case [rangeLower range, rangeUpper range] - of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) - _ -> Nothing + case [rangeLower range, rangeUpper range] of + [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) + _ -> Nothing rangeOffset :: NonnegRange -> Int rangeOffset range = - case rangeLower range - of BoundaryBelow from -> from - _ -> error "range without lower bound" -- should never happen + case rangeLower range of + BoundaryBelow from -> from + _ -> error "range without lower bound" -- should never happen rangeGeq :: Int -> NonnegRange rangeGeq n =