jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Reduce app function (#733)

Browse Source 
Simplify the big app function
This commit is contained in:
Diogo Biazus
2016-11-10 20:42:00 -08:00
committed by Joe Nelson
parent c3822da2d2
commit 41c1cf6e01
6 changed files with 247 additions and 221 deletions
Download Patch File Download Diff File Expand all files Collapse all files
postgrest.cabal
+1
View File
@@ -54,6 +54,7 @@ library
, configurator , configurator
, containers , containers
, contravariant , contravariant
, either
, hasql , hasql
, hasql-pool == 0.4.1 , hasql-pool == 0.4.1
, hasql-transaction == 0.4.5.1 , hasql-transaction == 0.4.5.1
src/PostgREST/ApiRequest.hs
+30 -14
View File
@@ -1,4 +1,17 @@
module PostgREST.ApiRequest where {-|
Module : PostgREST.ApiRequest
Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
-}
module PostgREST.ApiRequest ( ApiRequest(..)
, ContentType(..)
, Action(..)
, Target(..)
, PreferRepresentation (..)
, mutuallyAgreeable
, toHeader
, userApiRequest
, toMime
) where
import Protolude import Protolude
@@ -33,6 +46,7 @@ type RequestBody = BL.ByteString
data Action = ActionCreate | ActionRead data Action = ActionCreate | ActionRead
| ActionUpdate | ActionDelete | ActionUpdate | ActionDelete
| ActionInfo | ActionInvoke | ActionInfo | ActionInvoke
| ActionInspect
| ActionInappropriate | ActionInappropriate
deriving Eq deriving Eq
-- | The target db object of a user action -- | The target db object of a user action
@@ -40,6 +54,7 @@ data Target = TargetIdent QualifiedIdentifier
| TargetProc QualifiedIdentifier | TargetProc QualifiedIdentifier
| TargetRoot | TargetRoot
| TargetUnknown [Text] | TargetUnknown [Text]
deriving Eq
-- | How to return the inserted data -- | How to return the inserted data
data PreferRepresentation = Full | HeadersOnly | None deriving Eq data PreferRepresentation = Full | HeadersOnly | None deriving Eq
-- --
@@ -47,15 +62,17 @@ data PreferRepresentation = Full | HeadersOnly | None deriving Eq
data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
| CTAny | CTOther BS.ByteString deriving Eq | CTAny | CTOther BS.ByteString deriving Eq
ctToHeader :: ContentType -> Header -- | Convert from ContentType to a full HTTP Header
ctToHeader ct = (hContentType, toHeader ct <> "; charset=utf-8") toHeader :: ContentType -> Header
toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
toHeader :: ContentType -> ByteString -- | Convert from ContentType to a ByteString representing the mime type
toHeader CTApplicationJSON = "application/json" toMime :: ContentType -> ByteString
toHeader CTTextCSV = "text/csv" toMime CTApplicationJSON = "application/json"
toHeader CTOpenAPI = "application/openapi+json" toMime CTTextCSV = "text/csv"
toHeader CTAny = "*/*" toMime CTOpenAPI = "application/openapi+json"
toHeader (CTOther ct) = ct toMime CTAny = "*/*"
toMime (CTOther ct) = ct
{-| {-|
Describes what the user wants to do. This data type is a Describes what the user wants to do. This data type is a
@@ -104,7 +121,9 @@ userApiRequest schema req reqBody =
else ActionInappropriate else ActionInappropriate
else else
case method of case method of
"GET" -> ActionRead "GET" -> if target == TargetRoot
then ActionInspect
else ActionRead
"POST" -> ActionCreate "POST" -> ActionCreate
"PATCH" -> ActionUpdate "PATCH" -> ActionUpdate
"DELETE" -> ActionDelete "DELETE" -> ActionDelete
@@ -137,7 +156,7 @@ userApiRequest schema req reqBody =
. map (toS *** JSON.String . toS) . parseSimpleQuery . map (toS *** JSON.String . toS) . parseSimpleQuery
$ toS reqBody $ toS reqBody
ct -> ct ->
PayloadParseError $ "Content-Type not acceptable: " <> toHeader ct PayloadParseError $ "Content-Type not acceptable: " <> toMime ct
relevantPayload = case action of relevantPayload = case action of
ActionCreate -> Just payload ActionCreate -> Just payload
ActionUpdate -> Just payload ActionUpdate -> Just payload
@@ -281,6 +300,3 @@ ensureUniform arr =
if (V.length objs == V.length arr) && areKeysUniform if (V.length objs == V.length arr) && areKeysUniform
then Just (UniformObjects objs) then Just (UniformObjects objs)
else Nothing else Nothing
readBSMaybe :: Read a => ByteString -> Maybe a
readBSMaybe = readMaybe . toS
src/PostgREST/App.hs
+76 -67
View File
@@ -15,6 +15,7 @@ import Data.Ranged.Ranges (emptyRange)
import Data.Text (replace, strip, isInfixOf, dropWhile, drop, intercalate) import Data.Text (replace, strip, isInfixOf, dropWhile, drop, intercalate)
import Data.Time.Clock.POSIX (POSIXTime) import Data.Time.Clock.POSIX (POSIXTime)
import Data.Tree import Data.Tree
import Data.Either.Combinators (mapLeft)
import qualified Hasql.Pool as P import qualified Hasql.Pool as P
import qualified Hasql.Transaction as HT import qualified Hasql.Transaction as HT
@@ -41,10 +42,11 @@ import qualified Data.HashMap.Strict as M
import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..) import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..)
, Action(..), Target(..) , Action(..), Target(..)
, PreferRepresentation (..) , PreferRepresentation (..)
, userApiRequest, mutuallyAgreeable , mutuallyAgreeable
, ctToHeader , toHeader
, userApiRequest , userApiRequest
, toHeader) , toMime
)
import PostgREST.Auth (jwtClaims, containsRole) import PostgREST.Auth (jwtClaims, containsRole)
import PostgREST.Config (AppConfig (..)) import PostgREST.Config (AppConfig (..))
import PostgREST.DbStructure import PostgREST.DbStructure
@@ -98,39 +100,38 @@ transactionMode _ = HT.Write
app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response
app dbStructure conf apiRequest = app dbStructure conf apiRequest =
case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of
Left errorResponse -> return errorResponse
Right contentType ->
case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of
(ActionRead, TargetIdent qi, Nothing) -> (ActionRead, TargetIdent qi, Nothing) ->
serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
case readSqlParts of case readSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ toS e Left errorResponse -> return errorResponse
Right (q, cq) -> do Right (q, cq) -> respondToRange $ do
let singular = iPreferSingular apiRequest let singular = iPreferSingular apiRequest
stm = createReadStatement q cq singular stm = createReadStatement q cq singular shouldCount (contentType == CTTextCSV)
shouldCount (contentType == CTTextCSV)
respondToRange $ do
row <- H.query () stm row <- H.query () stm
let (tableTotal, queryTotal, _ , body) = row let (tableTotal, queryTotal, _ , body) = row
if singular if singular
then return $ if queryTotal <= 0 then return $ if queryTotal <= 0
then responseLBS status404 [] "" then notFound
else responseLBS status200 [ctToHeader contentType] (toS body) else responseLBS status200 [toHeader contentType] (toS body)
else do else do
let (status, contentRange) = rangeHeader queryTotal tableTotal let (status, contentRange) = rangeHeader queryTotal tableTotal
canonical = iCanonicalQS apiRequest canonical = iCanonicalQS apiRequest
--TargetIdent qi = iTarget apiRequest
return $ responseLBS status return $ responseLBS status
[ctToHeader contentType, contentRange, [toHeader contentType, contentRange,
("Content-Location", ("Content-Location",
"/" <> toS (qiName qi) <> "/" <> toS (qiName qi) <>
if BS.null canonical then "" else "?" <> toS canonical if BS.null canonical then "" else "?" <> toS canonical
) )
] (toS body) ] (toS body)
(ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON uniform@(UniformObjects rows))) ->
Just payload@(PayloadJSON uniform@(UniformObjects rows))) ->
serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
case mutateSqlParts of case mutateSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ toS e Left errorResponse -> return errorResponse
Right (sq, mq) -> do Right (sq, mq) -> do
let isSingle = (==1) $ V.length rows let isSingle = (==1) $ V.length rows
when (not isSingle && iPreferSingular apiRequest) $ when (not isSingle && iPreferSingular apiRequest) $
@@ -149,7 +150,7 @@ app dbStructure conf apiRequest =
then Nothing then Nothing
else Just (hLocation, "/" <> toS table <> renderLocationFields fs) else Just (hLocation, "/" <> toS table <> renderLocationFields fs)
, if iPreferRepresentation apiRequest == Full , if iPreferRepresentation apiRequest == Full
then Just $ ctToHeader contentType then Just $ toHeader contentType
else Nothing else Nothing
, Just . contentRangeH 1 0 $ , Just . contentRangeH 1 0 $
toInteger <$> if shouldCount then Just (V.length rows) else Nothing toInteger <$> if shouldCount then Just (V.length rows) else Nothing
@@ -160,9 +161,8 @@ app dbStructure conf apiRequest =
then toS body else "" then toS body else ""
(ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) -> (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) ->
serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
case mutateSqlParts of case mutateSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ toS e Left errorResponse -> return errorResponse
Right (sq, mq) -> do Right (sq, mq) -> do
let singular = iPreferSingular apiRequest let singular = iPreferSingular apiRequest
stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload
@@ -181,13 +181,12 @@ app dbStructure conf apiRequest =
| iPreferRepresentation apiRequest == Full -> status200 | iPreferRepresentation apiRequest == Full -> status200
| otherwise -> status204 | otherwise -> status204
return $ if iPreferRepresentation apiRequest == Full return $ if iPreferRepresentation apiRequest == Full
then responseLBS s [ctToHeader contentType, r] (toS body) then responseLBS s [toHeader contentType, r] (toS body)
else responseLBS s [r] "" else responseLBS s [r] ""
(ActionDelete, TargetIdent qi, Nothing) -> (ActionDelete, TargetIdent qi, Nothing) ->
serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
case mutateSqlParts of case mutateSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ toS e Left errorResponse -> return errorResponse
Right (sq, mq) -> do Right (sq, mq) -> do
let emptyUniform = UniformObjects V.empty let emptyUniform = UniformObjects V.empty
fakeload = PayloadJSON emptyUniform fakeload = PayloadJSON emptyUniform
@@ -199,7 +198,7 @@ app dbStructure conf apiRequest =
return $ if queryTotal == 0 return $ if queryTotal == 0
then notFound then notFound
else if iPreferRepresentation apiRequest == Full else if iPreferRepresentation apiRequest == Full
then responseLBS status200 [ctToHeader contentType, r] (toS body) then responseLBS status200 [toHeader contentType, r] (toS body)
else responseLBS status204 [r] "" else responseLBS status204 [r] ""
(ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
@@ -210,20 +209,19 @@ app dbStructure conf apiRequest =
let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
return $ responseLBS status200 [allOrigins, acceptH] "" return $ responseLBS status200 [allOrigins, acceptH] ""
(ActionInvoke, TargetProc qi, (ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) ->
Just (PayloadJSON (UniformObjects payload))) -> do case readSqlParts of
Left errorResponse -> return errorResponse
Right (q, cq) -> respondToRange $ do
let p = V.head payload let p = V.head payload
singular = iPreferSingular apiRequest singular = iPreferSingular apiRequest
serves [CTApplicationJSON] (iAccepts apiRequest) $ \_ -> case readSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ toS e
Right (q,cq) -> respondToRange $ do
row <- H.query () (callProc qi p q cq topLevelRange shouldCount singular) row <- H.query () (callProc qi p q cq topLevelRange shouldCount singular)
let (tableTotal, queryTotal, body) = let (tableTotal, queryTotal, body) =
fromMaybe (Just 0, 0, emptyArray) row fromMaybe (Just 0, 0, emptyArray) row
(status, contentRange) = rangeHeader queryTotal tableTotal (status, contentRange) = rangeHeader queryTotal tableTotal
return $ responseLBS status [jsonH, contentRange] (toS . encode $ body) return $ responseLBS status [jsonH, contentRange] (toS . encode $ body)
(ActionRead, TargetRoot, Nothing) -> do (ActionInspect, TargetRoot, Nothing) -> do
let host = configHost conf let host = configHost conf
port = toInteger $ configPort conf port = toInteger $ configPort conf
proxy = pickProxy $ toS <$> configProxyUri conf proxy = pickProxy $ toS <$> configProxyUri conf
@@ -231,19 +229,14 @@ app dbStructure conf apiRequest =
uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b) uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
uri' = uri proxy uri' = uri proxy
encodeApi ti = encodeOpenAPI (map snd $ dbProcs dbStructure) ti uri' encodeApi ti = encodeOpenAPI (map snd $ dbProcs dbStructure) ti uri'
serves [CTOpenAPI] (iAccepts apiRequest) $ \_ -> do
body <- encodeApi . toTableInfo <$> H.query schema accessibleTables body <- encodeApi . toTableInfo <$> H.query schema accessibleTables
return $ responseLBS status200 [openapiH] $ toS body return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body
(ActionInappropriate, _, _) -> return $ responseLBS status405 [] ""
(_, _, Just (PayloadParseError e)) -> (_, _, Just (PayloadParseError e)) ->
return $ responseLBS status400 [jsonH] $ return $ errResponse status400 $
toS (formatGeneralError "Cannot parse request payload" (toS e)) toS (formatGeneralError "Cannot parse request payload" (toS e))
(_, TargetUnknown _, _) -> return notFound _ -> return notFound
(_, _, _) -> return notFound
where where
toTableInfo :: [Table] -> [(Table, [Column], [Text])] toTableInfo :: [Table] -> [(Table, [Column], [Text])]
@@ -252,8 +245,7 @@ app dbStructure conf apiRequest =
tTable = tableName t tTable = tableName t
cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
in in (t, cols, pkeys))
(t, cols, pkeys))
notFound = responseLBS status404 [] "" notFound = responseLBS status404 [] ""
filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
filterCol :: Schema -> TableName -> Column -> Bool filterCol :: Schema -> TableName -> Column -> Bool
@@ -261,38 +253,53 @@ app dbStructure conf apiRequest =
filterCol _ _ _ = False filterCol _ _ _ = False
allPrKeys = dbPrimaryKeys dbStructure allPrKeys = dbPrimaryKeys dbStructure
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
jsonH = ctToHeader CTApplicationJSON jsonH = toHeader CTApplicationJSON
openapiH = ctToHeader CTOpenAPI
schema = toS $ configSchema conf
shouldCount = iPreferCount apiRequest shouldCount = iPreferCount apiRequest
schema = toS $ configSchema conf
topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest
mapSnd f (a, b) = (a, f b) rangeHeader queryTotal tableTotal =
readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest let lower = rangeOffset topLevelRange
mutateDbRequest = DbMutate <$> buildMutateRequest apiRequest
selectQuery = requestToQuery schema False <$> readDbRequest
countQuery = requestToCountQuery schema <$> readDbRequest
mutateQuery = requestToQuery schema False <$> mutateDbRequest
readSqlParts = (,) <$> selectQuery <*> countQuery
mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
respondToRange response = if topLevelRange == emptyRange
then return $ errResponse status416 "HTTP Range error"
else response
rangeHeader queryTotal tableTotal = let lower = rangeOffset topLevelRange
upper = lower + toInteger queryTotal - 1 upper = lower + toInteger queryTotal - 1
contentRange = contentRangeH lower upper (toInteger <$> tableTotal) contentRange = contentRangeH lower upper (toInteger <$> tableTotal)
status = rangeStatus lower upper (toInteger <$> tableTotal) status = rangeStatus lower upper (toInteger <$> tableTotal)
in (status, contentRange) in (status, contentRange)
mapSnd f (a, b) = (a, f b)
readDbRequest = DbRead <$> readRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest
mutateDbRequest = DbMutate <$> mutateRequest apiRequest
selectQuery = requestToQuery schema False <$> readDbRequest
mutateQuery = requestToQuery schema False <$> mutateDbRequest
countQuery = requestToCountQuery schema <$> readDbRequest
readSqlParts = (,) <$> selectQuery <*> countQuery
mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
respondToRange response =
if topLevelRange == emptyRange
then return $ errResponse status416 "HTTP Range error"
else response
serves :: Monad m => [ContentType] -> [ContentType] -> responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType
(ContentType -> m Response) -> m Response responseContentTypeOrError accepts action =
serves sProduces cAccepts resp = case action of
ActionInappropriate -> Left $ errResponse status405 "Unsupported HTTP verb"
_ -> serves contentTypesForRequest accepts
where
contentTypesForRequest =
case action of
ActionRead -> [CTApplicationJSON, CTTextCSV]
ActionCreate -> [CTApplicationJSON, CTTextCSV]
ActionUpdate -> [CTApplicationJSON, CTTextCSV]
ActionDelete -> [CTApplicationJSON, CTTextCSV]
ActionInvoke -> [CTApplicationJSON]
ActionInspect -> [CTOpenAPI]
ActionInfo -> [CTTextCSV]
ActionInappropriate -> []
serves sProduces cAccepts =
case mutuallyAgreeable sProduces cAccepts of case mutuallyAgreeable sProduces cAccepts of
Nothing -> do Nothing -> do
let failed = intercalate ", " $ map (toS . toHeader) cAccepts let failed = intercalate ", " $ map (toS . toMime) cAccepts
return $ errResponse status415 $ Left $ errResponse status415 $
"None of these Content-Types are available: " <> failed "None of these Content-Types are available: " <> failed
Just ct -> resp ct Just ct -> Right ct
splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString) splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
splitKeyValue kv = (k, BS.tail v) splitKeyValue kv = (k, BS.tail v)
@@ -372,11 +379,12 @@ treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` re
nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i) nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)
buildReadRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Text ReadRequest readRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Response ReadRequest
buildReadRequest maxRows allRels allProcs apiRequest = readRequest maxRows allRels allProcs apiRequest =
mapLeft (errResponse status400) $
treeRestrictRange maxRows =<< treeRestrictRange maxRows =<<
augumentRequestWithJoin schema relations =<< augumentRequestWithJoin schema relations =<<
first formatParserError readRequest first formatParserError parseReadRequest
where where
(schema, rootTableName) = fromJust $ -- Make it safe (schema, rootTableName) = fromJust $ -- Make it safe
let target = iTarget apiRequest in let target = iTarget apiRequest in
@@ -395,8 +403,8 @@ buildReadRequest maxRows allRels allProcs apiRequest =
action :: Action action :: Action
action = iAction apiRequest action = iAction apiRequest
readRequest :: Either ParseError ReadRequest parseReadRequest :: Either ParseError ReadRequest
readRequest = addFiltersOrdersRanges apiRequest <*> parseReadRequest = addFiltersOrdersRanges apiRequest <*>
parse (pRequestSelect rootName) ("failed to parse select parameter <<" <> toS selStr <> ">>") (toS selStr) parse (pRequestSelect rootName) ("failed to parse select parameter <<" <> toS selStr <> ">>") (toS selStr)
where where
selStr = iSelect apiRequest selStr = iSelect apiRequest
@@ -413,8 +421,9 @@ buildReadRequest maxRows allRels allProcs apiRequest =
_ -> allRels _ -> allRels
where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
buildMutateRequest :: ApiRequest -> Either Text MutateRequest mutateRequest :: ApiRequest -> Either Response MutateRequest
buildMutateRequest apiRequest = case action of mutateRequest apiRequest = mapLeft (errResponse status400) $
case action of
ActionCreate -> Insert rootTableName <$> pure payload ActionCreate -> Insert rootTableName <$> pure payload
ActionUpdate -> Update rootTableName <$> pure payload <*> filters ActionUpdate -> Update rootTableName <$> pure payload <*> filters
ActionDelete -> Delete rootTableName <$> filters ActionDelete -> Delete rootTableName <$> filters
src/PostgREST/Error.hs
+3 -3
View File
@@ -12,17 +12,17 @@ import qualified Hasql.Pool as P
import qualified Hasql.Session as H import qualified Hasql.Session as H
import qualified Network.HTTP.Types.Status as HT import qualified Network.HTTP.Types.Status as HT
import Network.Wai (Response, responseLBS) import Network.Wai (Response, responseLBS)
import PostgREST.ApiRequest (ctToHeader, ContentType(..)) import PostgREST.ApiRequest (toHeader, ContentType(..))
errResponse :: HT.Status -> Text -> Response errResponse :: HT.Status -> Text -> Response
errResponse status message = responseLBS status errResponse status message = responseLBS status
[ctToHeader CTApplicationJSON] [toHeader CTApplicationJSON]
(toS $ T.concat ["{\"message\":\"",message,"\"}"]) (toS $ T.concat ["{\"message\":\"",message,"\"}"])
pgErrResponse :: Bool -> P.UsageError -> Response pgErrResponse :: Bool -> P.UsageError -> Response
pgErrResponse authed e = pgErrResponse authed e =
let status = httpStatus authed e let status = httpStatus authed e
jsonType = ctToHeader CTApplicationJSON jsonType = toHeader CTApplicationJSON
wwwAuth = ("WWW-Authenticate", "Bearer") wwwAuth = ("WWW-Authenticate", "Bearer")
hdrs = if status == HT.status401 hdrs = if status == HT.status401
then [jsonType, wwwAuth] then [jsonType, wwwAuth]
src/PostgREST/Middleware.hs
+2 -2
View File
@@ -15,7 +15,7 @@ import Network.Wai.Middleware.Gzip (def, gzip)
import Network.Wai.Middleware.Static (only, staticPolicy) import Network.Wai.Middleware.Static (only, staticPolicy)
import PostgREST.ApiRequest (ApiRequest(..), ContentType(..), import PostgREST.ApiRequest (ApiRequest(..), ContentType(..),
ctToHeader) toHeader)
import PostgREST.Auth (claimsToSQL, JWTAttempt(..)) import PostgREST.Auth (claimsToSQL, JWTAttempt(..))
import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Config (AppConfig (..), corsPolicy)
import PostgREST.Error (errResponse) import PostgREST.Error (errResponse)
@@ -40,7 +40,7 @@ runWithClaims conf eClaims app req =
anon = String . toS $ configAnonRole conf anon = String . toS $ configAnonRole conf
customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
unauthed message = responseLBS unauthorized401 unauthed message = responseLBS unauthorized401
[ ctToHeader CTApplicationJSON [ toHeader CTApplicationJSON
, ( "WWW-Authenticate" , ( "WWW-Authenticate"
, "Bearer error=\"invalid_token\", " <> , "Bearer error=\"invalid_token\", " <>
"error_description=\"" <> message <> "\"" "error_description=\"" <> message <> "\""
src/PostgREST/OpenAPI.hs
+2 -2
View File
@@ -20,14 +20,14 @@ import Protolude hiding (concat, (&), Proxy, get, interca
import Data.Swagger import Data.Swagger
import PostgREST.ApiRequest (ContentType(..), toHeader) import PostgREST.ApiRequest (ContentType(..), toMime)
import PostgREST.Config (prettyVersion) import PostgREST.Config (prettyVersion)
import PostgREST.QueryBuilder (operators) import PostgREST.QueryBuilder (operators)
import PostgREST.Types (Table(..), Column(..), PgArg(..), import PostgREST.Types (Table(..), Column(..), PgArg(..),
Proxy(..), ProcDescription(..)) Proxy(..), ProcDescription(..))
makeMimeList :: [ContentType] -> MimeList makeMimeList :: [ContentType] -> MimeList
makeMimeList cs = MimeList $ map (fromString . toS . toHeader) cs makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs
toSwaggerType :: Text -> SwaggerType t toSwaggerType :: Text -> SwaggerType t
toSwaggerType "text" = SwaggerString toSwaggerType "text" = SwaggerString